commit 5a4381b470855c2038bea8c8f6de1f0b687671b3
parent 513920b834538a72776b9ce6932d9f74567a39d6
Author: Andres Navarro <canavarro82@gmail.com>
Date: Wed, 23 Nov 2011 05:27:44 -0300
Merged last batch of changes from r7rs/refactor
Diffstat:
113 files changed, 6263 insertions(+), 1858 deletions(-)
diff --git a/manual/html/Alphabetical-Index.html b/manual/html/Alphabetical-Index.html
@@ -55,7 +55,7 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<li><a href="Control.html#index-g_t_0024sequence-30"><code>$sequence</code></a>: <a href="Control.html#Control">Control</a></li>
<li><a href="Environments.html#index-g_t_0024set_0021-111"><code>$set!</code></a>: <a href="Environments.html#Environments">Environments</a></li>
<li><a href="Combiners.html#index-g_t_0024vau-119"><code>$vau</code></a>: <a href="Combiners.html#Combiners">Combiners</a></li>
-<li><a href="Ports.html#index-g_t_0028-261"><code>(</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-g_t_0028-263"><code>(</code></a>: <a href="Ports.html#Ports">Ports</a></li>
<li><a href="Numbers.html#index-g_t_0028-179"><code>(</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Continuations.html#index-g_t_0028-135"><code>(</code></a>: <a href="Continuations.html#Continuations">Continuations</a></li>
<li><a href="Environments.html#index-g_t_0028-110"><code>(</code></a>: <a href="Environments.html#Environments">Environments</a></li>
@@ -81,6 +81,7 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<li><a href="Pairs-and-lists.html#index-assoc-84"><code>assoc</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
<li><a href="Pairs-and-lists.html#index-assq-91"><code>assq</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
<li><a href="Numbers.html#index-atan-209"><code>atan</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
+<li><a href="Ports.html#index-binary_002dport_003f-262"><code>binary-port?</code></a>: <a href="Ports.html#Ports">Ports</a></li>
<li><a href="Booleans.html#index-boolean_003f-13"><code>boolean?</code></a>: <a href="Booleans.html#Booleans">Booleans</a></li>
<li><a href="Booleans.html#index-booleans-12">booleans</a>: <a href="Booleans.html#Booleans">Booleans</a></li>
<li><a href="Pairs-and-lists.html#index-caaaar-59"><code>caaaar</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
@@ -97,8 +98,8 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<li><a href="Pairs-and-lists.html#index-cadddr-66"><code>cadddr</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
<li><a href="Pairs-and-lists.html#index-caddr-54"><code>caddr</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
<li><a href="Pairs-and-lists.html#index-cadr-48"><code>cadr</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
-<li><a href="Ports.html#index-call_002dwith_002dinput_002dfile-271"><code>call-with-input-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
-<li><a href="Ports.html#index-call_002dwith_002doutput_002dfile-272"><code>call-with-output-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-call_002dwith_002dinput_002dfile-280"><code>call-with-input-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-call_002dwith_002doutput_002dfile-281"><code>call-with-output-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
<li><a href="Continuations.html#index-call_002fcc-128"><code>call/cc</code></a>: <a href="Continuations.html#Continuations">Continuations</a></li>
<li><a href="Pairs-and-lists.html#index-car-45"><code>car</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
<li><a href="Pairs-and-lists.html#index-cdaaar-67"><code>cdaaar</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
@@ -160,7 +161,7 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<li><a href="Pairs-and-lists.html#index-encycle_0021-77"><code>encycle!</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
<li><a href="Environments.html#index-environment_003f-95"><code>environment?</code></a>: <a href="Environments.html#Environments">Environments</a></li>
<li><a href="Environments.html#index-environments-93">environments</a>: <a href="Environments.html#Environments">Environments</a></li>
-<li><a href="Ports.html#index-eof_002dobject_003f-275"><code>eof-object?</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-eof_002dobject_003f-284"><code>eof-object?</code></a>: <a href="Ports.html#Ports">Ports</a></li>
<li><a href="Equivalence.html#index-eq_003f-20"><code>eq?</code></a>: <a href="Equivalence.html#Equivalence">Equivalence</a></li>
<li><a href="Equivalence.html#index-equal_003f-21"><code>equal?</code></a>: <a href="Equivalence.html#Equivalence">Equivalence</a></li>
<li><a href="Equivalence.html#index-equivalence-19">equivalence</a>: <a href="Equivalence.html#Equivalence">Equivalence</a></li>
@@ -185,7 +186,7 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<li><a href="Numbers.html#index-gcd-183"><code>gcd</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Environments.html#index-get_002dcurrent_002denvironment-102"><code>get-current-environment</code></a>: <a href="Environments.html#Environments">Environments</a></li>
<li><a href="Pairs-and-lists.html#index-get_002dlist_002dmetrics-75"><code>get-list-metrics</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
-<li><a href="Ports.html#index-get_002dmodule-274"><code>get-module</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-get_002dmodule-283"><code>get-module</code></a>: <a href="Ports.html#Ports">Ports</a></li>
<li><a href="Numbers.html#index-get_002dreal_002dexact_002dbounds-185"><code>get-real-exact-bounds</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Numbers.html#index-get_002dreal_002dexact_002dprimary-187"><code>get-real-exact-primary</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Numbers.html#index-get_002dreal_002dinternal_002dbounds-184"><code>get-real-internal-bounds</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
@@ -214,7 +215,7 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<li><a href="Pairs-and-lists.html#index-list_002dref-80"><code>list-ref</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
<li><a href="Pairs-and-lists.html#index-list_002dtail-76"><code>list-tail</code></a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
<li><a href="Pairs-and-lists.html#index-lists-36">lists</a>: <a href="Pairs-and-lists.html#Pairs-and-lists">Pairs and lists</a></li>
-<li><a href="Ports.html#index-load-273"><code>load</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-load-282"><code>load</code></a>: <a href="Ports.html#Ports">Ports</a></li>
<li><a href="Numbers.html#index-log-203"><code>log</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Encapsulations.html#index-make_002dencapsulation_002dtype-139"><code>make-encapsulation-type</code></a>: <a href="Encapsulations.html#Encapsulations">Encapsulations</a></li>
<li><a href="Environments.html#index-make_002denvironment-98"><code>make-environment</code></a>: <a href="Environments.html#Environments">Environments</a></li>
@@ -241,8 +242,10 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<li><a href="Numbers.html#index-numerator-194"><code>numerator</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="A-Sample-Applicative-Description.html#index-object-descriptions-10">object descriptions</a>: <a href="A-Sample-Applicative-Description.html#A-Sample-Applicative-Description">A Sample Applicative Description</a></li>
<li><a href="Numbers.html#index-odd_003f-177"><code>odd?</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
-<li><a href="Ports.html#index-open_002dinput_002dfile-265"><code>open-input-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
-<li><a href="Ports.html#index-open_002doutput_002dfile-266"><code>open-output-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-open_002dbinary_002dinput_002dfile-270"><code>open-binary-input-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-open_002dbinary_002doutput_002dfile-272"><code>open-binary-output-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-open_002dinput_002dfile-269"><code>open-input-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-open_002doutput_002dfile-271"><code>open-output-file</code></a>: <a href="Ports.html#Ports">Ports</a></li>
<li><a href="A-Sample-Applicative-Description.html#index-operative-descriptions-9">operative descriptions</a>: <a href="A-Sample-Applicative-Description.html#A-Sample-Applicative-Description">A Sample Applicative Description</a></li>
<li><a href="Combiners.html#index-operative_003f-117"><code>operative?</code></a>: <a href="Combiners.html#Combiners">Combiners</a></li>
<li><a href="Combiners.html#index-operatives-116">operatives</a>: <a href="Combiners.html#Combiners">Combiners</a></li>
@@ -258,7 +261,7 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<li><a href="Promises.html#index-promises-140">promises</a>: <a href="Promises.html#Promises">Promises</a></li>
<li><a href="Numbers.html#index-rational_003f-153"><code>rational?</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Numbers.html#index-rationalize-200"><code>rationalize</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
-<li><a href="Ports.html#index-read-269"><code>read</code></a>: <a href="Ports.html#Ports">Ports</a></li>
+<li><a href="Ports.html#index-read-278"><code>read</code></a>: <a href="Ports.html#Ports">Ports</a></li>
<li><a href="Numbers.html#index-real_002d_003eexact-190"><code>real->exact</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Numbers.html#index-real_002d_003einexact-189"><code>real->inexact</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Numbers.html#index-real_003f-154"><code>real?</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
@@ -298,6 +301,7 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<li><a href="Symbols.html#index-symbol_003f-23"><code>symbol?</code></a>: <a href="Symbols.html#Symbols">Symbols</a></li>
<li><a href="Symbols.html#index-symbols-22">symbols</a>: <a href="Symbols.html#Symbols">Symbols</a></li>
<li><a href="Numbers.html#index-tan-206"><code>tan</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
+<li><a href="Ports.html#index-textual_002dport_003f-261"><code>textual-port?</code></a>: <a href="Ports.html#Ports">Ports</a></li>
<li><a href="Numbers.html#index-truncate-198"><code>truncate</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Numbers.html#index-undefined_003f-159"><code>undefined?</code></a>: <a href="Numbers.html#Numbers">Numbers</a></li>
<li><a href="Combiners.html#index-unwrap-121"><code>unwrap</code></a>: <a href="Combiners.html#Combiners">Combiners</a></li>
diff --git a/manual/html/Ports.html b/manual/html/Ports.html
@@ -35,9 +35,14 @@ Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
<h2 class="chapter">16 Ports</h2>
<p><a name="index-ports-257"></a>
- A port is an object that mediates character-based input from a
-source or character-based output to a destination. In the former case,
-the port is an input port, in the latter case, an output port.
+ A port is an object that mediates data from an input or to a
+destination. In the former case, the port is an input port, in the
+latter case, an output port. The data itself can consist of either
+characters or bytes. In the former case the port is a textual port
+and in the latter case, a binary port.
+
+ <p>There are three textual ports open, binded by dynamic variables, one
+for standard input, output, and error.
<!-- TODO add xref to equal? & eq? -->
<p>Although ports are not considered immutable, none of the operations
@@ -45,7 +50,7 @@ on ports described in this section constitute mutation. Ports are
<code>equal?</code> iff <code>eq?</code>. The port type is encapsulated.
<p>An auxiliary data type used to signal the end of file was reached is
-eof. The eof type consists of a single immutable value, having
+<code>eof</code>. The eof type consists of a single immutable value, having
an output only external representation (so that it can never be the
normal result of a call to read). The eof type is encapsulated.
@@ -63,77 +68,96 @@ returns true iff all the objects in <code>objects</code> are of type port.
— Applicative: <b>output-port?</b> (<var>output-port? . objects</var>)<var><a name="index-output_002dport_003f-260"></a></var><br>
<blockquote><p> Applicative <code>input-port?</code> is a predicate that returns true
unless one or more of its arguments is not an input port. Applicative
-output-port? is a predicate that returns true unless one or more of
-its arguments is not an output port.
+<code>output-port?</code> is a predicate that returns true unless one or
+more of its arguments is not an output port.
<p>Every port must be admitted by at least one of these two predicates.
</p></blockquote></div>
<div class="defun">
-— with-input-from-file: <b>(</b><var>with-input-from-file string combiner</var>)<var><a name="index-g_t_0028-261"></a></var><br>
-— with-output-to-file: <b>(</b><var>with-output-to-file string combiner</var>)<var><a name="index-g_t_0028-262"></a></var><br>
-<blockquote><!-- add xref get-current-input-port/get-current-output-port -->
- <p>These two applicatives open the file named in <code>string</code> for
-input or output, an invoke the binder of the input-port & output-port
-keyed dynamic variables respectively with the opened port & the passed
-<code>combiner</code> (this means that the combiner is called in a fresh, empty
-dynamic environment). When/if the binder normally returns, the port is closed.
-The result of the applicatives <code>with-input-from-file</code> and
-<code>with-output-from-file</code> is inert.
+— Applicative: <b>textual-port?</b> (<var>textual-port? . objects</var>)<var><a name="index-textual_002dport_003f-261"></a></var><br>
+— Applicative: <b>binary-port?</b> (<var>binary-port? . objects</var>)<var><a name="index-binary_002dport_003f-262"></a></var><br>
+<blockquote><p> Applicative <code>textual-port?</code> is a predicate that returns true
+unless one or more of its arguments is not a textual port. Applicative
+<code>binary-port?</code> is a predicate that returns true unless one or more of
+its arguments is not a binary port.
- <p>SOURCE NOTE: this is enumerated in the Kernel report but the text is
-still missing. In the new scheme report there's also a third
-error-port variable. It is very likely that that will be added to the
-klisp implementation in the near future.
+ <p>Every port must be admitted by at least one of these two predicates.
+
+ <p>SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+</p></blockquote></div>
+
+<div class="defun">
+— with-input-from-file: <b>(</b><var>with-input-from-file string combiner</var>)<var><a name="index-g_t_0028-263"></a></var><br>
+— with-output-to-file: <b>(</b><var>with-output-to-file string combiner</var>)<var><a name="index-g_t_0028-264"></a></var><br>
+— with-error-to-file: <b>(</b><var>with-error-to-file string combiner</var>)<var><a name="index-g_t_0028-265"></a></var><br>
+<blockquote><!-- add xref get-current-input-port/get-current-output-port -->
+ <p>These three applicatives open the file named in <code>string</code> for
+textual input or output, an invoke the binder of either the
+input-port, the output-port or the error-port keyed dynamic variables
+respectively with the opened port & the passed <code>combiner</code> (this
+means that the combiner is called in a fresh, empty dynamic
+environment). When/if the binder normally returns, the port is
+closed. The result of the applicatives <code>with-input-from-file</code>
+and <code>with-output-from-file</code> is inert.
+
+ <p>SOURCE NOTE: The first two are enumerated in the Kernel report but
+the text is still missing. The third applicative is from Scheme.
</p></blockquote></div>
<div class="defun">
-— get-current-input-port: <b>(</b><var>get-current-input-port</var>)<var><a name="index-g_t_0028-263"></a></var><br>
-— get-current-output-port: <b>(</b><var>get-current-output-port</var>)<var><a name="index-g_t_0028-264"></a></var><br>
-<blockquote><p> These are the accessors for the input-port and output-port keyed
-dynamic variables repectively.
+— get-current-input-port: <b>(</b><var>get-current-input-port</var>)<var><a name="index-g_t_0028-266"></a></var><br>
+— get-current-output-port: <b>(</b><var>get-current-output-port</var>)<var><a name="index-g_t_0028-267"></a></var><br>
+— get-current-error-port: <b>(</b><var>get-current-error-port</var>)<var><a name="index-g_t_0028-268"></a></var><br>
+<blockquote><p> These are the accessors for the input-port, output-port, and
+error-port keyed dynamic variables repectively.
<!-- add xref to with-input-from-file, etc -->
<!-- add xref and text for these dynamic vars -->
- <p>SOURCE NOTE: this is enumerated in the Kernel report but the text is
-still missing. In the new scheme report there's also a third
-error-port variable. It is very likely that that will be added to the
-klisp implementation in the near future.
+ <p>SOURCE NOTE: The first two are enumerated in the Kernel report but
+the text is still missing. The third applicative is from Scheme.
</p></blockquote></div>
<div class="defun">
-— Applicative: <b>open-input-file</b> (<var>open-input-file string</var>)<var><a name="index-open_002dinput_002dfile-265"></a></var><br>
+— Applicative: <b>open-input-file</b> (<var>open-input-file string</var>)<var><a name="index-open_002dinput_002dfile-269"></a></var><br>
+— Applicative: <b>open-binary-input-file</b> (<var>open-binary-input-file string</var>)<var><a name="index-open_002dbinary_002dinput_002dfile-270"></a></var><br>
<blockquote><p> <code>string</code> should be the name/path for an existing file.
- <p>Applicative <code>open-input-file</code> creates and returns an input port
-associated with the file represented with <code>string</code>. If the file
-can't be opened (e.g. because it doesn't exists, or there's a
-permissions problem), an error is signaled.
+ <p>Applicative <code>open-input-file</code> creates and returns a textual
+input port associated with the file represented with <code>string</code>.
+Applicative <code>open-binary-input-file</code> creates and returns a binary
+input port associated with the file represented with <code>string</code>.
+In either case, if the file can't be opened (e.g. because it doesn't
+exists, or there's a permissions problem), an error is signaled.
- <p>SOURCE NOTE: this is enumerated in the Kernel report but the text is
-still missing.
+ <p>SOURCE NOTE: open-input-file is enumerated in the Kernel report but
+the text is still missing. open-binary-input-file is from Scheme.
</p></blockquote></div>
<div class="defun">
-— Applicative: <b>open-output-file</b> (<var>open-output-file string</var>)<var><a name="index-open_002doutput_002dfile-266"></a></var><br>
+— Applicative: <b>open-output-file</b> (<var>open-output-file string</var>)<var><a name="index-open_002doutput_002dfile-271"></a></var><br>
+— Applicative: <b>open-binary-output-file</b> (<var>open-binary-output-file string</var>)<var><a name="index-open_002dbinary_002doutput_002dfile-272"></a></var><br>
<blockquote><p> <code>string</code> should be the name/path for an existing file.
- <p>Applicative <code>open-output-file</code> creates and returns an output
-port associated with the file represented with <code>string</code>. If the
-file can't be opened (e.g. if there's a permissions problem), an error
-is signaled.
+ <p>Applicative <code>open-output-file</code> creates and returns a textual
+output port associated with the file represented with <code>string</code>.
+Applicative <code>open-binary-output-file</code> creates and returns a
+binary output port associated with the file represented with
+<code>string</code>. In either case, if the file can't be opened (e.g. if
+there's a permissions problem), an error is signaled.
- <p>In klisp, for now, applicative <code>open-output-file</code> truncates the
-file if it already exists, but that could change later (i.e. like in
-scheme the behaviour should be considered unspecified).
+ <p>In klisp, for now, applicative <code>open-output-file</code> and
+<code>open-binary-output-file</code> truncate the file if it already exists,
+but that could change later (i.e. like in Scheme the behaviour should
+be considered unspecified).
- <p>SOURCE NOTE: this is enumerated in the Kernel report but the text is
-still missing.
+ <p>SOURCE NOTE: open-output-file is enumerated in the Kernel report but
+the text is still missing. open-binary-output-file is from Scheme.
</p></blockquote></div>
<div class="defun">
-— close-input-file: <b>(</b><var>close-input-file input-port</var>)<var><a name="index-g_t_0028-267"></a></var><br>
-— close-output-file: <b>(</b><var>close-output-file output-port</var>)<var><a name="index-g_t_0028-268"></a></var><br>
+— close-input-file: <b>(</b><var>close-input-file input-port</var>)<var><a name="index-g_t_0028-273"></a></var><br>
+— close-output-file: <b>(</b><var>close-output-file output-port</var>)<var><a name="index-g_t_0028-274"></a></var><br>
<blockquote><p> These applicatives close the port argument, so that no more
input/output may be performed on them, and the resources can be
freed. If the port was already closed these applicatives have no
@@ -148,13 +172,31 @@ probably be called close-input-port & close-output-port.
</p></blockquote></div>
<div class="defun">
-— Applicative: <b>read</b> (<var>read </var>[<var>input-port</var>])<var><a name="index-read-269"></a></var><br>
+— close-input-port: <b>(</b><var>close-input-port input-port</var>)<var><a name="index-g_t_0028-275"></a></var><br>
+— close-output-port: <b>(</b><var>close-output-port output-port</var>)<var><a name="index-g_t_0028-276"></a></var><br>
+— close-port: <b>(</b><var>close-port port</var>)<var><a name="index-g_t_0028-277"></a></var><br>
+<blockquote><p> These applicatives close the port argument, so that no more
+input/output may be performed on them, and the resources can be
+freed. If the port was already closed these applicatives have no
+effect. If at some time klisp provided input/ouput ports these could
+be used to selectively close only one direction of the port.
+
+ <p>The result returned by applicatives <code>close-input-port</code>,
+<code>close-output-port</code>, and <code>close-port</code> is inert.
+
+ <p>SOURCE NOTE: this is from Scheme. The equivalent
+<code>close-input-file</code> and <code>close-output-file</code> are probably name
+errors and only retained here till the draft standard rectifies them
+</p></blockquote></div>
+
+<div class="defun">
+— Applicative: <b>read</b> (<var>read </var>[<var>textual-input-port</var>])<var><a name="index-read-278"></a></var><br>
<blockquote><p> If the <code>port</code> optional argument is not specified, then the
value of the <code>input-port</code> keyed dynamic variable is used. If the
port is closed, an error is signaled.
<p>Applicative <code>read</code> reads & returns the next parseable object
-from the given port, or the eof object if no objects remain. If
+from the given port, or the <code>eof</code> if no objects remain. If
<code>read</code> finds and unparseable object in the port, an error is
signaled. In that case, the remaining position in the port is
unspecified.
@@ -164,7 +206,7 @@ still missing.
</p></blockquote></div>
<div class="defun">
-— write: <b>(</b><var>write object </var>[<var>port</var>])<var><a name="index-g_t_0028-270"></a></var><br>
+— write: <b>(</b><var>write object </var>[<var>textual-output-port</var>])<var><a name="index-g_t_0028-279"></a></var><br>
<blockquote><p> If the <code>port</code> optional argument is not specified, then the
value of the <code>output-port</code> keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -182,25 +224,25 @@ still missing.
</p></blockquote></div>
<div class="defun">
-— Applicative: <b>call-with-input-file</b> (<var>call-with-input-file string combiner</var>)<var><a name="index-call_002dwith_002dinput_002dfile-271"></a></var><br>
-— Applicative: <b>call-with-output-file</b> (<var>call-with-output-file string combiner</var>)<var><a name="index-call_002dwith_002doutput_002dfile-272"></a></var><br>
-<blockquote><p> These applicatives open file named in <code>string</code> and call their
-<code>combiner</code> argument in a fresh empty environment passing it as a
-sole operand the opened port. When/if the combiner normally returns a
-value the port is closed and that value is returned as the result of
-the applicative.
+— Applicative: <b>call-with-input-file</b> (<var>call-with-input-file string combiner</var>)<var><a name="index-call_002dwith_002dinput_002dfile-280"></a></var><br>
+— Applicative: <b>call-with-output-file</b> (<var>call-with-output-file string combiner</var>)<var><a name="index-call_002dwith_002doutput_002dfile-281"></a></var><br>
+<blockquote><p> These applicatives open file named in <code>string</code> for textual
+input/output respectively and call their <code>combiner</code> argument in a
+fresh empty environment passing it as a sole operand the opened port.
+When/if the combiner normally returns a value the port is closed and
+that value is returned as the result of the applicative.
<p>SOURCE NOTE: this is enumerated in the Kernel report but the text is
still missing.
</p></blockquote></div>
<div class="defun">
-— Applicative: <b>load</b> (<var>load string</var>)<var><a name="index-load-273"></a></var><br>
+— Applicative: <b>load</b> (<var>load string</var>)<var><a name="index-load-282"></a></var><br>
<blockquote><!-- TODO add xref, open/input, read -->
- <p>Applicative <code>load</code> opens for input a file named <code>string</code>;
-reads objects from the file until the end of the file is reached;
-evaluates those objects consecutively in the created environment. The
-result from applicative <code>load</code> is inert.
+ <p>Applicative <code>load</code> opens the file named <code>string</code> for
+textual input; reads objects from the file until the end of the file
+is reached; evaluates those objects consecutively in the created
+environment. The result from applicative <code>load</code> is inert.
<p>SOURCE NOTE: load is enumerated in the Kernel report, but the
description is not there yet. This seems like a sane way to define
@@ -211,51 +253,51 @@ return the value of the last evaluation.
</p></blockquote></div>
<div class="defun">
-— Applicative: <b>get-module</b> (<var>get-module string </var>[<var>environment</var>])<var><a name="index-get_002dmodule-274"></a></var><br>
+— Applicative: <b>get-module</b> (<var>get-module string </var>[<var>environment</var>])<var><a name="index-get_002dmodule-283"></a></var><br>
<blockquote><!-- TODO add xref standard-environment, open/input, read -->
<p>Applicative <code>get-module</code> creates a fresh standard environment;
-opens for input a file named <code>string</code>; reads objects from the
-file until the end of the file is reached; evaluates those objects
-consecutively in the created environment; and, lastly, returns the
-created environment. If the optional argument <code>environment</code> is
-specified, the freshly created standard environment is augmented,
+opens the file named <code>string</code> for textual input; reads objects
+from the file until the end of the file is reached; evaluates those
+objects consecutively in the created environment; and, lastly, returns
+the created environment. If the optional argument <code>environment</code>
+is specified, the freshly created standard environment is augmented,
prior to evaluating read expressions, by binding symbol
<code>module-parameters</code> to the <code>environment</code> argument.
</p></blockquote></div>
<div class="defun">
-— Applicative: <b>eof-object?</b> (<var>eof-object? . objects</var>)<var><a name="index-eof_002dobject_003f-275"></a></var><br>
+— Applicative: <b>eof-object?</b> (<var>eof-object? . objects</var>)<var><a name="index-eof_002dobject_003f-284"></a></var><br>
<blockquote><p> The primitive type predicate for type eof. <code>eof-object?</code>
returns true iff all the objects in <code>objects</code> are of type eof.
<p>SOURCE NOTE: This is not in the report, the idea is from Scheme.
-The <code>eof-object?</code> name is also from scheme, but this will
+The <code>eof-object?</code> name is also from Scheme, but this will
probably be changed to just <code>eof?</code>, for consistency with the other
primitive type predicates.
</p></blockquote></div>
<div class="defun">
-— read-char: <b>(</b><var>read-char </var>[<var>port</var>])<var><a name="index-g_t_0028-276"></a></var><br>
+— read-char: <b>(</b><var>read-char </var>[<var>textual-input-port</var>])<var><a name="index-g_t_0028-285"></a></var><br>
<blockquote><p> If the <code>port</code> optional argument is not specified, then the
value of the <code>input-port</code> keyed dynamic variable is used. If the
port is closed, an error is signaled.
<p>Applicative <code>read-char</code> reads and returns a character (not
an external representation of a character) from the specified port, or
-an eof if the end of file was reached.
+an <code>eof</code> if the end of file was reached.
<p>SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
</p></blockquote></div>
<div class="defun">
-— peek-char: <b>(</b><var>peek-char </var>[<var>port</var>])<var><a name="index-g_t_0028-277"></a></var><br>
+— peek-char: <b>(</b><var>peek-char </var>[<var>textual-input-port</var>])<var><a name="index-g_t_0028-286"></a></var><br>
<blockquote><p> If the <code>port</code> optional argument is not specified, then the
value of the <code>input-port</code> keyed dynamic variable is used. If the
port is closed, an error is signaled.
<p>Applicative <code>peek-char</code> reads and returns a character (not
an external representation of a character) from the specified port, or
-an eof if the end of file was reached. The position of the port
+an <code>eof</code> if the end of file was reached. The position of the port
remains unchanged so that new call to <code>peek-char</code> or
<code>read-char</code> on the same port return the same character.
@@ -263,7 +305,7 @@ remains unchanged so that new call to <code>peek-char</code> or
</p></blockquote></div>
<div class="defun">
-— char-ready?: <b>(</b><var>char-ready? </var>[<var>port</var>])<var><a name="index-g_t_0028-278"></a></var><br>
+— char-ready?: <b>(</b><var>char-ready? </var>[<var>textual-input-port</var>])<var><a name="index-g_t_0028-287"></a></var><br>
<blockquote><p> If the <code>port</code> optional argument is not specified, then the
value of the <code>input-port</code> keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -278,7 +320,7 @@ the code to do this is non-portable.
</p></blockquote></div>
<div class="defun">
-— write-char: <b>(</b><var>write-char char </var>[<var>port</var>])<var><a name="index-g_t_0028-279"></a></var><br>
+— write-char: <b>(</b><var>write-char char </var>[<var>textual-output-port</var>])<var><a name="index-g_t_0028-288"></a></var><br>
<blockquote><p> If the <code>port</code> optional argument is not specified, then the
value of the <code>output-port</code> keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -291,7 +333,7 @@ The result returned by <code>write-char</code> is inert.
</p></blockquote></div>
<div class="defun">
-— newline: <b>(</b><var>newline </var>[<var>port</var>])<var><a name="index-g_t_0028-280"></a></var><br>
+— newline: <b>(</b><var>newline </var>[<var>textal-ouput-port</var>])<var><a name="index-g_t_0028-289"></a></var><br>
<blockquote><p> If the <code>port</code> optional argument is not specified, then the
value of the <code>output-port</code> keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -303,7 +345,7 @@ The result returned by <code>newline</code> is inert.
</p></blockquote></div>
<div class="defun">
-— display: <b>(</b><var>display object </var>[<var>port</var>])<var><a name="index-g_t_0028-281"></a></var><br>
+— display: <b>(</b><var>display object </var>[<var>textual-output-port</var>])<var><a name="index-g_t_0028-290"></a></var><br>
<blockquote><p> If the <code>port</code> optional argument is not specified, then the
value of the <code>output-port</code> keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -318,7 +360,66 @@ within those strings and character objects are output as if by
</p></blockquote></div>
<div class="defun">
-— flush-output-port: <b>(</b><var>flush-output-port </var>[<var>port</var>])<var><a name="index-g_t_0028-282"></a></var><br>
+— read-u8: <b>(</b><var>read-u8 </var>[<var>textual-input-port</var>])<var><a name="index-g_t_0028-291"></a></var><br>
+<blockquote><p> If the <code>port</code> optional argument is not specified, then the
+value of the <code>input-port</code> keyed dynamic variable is used. If the
+port is closed, an error is signaled.
+
+ <p>Applicative <code>read-u8</code> reads and returns a byte as an exact
+unsigned integer between 0 and 255 inclusive (not an external
+representation of a byte) from the specified port, or an <code>eof</code> if
+the end of file was reached.
+
+ <p>SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+</p></blockquote></div>
+
+<div class="defun">
+— peek-u8: <b>(</b><var>peek-u8 </var>[<var>textual-input-port</var>])<var><a name="index-g_t_0028-292"></a></var><br>
+<blockquote><p> If the <code>port</code> optional argument is not specified, then the
+value of the <code>input-port</code> keyed dynamic variable is used. If the
+port is closed, an error is signaled.
+
+ <p>Applicative <code>peek-u8</code> reads and returns a byte as an exact
+unsigned integer between 0 and 255 inclusive (not an external
+representation of a byte) from the specified port, or an <code>eof</code> if
+the end of file was reached. The position of the port remains
+unchanged so that new call to <code>peek-u8</code> or <code>read-u8</code> on the
+same port return the same byte.
+
+ <p>SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+</p></blockquote></div>
+
+<div class="defun">
+— u8-ready?: <b>(</b><var>u8-ready? </var>[<var>textual-input-port</var>])<var><a name="index-g_t_0028-293"></a></var><br>
+<blockquote><p> If the <code>port</code> optional argument is not specified, then the
+value of the <code>input-port</code> keyed dynamic variable is used. If the
+port is closed, an error is signaled.
+
+ <p>Predicate <code>u8-ready?</code> checks to see if a byte is
+available in the specified port. If it returns true, then a
+<code>read-u8</code> or <code>peek-u8</code> on that port is guaranteed not to
+block/hang. For now in klisp this is hardcoded to <code>#t</code> because
+the code to do this is non-portable.
+
+ <p>SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+</p></blockquote></div>
+
+<div class="defun">
+— write-u8: <b>(</b><var>write-u8 u8 </var>[<var>textual-output-port</var>])<var><a name="index-g_t_0028-294"></a></var><br>
+<blockquote><p> If the <code>port</code> optional argument is not specified, then the
+value of the <code>output-port</code> keyed dynamic variable is used. If the
+port is closed, an error is signaled.
+
+ <p>Applicative <code>write-u8</code> writes the byte represented by the
+unsigned integer <code>u8</code>, that should be between 0 and 255 inclusive,
+(not an external representation of byte) to the specified port. The
+result returned by <code>write-u8</code> is inert.
+
+ <p>SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+</p></blockquote></div>
+
+<div class="defun">
+— flush-output-port: <b>(</b><var>flush-output-port </var>[<var>output-port</var>])<var><a name="index-g_t_0028-295"></a></var><br>
<blockquote><p> If the <code>port</code> optional argument is not specified, then the
value of the <code>output-port</code> keyed dynamic variable is used. If
the <code>port</code> is closed or if it is not an output port, an error is
@@ -332,7 +433,7 @@ output port to the underlying file or device. The result returned by
</p></blockquote></div>
<div class="defun">
-— file-exists?: <b>(</b><var>file-exists? string</var>)<var><a name="index-g_t_0028-283"></a></var><br>
+— file-exists?: <b>(</b><var>file-exists? string</var>)<var><a name="index-g_t_0028-296"></a></var><br>
<blockquote><p> <code>string</code> should be the name/path for a file.
<p>Predicate <code>file-exists?</code> checks to see if a file named
@@ -342,7 +443,7 @@ output port to the underlying file or device. The result returned by
</p></blockquote></div>
<div class="defun">
-— delete-file: <b>(</b><var>delete-file string</var>)<var><a name="index-g_t_0028-284"></a></var><br>
+— delete-file: <b>(</b><var>delete-file string</var>)<var><a name="index-g_t_0028-297"></a></var><br>
<blockquote><p> <code>string</code> should be the name/path for an existing file.
<p>Applicative <code>delete-file</code> deletes the file named <code>string</code>.
@@ -353,7 +454,7 @@ result returned by <code>delete-file</code> is inert.
</p></blockquote></div>
<div class="defun">
-— rename-file: <b>(</b><var>rename-file string1 string2</var>)<var><a name="index-g_t_0028-285"></a></var><br>
+— rename-file: <b>(</b><var>rename-file string1 string2</var>)<var><a name="index-g_t_0028-298"></a></var><br>
<blockquote><p> <code>string1</code> should be the name/path for an existing file,
<code>string2</code> should be the name/path for a non existing file.
diff --git a/manual/klisp.info b/manual/klisp.info
@@ -2135,16 +2135,21 @@ File: klisp.info, Node: Ports, Next: Alphabetical Index, Prev: Characters, U
16 Ports
********
-A port is an object that mediates character-based input from a source
-or character-based output to a destination. In the former case, the
-port is an input port, in the latter case, an output port.
+A port is an object that mediates data from an input or to a
+destination. In the former case, the port is an input port, in the
+latter case, an output port. The data itself can consist of either
+characters or bytes. In the former case the port is a textual port and
+in the latter case, a binary port.
+
+ There are three textual ports open, binded by dynamic variables, one
+for standard input, output, and error.
Although ports are not considered immutable, none of the operations
on ports described in this section constitute mutation. Ports are
`equal?' iff `eq?'. The port type is encapsulated.
An auxiliary data type used to signal the end of file was reached is
-eof. The eof type consists of a single immutable value, having an
+`eof'. The eof type consists of a single immutable value, having an
output only external representation (so that it can never be the normal
result of a call to read). The eof type is encapsulated.
@@ -2159,62 +2164,82 @@ klisp and was taken from Scheme.
-- Applicative: output-port? (output-port? . objects)
Applicative `input-port?' is a predicate that returns true unless
one or more of its arguments is not an input port. Applicative
- output-port? is a predicate that returns true unless one or more of
- its arguments is not an output port.
+ `output-port?' is a predicate that returns true unless one or more
+ of its arguments is not an output port.
Every port must be admitted by at least one of these two
predicates.
+ -- Applicative: textual-port? (textual-port? . objects)
+ -- Applicative: binary-port? (binary-port? . objects)
+ Applicative `textual-port?' is a predicate that returns true
+ unless one or more of its arguments is not a textual port.
+ Applicative `binary-port?' is a predicate that returns true unless
+ one or more of its arguments is not a binary port.
+
+ Every port must be admitted by at least one of these two
+ predicates.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+
-- with-input-from-file: (with-input-from-file string combiner)
-- with-output-to-file: (with-output-to-file string combiner)
- These two applicatives open the file named in `string' for input
- or output, an invoke the binder of the input-port & output-port
- keyed dynamic variables respectively with the opened port & the
- passed `combiner' (this means that the combiner is called in a
- fresh, empty dynamic environment). When/if the binder normally
- returns, the port is closed. The result of the applicatives
+ -- with-error-to-file: (with-error-to-file string combiner)
+ These three applicatives open the file named in `string' for
+ textual input or output, an invoke the binder of either the
+ input-port, the output-port or the error-port keyed dynamic
+ variables respectively with the opened port & the passed
+ `combiner' (this means that the combiner is called in a fresh,
+ empty dynamic environment). When/if the binder normally returns,
+ the port is closed. The result of the applicatives
`with-input-from-file' and `with-output-from-file' is inert.
- SOURCE NOTE: this is enumerated in the Kernel report but the text
- is still missing. In the new scheme report there's also a third
- error-port variable. It is very likely that that will be added to
- the klisp implementation in the near future.
+ SOURCE NOTE: The first two are enumerated in the Kernel report but
+ the text is still missing. The third applicative is from Scheme.
-- get-current-input-port: (get-current-input-port)
-- get-current-output-port: (get-current-output-port)
- These are the accessors for the input-port and output-port keyed
- dynamic variables repectively.
+ -- get-current-error-port: (get-current-error-port)
+ These are the accessors for the input-port, output-port, and
+ error-port keyed dynamic variables repectively.
- SOURCE NOTE: this is enumerated in the Kernel report but the text
- is still missing. In the new scheme report there's also a third
- error-port variable. It is very likely that that will be added to
- the klisp implementation in the near future.
+ SOURCE NOTE: The first two are enumerated in the Kernel report but
+ the text is still missing. The third applicative is from Scheme.
-- Applicative: open-input-file (open-input-file string)
+ -- Applicative: open-binary-input-file (open-binary-input-file string)
`string' should be the name/path for an existing file.
- Applicative `open-input-file' creates and returns an input port
- associated with the file represented with `string'. If the file
- can't be opened (e.g. because it doesn't exists, or there's a
- permissions problem), an error is signaled.
+ Applicative `open-input-file' creates and returns a textual input
+ port associated with the file represented with `string'.
+ Applicative `open-binary-input-file' creates and returns a binary
+ input port associated with the file represented with `string'. In
+ either case, if the file can't be opened (e.g. because it doesn't
+ exists, or there's a permissions problem), an error is signaled.
- SOURCE NOTE: this is enumerated in the Kernel report but the text
- is still missing.
+ SOURCE NOTE: open-input-file is enumerated in the Kernel report but
+ the text is still missing. open-binary-input-file is from Scheme.
-- Applicative: open-output-file (open-output-file string)
+ -- Applicative: open-binary-output-file (open-binary-output-file
+ string)
`string' should be the name/path for an existing file.
- Applicative `open-output-file' creates and returns an output port
- associated with the file represented with `string'. If the file
- can't be opened (e.g. if there's a permissions problem), an error
- is signaled.
+ Applicative `open-output-file' creates and returns a textual
+ output port associated with the file represented with `string'.
+ Applicative `open-binary-output-file' creates and returns a binary
+ output port associated with the file represented with `string'.
+ In either case, if the file can't be opened (e.g. if there's a
+ permissions problem), an error is signaled.
- In klisp, for now, applicative `open-output-file' truncates the
- file if it already exists, but that could change later (i.e. like
- in scheme the behaviour should be considered unspecified).
+ In klisp, for now, applicative `open-output-file' and
+ `open-binary-output-file' truncate the file if it already exists,
+ but that could change later (i.e. like in Scheme the behaviour
+ should be considered unspecified).
- SOURCE NOTE: this is enumerated in the Kernel report but the text
- is still missing.
+ SOURCE NOTE: open-output-file is enumerated in the Kernel report
+ but the text is still missing. open-binary-output-file is from
+ Scheme.
-- close-input-file: (close-input-file input-port)
-- close-output-file: (close-output-file output-port)
@@ -2230,20 +2255,37 @@ klisp and was taken from Scheme.
is still missing. There's probably a name error here. These
should probably be called close-input-port & close-output-port.
- -- Applicative: read (read [input-port])
+ -- close-input-port: (close-input-port input-port)
+ -- close-output-port: (close-output-port output-port)
+ -- close-port: (close-port port)
+ These applicatives close the port argument, so that no more
+ input/output may be performed on them, and the resources can be
+ freed. If the port was already closed these applicatives have no
+ effect. If at some time klisp provided input/ouput ports these
+ could be used to selectively close only one direction of the port.
+
+ The result returned by applicatives `close-input-port',
+ `close-output-port', and `close-port' is inert.
+
+ SOURCE NOTE: this is from Scheme. The equivalent
+ `close-input-file' and `close-output-file' are probably name
+ errors and only retained here till the draft standard rectifies
+ them
+
+ -- Applicative: read (read [textual-input-port])
If the `port' optional argument is not specified, then the value
of the `input-port' keyed dynamic variable is used. If the port
is closed, an error is signaled.
Applicative `read' reads & returns the next parseable object from
- the given port, or the eof object if no objects remain. If `read'
+ the given port, or the `eof' if no objects remain. If `read'
finds and unparseable object in the port, an error is signaled.
In that case, the remaining position in the port is unspecified.
SOURCE NOTE: this is enumerated in the Kernel report but the text
is still missing.
- -- write: (write object [port])
+ -- write: (write object [textual-output-port])
If the `port' optional argument is not specified, then the value
of the `output-port' keyed dynamic variable is used. If the port
is closed, an error is signaled.
@@ -2262,20 +2304,20 @@ klisp and was taken from Scheme.
combiner)
-- Applicative: call-with-output-file (call-with-output-file string
combiner)
- These applicatives open file named in `string' and call their
- `combiner' argument in a fresh empty environment passing it as a
- sole operand the opened port. When/if the combiner normally
- returns a value the port is closed and that value is returned as
- the result of the applicative.
+ These applicatives open file named in `string' for textual
+ input/output respectively and call their `combiner' argument in a
+ fresh empty environment passing it as a sole operand the opened
+ port. When/if the combiner normally returns a value the port is
+ closed and that value is returned as the result of the applicative.
SOURCE NOTE: this is enumerated in the Kernel report but the text
is still missing.
-- Applicative: load (load string)
- Applicative `load' opens for input a file named `string'; reads
- objects from the file until the end of the file is reached;
- evaluates those objects consecutively in the created environment.
- The result from applicative `load' is inert.
+ Applicative `load' opens the file named `string' for textual
+ input; reads objects from the file until the end of the file is
+ reached; evaluates those objects consecutively in the created
+ environment. The result from applicative `load' is inert.
SOURCE NOTE: load is enumerated in the Kernel report, but the
description is not there yet. This seems like a sane way to define
@@ -2286,48 +2328,48 @@ klisp and was taken from Scheme.
-- Applicative: get-module (get-module string [environment])
Applicative `get-module' creates a fresh standard environment;
- opens for input a file named `string'; reads objects from the file
- until the end of the file is reached; evaluates those objects
- consecutively in the created environment; and, lastly, returns the
- created environment. If the optional argument `environment' is
- specified, the freshly created standard environment is augmented,
- prior to evaluating read expressions, by binding symbol
- `module-parameters' to the `environment' argument.
+ opens the file named `string' for textual input; reads objects
+ from the file until the end of the file is reached; evaluates those
+ objects consecutively in the created environment; and, lastly,
+ returns the created environment. If the optional argument
+ `environment' is specified, the freshly created standard
+ environment is augmented, prior to evaluating read expressions, by
+ binding symbol `module-parameters' to the `environment' argument.
-- Applicative: eof-object? (eof-object? . objects)
The primitive type predicate for type eof. `eof-object?' returns
true iff all the objects in `objects' are of type eof.
SOURCE NOTE: This is not in the report, the idea is from Scheme.
- The `eof-object?' name is also from scheme, but this will probably
+ The `eof-object?' name is also from Scheme, but this will probably
be changed to just `eof?', for consistency with the other
primitive type predicates.
- -- read-char: (read-char [port])
+ -- read-char: (read-char [textual-input-port])
If the `port' optional argument is not specified, then the value
of the `input-port' keyed dynamic variable is used. If the port
is closed, an error is signaled.
Applicative `read-char' reads and returns a character (not an
external representation of a character) from the specified port, or
- an eof if the end of file was reached.
+ an `eof' if the end of file was reached.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
- -- peek-char: (peek-char [port])
+ -- peek-char: (peek-char [textual-input-port])
If the `port' optional argument is not specified, then the value
of the `input-port' keyed dynamic variable is used. If the port
is closed, an error is signaled.
Applicative `peek-char' reads and returns a character (not an
external representation of a character) from the specified port, or
- an eof if the end of file was reached. The position of the port
+ an `eof' if the end of file was reached. The position of the port
remains unchanged so that new call to `peek-char' or `read-char'
on the same port return the same character.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
- -- char-ready?: (char-ready? [port])
+ -- char-ready?: (char-ready? [textual-input-port])
If the `port' optional argument is not specified, then the value
of the `input-port' keyed dynamic variable is used. If the port
is closed, an error is signaled.
@@ -2340,7 +2382,7 @@ klisp and was taken from Scheme.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
- -- write-char: (write-char char [port])
+ -- write-char: (write-char char [textual-output-port])
If the `port' optional argument is not specified, then the value
of the `output-port' keyed dynamic variable is used. If the port
is closed, an error is signaled.
@@ -2351,7 +2393,7 @@ klisp and was taken from Scheme.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
- -- newline: (newline [port])
+ -- newline: (newline [textal-ouput-port])
If the `port' optional argument is not specified, then the value
of the `output-port' keyed dynamic variable is used. If the port
is closed, an error is signaled.
@@ -2361,7 +2403,7 @@ klisp and was taken from Scheme.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
- -- display: (display object [port])
+ -- display: (display object [textual-output-port])
If the `port' optional argument is not specified, then the value
of the `output-port' keyed dynamic variable is used. If the port
is closed, an error is signaled.
@@ -2374,7 +2416,58 @@ klisp and was taken from Scheme.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
- -- flush-output-port: (flush-output-port [port])
+ -- read-u8: (read-u8 [textual-input-port])
+ If the `port' optional argument is not specified, then the value
+ of the `input-port' keyed dynamic variable is used. If the port
+ is closed, an error is signaled.
+
+ Applicative `read-u8' reads and returns a byte as an exact
+ unsigned integer between 0 and 255 inclusive (not an external
+ representation of a byte) from the specified port, or an `eof' if
+ the end of file was reached.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+
+ -- peek-u8: (peek-u8 [textual-input-port])
+ If the `port' optional argument is not specified, then the value
+ of the `input-port' keyed dynamic variable is used. If the port
+ is closed, an error is signaled.
+
+ Applicative `peek-u8' reads and returns a byte as an exact
+ unsigned integer between 0 and 255 inclusive (not an external
+ representation of a byte) from the specified port, or an `eof' if
+ the end of file was reached. The position of the port remains
+ unchanged so that new call to `peek-u8' or `read-u8' on the same
+ port return the same byte.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+
+ -- u8-ready?: (u8-ready? [textual-input-port])
+ If the `port' optional argument is not specified, then the value
+ of the `input-port' keyed dynamic variable is used. If the port
+ is closed, an error is signaled.
+
+ Predicate `u8-ready?' checks to see if a byte is available in the
+ specified port. If it returns true, then a `read-u8' or `peek-u8'
+ on that port is guaranteed not to block/hang. For now in klisp
+ this is hardcoded to `#t' because the code to do this is
+ non-portable.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+
+ -- write-u8: (write-u8 u8 [textual-output-port])
+ If the `port' optional argument is not specified, then the value
+ of the `output-port' keyed dynamic variable is used. If the port
+ is closed, an error is signaled.
+
+ Applicative `write-u8' writes the byte represented by the unsigned
+ integer `u8', that should be between 0 and 255 inclusive, (not an
+ external representation of byte) to the specified port. The
+ result returned by `write-u8' is inert.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+
+ -- flush-output-port: (flush-output-port [output-port])
If the `port' optional argument is not specified, then the value
of the `output-port' keyed dynamic variable is used. If the
`port' is closed or if it is not an output port, an error is
@@ -2447,7 +2540,7 @@ Index
* $sequence: Control. (line 23)
* $set!: Environments. (line 182)
* $vau: Combiners. (line 26)
-* ( <1>: Ports. (line 37)
+* ( <1>: Ports. (line 54)
* ( <2>: Numbers. (line 193)
* ( <3>: Continuations. (line 143)
* (: Environments. (line 174)
@@ -2474,6 +2567,7 @@ Index
* assoc: Pairs and lists. (line 252)
* assq: Pairs and lists. (line 333)
* atan: Numbers. (line 386)
+* binary-port?: Ports. (line 43)
* boolean?: Booleans. (line 12)
* booleans: Booleans. (line 6)
* caaaar: Pairs and lists. (line 101)
@@ -2490,8 +2584,8 @@ Index
* cadddr: Pairs and lists. (line 108)
* caddr: Pairs and lists. (line 96)
* cadr: Pairs and lists. (line 90)
-* call-with-input-file: Ports. (line 131)
-* call-with-output-file: Ports. (line 133)
+* call-with-input-file: Ports. (line 173)
+* call-with-output-file: Ports. (line 175)
* call/cc: Continuations. (line 43)
* car: Pairs and lists. (line 85)
* cdaaar: Pairs and lists. (line 109)
@@ -2554,7 +2648,7 @@ Index
* encycle!: Pairs and lists. (line 158)
* environment?: Environments. (line 23)
* environments: Environments. (line 6)
-* eof-object?: Ports. (line 166)
+* eof-object?: Ports. (line 208)
* eq?: Equivalence. (line 12)
* equal?: Equivalence. (line 16)
* equivalence: Equivalence. (line 6)
@@ -2580,7 +2674,7 @@ Index
* gcd: Numbers. (line 207)
* get-current-environment: Environments. (line 114)
* get-list-metrics: Pairs and lists. (line 123)
-* get-module: Ports. (line 156)
+* get-module: Ports. (line 198)
* get-real-exact-bounds: Numbers. (line 233)
* get-real-exact-primary: Numbers. (line 252)
* get-real-internal-bounds: Numbers. (line 232)
@@ -2593,7 +2687,7 @@ Index
* inert: Control. (line 6)
* inert?: Control. (line 11)
* inexact?: Numbers. (line 83)
-* input-port?: Ports. (line 27)
+* input-port?: Ports. (line 32)
* integer->char: Characters. (line 59)
* integer?: Numbers. (line 61)
* Kernel history: Kernel History. (line 6)
@@ -2609,7 +2703,7 @@ Index
* list-ref: Pairs and lists. (line 198)
* list-tail: Pairs and lists. (line 147)
* lists: Pairs and lists. (line 6)
-* load: Ports. (line 143)
+* load: Ports. (line 185)
* log: Numbers. (line 376)
* make-encapsulation-type: Encapsulations. (line 12)
* make-environment: Environments. (line 36)
@@ -2637,17 +2731,19 @@ Index
* object descriptions: A Sample Applicative Description.
(line 6)
* odd?: Numbers. (line 185)
-* open-input-file: Ports. (line 62)
-* open-output-file: Ports. (line 73)
+* open-binary-input-file: Ports. (line 79)
+* open-binary-output-file: Ports. (line 94)
+* open-input-file: Ports. (line 78)
+* open-output-file: Ports. (line 92)
* operative descriptions: A Sample Applicative Description.
(line 6)
* operative?: Combiners. (line 16)
* operatives: Combiners. (line 6)
* or?: Booleans. (line 24)
-* output-port?: Ports. (line 28)
+* output-port?: Ports. (line 33)
* pair?: Pairs and lists. (line 27)
* pairs: Pairs and lists. (line 6)
-* port?: Ports. (line 23)
+* port?: Ports. (line 28)
* ports: Ports. (line 6)
* positive?: Numbers. (line 177)
* printing notation: Printing Notation. (line 6)
@@ -2655,7 +2751,7 @@ Index
* promises: Promises. (line 6)
* rational?: Numbers. (line 66)
* rationalize: Numbers. (line 340)
-* read: Ports. (line 102)
+* read: Ports. (line 144)
* real->exact: Numbers. (line 286)
* real->inexact: Numbers. (line 285)
* real?: Numbers. (line 71)
@@ -2695,6 +2791,7 @@ Index
* symbol?: Symbols. (line 12)
* symbols: Symbols. (line 6)
* tan: Numbers. (line 381)
+* textual-port?: Ports. (line 42)
* truncate: Numbers. (line 326)
* undefined?: Numbers. (line 91)
* unwrap: Combiners. (line 72)
@@ -2733,6 +2830,6 @@ Node: Numbers72249
Node: Strings91748
Node: Characters97095
Node: Ports99805
-Node: Alphabetical Index112780
+Node: Alphabetical Index117409
End Tag Table
diff --git a/manual/src/ports.texi b/manual/src/ports.texi
@@ -7,9 +7,14 @@
@chapter Ports
@cindex ports
- A port is an object that mediates character-based input from a
-source or character-based output to a destination. In the former case,
-the port is an input port, in the latter case, an output port.
+ A port is an object that mediates data from an input or to a
+destination. In the former case, the port is an input port, in the
+latter case, an output port. The data itself can consist of either
+characters or bytes. In the former case the port is a textual port
+and in the latter case, a binary port.
+
+ There are three textual ports open, binded by dynamic variables, one
+for standard input, output, and error.
@c TODO add xref to equal? & eq?
Although ports are not considered immutable, none of the operations
@@ -17,7 +22,7 @@ on ports described in this section constitute mutation. Ports are
@code{equal?} iff @code{eq?}. The port type is encapsulated.
An auxiliary data type used to signal the end of file was reached is
-eof. The eof type consists of a single immutable value, having
+@code{eof}. The eof type consists of a single immutable value, having
an output only external representation (so that it can never be the
normal result of a call to read). The eof type is encapsulated.
@@ -33,68 +38,86 @@ returns true iff all the objects in @code{objects} are of type port.
@deffnx Applicative output-port? (output-port? . objects)
Applicative @code{input-port?} is a predicate that returns true
unless one or more of its arguments is not an input port. Applicative
-output-port? is a predicate that returns true unless one or more of
-its arguments is not an output port.
+@code{output-port?} is a predicate that returns true unless one or
+more of its arguments is not an output port.
Every port must be admitted by at least one of these two predicates.
@end deffn
+@deffn Applicative textual-port? (textual-port? . objects)
+@deffnx Applicative binary-port? (binary-port? . objects)
+ Applicative @code{textual-port?} is a predicate that returns true
+unless one or more of its arguments is not a textual port. Applicative
+@code{binary-port?} is a predicate that returns true unless one or more of
+its arguments is not a binary port.
+
+ Every port must be admitted by at least one of these two predicates.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+@end deffn
+
@deffn with-input-from-file (with-input-from-file string combiner)
@deffnx with-output-to-file (with-output-to-file string combiner)
+@deffnx with-error-to-file (with-error-to-file string combiner)
@c add xref get-current-input-port/get-current-output-port
- These two applicatives open the file named in @code{string} for
-input or output, an invoke the binder of the input-port & output-port
-keyed dynamic variables respectively with the opened port & the passed
-@code{combiner} (this means that the combiner is called in a fresh, empty
-dynamic environment). When/if the binder normally returns, the port is closed.
-The result of the applicatives @code{with-input-from-file} and
-@code{with-output-from-file} is inert.
-
- SOURCE NOTE: this is enumerated in the Kernel report but the text is
-still missing. In the new scheme report there's also a third
-error-port variable. It is very likely that that will be added to the
-klisp implementation in the near future.
+ These three applicatives open the file named in @code{string} for
+textual input or output, an invoke the binder of either the
+input-port, the output-port or the error-port keyed dynamic variables
+respectively with the opened port & the passed @code{combiner} (this
+means that the combiner is called in a fresh, empty dynamic
+environment). When/if the binder normally returns, the port is
+closed. The result of the applicatives @code{with-input-from-file}
+and @code{with-output-from-file} is inert.
+
+ SOURCE NOTE: The first two are enumerated in the Kernel report but
+the text is still missing. The third applicative is from Scheme.
@end deffn
@deffn get-current-input-port (get-current-input-port)
@deffnx get-current-output-port (get-current-output-port)
- These are the accessors for the input-port and output-port keyed
-dynamic variables repectively.
+@deffnx get-current-error-port (get-current-error-port)
+ These are the accessors for the input-port, output-port, and
+error-port keyed dynamic variables repectively.
@c add xref to with-input-from-file, etc
@c add xref and text for these dynamic vars
- SOURCE NOTE: this is enumerated in the Kernel report but the text is
-still missing. In the new scheme report there's also a third
-error-port variable. It is very likely that that will be added to the
-klisp implementation in the near future.
+ SOURCE NOTE: The first two are enumerated in the Kernel report but
+the text is still missing. The third applicative is from Scheme.
@end deffn
@deffn Applicative open-input-file (open-input-file string)
+@deffnx Applicative open-binary-input-file (open-binary-input-file string)
@code{string} should be the name/path for an existing file.
- Applicative @code{open-input-file} creates and returns an input port
-associated with the file represented with @code{string}. If the file
-can't be opened (e.g. because it doesn't exists, or there's a
-permissions problem), an error is signaled.
+ Applicative @code{open-input-file} creates and returns a textual
+input port associated with the file represented with @code{string}.
+Applicative @code{open-binary-input-file} creates and returns a binary
+input port associated with the file represented with @code{string}.
+In either case, if the file can't be opened (e.g. because it doesn't
+exists, or there's a permissions problem), an error is signaled.
- SOURCE NOTE: this is enumerated in the Kernel report but the text is
-still missing.
+ SOURCE NOTE: open-input-file is enumerated in the Kernel report but
+the text is still missing. open-binary-input-file is from Scheme.
@end deffn
@deffn Applicative open-output-file (open-output-file string)
+@deffnx Applicative open-binary-output-file (open-binary-output-file string)
@code{string} should be the name/path for an existing file.
- Applicative @code{open-output-file} creates and returns an output
-port associated with the file represented with @code{string}. If the
-file can't be opened (e.g. if there's a permissions problem), an error
-is signaled.
+ Applicative @code{open-output-file} creates and returns a textual
+output port associated with the file represented with @code{string}.
+Applicative @code{open-binary-output-file} creates and returns a
+binary output port associated with the file represented with
+@code{string}. In either case, if the file can't be opened (e.g. if
+there's a permissions problem), an error is signaled.
- In klisp, for now, applicative @code{open-output-file} truncates the
-file if it already exists, but that could change later (i.e. like in
-scheme the behaviour should be considered unspecified).
+ In klisp, for now, applicative @code{open-output-file} and
+@code{open-binary-output-file} truncate the file if it already exists,
+but that could change later (i.e. like in Scheme the behaviour should
+be considered unspecified).
- SOURCE NOTE: this is enumerated in the Kernel report but the text is
-still missing.
+ SOURCE NOTE: open-output-file is enumerated in the Kernel report but
+the text is still missing. open-binary-output-file is from Scheme.
@end deffn
@deffn close-input-file (close-input-file input-port)
@@ -112,13 +135,30 @@ still missing. There's probably a name error here. These should
probably be called close-input-port & close-output-port.
@end deffn
-@deffn Applicative read (read [input-port])
+@deffn close-input-port (close-input-port input-port)
+@deffnx close-output-port (close-output-port output-port)
+@deffnx close-port (close-port port)
+ These applicatives close the port argument, so that no more
+input/output may be performed on them, and the resources can be
+freed. If the port was already closed these applicatives have no
+effect. If at some time klisp provided input/ouput ports these could
+be used to selectively close only one direction of the port.
+
+ The result returned by applicatives @code{close-input-port},
+@code{close-output-port}, and @code{close-port} is inert.
+
+ SOURCE NOTE: this is from Scheme. The equivalent
+@code{close-input-file} and @code{close-output-file} are probably name
+errors and only retained here till the draft standard rectifies them
+@end deffn
+
+@deffn Applicative read (read [textual-input-port])
If the @code{port} optional argument is not specified, then the
value of the @code{input-port} keyed dynamic variable is used. If the
port is closed, an error is signaled.
Applicative @code{read} reads & returns the next parseable object
-from the given port, or the eof object if no objects remain. If
+from the given port, or the @code{eof} if no objects remain. If
@code{read} finds and unparseable object in the port, an error is
signaled. In that case, the remaining position in the port is
unspecified.
@@ -127,7 +167,7 @@ unspecified.
still missing.
@end deffn
-@deffn write (write object [port])
+@deffn write (write object [textual-output-port])
If the @code{port} optional argument is not specified, then the
value of the @code{output-port} keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -147,11 +187,11 @@ still missing.
@deffn Applicative call-with-input-file (call-with-input-file string combiner)
@deffnx Applicative call-with-output-file (call-with-output-file string combiner)
- These applicatives open file named in @code{string} and call their
-@code{combiner} argument in a fresh empty environment passing it as a
-sole operand the opened port. When/if the combiner normally returns a
-value the port is closed and that value is returned as the result of
-the applicative.
+ These applicatives open file named in @code{string} for textual
+input/output respectively and call their @code{combiner} argument in a
+fresh empty environment passing it as a sole operand the opened port.
+When/if the combiner normally returns a value the port is closed and
+that value is returned as the result of the applicative.
SOURCE NOTE: this is enumerated in the Kernel report but the text is
still missing.
@@ -159,10 +199,10 @@ still missing.
@deffn Applicative load (load string)
@c TODO add xref, open/input, read
- Applicative @code{load} opens for input a file named @code{string};
-reads objects from the file until the end of the file is reached;
-evaluates those objects consecutively in the created environment. The
-result from applicative @code{load} is inert.
+ Applicative @code{load} opens the file named @code{string} for
+textual input; reads objects from the file until the end of the file
+is reached; evaluates those objects consecutively in the created
+environment. The result from applicative @code{load} is inert.
SOURCE NOTE: load is enumerated in the Kernel report, but the
description is not there yet. This seems like a sane way to define
@@ -175,11 +215,11 @@ return the value of the last evaluation.
@deffn Applicative get-module (get-module string [environment])
@c TODO add xref standard-environment, open/input, read
Applicative @code{get-module} creates a fresh standard environment;
-opens for input a file named @code{string}; reads objects from the
-file until the end of the file is reached; evaluates those objects
-consecutively in the created environment; and, lastly, returns the
-created environment. If the optional argument @code{environment} is
-specified, the freshly created standard environment is augmented,
+opens the file named @code{string} for textual input; reads objects
+from the file until the end of the file is reached; evaluates those
+objects consecutively in the created environment; and, lastly, returns
+the created environment. If the optional argument @code{environment}
+is specified, the freshly created standard environment is augmented,
prior to evaluating read expressions, by binding symbol
@code{module-parameters} to the @code{environment} argument.
@end deffn
@@ -189,38 +229,38 @@ prior to evaluating read expressions, by binding symbol
returns true iff all the objects in @code{objects} are of type eof.
SOURCE NOTE: This is not in the report, the idea is from Scheme.
-The @code{eof-object?} name is also from scheme, but this will
+The @code{eof-object?} name is also from Scheme, but this will
probably be changed to just @code{eof?}, for consistency with the other
primitive type predicates.
@end deffn
-@deffn read-char (read-char [port])
+@deffn read-char (read-char [textual-input-port])
If the @code{port} optional argument is not specified, then the
value of the @code{input-port} keyed dynamic variable is used. If the
port is closed, an error is signaled.
Applicative @code{read-char} reads and returns a character (not
an external representation of a character) from the specified port, or
-an eof if the end of file was reached.
+an @code{eof} if the end of file was reached.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
@end deffn
-@deffn peek-char (peek-char [port])
+@deffn peek-char (peek-char [textual-input-port])
If the @code{port} optional argument is not specified, then the
value of the @code{input-port} keyed dynamic variable is used. If the
port is closed, an error is signaled.
Applicative @code{peek-char} reads and returns a character (not
an external representation of a character) from the specified port, or
-an eof if the end of file was reached. The position of the port
+an @code{eof} if the end of file was reached. The position of the port
remains unchanged so that new call to @code{peek-char} or
@code{read-char} on the same port return the same character.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
@end deffn
-@deffn char-ready? (char-ready? [port])
+@deffn char-ready? (char-ready? [textual-input-port])
If the @code{port} optional argument is not specified, then the
value of the @code{input-port} keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -234,7 +274,7 @@ the code to do this is non-portable.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
@end deffn
-@deffn write-char (write-char char [port])
+@deffn write-char (write-char char [textual-output-port])
If the @code{port} optional argument is not specified, then the
value of the @code{output-port} keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -246,7 +286,7 @@ The result returned by @code{write-char} is inert.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
@end deffn
-@deffn newline (newline [port])
+@deffn newline (newline [textal-ouput-port])
If the @code{port} optional argument is not specified, then the
value of the @code{output-port} keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -257,7 +297,7 @@ The result returned by @code{newline} is inert.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
@end deffn
-@deffn display (display object [port])
+@deffn display (display object [textual-output-port])
If the @code{port} optional argument is not specified, then the
value of the @code{output-port} keyed dynamic variable is used. If the
port is closed, an error is signaled.
@@ -271,7 +311,62 @@ within those strings and character objects are output as if by
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
@end deffn
-@deffn flush-output-port (flush-output-port [port])
+@deffn read-u8 (read-u8 [textual-input-port])
+ If the @code{port} optional argument is not specified, then the
+value of the @code{input-port} keyed dynamic variable is used. If the
+port is closed, an error is signaled.
+
+ Applicative @code{read-u8} reads and returns a byte as an exact
+unsigned integer between 0 and 255 inclusive (not an external
+representation of a byte) from the specified port, or an @code{eof} if
+the end of file was reached.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+@end deffn
+
+@deffn peek-u8 (peek-u8 [textual-input-port])
+ If the @code{port} optional argument is not specified, then the
+value of the @code{input-port} keyed dynamic variable is used. If the
+port is closed, an error is signaled.
+
+ Applicative @code{peek-u8} reads and returns a byte as an exact
+unsigned integer between 0 and 255 inclusive (not an external
+representation of a byte) from the specified port, or an @code{eof} if
+the end of file was reached. The position of the port remains
+unchanged so that new call to @code{peek-u8} or @code{read-u8} on the
+same port return the same byte.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+@end deffn
+
+@deffn u8-ready? (u8-ready? [textual-input-port])
+ If the @code{port} optional argument is not specified, then the
+value of the @code{input-port} keyed dynamic variable is used. If the
+port is closed, an error is signaled.
+
+ Predicate @code{u8-ready?} checks to see if a byte is
+available in the specified port. If it returns true, then a
+@code{read-u8} or @code{peek-u8} on that port is guaranteed not to
+block/hang. For now in klisp this is hardcoded to @code{#t} because
+the code to do this is non-portable.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+@end deffn
+
+@deffn write-u8 (write-u8 u8 [textual-output-port])
+ If the @code{port} optional argument is not specified, then the
+value of the @code{output-port} keyed dynamic variable is used. If the
+port is closed, an error is signaled.
+
+ Applicative @code{write-u8} writes the byte represented by the
+unsigned integer @code{u8}, that should be between 0 and 255 inclusive,
+(not an external representation of byte) to the specified port. The
+result returned by @code{write-u8} is inert.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+@end deffn
+
+@deffn flush-output-port (flush-output-port [output-port])
If the @code{port} optional argument is not specified, then the
value of the @code{output-port} keyed dynamic variable is used. If
the @code{port} is closed or if it is not an output port, an error is
diff --git a/src/Makefile b/src/Makefile
@@ -35,12 +35,12 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kwrite.o kstate.o kmem.o kerror.o kauxlib.o kenvironment.o \
kcontinuation.o koperative.o kapplicative.o keval.o krepl.o kscript.o \
kencapsulation.o kpromise.o kport.o kinteger.o krational.o \
- kreal.o ktable.o kgc.o imath.o imrat.o kblob.o \
+ kreal.o ktable.o kgc.o imath.o imrat.o kbytevector.o kvector.o \
kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
kgpromises.o kgkd_vars.o kgks_vars.o kgports.o kgchars.o kgnumbers.o \
- kgstrings.o kgblobs.o kgsystem.o kgerror.o \
+ kgstrings.o kgbytevectors.o kgvectors.o kgsystem.o kgerror.o \
$(if $(USE_LIBFFI),kgffi.o)
# TEMP: in klisp there is no distinction between core & lib
@@ -69,10 +69,11 @@ $(KRN_T): $(KRN_O) $(KRN_A)
$(CC) -o $@ $(MYLDFLAGS) $(KRN_O) $(KRN_A) $(LIBS)
clean:
- $(RM) $(ALL_T) $(ALL_O)
+ $(RM) $(ALL_T) $(ALL_O) kgffi.o
+# XXX this fails if USE_LIBFFI is not defined
depend:
- @$(CC) $(CFLAGS) -MM k*.c imath.c imrat.c
+ @$(CC) $(CFLAGS) -DKUSE_LIBFFI=1 -MM k*.c imath.c imrat.c
echo:
@echo "PLAT = $(PLAT)"
@@ -116,8 +117,8 @@ kapplicative.o: kapplicative.c kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kapplicative.h koperative.h kgc.h
kauxlib.o: kauxlib.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h
-kblob.o: kblob.c kblob.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
- ktoken.h kmem.h kgc.h
+kbytevector.o: kbytevector.c kbytevector.h kobject.h klimits.h klisp.h \
+ klispconf.h kstate.h ktoken.h kmem.h kgc.h kstring.h
kcontinuation.o: kcontinuation.c kcontinuation.h kobject.h klimits.h \
klisp.h klispconf.h kstate.h ktoken.h kmem.h kgc.h
kencapsulation.o: kencapsulation.c kobject.h klimits.h klisp.h \
@@ -126,23 +127,20 @@ kenvironment.o: kenvironment.c kenvironment.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kpair.h kgc.h ksymbol.h kstring.h \
kerror.h ktable.h kapplicative.h koperative.h
kerror.o: kerror.c klisp.h kobject.h klimits.h klispconf.h kpair.h \
- kstate.h ktoken.h kmem.h kgc.h kstring.h
+ kstate.h ktoken.h kmem.h kgc.h kstring.h kerror.h
keval.o: keval.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h kerror.h
-kgblobs.o: kgblobs.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- kblob.h kghelpers.h kpair.h kgc.h kenvironment.h ksymbol.h kstring.h \
- kgblobs.h kgnumbers.h
kgbooleans.o: kgbooleans.c kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kpair.h kgc.h ksymbol.h kstring.h \
kcontinuation.h kerror.h kghelpers.h kapplicative.h koperative.h \
kenvironment.h
+kgbytevectors.o: kgbytevectors.c kstate.h klimits.h klisp.h kobject.h \
+ klispconf.h ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h \
+ kerror.h kpair.h kgc.h kbytevector.h kghelpers.h kenvironment.h \
+ ksymbol.h kstring.h kgbytevectors.h kgnumbers.h
kgc.o: kgc.c kgc.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
- ktoken.h kmem.h kport.h imath.h imrat.h ktable.h kstring.h kblob.h \
- kerror.h
-kgchars.o: kgchars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- kghelpers.h kpair.h kgc.h kenvironment.h ksymbol.h kstring.h kgchars.h
+ ktoken.h kmem.h kport.h imath.h imrat.h ktable.h kstring.h kbytevector.h \
+ kvector.h kerror.h kpair.h
kgcombiners.o: kgcombiners.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
ksymbol.h kstring.h koperative.h kapplicative.h kerror.h kghelpers.h \
@@ -157,31 +155,39 @@ kgcontrol.o: kgcontrol.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgcontrol.h kgcombiners.h
kgencapsulations.o: kgencapsulations.c kstate.h klimits.h klisp.h \
kobject.h klispconf.h ktoken.h kmem.h kencapsulation.h kapplicative.h \
- koperative.h kerror.h kghelpers.h kpair.h kgc.h kcontinuation.h \
+ koperative.h kerror.h kpair.h kgc.h kghelpers.h kcontinuation.h \
kenvironment.h ksymbol.h kstring.h kgencapsulations.h
-kgenv_mut.o: kgenv_mut.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h ksymbol.h \
- kstring.h kerror.h kghelpers.h kapplicative.h koperative.h kgenv_mut.h \
- kgcontrol.h
kgenvironments.o: kgenvironments.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
ksymbol.h kstring.h kerror.h kghelpers.h kapplicative.h koperative.h \
kgenvironments.h kgenv_mut.h kgpair_mut.h kgcontrol.h
+kgenv_mut.o: kgenv_mut.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h ksymbol.h \
+ kstring.h kerror.h kghelpers.h kapplicative.h koperative.h kgenv_mut.h \
+ kgcontrol.h
kgeqp.o: kgeqp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h kerror.h kghelpers.h \
kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h kgeqp.h \
kinteger.h imath.h krational.h imrat.h
kgequalp.o: kgequalp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kpair.h kgc.h kstring.h kblob.h kcontinuation.h kerror.h \
- kghelpers.h kapplicative.h koperative.h kenvironment.h ksymbol.h kgeqp.h \
- kinteger.h imath.h krational.h imrat.h kgequalp.h
+ ktoken.h kmem.h kpair.h kgc.h kstring.h kbytevector.h kcontinuation.h \
+ kerror.h kghelpers.h kapplicative.h koperative.h kenvironment.h \
+ ksymbol.h kgeqp.h kinteger.h imath.h krational.h imrat.h kgequalp.h
kgerror.o: kgerror.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kstring.h kpair.h kgc.h kerror.h kghelpers.h \
kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
- kgerror.h
+ kgerror.h
+kgffi.o: kgffi.c imath.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
+ ktoken.h kmem.h kinteger.h kpair.h kgc.h kerror.h kbytevector.h \
+ kencapsulation.h ktable.h kghelpers.h kapplicative.h koperative.h \
+ kcontinuation.h kenvironment.h ksymbol.h kstring.h kgencapsulations.h \
+ kgcombiners.h kgcontinuations.h kgffi.h
kghelpers.o: kghelpers.c kghelpers.h kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kerror.h kpair.h kgc.h kapplicative.h \
koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h
+kgchars.o: kgchars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
+ kpair.h kgc.h kghelpers.h kenvironment.h ksymbol.h kstring.h kgchars.h
kgkd_vars.o: kgkd_vars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h koperative.h \
kapplicative.h kenvironment.h kerror.h kghelpers.h ksymbol.h kstring.h \
@@ -192,8 +198,8 @@ kgks_vars.o: kgks_vars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgks_vars.h
kgnumbers.o: kgnumbers.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- ksymbol.h kstring.h kinteger.h imath.h krational.h imrat.h kreal.h \
- kghelpers.h kpair.h kgc.h kenvironment.h kgnumbers.h kgkd_vars.h
+ kpair.h kgc.h ksymbol.h kstring.h kinteger.h imath.h krational.h imrat.h \
+ kreal.h kghelpers.h kenvironment.h kgnumbers.h kgkd_vars.h
kgpair_mut.o: kgpair_mut.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kcontinuation.h ksymbol.h \
kstring.h kerror.h kghelpers.h kapplicative.h koperative.h \
@@ -204,9 +210,10 @@ kgpairs_lists.o: kgpairs_lists.c kstate.h klimits.h klisp.h kobject.h \
kenvironment.h ksymbol.h kerror.h kghelpers.h kapplicative.h \
koperative.h kgequalp.h kgpairs_lists.h kgnumbers.h kinteger.h imath.h
kgports.o: kgports.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kport.h kenvironment.h kapplicative.h koperative.h \
- kcontinuation.h kpair.h kgc.h kerror.h ksymbol.h kstring.h kread.h \
- kwrite.h kghelpers.h kgports.h kgcontinuations.h kgcontrol.h kgkd_vars.h kscript.h
+ ktoken.h kmem.h kport.h kstring.h kbytevector.h kenvironment.h \
+ kapplicative.h koperative.h kcontinuation.h kpair.h kgc.h kerror.h \
+ ksymbol.h kread.h kwrite.h kscript.h kghelpers.h kgports.h \
+ kgcontinuations.h kgcontrol.h kgkd_vars.h
kgpromises.o: kgpromises.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpromise.h kpair.h kgc.h kapplicative.h \
koperative.h kcontinuation.h kerror.h kghelpers.h kenvironment.h \
@@ -218,11 +225,11 @@ kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgequalp.h kgsymbols.h kgcontrol.h kgpairs_lists.h kgpair_mut.h \
kgenvironments.h kgenv_mut.h kgcombiners.h kgcontinuations.h \
kgencapsulations.h kgpromises.h kgkd_vars.h kgks_vars.h kgnumbers.h \
- kgstrings.h kgchars.h kgports.h kgblobs.h ktable.h keval.h krepl.h \
- kscript.h kgsystem.h kgerror.h kgffi.h
+ kgstrings.h kgchars.h kgports.h kgbytevectors.h kgvectors.h kgsystem.h \
+ kgerror.h kgffi.h ktable.h keval.h krepl.h kscript.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- ksymbol.h kstring.h kghelpers.h kpair.h kgc.h kenvironment.h kgchars.h \
+ kpair.h kgc.h ksymbol.h kstring.h kghelpers.h kenvironment.h kgchars.h \
kgstrings.h kgnumbers.h
kgsymbols.o: kgsymbols.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kcontinuation.h kpair.h kgc.h kstring.h ksymbol.h \
@@ -232,23 +239,26 @@ kgsystem.o: kgsystem.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kerror.h kghelpers.h kapplicative.h \
koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h \
kgsystem.h
-kgffi.o: kgsystem.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kpair.h kgc.h kerror.h kghelpers.h kapplicative.h \
- koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h \
- kblob.h kencapsulation.h kgencapsulations.h kgffi.h
+kgvectors.o: kgvectors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
+ kpair.h kgc.h kvector.h kghelpers.h kenvironment.h ksymbol.h kstring.h \
+ kgvectors.h kgnumbers.h
kinteger.o: kinteger.c kinteger.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h imath.h kgc.h
klisp.o: klisp.c klimits.h klisp.h kobject.h klispconf.h kstate.h \
- ktoken.h kmem.h kauxlib.h
+ ktoken.h kmem.h kauxlib.h kstring.h kcontinuation.h koperative.h \
+ kenvironment.h kport.h kread.h kwrite.h kerror.h kpair.h kgc.h \
+ kgcontinuations.h kghelpers.h kapplicative.h ksymbol.h kgcontrol.h \
+ kscript.h krepl.h
kmem.o: kmem.c klisp.h kobject.h klimits.h klispconf.h kstate.h ktoken.h \
- kmem.h kerror.h kgc.h
+ kmem.h kerror.h kpair.h kgc.h
kobject.o: kobject.c kobject.h klimits.h klisp.h klispconf.h
koperative.o: koperative.c koperative.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kgc.h
kpair.o: kpair.c kpair.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kgc.h
kport.o: kport.c kport.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
- ktoken.h kmem.h kerror.h kstring.h kgc.h
+ ktoken.h kmem.h kerror.h kpair.h kgc.h kstring.h kbytevector.h
kpromise.o: kpromise.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kpromise.h kpair.h kgc.h
krational.o: krational.c krational.h kobject.h klimits.h klisp.h \
@@ -259,15 +269,18 @@ kreal.o: kreal.c kreal.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kinteger.h imath.h krational.h imrat.h kgc.h kpair.h \
kerror.h
krepl.o: krepl.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
- ktoken.h kmem.h kcontinuation.h kenvironment.h kerror.h kread.h kwrite.h \
- kstring.h krepl.h ksymbol.h kport.h kpair.h kgc.h ktable.h
+ ktoken.h kmem.h kcontinuation.h kenvironment.h kerror.h kpair.h kgc.h \
+ kread.h kwrite.h kstring.h krepl.h ksymbol.h kport.h kgerror.h \
+ kghelpers.h kapplicative.h koperative.h ktable.h kgcontinuations.h
kscript.o: kscript.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
- ktoken.h kmem.h kcontinuation.h kenvironment.h kerror.h kread.h kwrite.h \
- kstring.h krepl.h kscript.h ksymbol.h kport.h kpair.h kgc.h ktable.h kgcontrol.h
+ ktoken.h kmem.h kcontinuation.h kenvironment.h kerror.h kpair.h kgc.h \
+ kread.h kwrite.h kstring.h krepl.h kscript.h ksymbol.h kport.h \
+ kgcontrol.h kghelpers.h kapplicative.h koperative.h kgerror.h ktable.h
kstate.o: kstate.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h kstring.h kpair.h kgc.h keval.h koperative.h \
- kapplicative.h kcontinuation.h kenvironment.h kground.h krepl.h kscript.h \
- ksymbol.h kport.h ktable.h kblob.h kgpairs_lists.h kghelpers.h kerror.h
+ kapplicative.h kcontinuation.h kenvironment.h kground.h krepl.h \
+ kscript.h ksymbol.h kport.h ktable.h kbytevector.h kvector.h \
+ kgpairs_lists.h kghelpers.h kerror.h kgerror.h
kstring.o: kstring.c kstring.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kgc.h
ksymbol.o: ksymbol.c ksymbol.h kobject.h klimits.h klisp.h klispconf.h \
@@ -278,12 +291,14 @@ ktable.o: ktable.c klisp.h kobject.h klimits.h klispconf.h kgc.h kstate.h \
kenvironment.h ksymbol.h kstring.h
ktoken.o: ktoken.c ktoken.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h kmem.h kinteger.h imath.h krational.h imrat.h kreal.h kpair.h \
- kgc.h kstring.h ksymbol.h kerror.h kport.h
+ kgc.h kstring.h kbytevector.h ksymbol.h kerror.h kport.h
+kvector.o: kvector.c kvector.h kobject.h klimits.h klisp.h klispconf.h \
+ kstate.h ktoken.h kmem.h kgc.h
kwrite.o: kwrite.c kwrite.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kinteger.h imath.h krational.h imrat.h kreal.h \
kpair.h kgc.h kstring.h ksymbol.h kerror.h ktable.h kport.h \
- kenvironment.h kblob.h
+ kenvironment.h kbytevector.h
imath.o: imath.c imath.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
- ktoken.h kmem.h kerror.h
+ ktoken.h kmem.h kerror.h kpair.h kgc.h
imrat.o: imrat.c imrat.h imath.h kobject.h klimits.h klisp.h klispconf.h \
- kstate.h ktoken.h kmem.h kerror.h
+ kstate.h ktoken.h kmem.h kerror.h kpair.h kgc.h
diff --git a/src/examples/ffi-gsl.k b/src/examples/ffi-gsl.k
@@ -24,7 +24,7 @@
(cif (ffi-make-call-interface abi "double" (list "double" "pointer"))) )
($lambda (f)
($let
- ( (gslf (make-blob (* 2 pointer-size)) )
+ ( (gslf (make-bytevector (* 2 pointer-size)) )
(aux ($lambda (x params) (f x))))
(set! (list gslf 0) (ffi-make-callback aux cif))
gslf))))
@@ -39,8 +39,8 @@
((gslf (make-gsl-function f)))
($lambda (x h)
($let
- ( (result (make-blob double-size))
- (abserr (make-blob double-size)))
+ ( (result (make-bytevector double-size))
+ (abserr (make-bytevector double-size)))
(gsl_deriv_central gslf x h result abserr)
(list (ref result) (ref abserr))))))))
diff --git a/src/examples/ffi-sdl.k b/src/examples/ffi-sdl.k
@@ -45,10 +45,10 @@
((SDL_WaitEvent (sdl-import "sint" "SDL_WaitEvent" "pointer")))
($lambda ()
($let*
- ( (buffer (make-blob 512))
+ ( (buffer (make-bytevector 512))
(ok (SDL_WaitEvent buffer)))
($if (zero? ok)
- (apply-continuation error-continuation "SDL_WaitEvent signalled error")
+ (error "SDL_WaitEvent signalled error")
buffer)))))
($define! align
@@ -113,14 +113,14 @@
(write status)
(newline)
($if (<? status 0)
- (apply error-continuation "error initializing SDL")
+ (error "error initializing SDL")
($sequence
(guard-dynamic-extent
()
($lambda ()
($let* ((screen (sdl-set-video-mode 640 480 32 SDL_HWSURFACE)))
($if (null? screen)
- (apply-continuation error-contination "unable to set video mode")
+ (error "unable to set video mode")
($sequence
(sdl-wm-set-caption window-title ())
(worker screen)))))
@@ -156,7 +156,7 @@
(SDL_Flip (sdl-import "sint" "SDL_Flip" "pointer")))
($lambda (screen (x y) (r g b))
($if (<? (SDL_LockSurface screen) 0)
- (apply error-continuation "SDL_LockSurface failed")
+ (error "SDL_LockSurface failed")
())
($let
( (pixels (SDL_Surface.pixels screen))
diff --git a/src/examples/ffi-signal.c b/src/examples/ffi-signal.c
@@ -58,7 +58,7 @@ static void open_signal_port(klisp_State *K, TValue *xparams,
FILE *fw = fdopen(self_pipe[0], "r");
TValue filename = kstring_new_b_imm(K, "**SIGNAL**");
krooted_tvs_push(K, filename);
- TValue port = kmake_std_port(K, filename, false, fw);
+ TValue port = kmake_std_fport(K, filename, false, true, fw);
krooted_tvs_pop(K);
kapply_cc(K, port);
}
diff --git a/src/examples/ffi-signal.k b/src/examples/ffi-signal.k
@@ -39,7 +39,7 @@
;; an internal pipe.
;;
;; (open-signal-port) opens the read-end of the internal pipe
-;; as a port.
+;; as a binary input port.
;;
;; The following code demonstrates the signal handling (it is not
;; possible to install arbitrary klisp procedure as a signal handler,
@@ -48,10 +48,10 @@
(install-signal-handler "SIGINT")
($define! signal-port (open-signal-port))
(display "Installed signal handler for SIGINT. Press Ctrl-C to continue...")
-(read-char signal-port)
+(read-u8 signal-port)
(newline)
(display "Signal detected. Press Ctrl-C again...")
-(read-char signal-port)
+(read-u8 signal-port)
(newline)
(display "Done.")
(newline)
diff --git a/src/examples/ffi.k b/src/examples/ffi.k
@@ -41,7 +41,7 @@
;; "uint64" uint64_t fixint, bigint
;; "float" float double
;; "double" double double
-;; "pointer" (void *) blob (only for arguments)
+;; "pointer" (void *) bytevector (only for arguments)
;; string (only for arguments)
;; nil
;; pointer (TAG_USER)
@@ -122,7 +122,7 @@
;; (REF MEMORY-LOCATION)
;; (SET! MEMORY-LOCATION VALUE)
;;
-;; MEMORY-LOCATION is either blob, string, pointer,
+;; MEMORY-LOCATION is either bytevector, string, pointer,
;; or a two-element list (MEMORY-LOCATION OFFSET).
;; The offset specification can not be nested, i.e.
;; ((blob 1) 2) is not valid memory location.
@@ -136,7 +136,7 @@
(newline)
;; Using ffi-type-suite, one can define means to convert
-;; C structs (stored in blobs or arbitrary memory locations)
+;; C structs (stored in bytevectors or arbitrary memory locations)
;; to lists.
;;
($define! align
@@ -184,7 +184,7 @@
(ffi-make-call-interface abi
"sint" (list "pointer" "pointer")))))
($lambda ()
- ($let* ((buffer (make-blob (* 2 sint-size))))
+ ($let* ((buffer (make-bytevector (* 2 sint-size))))
(unix-gettimeofday buffer ())
($let (((tv_sec tv_usec) (struct-timeval-ref buffer)))
(list tv_sec (/ tv_usec 1000000)))))))
@@ -203,8 +203,8 @@
(decode-struct "sint" "sint" "sint" "sint" "sint" "sint" "sint" "sint")))
($lambda (t)
($let*
- ( (t-buf (make-blob sint-size))
- (tm-buf (make-blob 128)) )
+ ( (t-buf (make-bytevector sint-size))
+ (tm-buf (make-bytevector 128)) )
(sint-set! t-buf t)
(localtime-r t-buf tm-buf)
($let
@@ -236,21 +236,21 @@
;; (ffi-memmove DESTINATION SOURCE SIZE) copies
;; SIZE bytes from SOURCE to DESTINATION. Both SOURCE
;; and DESTINATION are memory locations as described above.
-;; ffi-memmove can copy data between blobs and arbitrary
+;; ffi-memmove can copy data between bytevectors and arbitrary
;; memory locations.
;;
($define! copy-location
($lambda (location size)
- ($let ((blob (make-blob size)))
+ ($let ((blob (make-bytevector size)))
(ffi-memmove blob location size)
blob)))
-($define! blob->list
+($define! bytevector->list
($letrec
((aux ($lambda (blob index)
- ($if (<? index (blob-length blob))
+ ($if (<? index (bytevector-length blob))
(cons
- (blob-u8-ref blob index)
+ (bytevector-u8-ref blob index)
(aux blob (+ 1 index)))
()))))
($lambda (blob)
@@ -258,7 +258,7 @@
($define! parse-address
($lambda (location size)
- (blob->list (copy-location location size))))
+ (bytevector->list (copy-location location size))))
($define!
(voidptr-size voidptr-alignment voidptr-ref voidptr-set!)
@@ -322,10 +322,10 @@
($define! endianess
($let
- ((buffer (make-blob 4)))
+ ((buffer (make-bytevector 4)))
(uint32-set! buffer #x01020304)
($let
- ((bytes (blob->list buffer)))
+ ((bytes (bytevector->list buffer)))
($cond
((equal? bytes (list 1 2 3 4)) "big-endian")
((equal? bytes (list 4 3 2 1)) "little-endian")
diff --git a/src/kblob.c b/src/kblob.c
@@ -1,66 +0,0 @@
-/*
-** kblob.c
-** Kernel Blobs (byte vectors)
-** See Copyright Notice in klisp.h
-*/
-
-#include <string.h>
-
-#include "kblob.h"
-#include "kobject.h"
-#include "kstate.h"
-#include "kmem.h"
-#include "kgc.h"
-
-/* Constructors */
-TValue kblob_new_g(klisp_State *K, bool m, uint32_t size)
-{
- Blob *new_blob;
-
- /* XXX: find a better way to do this! */
- if (size == 0 && ttisblob(K->empty_blob)) {
- return K->empty_blob;
- }
-
- new_blob = klispM_malloc(K, sizeof(Blob) + size);
-
- /* header + gc_fields */
- klispC_link(K, (GCObject *) new_blob, K_TBLOB, m? 0 : K_FLAG_IMMUTABLE);
-
- /* blob specific fields */
- new_blob->mark = KFALSE;
- new_blob->size = size;
-
- /* clear the buffer */
- memset(new_blob->b, 0, size);
-
- return gc2blob(new_blob);
-}
-
-TValue kblob_new(klisp_State *K, uint32_t size)
-{
- return kblob_new_g(K, true, size);
-}
-
-TValue kblob_new_imm(klisp_State *K, uint32_t size)
-{
- return kblob_new_g(K, false, size);
-}
-
-/* both obj1 and obj2 should be blobs */
-bool kblob_equalp(TValue obj1, TValue obj2)
-{
- klisp_assert(ttisblob(obj1) && ttisblob(obj2));
-
- Blob *blob1 = tv2blob(obj1);
- Blob *blob2 = tv2blob(obj2);
-
- if (blob1->size == blob2->size) {
- return (blob1->size == 0) ||
- (memcmp(blob1->b, blob2->b, blob1->size) == 0);
- } else {
- return false;
- }
-}
-
-bool kblobp(TValue obj) { return ttisblob(obj); }
diff --git a/src/kblob.h b/src/kblob.h
@@ -1,34 +0,0 @@
-/*
-** kblob.h
-** Kernel Blobs (byte vectors)
-** See Copyright Notice in klisp.h
-*/
-
-#ifndef kblob_h
-#define kblob_h
-
-#include "kobject.h"
-#include "kstate.h"
-
-/* TODO change blob constructors to string like constructors */
-/* TODO change names to lua-like (e.g. klispB_new, etc) */
-
-/* Constructors for blobs */
-TValue kblob_new_g(klisp_State *K, bool m, uint32_t size);
-TValue kblob_new_imm(klisp_State *K, uint32_t size);
-TValue kblob_new(klisp_State *K, uint32_t size);
-
-/* both obj1 and obj2 should be blobs, this compares byte by byte
- and doesn't differentiate immutable from mutable blobs */
-bool kblob_equalp(TValue obj1, TValue obj2);
-bool kblob(TValue obj);
-
-/* some macros to access the parts of the blobs */
-#define kblob_buf(tv_) (tv2blob(tv_)->b)
-#define kblob_size(tv_) (tv2blob(tv_)->size)
-
-#define kblob_emptyp(tv_) (kblob_size(tv_) == 0)
-#define kblob_mutablep(tv_) (kis_mutable(tv_))
-#define kblob_immutablep(tv_) (kis_immutable(tv_))
-
-#endif
diff --git a/src/kbytevector.c b/src/kbytevector.c
@@ -0,0 +1,183 @@
+/*
+** kbytevector.c
+** Kernel Byte Vectors
+** See Copyright Notice in klisp.h
+*/
+
+#include <string.h>
+
+#include "kbytevector.h"
+#include "kobject.h"
+#include "kstate.h"
+#include "kmem.h"
+#include "kgc.h"
+/* for immutable table */
+#include "kstring.h"
+
+/* Constructors */
+
+/* General constructor for bytevectors */
+TValue kbytevector_new_bs_g(klisp_State *K, bool m, const uint8_t *buf,
+ uint32_t size)
+{
+ return m? kbytevector_new_bs(K, buf, size) :
+ kbytevector_new_bs_imm(K, buf, size);
+}
+
+/*
+** Constructors for immutable bytevectors
+*/
+
+/* main constructor for immutable bytevectors */
+TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size)
+{
+ /* first check to see if it's in the stringtable */
+ GCObject *o;
+ uint32_t h = size; /* seed */
+ size_t step = (size>>5)+1; /* if bytevector is too long, don't hash all
+ its bytes */
+ size_t size1;
+ for (size1 = size; size1 >= step; size1 -= step) /* compute hash */
+ h = h ^ ((h<<5)+(h>>2)+ buf[size1-1]);
+
+ for (o = K->strt.hash[lmod(h, K->strt.size)];
+ o != NULL; o = o->gch.next) {
+ Bytevector *tb = NULL;
+ if (o->gch.tt == K_TBYTEVECTOR) {
+ tb = (Bytevector *) o;
+ } else if (o->gch.tt == K_TSYMBOL || o->gch.tt == K_TSTRING) {
+ continue;
+ } else {
+ /* only symbols, immutable bytevectors and immutable strings */
+ klisp_assert(0);
+ }
+ if (tb->size == size && (memcmp(buf, tb->b, size) == 0)) {
+ /* bytevector may be dead */
+ if (isdead(K, o)) changewhite(o);
+ return gc2bytevector(o);
+ }
+ }
+
+ /* If it exits the loop, it means it wasn't found, hash is still in h */
+ /* REFACTOR: move all of these to a new function */
+ Bytevector *new_bb;
+
+ if (size > (SIZE_MAX - sizeof(Bytevector)))
+ klispM_toobig(K);
+
+ new_bb = (Bytevector *) klispM_malloc(K, sizeof(Bytevector) + size);
+
+ /* header + gc_fields */
+ /* can't use klispC_link, because strings use the next pointer
+ differently */
+ new_bb->gct = klispC_white(K);
+ new_bb->tt = K_TBYTEVECTOR;
+ new_bb->kflags = K_FLAG_IMMUTABLE;
+ new_bb->si = NULL;
+
+ /* bytevector specific fields */
+ new_bb->hash = h;
+ new_bb->mark = KFALSE;
+ new_bb->size = size;
+
+ if (size != 0) {
+ memcpy(new_bb->b, buf, size);
+ }
+
+ /* add to the string/symbol table (and link it) */
+ stringtable *tb;
+ tb = &K->strt;
+ h = lmod(h, tb->size);
+ new_bb->next = tb->hash[h]; /* chain new entry */
+ tb->hash[h] = (GCObject *)(new_bb);
+ tb->nuse++;
+ TValue ret_tv = gc2bytevector(new_bb);
+ if (tb->nuse > ((uint32_t) tb->size) && tb->size <= INT32_MAX / 2) {
+ krooted_tvs_push(K, ret_tv); /* save in case of gc */
+ klispS_resize(K, tb->size*2); /* too crowded */
+ krooted_tvs_pop(K);
+ }
+
+ return ret_tv;
+}
+
+/*
+** Constructors for mutable bytevectors
+*/
+
+/* main constructor for mutable bytevectors */
+/* with just size */
+TValue kbytevector_new_s(klisp_State *K, uint32_t size)
+{
+ Bytevector *new_bb;
+
+ if (size == 0) {
+ klisp_assert(ttisbytevector(K->empty_bytevector));
+ return K->empty_bytevector;
+ }
+
+ new_bb = klispM_malloc(K, sizeof(Bytevector) + size);
+
+ /* header + gc_fields */
+ klispC_link(K, (GCObject *) new_bb, K_TBYTEVECTOR, 0);
+
+ /* bytevector specific fields */
+ new_bb->mark = KFALSE;
+ new_bb->size = size;
+
+ /* the buffer is initialized elsewhere */
+
+ return gc2bytevector(new_bb);
+}
+
+/* with buffer & size */
+TValue kbytevector_new_bs(klisp_State *K, const uint8_t *buf, uint32_t size)
+{
+ if (size == 0) {
+ klisp_assert(ttisbytevector(K->empty_bytevector));
+ return K->empty_bytevector;
+ }
+
+ TValue new_bb = kbytevector_new_s(K, size);
+ memcpy(kbytevector_buf(new_bb), buf, size);
+ return new_bb;
+}
+
+/* with size and fill uint8_t */
+TValue kbytevector_new_sf(klisp_State *K, uint32_t size, uint8_t fill)
+{
+ if (size == 0) {
+ klisp_assert(ttisbytevector(K->empty_bytevector));
+ return K->empty_bytevector;
+ }
+
+ TValue new_bb = kbytevector_new_s(K, size);
+ memset(kbytevector_buf(new_bb), fill, size);
+ return new_bb;
+}
+
+/* both obj1 and obj2 should be bytevectors */
+bool kbytevector_equalp(TValue obj1, TValue obj2)
+{
+ klisp_assert(ttisbytevector(obj1) && ttisbytevector(obj2));
+
+ Bytevector *bytevector1 = tv2bytevector(obj1);
+ Bytevector *bytevector2 = tv2bytevector(obj2);
+
+ if (bytevector1->size == bytevector2->size) {
+ return (bytevector1->size == 0) ||
+ (memcmp(bytevector1->b, bytevector2->b, bytevector1->size) == 0);
+ } else {
+ return false;
+ }
+}
+
+bool kbytevectorp(TValue obj) { return ttisbytevector(obj); }
+bool kimmutable_bytevectorp(TValue obj)
+{
+ return ttisbytevector(obj) && kis_immutable(obj);
+}
+bool kmutable_bytevectorp(TValue obj)
+{
+ return ttisbytevector(obj) && kis_mutable(obj);
+}
diff --git a/src/kbytevector.h b/src/kbytevector.h
@@ -0,0 +1,54 @@
+/*
+** kbytevector.h
+** Kernel Byte Vectors
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kbytevector_h
+#define kbytevector_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+/* TODO change names to be lua-like (e.g. klispBB_new, etc) */
+
+/* General constructor for bytevectors */
+TValue kbytevector_new_bs_g(klisp_State *K, bool m, const uint8_t *buf,
+ uint32_t size);
+
+/*
+** Constructors for immutable bytevectors
+*/
+
+/* main immutable bytevector constructor */
+/* with buffer & size */
+TValue kbytevector_new_bs_imm(klisp_State *K, const uint8_t *buf, uint32_t size);
+
+/*
+** Constructors for mutable bytevectors
+*/
+
+/* main mutable bytevector constructor */
+/* with just size */
+TValue kbytevector_new_s(klisp_State *K, uint32_t size);
+/* with buffer & size */
+TValue kbytevector_new_bs(klisp_State *K, const uint8_t *buf, uint32_t size);
+/* with size & fill byte */
+TValue kbytevector_new_sf(klisp_State *K, uint32_t size, uint8_t fill);
+
+/* both obj1 and obj2 should be bytevectors, this compares byte by byte
+ and doesn't differentiate immutable from mutable bytevectors */
+bool kbytevector_equalp(TValue obj1, TValue obj2);
+bool kbytevectorp(TValue obj);
+bool kimmutable_bytevectorp(TValue obj);
+bool kmutable_bytevectorp(TValue obj);
+
+/* some macros to access the parts of the bytevectors */
+#define kbytevector_buf(tv_) (tv2bytevector(tv_)->b)
+#define kbytevector_size(tv_) (tv2bytevector(tv_)->size)
+
+#define kbytevector_emptyp(tv_) (kbytevector_size(tv_) == 0)
+#define kbytevector_mutablep(tv_) (kis_mutable(tv_))
+#define kbytevector_immutablep(tv_) (kis_immutable(tv_))
+
+#endif
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -12,7 +12,7 @@
#include "kmem.h"
#include "kgc.h"
-TValue kmake_continuation(klisp_State *K, TValue parent, klisp_Cfunc fn,
+TValue kmake_continuation(klisp_State *K, TValue parent, klisp_CFunction fn,
int32_t xcount, ...)
{
va_list argp;
diff --git a/src/kcontinuation.h b/src/kcontinuation.h
@@ -11,7 +11,7 @@
#include "kstate.h"
/* TODO: make some specialized constructors for 0, 1 and 2 parameters */
-TValue kmake_continuation(klisp_State *K, TValue parent, klisp_Cfunc fn,
+TValue kmake_continuation(klisp_State *K, TValue parent, klisp_CFunction fn,
int xcount, ...);
#endif
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -314,7 +314,7 @@ TValue kget_keyed_static_var(klisp_State *K, TValue env, TValue key)
}
/* environments with hashtable bindings */
-/* TEMP: for now only for ground environment */
+/* TEMP: for now only for ground & std environments */
TValue kmake_table_environment(klisp_State *K, TValue parents)
{
TValue new_env = kmake_environment(K, parents);
diff --git a/src/kerror.c b/src/kerror.c
@@ -32,6 +32,21 @@ TValue klispE_new(klisp_State *K, TValue who, TValue cont, TValue msg,
return gc2error(new_error);
}
+TValue klispE_new_with_errno_irritants(klisp_State *K, const char *service,
+ int errnum, TValue irritants)
+{
+ TValue error_description = klispE_describe_errno(K, service, errnum);
+ krooted_tvs_push(K, error_description);
+ TValue all_irritants = kimm_cons(K, error_description, irritants);
+ krooted_tvs_push(K, all_irritants);
+ TValue error_obj = klispE_new(K, K->next_obj, K->curr_cont,
+ kcaddr(error_description),
+ all_irritants);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ return error_obj;
+}
+
void klispE_free(klisp_State *K, Error *error)
{
klispM_free(K, error);
@@ -102,15 +117,11 @@ void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants)
kcall_cont(K, K->error_cont, error_obj);
}
-void klispE_throw_system_error_with_irritants(klisp_State *K, const char *service, int errnum, TValue irritants)
+void klispE_throw_system_error_with_irritants(
+ klisp_State *K, const char *service, int errnum, TValue irritants)
{
- TValue error_description = klispE_describe_errno(K, service, errnum);
- krooted_tvs_push(K, error_description);
- TValue all_irritants = kimm_cons(K, error_description, irritants);
- krooted_tvs_push(K, all_irritants);
- TValue error_obj = klispE_new(K, K->next_obj, K->curr_cont,
- kcaddr(error_description),
- all_irritants);
+ TValue error_obj = klispE_new_with_errno_irritants(K, service, errnum,
+ irritants);
krooted_tvs_push(K, error_obj);
clear_buffers(K);
kcall_cont(K, K->system_error_cont, error_obj);
@@ -190,7 +201,8 @@ static const char * const symbolic_error_codes[] = {
TValue klispE_describe_errno(klisp_State *K, const char *service, int errnum)
{
const char *code = NULL;
- int tabsize = sizeof(symbolic_error_codes) / sizeof(symbolic_error_codes[0]);
+ int tabsize = sizeof(symbolic_error_codes) /
+ sizeof(symbolic_error_codes[0]);
if (0 <= errnum && errnum < tabsize)
code = symbolic_error_codes[errnum];
if (code == NULL)
diff --git a/src/kerror.h b/src/kerror.h
@@ -13,24 +13,42 @@
#include "klisp.h"
#include "kstate.h"
+#include "kpair.h" /* for klist */
TValue klispE_new(klisp_State *K, TValue who, TValue cont, TValue msg,
TValue irritants);
+TValue klispE_new_with_errno_irritants(klisp_State *K, const char *service,
+ int errnum, TValue irritants);
void klispE_free(klisp_State *K, Error *error);
void klispE_throw_simple(klisp_State *K, char *msg);
void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants);
-void klispE_throw_system_error_with_irritants(klisp_State *K, const char *service, int errnum, TValue irritants);
+void klispE_throw_system_error_with_irritants(
+ klisp_State *K, const char *service, int errnum, TValue irritants);
+
+/* the objects should be rooted */
+#define klispE_new_simple_with_errno_irritants(K__, service__, ...) \
+ ({ \
+ int errnum__ = errno; \
+ TValue ls__ = klist(K__, __VA_ARGS__); \
+ krooted_tvs_push(K__, ls__); \
+ TValue err__ = klispE_new_with_errno_irritants(K__, service__, \
+ errnum__, ls__); \
+ krooted_tvs_pop(K__); \
+ err__; \
+ })
/* evaluates K__ more than once */
+/* the objects should be rooted */
#define klispE_throw_simple_with_irritants(K__, msg__, ...) \
{ TValue ls__ = klist(K__, __VA_ARGS__); \
krooted_tvs_push(K__, ls__); \
/* the pop is implicit in throw_with_irritants */ \
klispE_throw_with_irritants(K__, msg__, ls__); }
+/* the objects should be rooted */
#define klispE_throw_errno_with_irritants(K__, service__, ...) \
{ \
int errnum__ = errno; \
diff --git a/src/keval.c b/src/keval.c
@@ -15,8 +15,11 @@
/*
** Eval helpers
*/
-void do_eval_ls(klisp_State *K, TValue *xparams, TValue obj)
+void do_eval_ls(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: this argument list pair
** xparams[1]: dynamic environment
@@ -89,8 +92,11 @@ inline TValue make_arg_ls(klisp_State *K, TValue operands, TValue *tail)
return arg_ls;
}
-void do_combine(klisp_State *K, TValue *xparams, TValue obj)
+void do_combine(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: operand list
** xparams[1]: dynamic environment
@@ -138,22 +144,29 @@ void do_combine(klisp_State *K, TValue *xparams, TValue obj)
}
/* the underlying function of the eval operative */
-void keval_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
+void keval_ofn(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
UNUSED(xparams);
+ TValue obj = ptree;
+
switch(ttype(obj)) {
case K_TPAIR: {
TValue new_cont =
kmake_continuation(K, kget_cc(K), do_combine, 3, kcdr(obj),
- env, ktry_get_si(K, obj));
+ denv, ktry_get_si(K, obj));
kset_cc(K, new_cont);
- ktail_eval(K, kcar(obj), env);
+ ktail_eval(K, kcar(obj), denv);
break;
}
case K_TSYMBOL:
/* error handling happens in kget_binding */
- kapply_cc(K, kget_binding(K, env, obj));
+ kapply_cc(K, kget_binding(K, denv, obj));
break;
default:
kapply_cc(K, obj);
diff --git a/src/keval.h b/src/keval.h
@@ -11,8 +11,8 @@
#include "kstate.h"
#include "kobject.h"
-void keval_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env);
-void do_eval_ls(klisp_State *K, TValue *xparams, TValue obj);
-void do_combine(klisp_State *K, TValue *xparams, TValue obj);
+void keval_ofn(klisp_State *K);
+void do_eval_ls(klisp_State *K);
+void do_combine(klisp_State *K);
#endif
diff --git a/src/kgblobs.c b/src/kgblobs.c
@@ -1,250 +0,0 @@
-/*
-** kgblobs.c
-** Blobs features for the ground environment
-** See Copyright Notice in klisp.h
-*/
-
-#include <assert.h>
-#include <stdio.h>
-#include <string.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kstate.h"
-#include "kobject.h"
-#include "kapplicative.h"
-#include "koperative.h"
-#include "kcontinuation.h"
-#include "kerror.h"
-#include "kblob.h"
-
-#include "kghelpers.h"
-#include "kgblobs.h"
-#include "kgnumbers.h" /* for keintegerp & knegativep */
-
-/* 13.1.1? blob? */
-/* uses typep */
-
-/* 13.1.2? make-blob */
-void make_blob(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- UNUSED(xparams);
- UNUSED(denv);
- bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s,
- maybe_byte);
-
- uint8_t fill = 0;
- if (get_opt_tpar(K, "make-blob", K_TFIXINT, &maybe_byte)) {
- if (ivalue(maybe_byte) < 0 || ivalue(maybe_byte) > 255) {
- klispE_throw_simple(K, "bad fill byte");
- return;
- }
- fill = ivalue(maybe_byte);
- }
-
- if (knegativep(tv_s)) {
- klispE_throw_simple(K, "negative size");
- return;
- } else if (!ttisfixint(tv_s)) {
- klispE_throw_simple(K, "size is too big");
- return;
- }
-/* XXX/TODO */
-/* TValue new_blob = kblob_new_sf(K, ivalue(tv_s), fill); */
- TValue new_blob = kblob_new(K, ivalue(tv_s));
- if (fill != 0) {
- int32_t s = ivalue(tv_s);
- uint8_t *ptr = kblob_buf(new_blob);
- while(s--)
- *ptr++ = fill;
- }
-
- kapply_cc(K, new_blob);
-}
-
-/* 13.1.3? blob-length */
-void blob_length(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
-{
- UNUSED(xparams);
- UNUSED(denv);
- bind_1tp(K, ptree, "blob", ttisblob, blob);
-
- TValue res = i2tv(kblob_size(blob));
- kapply_cc(K, res);
-}
-
-/* 13.1.4? blob-u8-ref */
-void blob_u8_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- UNUSED(xparams);
- UNUSED(denv);
- bind_2tp(K, ptree, "blob", ttisblob, blob,
- "exact integer", keintegerp, tv_i);
-
- if (!ttisfixint(tv_i)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
- }
- int32_t i = ivalue(tv_i);
-
- if (i < 0 || i >= kblob_size(blob)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
- }
-
- TValue res = i2tv(kblob_buf(blob)[i]);
- kapply_cc(K, res);
-}
-
-/* 13.1.5? blob-u8-set! */
-void blob_u8_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- UNUSED(xparams);
- UNUSED(denv);
- bind_3tp(K, ptree, "blob", ttisblob, blob,
- "exact integer", keintegerp, tv_i, "exact integer", keintegerp, tv_byte);
-
- if (!ttisfixint(tv_i)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
- } else if (kblob_immutablep(blob)) {
- klispE_throw_simple(K, "immutable blob");
- return;
- } else if (ivalue(tv_byte) < 0 || ivalue(tv_byte) > 255) {
- klispE_throw_simple(K, "bad byte");
- return;
- }
-
- int32_t i = ivalue(tv_i);
-
- if (i < 0 || i >= kblob_size(blob)) {
- /* TODO show index */
- klispE_throw_simple(K, "index out of bounds");
- return;
- }
-
- kblob_buf(blob)[i] = (uint8_t) ivalue(tv_byte);
- kapply_cc(K, KINERT);
-}
-
-/* TODO change blob constructors to string like constructors */
-
-/* 13.2.8? blob-copy */
-/* TEMP: at least for now this always returns mutable blobs */
-void blob_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- UNUSED(xparams);
- UNUSED(denv);
- bind_1tp(K, ptree, "blob", ttisblob, blob);
-
- TValue new_blob;
- /* the if isn't strictly necessary but it's clearer this way */
- if (tv_equal(blob, K->empty_blob)) {
- new_blob = blob;
- } else {
- new_blob = kblob_new(K, kblob_size(blob));
- memcpy(kblob_buf(new_blob), kblob_buf(blob), kblob_size(blob));
- }
- kapply_cc(K, new_blob);
-}
-
-/* 13.2.9? blob->immutable-blob */
-void blob_to_immutable_blob(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
-{
- UNUSED(xparams);
- UNUSED(denv);
- bind_1tp(K, ptree, "blob", ttisblob, blob);
-
- TValue res_blob;
- if (kblob_immutablep(blob)) {/* this includes the empty blob */
- res_blob = blob;
- } else {
- res_blob = kblob_new_imm(K, kblob_size(blob));
- memcpy(kblob_buf(res_blob), kblob_buf(blob), kblob_size(blob));
- }
- kapply_cc(K, res_blob);
-}
-
-/* init ground */
-void kinit_blobs_ground_env(klisp_State *K)
-{
- TValue ground_env = K->ground_env;
- TValue symbol, value;
-
- /*
- ** This section is not in the report. The bindings here are
- ** taken from the r7rs scheme draft and should not be considered standard.
- ** They are provided in the meantime to allow programs to use byte vectors.
- */
-
- /* ??.1.1? blob? */
- add_applicative(K, ground_env, "blob?", typep, 2, symbol,
- i2tv(K_TBLOB));
- /* ??.1.2? make-blob */
- add_applicative(K, ground_env, "make-blob", make_blob, 0);
- /* ??.1.3? blob-length */
- add_applicative(K, ground_env, "blob-length", blob_length, 0);
-
- /* ??.1.4? blob-u8-ref */
- add_applicative(K, ground_env, "blob-u8-ref", blob_u8_ref, 0);
- /* ??.1.5? blob-u8-set! */
- add_applicative(K, ground_env, "blob-u8-set!", blob_u8_setS, 0);
-
- /* ??.1.?? blob-copy */
- add_applicative(K, ground_env, "blob-copy", blob_copy, 0);
- /* ??.1.?? blob->immutable-blob */
- add_applicative(K, ground_env, "blob->immutable-blob", blob_to_immutable_blob, 0);
-
-/* TODO put the blob equivalents here */
-#if 0
- /* 13.2.1? string */
- add_applicative(K, ground_env, "string", string, 0);
- /* 13.2.2? string=?, string-ci=? */
- add_applicative(K, ground_env, "string=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_eqp));
- add_applicative(K, ground_env, "string-ci=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_eqp));
- /* 13.2.3? string<?, string<=?, string>?, string>=? */
- add_applicative(K, ground_env, "string<?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ltp));
- add_applicative(K, ground_env, "string<=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_lep));
- add_applicative(K, ground_env, "string>?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_gtp));
- add_applicative(K, ground_env, "string>=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_gep));
- /* 13.2.4? string-ci<?, string-ci<=?, string-ci>?, string-ci>=? */
- add_applicative(K, ground_env, "string-ci<?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_ltp));
- add_applicative(K, ground_env, "string-ci<=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_lep));
- add_applicative(K, ground_env, "string-ci>?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_gtp));
- add_applicative(K, ground_env, "string-ci>=?", ftyped_bpredp, 3,
- symbol, p2tv(kstringp), p2tv(kstring_ci_gep));
- /* 13.2.5? substring */
- add_applicative(K, ground_env, "substring", substring, 0);
- /* 13.2.6? string-append */
- add_applicative(K, ground_env, "string-append", string_append, 0);
- /* 13.2.7? string->list, list->string */
- add_applicative(K, ground_env, "string->list", string_to_list, 0);
- add_applicative(K, ground_env, "list->string", list_to_string, 0);
- /* 13.2.8? string-copy */
- add_applicative(K, ground_env, "string-copy", string_copy, 0);
- /* 13.2.9? string->immutable-string */
- add_applicative(K, ground_env, "string->immutable-string",
- string_to_immutable_string, 0);
-
- /* TODO: add string-immutable? or general immutable? */
- /* TODO: add string-upcase and string-downcase like in r7rs-draft */
-
- /* 13.2.10? string-fill! */
- add_applicative(K, ground_env, "string-fill!", string_fillS, 0);
-#endif
-}
diff --git a/src/kgblobs.h b/src/kgblobs.h
@@ -1,48 +0,0 @@
-/*
-** kgblobs.h
-** Blobs features for the ground environment
-** See Copyright Notice in klisp.h
-*/
-
-#ifndef kgblobs_h
-#define kgblobs_h
-
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
-#include "kstate.h"
-#include "kghelpers.h"
-
-/* ??.1.1? blob? */
-/* uses typep */
-
-/* ??.1.2? make-blob */
-void make_blob(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-
-/* ??.1.3? blob-length */
-void blob_length(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
-
-/* ??.1.4? blob-u8-ref */
-void blob_u8_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-
-/* ??.1.5? blob-u8-set! */
-void blob_u8_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-
-/* ??.2.?? blob-copy */
-void blob_copy(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
-
-/* ??.2.?? blob->immutable-blob */
-void blob_to_immutable_blob(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
-
-/* init ground */
-void kinit_blobs_ground_env(klisp_State *K);
-
-#endif
diff --git a/src/kgbooleans.c b/src/kgbooleans.c
@@ -23,8 +23,12 @@
/* uses typep */
/* 6.1.1 not? */
-void notp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void notp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -38,8 +42,12 @@ void notp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bool kbooleanp(TValue obj) { return ttisboolean(obj); }
/* 6.1.2 and? */
-void andp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void andp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
/* don't care about cycle pairs */
@@ -59,8 +67,12 @@ void andp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.1.3 or? */
-void orp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void orp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
/* don't care about cycle pairs */
@@ -90,8 +102,11 @@ void orp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
** call that is acomplished by checking if the current continuation will
** perform a boolean check, and in that case, no continuation is created
*/
-void do_Sandp_Sorp(klisp_State *K, TValue *xparams, TValue obj)
+void do_Sandp_Sorp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: symbol name
** xparams[1]: termination boolean
@@ -141,8 +156,12 @@ void do_Sandp_Sorp(klisp_State *K, TValue *xparams, TValue obj)
}
}
-void Sandp_Sorp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Sandp_Sorp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
** xparams[1]: termination boolean
diff --git a/src/kgbooleans.h b/src/kgbooleans.h
@@ -22,17 +22,17 @@
/* uses typep */
/* 6.1.1 not? */
-void notp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void notp(klisp_State *K);
/* 6.1.2 and? */
-void andp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void andp(klisp_State *K);
/* 6.1.3 or? */
-void orp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void orp(klisp_State *K);
/* Helpers for $and? & $or? */
-void do_Sandp_Sorp(klisp_State *K, TValue *xparams, TValue obj);
-void Sandp_Sorp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void do_Sandp_Sorp(klisp_State *K);
+void Sandp_Sorp(klisp_State *K);
/* 6.1.4 $and? */
/* uses Sandp_Sorp */
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -0,0 +1,379 @@
+/*
+** kgbytevectors.c
+** Bytevectors features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kapplicative.h"
+#include "koperative.h"
+#include "kcontinuation.h"
+#include "kerror.h"
+#include "kbytevector.h"
+
+#include "kghelpers.h"
+#include "kgbytevectors.h"
+#include "kgnumbers.h" /* for keintegerp & knegativep */
+
+/* 13.1.1? bytevector? */
+/* uses typep */
+
+/* 13.? immutable-bytevector?, mutable-bytevector? */
+/* use ftypep */
+
+/* 13.1.2? make-bytevector */
+void make_bytevector(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s,
+ maybe_byte);
+
+ uint8_t fill = 0;
+ if (get_opt_tpar(K, maybe_byte, "u8", ttisu8)) {
+ fill = ivalue(maybe_byte);
+ }
+
+ if (knegativep(tv_s)) {
+ klispE_throw_simple(K, "negative size");
+ return;
+ } else if (!ttisfixint(tv_s)) {
+ klispE_throw_simple(K, "size is too big");
+ return;
+ }
+ TValue new_bytevector = kbytevector_new_sf(K, ivalue(tv_s), fill);
+ kapply_cc(K, new_bytevector);
+}
+
+/* 13.1.3? bytevector-length */
+void bytevector_length(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "bytevector", ttisbytevector, bytevector);
+
+ TValue res = i2tv(kbytevector_size(bytevector));
+ kapply_cc(K, res);
+}
+
+/* 13.1.4? bytevector-u8-ref */
+void bytevector_u8_ref(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_2tp(K, ptree, "bytevector", ttisbytevector, bytevector,
+ "exact integer", keintegerp, tv_i);
+
+ if (!ttisfixint(tv_i)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
+ }
+ int32_t i = ivalue(tv_i);
+
+ if (i < 0 || i >= kbytevector_size(bytevector)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
+ }
+
+ TValue res = i2tv(kbytevector_buf(bytevector)[i]);
+ kapply_cc(K, res);
+}
+
+/* 13.1.5? bytevector-u8-set! */
+void bytevector_u8_setS(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_3tp(K, ptree, "bytevector", ttisbytevector, bytevector,
+ "exact integer", keintegerp, tv_i, "u8", ttisu8, tv_byte);
+
+ if (!ttisfixint(tv_i)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
+ } else if (kbytevector_immutablep(bytevector)) {
+ klispE_throw_simple(K, "immutable bytevector");
+ return;
+ }
+
+ int32_t i = ivalue(tv_i);
+
+ if (i < 0 || i >= kbytevector_size(bytevector)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "index out of bounds");
+ return;
+ }
+
+ kbytevector_buf(bytevector)[i] = (uint8_t) ivalue(tv_byte);
+ kapply_cc(K, KINERT);
+}
+
+/* 13.2.8? bytevector-copy */
+/* TEMP: at least for now this always returns mutable bytevectors */
+void bytevector_copy(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "bytevector", ttisbytevector, bytevector);
+
+ TValue new_bytevector;
+ /* the if isn't strictly necessary but it's clearer this way */
+ if (tv_equal(bytevector, K->empty_bytevector)) {
+ new_bytevector = bytevector;
+ } else {
+ new_bytevector = kbytevector_new_bs(K, kbytevector_buf(bytevector),
+ kbytevector_size(bytevector));
+ }
+ kapply_cc(K, new_bytevector);
+}
+
+/* 13.2.9? bytevector-copy! */
+void bytevector_copyS(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_2tp(K, ptree, "bytevector", ttisbytevector, bytevector1,
+ "bytevector", ttisbytevector, bytevector2);
+
+ if (kbytevector_immutablep(bytevector2)) {
+ klispE_throw_simple(K, "immutable destination bytevector");
+ return;
+ } else if (kbytevector_size(bytevector1) > kbytevector_size(bytevector2)) {
+ klispE_throw_simple(K, "destination bytevector is too small");
+ return;
+ }
+
+ if (!tv_equal(bytevector1, bytevector2) &&
+ !tv_equal(bytevector1, K->empty_bytevector)) {
+ memcpy(kbytevector_buf(bytevector2),
+ kbytevector_buf(bytevector1),
+ kbytevector_size(bytevector1));
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* 13.2.10? bytevector-copy-partial */
+/* TEMP: at least for now this always returns mutable bytevectors */
+void bytevector_copy_partial(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_3tp(K, ptree, "bytevector", ttisbytevector, bytevector,
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end);
+
+ if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
+ ivalue(tv_start) > kbytevector_size(bytevector)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "start index out of bounds");
+ return;
+ }
+
+ int32_t start = ivalue(tv_start);
+
+ if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 ||
+ ivalue(tv_end) > kbytevector_size(bytevector)) {
+ klispE_throw_simple(K, "end index out of bounds");
+ return;
+ }
+
+ int32_t end = ivalue(tv_end);
+
+ if (start > end) {
+ /* TODO show indexes */
+ klispE_throw_simple(K, "end index is smaller than start index");
+ return;
+ }
+
+ int32_t size = end - start;
+ TValue new_bytevector;
+ /* the if isn't strictly necessary but it's clearer this way */
+ if (size == 0) {
+ new_bytevector = K->empty_bytevector;
+ } else {
+ new_bytevector = kbytevector_new_bs(K, kbytevector_buf(bytevector)
+ + start, size);
+ }
+ kapply_cc(K, new_bytevector);
+}
+
+/* 13.2.11? bytevector-copy-partial! */
+void bytevector_copy_partialS(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_al3tp(K, ptree, "bytevector", ttisbytevector, bytevector1,
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end,
+ rest);
+
+ /* XXX: this will send wrong error msgs (bad number of arg) */
+ bind_2tp(K, rest,
+ "bytevector", ttisbytevector, bytevector2,
+ "exact integer", keintegerp, tv_start2);
+
+ if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
+ ivalue(tv_start) > kbytevector_size(bytevector1)) {
+ /* TODO show index */
+ klispE_throw_simple(K, "start index out of bounds");
+ return;
+ }
+
+ int32_t start = ivalue(tv_start);
+
+ if (!ttisfixint(tv_end) || ivalue(tv_end) < 0 ||
+ ivalue(tv_end) > kbytevector_size(bytevector1)) {
+ klispE_throw_simple(K, "end index out of bounds");
+ return;
+ }
+
+ int32_t end = ivalue(tv_end);
+
+ if (start > end) {
+ /* TODO show indexes */
+ klispE_throw_simple(K, "end index is smaller than start index");
+ return;
+ }
+
+ int32_t size = end - start;
+
+ if (kbytevector_immutablep(bytevector2)) {
+ klispE_throw_simple(K, "immutable destination bytevector");
+ return;
+ }
+
+ if (!ttisfixint(tv_start2) || ivalue(tv_start2) < 0 ||
+ ivalue(tv_start2) > kbytevector_size(bytevector2)) {
+ klispE_throw_simple(K, "to index out of bounds");
+ return;
+ }
+
+ int32_t start2 = ivalue(tv_start2);
+ int64_t end2 = (int64_t) start2 + size;
+
+ if ((end2 > INT32_MAX) ||
+ (((int32_t) end2) > kbytevector_size(bytevector2))) {
+ klispE_throw_simple(K, "not enough space in destination");
+ return;
+ }
+
+ if (size > 0) {
+ memcpy(kbytevector_buf(bytevector2) + start2,
+ kbytevector_buf(bytevector1) + start,
+ size);
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* 13.2.12? bytevector->immutable-bytevector */
+void bytevector_to_immutable_bytevector(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "bytevector", ttisbytevector, bytevector);
+
+ TValue res_bytevector;
+ if (kbytevector_immutablep(bytevector)) {
+/* this includes the empty bytevector */
+ res_bytevector = bytevector;
+ } else {
+ res_bytevector = kbytevector_new_bs_imm(K, kbytevector_buf(bytevector),
+ kbytevector_size(bytevector));
+ }
+ kapply_cc(K, res_bytevector);
+}
+
+/* init ground */
+void kinit_bytevectors_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /*
+ ** This section is not in the report. The bindings here are
+ ** taken from the r7rs scheme draft and should not be considered standard.
+ ** They are provided in the meantime to allow programs to use byte vectors.
+ */
+
+ /* ??.1.1? bytevector? */
+ add_applicative(K, ground_env, "bytevector?", typep, 2, symbol,
+ i2tv(K_TBYTEVECTOR));
+ /* ??.? immutable-bytevector?, mutable-bytevector? */
+ add_applicative(K, ground_env, "immutable-bytevector?", ftypep, 2, symbol,
+ p2tv(kimmutable_bytevectorp));
+ add_applicative(K, ground_env, "mutable-bytevector?", ftypep, 2, symbol,
+ p2tv(kmutable_bytevectorp));
+ /* ??.1.2? make-bytevector */
+ add_applicative(K, ground_env, "make-bytevector", make_bytevector, 0);
+ /* ??.1.3? bytevector-length */
+ add_applicative(K, ground_env, "bytevector-length", bytevector_length, 0);
+
+ /* ??.1.4? bytevector-u8-ref */
+ add_applicative(K, ground_env, "bytevector-u8-ref", bytevector_u8_ref, 0);
+ /* ??.1.5? bytevector-u8-set! */
+ add_applicative(K, ground_env, "bytevector-u8-set!", bytevector_u8_setS,
+ 0);
+
+ /* ??.1.?? bytevector-copy */
+ add_applicative(K, ground_env, "bytevector-copy", bytevector_copy, 0);
+ /* ??.1.?? bytevector-copy! */
+ add_applicative(K, ground_env, "bytevector-copy!", bytevector_copyS, 0);
+
+ /* ??.1.?? bytevector-copy-partial */
+ add_applicative(K, ground_env, "bytevector-copy-partial",
+ bytevector_copy_partial, 0);
+ /* ??.1.?? bytevector-copy-partial! */
+ add_applicative(K, ground_env, "bytevector-copy-partial!",
+ bytevector_copy_partialS, 0);
+
+ /* ??.1.?? bytevector->immutable-bytevector */
+ add_applicative(K, ground_env, "bytevector->immutable-bytevector",
+ bytevector_to_immutable_bytevector, 0);
+
+}
diff --git a/src/kgbytevectors.h b/src/kgbytevectors.h
@@ -0,0 +1,54 @@
+/*
+** kgbytevectors.h
+** Bytevectors features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgbytevectors_h
+#define kgbytevectors_h
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kobject.h"
+#include "klisp.h"
+#include "kstate.h"
+#include "kghelpers.h"
+
+/* ??.1.1? bytevector? */
+/* uses typep */
+
+/* ??.1.2? make-bytevector */
+void make_bytevector(klisp_State *K);
+
+/* ??.1.3? bytevector-length */
+void bytevector_length(klisp_State *K);
+
+/* ??.1.4? bytevector-u8-ref */
+void bytevector_u8_ref(klisp_State *K);
+
+/* ??.1.5? bytevector-u8-set! */
+void bytevector_u8_setS(klisp_State *K);
+
+/* ??.2.?? bytevector-copy */
+void bytevector_copy(klisp_State *K);
+
+/* ??.2.?? bytevector-copy! */
+void bytevector_copyS(klisp_State *K);
+
+/* ??.2.?? bytevector-copy-partial */
+void bytevector_copy_partial(klisp_State *K);
+
+/* ??.2.?? bytevector-copy-partial! */
+void bytevector_copy_partialS(klisp_State *K);
+
+/* ??.2.?? bytevector->immutable-bytevector */
+void bytevector_to_immutable_bytevector(klisp_State *K);
+
+/* init ground */
+void kinit_bytevectors_ground_env(klisp_State *K);
+
+#endif
diff --git a/src/kgc.c b/src/kgc.c
@@ -20,7 +20,8 @@
#include "imrat.h"
#include "ktable.h"
#include "kstring.h"
-#include "kblob.h"
+#include "kbytevector.h"
+#include "kvector.h"
#include "kerror.h"
#define GCSTEPSIZE 1024u
@@ -106,10 +107,12 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
case K_TAPPLICATIVE:
case K_TENCAPSULATION:
case K_TPROMISE:
- case K_TPORT:
case K_TTABLE:
case K_TERROR:
- case K_TBLOB:
+ case K_TBYTEVECTOR:
+ case K_TVECTOR:
+ case K_TFPORT:
+ case K_TMPORT:
o->gch.gclist = K->gray;
K->gray = o;
break;
@@ -261,7 +264,7 @@ static int32_t propagatemark (klisp_State *K) {
case K_TSTRING: {
String *s = cast(String *, o);
markvalue(K, s->mark);
- return sizeof(String) + s->size * sizeof(char);
+ return sizeof(String) + (s->size + 1 * sizeof(char));
}
case K_TENVIRONMENT: {
Environment *e = cast(Environment *, o);
@@ -301,11 +304,6 @@ static int32_t propagatemark (klisp_State *K) {
markvalue(K, p->node);
return sizeof(Promise);
}
- case K_TPORT: {
- Port *p = cast(Port *, o);
- markvalue(K, p->filename);
- return sizeof(Port);
- }
case K_TTABLE: {
Table *h = cast(Table *, o);
if (traversetable(K, h)) /* table is weak? */
@@ -321,10 +319,27 @@ static int32_t propagatemark (klisp_State *K) {
markvalue(K, e->irritants);
return sizeof(Error);
}
- case K_TBLOB: {
- Blob *b = cast(Blob *, o);
+ case K_TBYTEVECTOR: {
+ Bytevector *b = cast(Bytevector *, o);
markvalue(K, b->mark);
- return sizeof(String) + b->size * sizeof(uint8_t);
+ return sizeof(Bytevector) + b->size * sizeof(uint8_t);
+ }
+ case K_TFPORT: {
+ FPort *p = cast(FPort *, o);
+ markvalue(K, p->filename);
+ return sizeof(FPort);
+ }
+ case K_TMPORT: {
+ MPort *p = cast(MPort *, o);
+ markvalue(K, p->filename);
+ markvalue(K, p->buf);
+ return sizeof(MPort);
+ }
+ case K_TVECTOR: {
+ Vector *v = cast(Vector *, o);
+ markvalue(K, v->mark);
+ markvaluearray(K, v->array, v->sizearray);
+ return sizeof(Vector) + v->sizearray * sizeof(TValue);
}
default:
fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
@@ -347,6 +362,8 @@ static size_t propagateall (klisp_State *K) {
** other objects: if really collected, cannot keep them; for userdata
** being finalized, keep them in keys, but not in values
*/
+/* XXX what the hell is this, I should reread this part of the lua
+ source Andres Navarro */
static int32_t iscleared (TValue o, int iskey) {
if (!iscollectable(o)) return 0;
#if 0 /* klisp: strings may be mutable... */
@@ -441,24 +458,35 @@ static void freeobj (klisp_State *K, GCObject *o) {
case K_TPROMISE:
klispM_free(K, (Promise *)o);
break;
- case K_TPORT:
- /* first close the port to free the FILE structure.
- This works even if the port was already closed,
- it is important that this don't throw errors, because
- the mechanism used in error handling would crash at this
- point */
- kclose_port(K, gc2port(o));
- klispM_free(K, (Port *)o);
- break;
case K_TTABLE:
klispH_free(K, (Table *)o);
break;
case K_TERROR:
klispE_free(K, (Error *)o);
break;
- case K_TBLOB:
- klispM_freemem(K, o, sizeof(Blob)+o->blob.size);
+ case K_TBYTEVECTOR:
+ /* immutable bytevectors are in the string/symbol table */
+ if (kbytevector_immutablep(gc2str(o)))
+ K->strt.nuse--;
+ klispM_freemem(K, o, sizeof(Bytevector)+o->bytevector.size);
break;
+ case K_TFPORT:
+ /* first close the port to free the FILE structure.
+ This works even if the port was already closed,
+ it is important that this don't throw errors, because
+ the mechanism used in error handling would crash at this
+ point */
+ kclose_port(K, gc2fport(o));
+ klispM_free(K, (FPort *)o);
+ break;
+ case K_TMPORT:
+ /* memory ports (string & bytevector) don't need to be closed
+ explicitly */
+ klispM_free(K, (MPort *)o);
+ break;
+ case K_TVECTOR:
+ klispM_freemem(K, o, sizeof(Vector) + sizeof(TValue) * o->vector.sizearray);
+ break;
default:
/* shouldn't happen */
fprintf(stderr, "Unknown GCObject type (in GC free): %d\n",
@@ -552,7 +580,7 @@ void klispC_freeall (klisp_State *K) {
K->currentwhite = WHITEBITS | bitmask(SFIXEDBIT); /* in klisp this may not be
necessary */
sweepwholelist(K, &K->rootgc);
- /* free all symbol/string lists */
+ /* free all symbol/string/bytevectors lists */
for (int32_t i = 0; i < K->strt.size; i++)
sweepwholelist(K, &K->strt.hash[i]);
}
@@ -564,7 +592,7 @@ static void markroot (klisp_State *K) {
K->grayagain = NULL;
K->weak = NULL;
- /* TEMP: this is quite awfull, think of other way to do this */
+ /* TEMP: this is quite awful, think of other way to do this */
/* MAYBE: some of these could be FIXED */
markvalue(K, K->name_table);
markvalue(K, K->cont_name_table);
@@ -587,13 +615,17 @@ static void markroot (klisp_State *K) {
markvalue(K, K->kd_error_port_key);
markvalue(K, K->kd_strict_arith_key);
markvalue(K, K->empty_string);
- markvalue(K, K->empty_blob);
+ markvalue(K, K->empty_bytevector);
+ markvalue(K, K->empty_vector);
markvalue(K, K->ktok_lparen);
markvalue(K, K->ktok_rparen);
markvalue(K, K->ktok_dot);
+ markvalue(K, K->ktok_sexp_comment);
markvalue(K, K->shared_dict);
+ markvalue(K, K->curr_port);
+
/* Mark all objects in the auxiliary stack,
(all valid indexes are below top), all the objects in
the two protected areas, and the three dummy pairs */
@@ -778,7 +810,8 @@ void klispC_barrierback (klisp_State *K, Table *t) {
}
/* NOTE: kflags is added for klisp */
-/* NOTE: both symbols & strings do this "by hand", they don't call this */
+/* NOTE: symbols, immutable strings and immutable bytevectors do this
+ "by hand", they don't call this */
void klispC_link (klisp_State *K, GCObject *o, uint8_t tt, uint8_t kflags) {
o->gch.next = K->rootgc;
K->rootgc = o;
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -39,9 +39,12 @@ bool kchar_upper_casep(TValue ch) { return isupper(chvalue(ch)) != 0; }
bool kchar_lower_casep(TValue ch) { return islower(chvalue(ch)) != 0; }
/* 14.1.4? char->integer, integer->char */
-void kchar_to_integer(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kchar_to_integer(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "character", ttischar, ch);
@@ -49,9 +52,12 @@ void kchar_to_integer(klisp_State *K, TValue *xparams, TValue ptree,
kapply_cc(K, i2tv((int32_t) chvalue(ch)));
}
-void kinteger_to_char(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kinteger_to_char(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "exact integer", ttiseinteger, itv);
@@ -71,9 +77,12 @@ void kinteger_to_char(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 14.1.4? char-upcase, char-downcase */
-void kchar_upcase(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kchar_upcase(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "character", ttischar, chtv);
@@ -82,9 +91,12 @@ void kchar_upcase(klisp_State *K, TValue *xparams, TValue ptree,
kapply_cc(K, ch2tv(ch));
}
-void kchar_downcase(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kchar_downcase(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "character", ttischar, chtv);
diff --git a/src/kgchars.h b/src/kgchars.h
@@ -38,16 +38,12 @@ bool kchar_upper_casep(TValue ch);
bool kchar_lower_casep(TValue ch);
/* 14.1.4? char->integer, integer->char */
-void kchar_to_integer(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
-void kinteger_to_char(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void kchar_to_integer(klisp_State *K);
+void kinteger_to_char(klisp_State *K);
/* 14.1.4? char-upcase, char-downcase */
-void kchar_upcase(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
-void kchar_downcase(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void kchar_upcase(klisp_State *K);
+void kchar_downcase(klisp_State *K);
/* 14.2.1? char=? */
/* uses ftyped_bpredp */
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -27,7 +27,7 @@
#include "kgcombiners.h"
/* Helper (used by $vau & $lambda) */
-void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv);
+void do_vau(klisp_State *K);
/* 4.10.1 operative? */
/* uses typep */
@@ -37,8 +37,12 @@ void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv);
/* 4.10.3 $vau */
/* 5.3.1 $vau */
-void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Svau(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) xparams;
bind_al2p(K, ptree, vptree, vpenv, vbody);
@@ -71,15 +75,22 @@ void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, new_op);
}
-void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv)
+void do_vau(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(denv);
+
/*
- ** xparams[0]: ptree
+ ** xparams[0]: op_ptree
** xparams[1]: penv
** xparams[2]: body
** xparams[3]: senv
*/
- TValue ptree = xparams[0];
+ TValue op_ptree = xparams[0];
TValue penv = xparams[1];
TValue body = xparams[2];
TValue senv = xparams[3];
@@ -91,7 +102,7 @@ void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv)
krooted_tvs_push(K, env);
/* TODO use name from operative */
- match(K, "[user-operative]", env, ptree, obj);
+ match(K, "[user-operative]", env, op_ptree, ptree);
if (!ttisignore(penv))
kadd_binding(K, env, penv, denv);
@@ -120,8 +131,12 @@ void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv)
}
/* 4.10.4 wrap */
-void wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void wrap(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -141,8 +156,12 @@ void wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 4.10.5 unwrap */
-void unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void unwrap(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) denv;
(void) xparams;
bind_1tp(K, ptree, "applicative", ttisapplicative, app);
@@ -153,8 +172,12 @@ void unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 5.3.1 $vau */
/* DONE: above, together with 4.10.4 */
/* 5.3.2 $lambda */
-void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Slambda(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) xparams;
bind_al1p(K, ptree, vptree, vbody);
@@ -188,9 +211,12 @@ void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 5.5.1 apply */
-void apply(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void apply(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -199,7 +225,7 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree,
"any", anytype, obj,
maybe_env);
- TValue env = (get_opt_tpar(K, "apply", K_TENVIRONMENT, &maybe_env))?
+ TValue env = (get_opt_tpar(K, maybe_env, "environment", ttisenvironment))?
maybe_env : kmake_empty_environment(K);
krooted_tvs_push(K, env);
@@ -411,8 +437,11 @@ TValue map_for_each_transpose(klisp_State *K, TValue lss,
/* Continuation helpers for map */
/* For acyclic input lists: Return the mapped list */
-void do_map_ret(klisp_State *K, TValue *xparams, TValue obj)
+void do_map_ret(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: (dummy . complete-ls)
*/
@@ -427,8 +456,11 @@ void do_map_ret(klisp_State *K, TValue *xparams, TValue obj)
}
/* For cyclic input list: close the cycle and return the mapped list */
-void do_map_encycle(klisp_State *K, TValue *xparams, TValue obj)
+void do_map_encycle(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: (dummy . complete-ls)
** xparams[1]: last non-cycle pair
@@ -450,8 +482,11 @@ void do_map_encycle(klisp_State *K, TValue *xparams, TValue obj)
kapply_cc(K, copy);
}
-void do_map(klisp_State *K, TValue *xparams, TValue obj)
+void do_map(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: app
** xparams[1]: rem-ls
@@ -499,8 +534,11 @@ void do_map(klisp_State *K, TValue *xparams, TValue obj)
}
}
-void do_map_cycle(klisp_State *K, TValue *xparams, TValue obj)
+void do_map_cycle(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: app
** xparams[1]: (dummy . res-list)
@@ -528,7 +566,9 @@ void do_map_cycle(klisp_State *K, TValue *xparams, TValue obj)
the inert value passed to the first continuation */
TValue new_cont =
kmake_continuation(K, encycle_cont, do_map, 6, app, ls,
- last_apair, cpairs, denv, KTRUE);
+ last_apair, i2tv(cpairs), denv, KTRUE);
+ klisp_assert(ttisenvironment(denv));
+
krooted_tvs_pop(K);
kset_cc(K, new_cont);
/* this will be like a nop and will continue with do_map */
@@ -536,8 +576,12 @@ void do_map_cycle(klisp_State *K, TValue *xparams, TValue obj)
}
/* 5.9.1 map */
-void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void map(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
@@ -577,7 +621,6 @@ void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
: kmake_continuation(K, kget_cc(K), do_map_cycle, 4,
app, dummy, i2tv(res_cpairs), denv);
-
krooted_tvs_push(K, ret_cont);
/* schedule the mapping of the elements of the acyclic part.
@@ -592,6 +635,7 @@ void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
krooted_tvs_pop(K);
kset_cc(K, new_cont);
+
/* this will be a nop, and will continue with do_map */
kapply_cc(K, KINERT);
}
diff --git a/src/kgcombiners.h b/src/kgcombiners.h
@@ -26,23 +26,22 @@
/* 4.10.3 $vau */
/* 5.3.1 $vau */
-void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Svau(klisp_State *K);
/* 4.10.4 wrap */
-void wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void wrap(klisp_State *K);
/* 4.10.5 unwrap */
-void unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void unwrap(klisp_State *K);
/* 5.3.1 $vau */
/* DONE: above, together with 4.10.4 */
/* 5.3.2 $lambda */
-void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Slambda(klisp_State *K);
/* 5.5.1 apply */
-void apply(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void apply(klisp_State *K);
/* Helpers for map (also used by for each) */
@@ -69,7 +68,7 @@ TValue map_for_each_transpose(klisp_State *K, TValue lss,
int32_t res_apairs, int32_t res_cpairs);
/* 5.9.1 map */
-void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void map(klisp_State *K);
/* 6.2.1 combiner? */
/* uses ftypedp */
@@ -78,11 +77,11 @@ void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
bool kcombinerp(TValue obj);
-void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv);
-void do_map_ret(klisp_State *K, TValue *xparams, TValue obj);
-void do_map_encycle(klisp_State *K, TValue *xparams, TValue obj);
-void do_map(klisp_State *K, TValue *xparams, TValue obj);
-void do_map_cycle(klisp_State *K, TValue *xparams, TValue obj);
+void do_vau(klisp_State *K);
+void do_map_ret(klisp_State *K);
+void do_map_encycle(klisp_State *K);
+void do_map(klisp_State *K);
+void do_map_cycle(klisp_State *K);
/* init ground */
void kinit_combiners_ground_env(klisp_State *K);
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -28,8 +28,12 @@
/* uses typep */
/* 7.2.2 call/cc */
-void call_cc(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void call_cc(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
bind_1tp(K, ptree, "combiner", ttiscombiner, comb);
@@ -38,8 +42,11 @@ void call_cc(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helper for extend-continuation */
-void do_extended_cont(klisp_State *K, TValue *xparams, TValue obj)
+void do_extended_cont(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: applicative
** xparams[1]: environment
@@ -53,9 +60,12 @@ void do_extended_cont(klisp_State *K, TValue *xparams, TValue obj)
}
/* 7.2.3 extend-continuation */
-void extend_continuation(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void extend_continuation(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -64,7 +74,7 @@ void extend_continuation(klisp_State *K, TValue *xparams, TValue ptree,
"applicative", ttisapplicative, app,
maybe_env);
- TValue env = (get_opt_tpar(K, "apply", K_TENVIRONMENT, &maybe_env))?
+ TValue env = (get_opt_tpar(K, maybe_env, "environment", ttisenvironment))?
maybe_env : kmake_empty_environment(K);
krooted_tvs_push(K, env);
@@ -80,8 +90,11 @@ void extend_continuation(klisp_State *K, TValue *xparams, TValue ptree,
passes the value. xparams is not actually empty, it contains
the entry/exit guards, but they are used only in
continuation->applicative (that is during abnormal passes) */
-void do_pass_value(klisp_State *K, TValue *xparams, TValue obj)
+void do_pass_value(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
UNUSED(xparams);
kapply_cc(K, obj);
}
@@ -158,9 +171,12 @@ TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
}
/* 7.2.4 guard-continuation */
-void guard_continuation(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void guard_continuation(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
bind_3tp(K, ptree, "any", anytype, entry_guards,
@@ -194,10 +210,16 @@ void guard_continuation(klisp_State *K, TValue *xparams, TValue ptree,
/* 7.2.5 continuation->applicative */
-void continuation_applicative(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void continuation_applicative(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
UNUSED(xparams);
+ UNUSED(denv);
+
bind_1tp(K, ptree, "continuation",
ttiscontinuation, cont);
/* cont_app is from kstate, it handles dynamic vars &
@@ -217,9 +239,12 @@ void continuation_applicative(klisp_State *K, TValue *xparams, TValue ptree,
*/
/* 7.3.1 apply-continuation */
-void apply_continuation(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void apply_continuation(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -232,9 +257,12 @@ void apply_continuation(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 7.3.2 $let/cc */
-void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void Slet_cc(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
/* from the report: #ignore is not ok, only symbol */
bind_al1tp(K, ptree, "symbol", ttissymbol, sym, objs);
@@ -272,9 +300,12 @@ void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 7.3.3 guard-dynamic-extent */
-void guard_dynamic_extent(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void guard_dynamic_extent(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
bind_3tp(K, ptree, "any", anytype, entry_guards,
@@ -310,9 +341,12 @@ void guard_dynamic_extent(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 7.3.4 exit */
-void kgexit(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kgexit(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -344,11 +378,13 @@ void kinit_continuations_ground_env(klisp_State *K)
add_applicative(K, ground_env, "continuation->applicative",
continuation_applicative, 0);
/* 7.2.6 root-continuation */
+ klisp_assert(ttiscontinuation(K->root_cont));
add_value(K, ground_env, "root-continuation",
K->root_cont);
/* 7.2.7 error-continuation */
+ klisp_assert(ttiscontinuation(K->error_cont));
add_value(K, ground_env, "error-continuation",
- K->root_cont);
+ K->error_cont);
/* 7.3.1 apply-continuation */
add_applicative(K, ground_env, "apply-continuation", apply_continuation,
0);
diff --git a/src/kgcontinuations.h b/src/kgcontinuations.h
@@ -19,25 +19,22 @@
#include "kghelpers.h"
/* Helpers (also used in keyed dynamic code) */
-void do_pass_value(klisp_State *K, TValue *xparams, TValue obj);
+void do_pass_value(klisp_State *K);
/* 7.1.1 continuation? */
/* uses typep */
/* 7.2.2 call/cc */
-void call_cc(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void call_cc(klisp_State *K);
/* 7.2.3 extend-continuation */
-void extend_continuation(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void extend_continuation(klisp_State *K);
/* 7.2.4 guard-continuation */
-void guard_continuation(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void guard_continuation(klisp_State *K);
/* 7.2.5 continuation->applicative */
-void continuation_applicative(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void continuation_applicative(klisp_State *K);
/* 7.2.6 root-continuation */
/* done in kground.c/krepl.c */
@@ -46,23 +43,18 @@ void continuation_applicative(klisp_State *K, TValue *xparams, TValue ptree,
/* done in kground.c/krepl.c */
/* 7.3.1 apply-continuation */
-void apply_continuation(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void apply_continuation(klisp_State *K);
/* 7.3.2 $let/cc */
-void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void Slet_cc(klisp_State *K);
/* 7.3.3 guard-dynamic-extent */
-void guard_dynamic_extent(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void guard_dynamic_extent(klisp_State *K);
/* 7.3.4 exit */
-void kgexit(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void kgexit(klisp_State *K);
-void do_extended_cont(klisp_State *K, TValue *xparams, TValue obj);
-void do_pass_value(klisp_State *K, TValue *xparams, TValue obj);
+void do_extended_cont(klisp_State *K);
/* init ground */
void kinit_continuations_ground_env(klisp_State *K);
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -26,11 +26,15 @@
/* 4.5.2 $if */
/* helpers */
-void do_select_clause(klisp_State *K, TValue *xparams, TValue obj);
+void do_select_clause(klisp_State *K);
/* ASK JOHN: both clauses should probably be copied (copy-es-immutable) */
-void Sif(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Sif(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) denv;
(void) xparams;
@@ -48,8 +52,11 @@ void Sif(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
ktail_eval(K, test, denv);
}
-void do_select_clause(klisp_State *K, TValue *xparams, TValue obj)
+void do_select_clause(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: dynamic env
** xparams[1]: consequent clause
@@ -66,8 +73,12 @@ void do_select_clause(klisp_State *K, TValue *xparams, TValue obj)
}
/* 5.1.1 $sequence */
-void Ssequence(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Ssequence(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
if (ttisnil(ptree)) {
@@ -98,9 +109,15 @@ void Ssequence(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helper (also used by $vau and $lambda) */
-/* the ramaining list can't be null, that case is managed before */
-void do_seq(klisp_State *K, TValue *xparams, TValue obj)
+/* the remaining list can't be null, that case is managed before */
+void do_seq(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+
+ UNUSED(obj);
+
/*
** xparams[0]: remaining list
** xparams[1]: dynamic environment
@@ -198,8 +215,11 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
}
/* Helper for the $cond continuation */
-void do_cond(klisp_State *K, TValue *xparams, TValue obj)
+void do_cond(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: the body corresponding to obj
** xparams[1]: remaining tests
@@ -258,8 +278,12 @@ void do_cond(klisp_State *K, TValue *xparams, TValue obj)
}
/* 5.6.1 $cond */
-void Scond(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Scond(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) xparams;
TValue bodies;
@@ -289,8 +313,11 @@ void Scond(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helper continuation for for-each */
-void do_for_each(klisp_State *K, TValue *xparams, TValue obj)
+void do_for_each(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: app
** xparams[1]: rem-ls
@@ -329,8 +356,12 @@ void do_for_each(klisp_State *K, TValue *xparams, TValue obj)
}
/* 6.9.1 for-each */
-void for_each(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void for_each(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) xparams;
bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
diff --git a/src/kgcontrol.h b/src/kgcontrol.h
@@ -23,10 +23,10 @@
/* 4.5.2 $if */
-void Sif(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Sif(klisp_State *K);
/* 5.1.1 $sequence */
-void Ssequence(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Ssequence(klisp_State *K);
/* Helpers for $cond */
TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
@@ -34,15 +34,15 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
/* 5.6.1 $cond */
-void Scond(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Scond(klisp_State *K);
/* 6.9.1 for-each */
-void for_each(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void for_each(klisp_State *K);
-void do_seq(klisp_State *K, TValue *xparams, TValue obj);
-void do_cond(klisp_State *K, TValue *xparams, TValue obj);
-void do_select_clause(klisp_State *K, TValue *xparams, TValue obj);
-void do_for_each(klisp_State *K, TValue *xparams, TValue obj);
+void do_seq(klisp_State *K);
+void do_cond(klisp_State *K);
+void do_select_clause(klisp_State *K);
+void do_for_each(klisp_State *K);
/* init ground */
void kinit_control_ground_env(klisp_State *K);
diff --git a/src/kgencapsulations.c b/src/kgencapsulations.c
@@ -23,8 +23,12 @@
/* Helpers for make-encapsulation-type */
/* Type predicate for encapsulations */
-void enc_typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void enc_typep(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
/*
** xparams[0]: encapsulation key
@@ -54,8 +58,12 @@ void enc_typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Constructor for encapsulations */
-void enc_wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void enc_wrap(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
bind_1p(K, ptree, obj);
UNUSED(denv);
/*
@@ -67,8 +75,12 @@ void enc_wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Accessor for encapsulations */
-void enc_unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void enc_unwrap(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
bind_1p(K, ptree, enc);
UNUSED(denv);
/*
@@ -86,9 +98,12 @@ void enc_unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 8.1.1 make-encapsulation-type */
-void make_encapsulation_type(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void make_encapsulation_type(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
check_0p(K, ptree);
UNUSED(denv);
UNUSED(xparams);
diff --git a/src/kgencapsulations.h b/src/kgencapsulations.h
@@ -19,11 +19,10 @@
#include "kghelpers.h"
/* needed by kgffi.c */
-void enc_typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void enc_typep(klisp_State *K);
/* 8.1.1 make-encapsulation-type */
-void make_encapsulation_type(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void make_encapsulation_type(klisp_State *K);
/* init ground */
void kinit_encapsulations_ground_env(klisp_State *K);
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -23,8 +23,12 @@
#include "kgcontrol.h" /* for do_seq */
/* 4.9.1 $define! */
-void SdefineB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void SdefineB(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0] = define symbol
*/
@@ -45,8 +49,11 @@ void SdefineB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* helper */
-void do_match(klisp_State *K, TValue *xparams, TValue obj)
+void do_match(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: ptree
** xparams[1]: dynamic environment
@@ -61,8 +68,12 @@ void do_match(klisp_State *K, TValue *xparams, TValue obj)
}
/* 6.8.1 $set! */
-void SsetB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void SsetB(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
TValue sname = xparams[0];
@@ -82,8 +93,11 @@ void SsetB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helpers for $set! */
-void do_set_eval_obj(klisp_State *K, TValue *xparams, TValue obj)
+void do_set_eval_obj(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: name as symbol
** xparams[1]: ptree
@@ -169,8 +183,11 @@ TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj)
return kcutoff_dummy1(K);
}
-void do_import(klisp_State *K, TValue *xparams, TValue obj)
+void do_import(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: name as symbol
** xparams[1]: symbols
@@ -195,8 +212,12 @@ void do_import(klisp_State *K, TValue *xparams, TValue obj)
}
/* 6.8.2 $provide! */
-void SprovideB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void SprovideB(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: name as symbol
*/
@@ -251,8 +272,12 @@ void SprovideB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.8.3 $import! */
-void SimportB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void SimportB(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/* ASK John: The report says that symbols can have repeated symbols
and even be cyclical (cf $provide!) however this doesn't work
in the derivation (that uses $set! and so needs a ptree, which are
diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h
@@ -21,12 +21,12 @@
/* helpers */
inline void match(klisp_State *K, char *name, TValue env, TValue ptree,
TValue obj);
-void do_match(klisp_State *K, TValue *xparams, TValue obj);
+void do_match(klisp_State *K);
inline void ptree_clear_all(klisp_State *K, TValue sym_ls);
inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
TValue penv);
/* 4.9.1 $define! */
-void SdefineB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void SdefineB(klisp_State *K);
/* MAYBE: don't make these inline */
/*
@@ -235,20 +235,20 @@ inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
}
/* 6.8.1 $set! */
-void SsetB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void SsetB(klisp_State *K);
/* Helper for $set! */
-void do_set_eval_obj(klisp_State *K, TValue *xparams, TValue obj);
+void do_set_eval_obj(klisp_State *K);
/* Helpers for $provide & $import! */
TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj);
-void do_import(klisp_State *K, TValue *xparams, TValue obj);
+void do_import(klisp_State *K);
/* 6.8.2 $provide! */
-void SprovideB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void SprovideB(klisp_State *K);
/* 6.8.3 $import! */
-void SimportB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void SimportB(klisp_State *K);
/* init ground */
void kinit_env_mut_ground_env(klisp_State *K);
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -32,9 +32,12 @@
/* uses typep */
/* 4.8.3 eval */
-void eval(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void eval(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -45,9 +48,12 @@ void eval(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 4.8.4 make-environment */
-void make_environment(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void make_environment(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -156,8 +162,11 @@ TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
** it expects the result of the last evaluation to be matched to
** this-ptree
*/
-void do_let(klisp_State *K, TValue *xparams, TValue obj)
+void do_let(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: symbol name
** xparams[1]: this ptree
@@ -203,7 +212,7 @@ void do_let(klisp_State *K, TValue *xparams, TValue obj)
TValue new_cont =
kmake_continuation(K, kget_cc(K), do_let, 7, sname,
kcar(bindings), kcdr(bindings), kcdr(exprs),
- new_env, b2tv(false), body);
+ new_env, b2tv(recp), body);
krooted_tvs_pop(K);
kset_cc(K, new_cont);
ktail_eval(K, kcar(exprs), recp? new_env : env);
@@ -212,8 +221,12 @@ void do_let(klisp_State *K, TValue *xparams, TValue obj)
/* 5.10.1 $let */
/* REFACTOR: reuse code in other members of the $let family */
-void Slet(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Slet(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
*/
@@ -248,8 +261,11 @@ void Slet(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helper for $binds? */
-void do_bindsp(klisp_State *K, TValue *xparams, TValue obj)
+void do_bindsp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: symbol list (may contain cycles)
** xparams[1]: symbol list count
@@ -278,8 +294,12 @@ void do_bindsp(klisp_State *K, TValue *xparams, TValue obj)
}
/* 6.7.1 $binds? */
-void Sbindsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Sbindsp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
bind_al1p(K, ptree, env_expr, symbols);
@@ -297,29 +317,41 @@ void Sbindsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.7.2 get-current-environment */
-void get_current_environment(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void get_current_environment(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
check_0p(K, ptree);
kapply_cc(K, denv);
}
/* 6.7.3 make-kernel-standard-environment */
-void make_kernel_standard_environment(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void make_kernel_standard_environment(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
check_0p(K, ptree);
- TValue new_env = kmake_environment(K, K->ground_env);
+ /* std environments have hashtable for bindings */
+ TValue new_env = kmake_table_environment(K, K->ground_env);
+// TValue new_env = kmake_environment(K, K->ground_env);
kapply_cc(K, new_env);
}
/* 6.7.4 $let* */
-void SletS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void SletS(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
*/
@@ -367,8 +399,12 @@ void SletS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.7.5 $letrec */
-void Sletrec(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Sletrec(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
*/
@@ -404,8 +440,12 @@ void Sletrec(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.7.6 $letrec* */
-void SletrecS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void SletrecS(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
*/
@@ -454,8 +494,11 @@ void SletrecS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helper for $let-redirect */
-void do_let_redirect(klisp_State *K, TValue *xparams, TValue obj)
+void do_let_redirect(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: symbol name
** xparams[1]: ptree
@@ -485,8 +528,12 @@ void do_let_redirect(klisp_State *K, TValue *xparams, TValue obj)
}
/* 6.7.7 $let-redirect */
-void Slet_redirect(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Slet_redirect(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
*/
@@ -520,8 +567,12 @@ void Slet_redirect(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.7.8 $let-safe */
-void Slet_safe(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Slet_safe(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
*/
@@ -559,8 +610,12 @@ void Slet_safe(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.7.9 $remote-eval */
-void Sremote_eval(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Sremote_eval(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -574,8 +629,11 @@ void Sremote_eval(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helper for $remote-eval */
-void do_remote_eval(klisp_State *K, TValue *xparams, TValue obj)
+void do_remote_eval(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
if (!ttisenvironment(obj)) {
klispE_throw_simple(K, "bad type from second operand "
"evaluation (expected environment)");
@@ -587,8 +645,11 @@ void do_remote_eval(klisp_State *K, TValue *xparams, TValue obj)
}
/* Helper for $bindings->environment */
-void do_b_to_env(klisp_State *K, TValue *xparams, TValue obj)
+void do_b_to_env(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: ptree
** xparams[1]: created env
@@ -601,9 +662,12 @@ void do_b_to_env(klisp_State *K, TValue *xparams, TValue obj)
}
/* 6.7.10 $bindings->environment */
-void Sbindings_to_environment(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void Sbindings_to_environment(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
TValue exprs;
TValue bptree = split_check_let_bindings(K, "$bindings->environment",
diff --git a/src/kgenvironments.h b/src/kgenvironments.h
@@ -25,65 +25,60 @@
/* uses typep */
/* 4.8.3 eval */
-void eval(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void eval(klisp_State *K);
/* 4.8.4 make-environment */
-void make_environment(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void make_environment(klisp_State *K);
/* Helpers for all $let family */
TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
TValue *exprs, bool starp);
/* 5.10.1 $let */
-void Slet(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Slet(klisp_State *K);
/* Helper for $binds? */
-void do_bindsp(klisp_State *K, TValue *xparams, TValue obj);
+void do_bindsp(klisp_State *K);
/* 6.7.1 $binds? */
-void Sbindsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Sbindsp(klisp_State *K);
/* 6.7.2 get-current-environment */
-void get_current_environment(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void get_current_environment(klisp_State *K);
/* 6.7.3 make-kernel-standard-environment */
-void make_kernel_standard_environment(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
+void make_kernel_standard_environment(klisp_State *K);
/* 6.7.4 $let* */
-void SletS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void SletS(klisp_State *K);
/* 6.7.5 $letrec */
-void Sletrec(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Sletrec(klisp_State *K);
/* 6.7.6 $letrec* */
-void SletrecS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void SletrecS(klisp_State *K);
/* Helper for $let-redirect */
-void do_let_redirect(klisp_State *K, TValue *xparams, TValue obj);
+void do_let_redirect(klisp_State *K);
/* 6.7.7 $let-redirect */
-void Slet_redirect(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Slet_redirect(klisp_State *K);
/* 6.7.8 $let-safe */
-void Slet_safe(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Slet_safe(klisp_State *K);
/* 6.7.9 $remote-eval */
-void Sremote_eval(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Sremote_eval(klisp_State *K);
/* Helper for $remote-eval */
-void do_remote_eval(klisp_State *K, TValue *xparams, TValue obj);
+void do_remote_eval(klisp_State *K);
/* Helper for $bindings->environment */
-void do_b_to_env(klisp_State *K, TValue *xparams, TValue obj);
+void do_b_to_env(klisp_State *K);
/* 6.7.10 $bindings->environment */
-void Sbindings_to_environment(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void Sbindings_to_environment(klisp_State *K);
-void do_let(klisp_State *K, TValue *xparams, TValue obj);
+void do_let(klisp_State *K);
/* init ground */
void kinit_environments_ground_env(klisp_State *K);
diff --git a/src/kgeqp.c b/src/kgeqp.c
@@ -22,8 +22,12 @@
/* 4.2.1 eq? */
/* 6.5.1 eq? */
/* NOTE: this does 2 passes but could do it in one */
-void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void eqp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
diff --git a/src/kgeqp.h b/src/kgeqp.h
@@ -23,13 +23,11 @@
/* 4.2.1 eq? */
/* 6.5.1 eq? */
-void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void eqp(klisp_State *K);
/* Helper (also used in equal?) */
inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
{
- /* TODO/FIXME: immutable blobs aren't interned and so will compare
- as un-eq? even if the contents are the same */
bool res = (tv_equal(obj1, obj2));
if (!res && (ttype(obj1) == ttype(obj2))) {
switch (ttype(obj1)) {
@@ -56,7 +54,9 @@ inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
(eq? obj1 obj2) */
res = kbigrat_eqp(K, obj1, obj2);
break;
- } /* immutable strings are interned so are covered already */
+ } /* immutable strings & bytevectors are interned so they are
+ covered already by tv_equalp */
+
}
return res;
}
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -14,7 +14,7 @@
#include "kobject.h"
#include "kpair.h"
#include "kstring.h" /* for kstring_equalp */
-#include "kblob.h" /* for kblob_equalp */
+#include "kbytevector.h" /* for kbytevector_equalp */
#include "kcontinuation.h"
#include "kerror.h"
@@ -34,8 +34,12 @@
** Idea to look up these papers from srfi 85:
** "Recursive Equivalence Predicates" by William D. Clinger
*/
-void equalp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void equalp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -197,11 +201,14 @@ bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
result = false;
break;
}
- } else if (ttisblob(obj1) && ttisblob(obj2)) {
- if (!kblob_equalp(obj1, obj2)) {
+ } else if (ttisbytevector(obj1) && ttisbytevector(obj2)) {
+ if (!kbytevector_equalp(obj1, obj2)) {
result = false;
break;
}
+ } else if (ttisvector(obj1) && ttisvector(obj2)) {
+ fprintf(stderr, "TODO: equal? for vectors not implemented!\n");
+ result = false;
} else {
result = false;
break;
diff --git a/src/kgequalp.h b/src/kgequalp.h
@@ -20,7 +20,7 @@
/* 4.3.1 equal? */
/* 6.6.1 equal? */
-void equalp(klisp_State *K, TValue *xparas, TValue ptree, TValue denv);
+void equalp(klisp_State *K);
/* Helper (may be used in assoc and member) */
/* compare two objects and check to see if they are "equal?". */
diff --git a/src/kgerror.c b/src/kgerror.c
@@ -4,7 +4,6 @@
** See Copyright Notice in klisp.h
*/
-#include <assert.h>
#include <stdbool.h>
#include <stdint.h>
@@ -17,9 +16,12 @@
#include "kghelpers.h"
#include "kgerror.h"
-void r7rs_error(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void r7rs_error(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
if (ttispair(ptree) && ttisstring(kcar(ptree))) {
@@ -29,45 +31,52 @@ void r7rs_error(klisp_State *K, TValue *xparams, TValue ptree,
}
}
-void error_object_message(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void error_object_message(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "error object", ttiserror, error_tv);
Error *err_obj = tv2error(error_tv);
- assert(ttisstring(err_obj->msg));
+ klisp_assert(ttisstring(err_obj->msg));
kapply_cc(K, err_obj->msg);
}
-void error_object_irritants(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void error_object_irritants(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "error object", ttiserror, error_tv);
Error *err_obj = tv2error(error_tv);
kapply_cc(K, err_obj->irritants);
}
-
-void do_exception_cont(klisp_State *K, TValue *xparams, TValue obj)
+/* REFACTOR this is the same as do_pass_value */
+void do_exception_cont(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
UNUSED(xparams);
/* Just pass error object to general error continuation. */
kapply_cc(K, obj);
}
+/* REFACTOR maybe this should be in kerror.c */
/* Create system-error-continuation. */
void kinit_error_hierarchy(klisp_State *K)
{
- assert(ttiscontinuation(K->error_cont));
- assert(ttisinert(K->system_error_cont));
+ klisp_assert(ttiscontinuation(K->error_cont));
+ klisp_assert(ttisinert(K->system_error_cont));
- K->system_error_cont = kmake_continuation(K, K->error_cont, do_exception_cont, 0);
- TValue symbol = ksymbol_new(K, "system-error-continuation", KNIL);
- krooted_tvs_push(K, symbol);
- kadd_binding(K, K->ground_env, symbol, K->system_error_cont);
- krooted_tvs_pop(K);
+ K->system_error_cont = kmake_continuation(K, K->error_cont,
+ do_exception_cont, 0);
}
/* init ground */
@@ -80,4 +89,7 @@ void kinit_error_ground_env(klisp_State *K)
add_applicative(K, ground_env, "error", r7rs_error, 0);
add_applicative(K, ground_env, "error-object-message", error_object_message, 0);
add_applicative(K, ground_env, "error-object-irritants", error_object_irritants, 0);
+
+ klisp_assert(ttiscontinuation(K->system_error_cont));
+ add_value(K, ground_env, "system-error-continuation", K->system_error_cont);
}
diff --git a/src/kgffi.c b/src/kgffi.c
@@ -36,7 +36,7 @@
#include "kinteger.h"
#include "kpair.h"
#include "kerror.h"
-#include "kblob.h"
+#include "kbytevector.h"
#include "kencapsulation.h"
#include "ktable.h"
@@ -123,8 +123,8 @@ static TValue ffi_decode_pointer(ffi_codec_t *self, klisp_State *K, const void *
static void ffi_encode_pointer(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
{
- if (ttisblob(v)) {
- *(void **)buf = tv2blob(v)->b;
+ if (ttisbytevector(v)) {
+ *(void **)buf = tv2bytevector(v)->b;
} else if (ttisstring(v)) {
*(void **)buf = kstring_buf(v);
} else if (ttisnil(v)) {
@@ -133,7 +133,7 @@ static void ffi_encode_pointer(ffi_codec_t *self, klisp_State *K, TValue v, void
/* TODO: do not use internal macro tbasetype_ */
*(void **)buf = pvalue(v);
} else {
- klispE_throw_simple_with_irritants(K, "neither blob, string, pointer or nil", 1, v);
+ klispE_throw_simple_with_irritants(K, "neither bytevector, string, pointer or nil", 1, v);
}
}
@@ -260,6 +260,23 @@ static void ffi_encode_uint32(ffi_codec_t *self, klisp_State *K, TValue v, void
}
}
+static TValue ffi_decode_sint32(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return i2tv(*(int32_t *)buf);
+}
+
+static void ffi_encode_sint32(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v)) {
+ *(int32_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C int32_t", 1, v);
+ return;
+ }
+}
+
static TValue ffi_decode_uint64(ffi_codec_t *self, klisp_State *K, const void *buf)
{
/* TODO */
@@ -352,6 +369,7 @@ static ffi_codec_t ffi_codecs[] = {
SIMPLE_TYPE(uint16),
SIMPLE_TYPE(sint16),
SIMPLE_TYPE(uint32),
+ SIMPLE_TYPE(sint32),
SIMPLE_TYPE(uint64),
SIMPLE_TYPE(float),
SIMPLE_TYPE(double)
@@ -376,9 +394,12 @@ static TValue ffi_win32_error_message(klisp_State *K, DWORD dwMessageId)
}
#endif
-void ffi_load_library(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void ffi_load_library(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
/*
** xparams[0]: encapsulation key denoting loaded library
@@ -386,8 +407,8 @@ void ffi_load_library(klisp_State *K, TValue *xparams,
TValue filename = ptree;
const char *filename_c =
- get_opt_tpar(K, "ffi-load-library", K_TSTRING, &filename)
- ? kstring_buf(filename) : NULL;
+ get_opt_tpar(K, filename, "string", ttisstring)
+ ? kstring_buf(filename) : NULL;
#if KGFFI_DLFCN
void *handle = dlopen(filename_c, RTLD_LAZY | RTLD_GLOBAL);
@@ -460,9 +481,12 @@ inline size_t align(size_t offset, size_t alignment)
return offset + (alignment - offset % alignment) % alignment;
}
-void ffi_make_call_interface(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void ffi_make_call_interface(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
/*
** xparams[0]: encapsulation key denoting call interface
@@ -478,30 +502,24 @@ void ffi_make_call_interface(klisp_State *K, TValue *xparams,
size_t nargs = check_typed_list(K, "ffi-make-call-interface", "argtype string",
kstringp, false, argtypes_tv, NULL);
- krooted_tvs_push(K, abi_tv);
- krooted_tvs_push(K, rtype_tv);
- krooted_tvs_push(K, argtypes_tv);
- TValue key = xparams[0];
- krooted_tvs_push(K, key);
- size_t blob_size = sizeof(ffi_call_interface_t) + (sizeof(ffi_codec_t *) + sizeof(ffi_type)) * nargs;
- TValue blob = kblob_new_imm(K, blob_size);
- krooted_tvs_push(K, blob);
- TValue enc = kmake_encapsulation(K, key, blob);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
+ /* Allocate C structure ffi_call_interface_t inside
+ a mutable bytevector. The structure contains C pointers
+ into itself. It must never be reallocated or copied.
+ The bytevector will be encapsulated later to protect
+ it from lisp code. */
- ffi_call_interface_t *p = (ffi_call_interface_t *) tv2blob(blob)->b;
+ size_t bytevector_size = sizeof(ffi_call_interface_t) + (sizeof(ffi_codec_t *) + sizeof(ffi_type)) * nargs;
+ TValue bytevector = kbytevector_new_sf(K, bytevector_size, 0);
+ krooted_tvs_push(K, bytevector);
+
+ ffi_call_interface_t *p = (ffi_call_interface_t *) tv2bytevector(bytevector)->b;
p->acodecs = (ffi_codec_t **) ((char *) p + sizeof(ffi_call_interface_t));
p->argtypes = (ffi_type **) ((char *) p + sizeof(ffi_call_interface_t) + nargs * sizeof(ffi_codec_t *));
-
p->nargs = nargs;
p->rcodec = tv2ffi_codec(K, rtype_tv);
if (p->rcodec->decode == NULL) {
- klispE_throw_simple(K, "this type is not allowed as a return type");
- return;
+ klispE_throw_simple_with_irritants(K, "this type is not allowed as a return type", 1, rtype_tv);
+ return;
}
p->buffer_size = p->rcodec->libffi_type->size;
@@ -509,7 +527,7 @@ void ffi_make_call_interface(klisp_State *K, TValue *xparams,
for (int i = 0; i < nargs; i++) {
p->acodecs[i] = tv2ffi_codec(K, kcar(tail));
if (p->acodecs[i]->encode == NULL) {
- klispE_throw_simple(K, "this type is not allowed in argument list");
+ klispE_throw_simple_with_irritants(K, "this type is not allowed in argument list", 1, kcar(tail));
return;
}
ffi_type *t = p->acodecs[i]->libffi_type;
@@ -533,19 +551,27 @@ void ffi_make_call_interface(klisp_State *K, TValue *xparams,
klispE_throw_simple(K, "unknown error in ffi_prep_cif");
return;
}
+
+ TValue key = xparams[0];
+ TValue enc = kmake_encapsulation(K, key, bytevector);
+ krooted_tvs_pop(K);
kapply_cc(K, enc);
}
-void do_ffi_call(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void do_ffi_call(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
/*
** xparams[0]: function pointer
- ** xparams[1]: call interface (encapsulated blob)
+ ** xparams[1]: call interface (encapsulated bytevector)
*/
void *funptr = pvalue(xparams[0]);
- ffi_call_interface_t *p = (ffi_call_interface_t *) tv2blob(kget_enc_val(xparams[1]))->b;
+ ffi_call_interface_t *p = (ffi_call_interface_t *) tv2bytevector(kget_enc_val(xparams[1]))->b;
int64_t buffer[(p->buffer_size + sizeof(int64_t) - 1) / sizeof(int64_t)];
@@ -580,9 +606,12 @@ void do_ffi_call(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, result);
}
-void ffi_make_applicative(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void ffi_make_applicative(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
/*
** xparams[0]: encapsulation key denoting dynamically loaded library
@@ -671,7 +700,7 @@ static TValue ffi_callback_pop(ffi_callback_t *cb)
return v;
}
-static TValue ffi_callback_guard(ffi_callback_t *cb, klisp_Ofunc fn)
+static TValue ffi_callback_guard(ffi_callback_t *cb, klisp_CFunction fn)
{
TValue app = kmake_applicative(cb->K, fn, 1, p2tv(cb));
krooted_tvs_push(cb->K, app);
@@ -683,22 +712,27 @@ static TValue ffi_callback_guard(ffi_callback_t *cb, klisp_Ofunc fn)
return ls2;
}
-void do_ffi_callback_encode_result(klisp_State *K, TValue *xparams,
- TValue obj)
+void do_ffi_callback_encode_result(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: cif
** xparams[1]: p2tv(libffi return buffer)
*/
- ffi_call_interface_t *p = (ffi_call_interface_t *) kblob_buf(kget_enc_val(xparams[0]));
+ ffi_call_interface_t *p = (ffi_call_interface_t *) kbytevector_buf(kget_enc_val(xparams[0]));
void *ret = pvalue(xparams[1]);
p->rcodec->encode(p->rcodec, K, obj, ret);
kapply_cc(K, KINERT);
}
-void do_ffi_callback_decode_arguments(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void do_ffi_callback_decode_arguments(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: p2tv(ffi_callback_t)
** xparams[1]: p2tv(libffi return buffer)
@@ -719,7 +753,7 @@ void do_ffi_callback_decode_arguments(klisp_State *K, TValue *xparams,
assert(ttisencapsulation(cif_tv));
krooted_tvs_push(K, app_tv);
krooted_tvs_push(K, cif_tv);
- ffi_call_interface_t *p = (ffi_call_interface_t *) kblob_buf(kget_enc_val(cif_tv));
+ ffi_call_interface_t *p = (ffi_call_interface_t *) kbytevector_buf(kget_enc_val(cif_tv));
/* Decode arguments. */
@@ -748,8 +782,11 @@ void do_ffi_callback_decode_arguments(klisp_State *K, TValue *xparams,
ktail_call(K, app_tv, tail, denv);
}
-void do_ffi_callback_return(klisp_State *K, TValue *xparams, TValue obj)
+void do_ffi_callback_return(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
UNUSED(obj);
/*
** xparams[0]: p2tv(ffi_callback_t)
@@ -762,11 +799,15 @@ void do_ffi_callback_return(klisp_State *K, TValue *xparams, TValue obj)
K->next_func = NULL;
}
-void do_ffi_callback_entry_guard(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void do_ffi_callback_entry_guard(klisp_State *K)
{
- UNUSED(denv);
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
+ UNUSED(ptree);
+ UNUSED(denv);
/* The entry guard is invoked only if the user captured
* the continuation under foreign callback and applied
* it later after the foreign callback terminated.
@@ -778,9 +819,13 @@ void do_ffi_callback_entry_guard(klisp_State *K, TValue *xparams,
klispE_throw_simple(K, "tried to re-enter continuation under FFI callback");
}
-void do_ffi_callback_exit_guard(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void do_ffi_callback_exit_guard(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(ptree);
UNUSED(denv);
/*
** xparams[0]: p2tv(ffi_callback_t)
@@ -829,7 +874,10 @@ static void ffi_callback_entry(ffi_cif *cif, void *ret, void **args, void *user_
krooted_tvs_pop(K);
krooted_tvs_pop(K);
- guard_dynamic_extent(K, NULL, ptree, K->next_env);
+ K->next_xparams = NULL;
+ K->next_value = ptree;
+ /* K->next_env already has the correct value */
+ guard_dynamic_extent(K);
/* Enter new "inner" trampoline loop. */
@@ -862,9 +910,12 @@ static void ffi_callback_entry(ffi_cif *cif, void *ret, void **args, void *user_
}
-void ffi_make_callback(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void ffi_make_callback(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
/*
** xparams[0]: encapsulation key denoting call interface
@@ -878,7 +929,7 @@ void ffi_make_callback(klisp_State *K, TValue *xparams,
klispE_throw_simple(K, "second argument shall be call interface");
return;
}
- ffi_call_interface_t *p = (ffi_call_interface_t *) kblob_buf(kget_enc_val(cif_tv));
+ ffi_call_interface_t *p = (ffi_call_interface_t *) kbytevector_buf(kget_enc_val(cif_tv));
TValue cb_tab = xparams[1];
/* Allocate memory for libffi closure. */
@@ -936,15 +987,15 @@ void ffi_make_callback(klisp_State *K, TValue *xparams,
static uint8_t * ffi_memory_location(klisp_State *K, bool allow_nesting,
TValue v, bool mutable, size_t size)
{
- if (ttisblob(v)) {
- if (mutable && kblob_immutablep(v)) {
- klispE_throw_simple_with_irritants(K, "blob not mutable", 1, v);
+ if (ttisbytevector(v)) {
+ if (mutable && kbytevector_immutablep(v)) {
+ klispE_throw_simple_with_irritants(K, "bytevector not mutable", 1, v);
return NULL;
- } else if (size > kblob_size(v)) {
- klispE_throw_simple_with_irritants(K, "blob too small", 1, v);
+ } else if (size > kbytevector_size(v)) {
+ klispE_throw_simple_with_irritants(K, "bytevector too small", 1, v);
return NULL;
} else {
- return kblob_buf(v);
+ return kbytevector_buf(v);
}
} else if (ttisstring(v)) {
if (mutable && kstring_immutablep(v)) {
@@ -980,9 +1031,12 @@ static uint8_t * ffi_memory_location(klisp_State *K, bool allow_nesting,
}
}
-void ffi_memmove(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void ffi_memmove(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -1002,10 +1056,14 @@ void ffi_memmove(klisp_State *K, TValue *xparams,
kapply_cc(K, KINERT);
}
-static void ffi_type_ref(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+static void ffi_type_ref(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
+
/*
** xparams[0]: pointer to ffi_codec_t
*/
@@ -1022,10 +1080,14 @@ static void ffi_type_ref(klisp_State *K, TValue *xparams,
kapply_cc(K, result);
}
-static void ffi_type_set(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+static void ffi_type_set(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
+
/*
** xparams[0]: pointer to ffi_codec_t
*/
@@ -1044,9 +1106,16 @@ static void ffi_type_set(klisp_State *K, TValue *xparams,
kapply_cc(K, KINERT);
}
-void ffi_type_suite(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void ffi_type_suite(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(xparams);
+ UNUSED(denv);
+
bind_1tp(K, ptree, "string", ttisstring, type_tv);
ffi_codec_t *codec = tv2ffi_codec(K, type_tv);
@@ -1078,9 +1147,12 @@ void ffi_type_suite(klisp_State *K, TValue *xparams,
kapply_cc(K, suite_tv);
}
-void ffi_klisp_state(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void ffi_klisp_state(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
check_0p(K, ptree);
diff --git a/src/kgffi.h b/src/kgffi.h
@@ -21,8 +21,7 @@
#include "kstate.h"
#include "kghelpers.h"
-void ffi_load_library(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
+void ffi_load_library(klisp_State *K);
/* init ground */
void kinit_ffi_ground_env(klisp_State *K);
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -17,8 +17,12 @@
#include "kerror.h"
#include "ksymbol.h"
-void typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void typep(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: name symbol
** xparams[1]: type tag (as by i2tv)
@@ -47,8 +51,12 @@ void typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
}
-void ftypep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void ftypep(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) denv;
/*
** xparams[0]: name symbol
@@ -80,8 +88,12 @@ void ftypep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/*
** REFACTOR: Change this to make it a single pass
*/
-void ftyped_predp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void ftyped_predp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) denv;
/*
** xparams[0]: name symbol
@@ -120,8 +132,12 @@ void ftyped_predp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/*
** REFACTOR: Change this to make it a single pass
*/
-void ftyped_bpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void ftyped_bpredp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) denv;
/*
** xparams[0]: name symbol
@@ -176,8 +192,12 @@ void ftyped_bpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* This is the same, but the comparison predicate takes a klisp_State */
/* TODO unify them */
-void ftyped_kbpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void ftyped_kbpredp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) denv;
/*
** xparams[0]: name symbol
@@ -268,7 +288,7 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
return pairs;
}
-int32_t check_list(klisp_State *K, char *name, bool allow_infp,
+int32_t check_list(klisp_State *K, const char *name, bool allow_infp,
TValue obj, int32_t *cpairs)
{
TValue tail = obj;
@@ -301,8 +321,11 @@ int32_t check_list(klisp_State *K, char *name, bool allow_infp,
** Continuation that ignores the value received and instead returns
** a previously computed value.
*/
-void do_return_value(klisp_State *K, TValue *xparams, TValue obj)
+void do_return_value(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: saved_obj
*/
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -34,6 +34,10 @@
*/
/* XXX: add parens around macro vars!! */
+/* TODO try to rewrite all of these with just check_0p and check_al1p,
+ (the same with check_0tp and check_al1tp)
+ add a number param and use an array of strings for msgs */
+
#define check_0p(K_, ptree_) \
if (!ttisnil(ptree_)) { \
klispE_throw_simple((K_), \
@@ -195,31 +199,26 @@
/* returns true if the obj pointed by par is a list of one element of
type type, and puts that element in par
- returns false if *par is nil
+ returns false if par is nil
In any other case it throws an error */
-inline bool get_opt_tpar(klisp_State *K, char *name, int32_t type, TValue *par)
-{
- if (ttisnil(*par)) {
- return false;
- } else if (ttispair(*par) && ttisnil(kcdr(*par))) {
- *par = kcar(*par);
- if (ttype(*par) != type) {
- /* TODO show expected type */
- klispE_throw_simple(K, "Bad type on optional argument "
- "(expected ?)");
- /* avoid warning */
- return false;
- } else {
- return true;
- }
- } else {
- klispE_throw_simple(K, "Bad ptree structure (in optional "
- "argument)");
- /* avoid warning */
- return false;
- }
-}
-
+#define get_opt_tpar(K_, par_, tstr_, t_) ({ \
+ bool res_; \
+ if (ttisnil(par_)) { \
+ res_ = false; \
+ } else if (!ttispair(par_) || !ttisnil(kcdr(par_))) { \
+ klispE_throw_simple((K_), \
+ "Bad ptree structure " \
+ "(in optional argument)"); \
+ return; \
+ } else if (!t_(kcar(par_))) { \
+ klispE_throw_simple(K_, "Bad type on optional argument " \
+ "(expected " tstr_ ")"); \
+ return; \
+ } else { \
+ par_ = kcar(par_); \
+ res_ = true; \
+ } \
+ res_; })
/*
** This states are useful for traversing trees, saving the state in the
@@ -274,7 +273,7 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
/* check that obj is a list, returns the number of pairs */
/* TODO change the return to void and add int32_t pairs obj */
-int32_t check_list(klisp_State *K, char *name, bool allow_infp,
+int32_t check_list(klisp_State *K, const char *name, bool allow_infp,
TValue obj, int32_t *cpairs);
/*
@@ -364,13 +363,13 @@ inline TValue check_copy_env_list(klisp_State *K, char *name, TValue obj)
** Generic function for type predicates
** It can only be used by types that have a unique tag
*/
-void typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void typep(klisp_State *K);
/*
** Generic function for type predicates
** It takes an arbitrary function pointer of type bool (*fn)(TValue o)
*/
-void ftypep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void ftypep(klisp_State *K);
/*
** Generic function for typed predicates (like char-alphabetic? or finite?)
@@ -379,7 +378,7 @@ void ftypep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
** both of the same type: bool (*fn)(TValue o).
** On zero operands this return true
*/
-void ftyped_predp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void ftyped_predp(klisp_State *K);
/*
** Generic function for typed binary predicates (like =? & char<?)
@@ -389,18 +388,18 @@ void ftyped_predp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
** This assumes the predicate is transitive and works even in cyclic lists
** On zero and one operand this return true
*/
-void ftyped_bpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void ftyped_bpredp(klisp_State *K);
/* This is the same, but the comparison predicate takes a klisp_State */
/* TODO unify them */
-void ftyped_kbpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void ftyped_kbpredp(klisp_State *K);
/*
** Continuation that ignores the value received and instead returns
** a previously computed value.
*/
-void do_return_value(klisp_State *K, TValue *xparams, TValue obj);
+void do_return_value(klisp_State *K);
/* GC: assumes parent & obj are rooted */
inline TValue make_return_value_cont(klisp_State *K, TValue parent, TValue obj)
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -32,9 +32,12 @@
/* Helpers for make-keyed-dynamic-variable */
/* accesor returned */
-void do_access(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void do_access(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: dynamic key
*/
@@ -51,8 +54,11 @@ void do_access(klisp_State *K, TValue *xparams, TValue ptree,
}
/* continuation to set the key to the old value on normal return */
-void do_unbind(klisp_State *K, TValue *xparams, TValue obj)
+void do_unbind(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: dynamic key
** xparams[1]: old flag
@@ -70,9 +76,12 @@ void do_unbind(klisp_State *K, TValue *xparams, TValue obj)
}
/* operative for setting the key to the new/old flag/value */
-void do_set_pass(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void do_set_pass(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: dynamic key
** xparams[1]: flag
@@ -149,9 +158,12 @@ inline TValue make_bind_continuation(klisp_State *K, TValue key,
}
/* binder returned */
-void do_bind(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void do_bind(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: dynamic key
*/
@@ -186,9 +198,12 @@ void do_bind(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 10.1.1 make-keyed-dynamic-variable */
-void make_keyed_dynamic_variable(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void make_keyed_dynamic_variable(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
diff --git a/src/kgkd_vars.h b/src/kgkd_vars.h
@@ -19,16 +19,13 @@
#include "kghelpers.h"
/* This is also used by kgports.c */
-void do_bind(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
-void do_access(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void do_bind(klisp_State *K);
+void do_access(klisp_State *K);
/* 10.1.1 make-keyed-dynamic-variable */
-void make_keyed_dynamic_variable(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
+void make_keyed_dynamic_variable(klisp_State *K);
-void do_unbind(klisp_State *K, TValue *xparams, TValue obj);
+void do_unbind(klisp_State *K);
/* init ground */
void kinit_kgkd_vars_ground_env(klisp_State *K);
diff --git a/src/kgks_vars.c b/src/kgks_vars.c
@@ -25,9 +25,12 @@
/* Helpers for make-static-dynamic-variable */
/* accesor returned */
-void do_sv_access(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void do_sv_access(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: static key
*/
@@ -40,9 +43,12 @@ void do_sv_access(klisp_State *K, TValue *xparams, TValue ptree,
}
/* binder returned */
-void do_sv_bind(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void do_sv_bind(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: static key
*/
@@ -56,9 +62,12 @@ void do_sv_bind(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 11.1.1 make-static-dynamic-variable */
-void make_keyed_static_variable(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void make_keyed_static_variable(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
diff --git a/src/kgks_vars.h b/src/kgks_vars.h
@@ -19,8 +19,7 @@
#include "kghelpers.h"
/* 11.1.1 make-static-dynamic-variable */
-void make_keyed_static_variable(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
+void make_keyed_static_variable(klisp_State *K);
/* init ground */
void kinit_kgks_vars_ground_env(klisp_State *K);
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -50,6 +50,8 @@ bool kfinitep(TValue obj) { return !ttisinf(obj); }
bool kintegerp(TValue obj) { return ttisinteger(obj); }
/* only exact integers (like for indices), bigints & fixints */
bool keintegerp(TValue obj) { return ttiseinteger(obj); }
+/* exact integers between 0 and 255 inclusive */
+bool ku8p(TValue obj) { return ttisu8(obj); }
bool krationalp(TValue obj) { return ttisrational(obj); }
bool krealp(TValue obj) { return ttisreal(obj); }
/* TEMP used (as a type predicate) in all predicates that need a real with
@@ -896,8 +898,12 @@ TValue knum_rationalize(klisp_State *K, TValue n1, TValue n2)
}
/* 12.5.4 + */
-void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kplus(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
@@ -963,8 +969,12 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 12.5.5 * */
-void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void ktimes(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
@@ -1041,8 +1051,12 @@ void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 12.5.6 - */
-void kminus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kminus(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
@@ -1193,8 +1207,12 @@ int32_t kfixint_div0_mod0(int32_t n, int32_t d, int32_t *res_mod)
}
/* flags are FDIV_DIV, FDIV_MOD, FDIV_ZERO */
-void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kdiv_mod(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: name symbol
** xparams[1]: div_mod_flags
@@ -1434,8 +1452,12 @@ bool kevenp(TValue n)
}
/* 12.5.12 abs */
-void kabs(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kabs(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -1448,8 +1470,12 @@ void kabs(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 12.5.13 min, max */
/* NOTE: this does two passes, one for error checking and one for doing
the actual work */
-void kmin_max(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kmin_max(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
** xparams[1]: bool: true min, false max
@@ -1486,8 +1512,12 @@ void kmin_max(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 12.5.14 gcm, lcm */
-void kgcd(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kgcd(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
/* cycles are allowed, loop counting pairs */
@@ -1520,8 +1550,12 @@ void kgcd(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
arith_kapply_cc(K, res);
}
-void klcm(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void klcm(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
/* cycles are allowed, loop counting pairs */
@@ -1549,9 +1583,16 @@ void klcm(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* use fyped_predp */
/* 12.6.2 get-real-internal-bounds, get-real-exact-bounds */
-void kget_real_internal_bounds(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kget_real_internal_bounds(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(denv);
+ UNUSED(xparams);
+
bind_1tp(K, ptree, "real", krealp, tv_n);
/* TEMP: do it here directly, for now all inexact objects have
[-inf, +inf] bounds */
@@ -1564,9 +1605,15 @@ void kget_real_internal_bounds(klisp_State *K, TValue *xparams, TValue ptree,
kapply_cc(K, res);
}
-void kget_real_exact_bounds(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kget_real_exact_bounds(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(denv);
+ UNUSED(xparams);
+
bind_1tp(K, ptree, "real", krealp, tv_n);
/* TEMP: do it here directly, for now all inexact objects have
[-inf, +inf] bounds, when bounded reals are implemented this
@@ -1582,9 +1629,15 @@ void kget_real_exact_bounds(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 12.6.3 get-real-internal-primary, get-real-exact-primary */
-void kget_real_internal_primary(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void kget_real_internal_primary(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(denv);
+ UNUSED(xparams);
+
bind_1tp(K, ptree, "real", krealp, tv_n);
/* TEMP: do it here directly */
if (ttisrwnpv(tv_n)) {
@@ -1595,9 +1648,15 @@ void kget_real_internal_primary(klisp_State *K, TValue *xparams,
}
}
-void kget_real_exact_primary(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void kget_real_exact_primary(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ klisp_assert(ttisenvironment(K->next_env));
bind_1tp(K, ptree, "real", krealp, tv_n);
/* NOTE: this handles no primary value errors & exact cases just fine */
@@ -1606,8 +1665,15 @@ void kget_real_exact_primary(klisp_State *K, TValue *xparams,
}
/* 12.6.4 make-inexact */
-void kmake_inexact(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kmake_inexact(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(denv);
+ UNUSED(xparams);
+
bind_3tp(K, ptree, "real", krealp, real1,
"real", krealp, real2, "real", krealp, real3);
@@ -1625,9 +1691,12 @@ void kmake_inexact(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 12.6.5 real->inexact, real->exact */
-void kreal_to_inexact(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kreal_to_inexact(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -1638,9 +1707,12 @@ void kreal_to_inexact(klisp_State *K, TValue *xparams, TValue ptree,
kapply_cc(K, res);
}
-void kreal_to_exact(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kreal_to_exact(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -1651,9 +1723,14 @@ void kreal_to_exact(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
-void kwith_strict_arithmetic(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kwith_strict_arithmetic(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+
bind_2tp(K, ptree, "bool", ttisboolean, strictp,
"combiner", ttiscombiner, comb);
@@ -1669,9 +1746,12 @@ void kwith_strict_arithmetic(klisp_State *K, TValue *xparams, TValue ptree,
ktail_call(K, op, args, denv);
}
-void kget_strict_arithmeticp(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kget_strict_arithmeticp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -1686,8 +1766,12 @@ void kget_strict_arithmeticp(klisp_State *K, TValue *xparams, TValue ptree,
/* uses ftypep */
/* 12.8.2 / */
-void kdivided(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kdivided(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
@@ -1781,8 +1865,12 @@ void kdivided(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 12.8.3 numerator, denominator */
-void knumerator(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void knumerator(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -1792,8 +1880,12 @@ void knumerator(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, res);
}
-void kdenominator(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kdenominator(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -1804,9 +1896,12 @@ void kdenominator(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 12.8.4 floor, ceiling, truncate, round */
-void kreal_to_integer(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void kreal_to_integer(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
** xparams[1]: bool: true min, false max
@@ -1821,9 +1916,12 @@ void kreal_to_integer(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 12.8.5 rationalize, simplest-rational */
-void krationalize(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void krationalize(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -1834,9 +1932,12 @@ void krationalize(klisp_State *K, TValue *xparams, TValue ptree,
kapply_cc(K, res);
}
-void ksimplest_rational(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void ksimplest_rational(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -1847,8 +1948,12 @@ void ksimplest_rational(klisp_State *K, TValue *xparams, TValue ptree,
kapply_cc(K, res);
}
-void kexp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kexp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -1884,8 +1989,12 @@ void kexp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, res);
}
-void klog(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void klog(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -1931,8 +2040,12 @@ void klog(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, res);
}
-void ktrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void ktrig(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
/*
** xparams[0]: trig function
@@ -1971,8 +2084,12 @@ void ktrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
arith_kapply_cc(K, res);
}
-void katrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void katrig(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
/*
** xparams[0]: trig function
@@ -2016,8 +2133,12 @@ void katrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
arith_kapply_cc(K, res);
}
-void katan(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void katan(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -2103,8 +2224,12 @@ void katan(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
arith_kapply_cc(K, res);
}
-void ksqrt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void ksqrt(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -2144,8 +2269,12 @@ void ksqrt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
arith_kapply_cc(K, res);
}
-void kexpt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void kexpt(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
@@ -2349,4 +2478,6 @@ void kinit_numbers_ground_env(klisp_State *K)
add_applicative(K, ground_env, "sqrt", ksqrt, 0);
/* 12.9.6 expt */
add_applicative(K, ground_env, "expt", kexpt, 0);
+
+ /* TODO add some conversion like number->string, string->number */
}
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -36,6 +36,7 @@ bool kexactp(TValue obj);
bool kinexactp(TValue obj);
bool kundefinedp(TValue obj);
bool krobustp(TValue obj);
+bool ku8p(TValue obj);
/* 12.5.2 =? */
@@ -55,15 +56,15 @@ bool knum_gep(klisp_State *K, TValue n1, TValue n2);
/* 12.5.4 + */
/* TEMP: for now only accept two arguments */
-void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kplus(klisp_State *K);
/* 12.5.5 * */
/* TEMP: for now only accept two arguments */
-void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void ktimes(klisp_State *K);
/* 12.5.6 - */
/* TEMP: for now only accept two arguments */
-void kminus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kminus(klisp_State *K);
/* 12.5.7 zero? */
/* uses ftyped_predp */
@@ -100,11 +101,11 @@ bool kevenp(TValue n);
#define FDIV_MOD 2
#define FDIV_ZERO 4
-void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kdiv_mod(klisp_State *K);
/* 12.5.12 abs */
-void kabs(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kabs(klisp_State *K);
/* 12.5.13 min, max */
/* use kmin_max */
@@ -112,84 +113,73 @@ void kabs(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* Helper */
#define FMIN (true)
#define FMAX (false)
-void kmin_max(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kmin_max(klisp_State *K);
/* 12.5.14 gcm, lcm */
-void kgcd(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-void klcm(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kgcd(klisp_State *K);
+void klcm(klisp_State *K);
/* 12.6.1 exact?, inexact?, robust?, undefined? */
/* use fyped_predp */
/* 12.6.2 get-real-internal-bounds, get-real-exact-bounds */
-void kget_real_internal_bounds(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
-void kget_real_exact_bounds(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void kget_real_internal_bounds(klisp_State *K);
+void kget_real_exact_bounds(klisp_State *K);
/* 12.6.3 get-real-internal-primary, get-real-exact-primary */
-void kget_real_internal_primary(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
-void kget_real_exact_primary(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
+void kget_real_internal_primary(klisp_State *K);
+void kget_real_exact_primary(klisp_State *K);
/* 12.6.4 make-inexact */
-void kmake_inexact(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kmake_inexact(klisp_State *K);
/* 12.6.5 real->inexact, real->exact */
-void kreal_to_inexact(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
-void kreal_to_exact(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void kreal_to_inexact(klisp_State *K);
+void kreal_to_exact(klisp_State *K);
/* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
-void kwith_strict_arithmetic(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void kwith_strict_arithmetic(klisp_State *K);
-void kget_strict_arithmeticp(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void kget_strict_arithmeticp(klisp_State *K);
/* 12.8.1 rational? */
/* uses ftypep */
/* 12.8.2 / */
-void kdivided(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kdivided(klisp_State *K);
/* 12.8.3 numerator, denominator */
-void knumerator(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-void kdenominator(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void knumerator(klisp_State *K);
+void kdenominator(klisp_State *K);
/* 12.8.4 floor, ceiling, truncate, round */
-void kreal_to_integer(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void kreal_to_integer(klisp_State *K);
/* 12.8.5 rationalize, simplest-rational */
-void krationalize(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void krationalize(klisp_State *K);
-void ksimplest_rational(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void ksimplest_rational(klisp_State *K);
/* 12.9.1 real? */
/* uses ftypep */
/* 12.9.2 exp, log */
-void kexp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-void klog(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kexp(klisp_State *K);
+void klog(klisp_State *K);
/* 12.9.3 sin, cos, tan */
-void ktrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void ktrig(klisp_State *K);
/* 12.9.4 asin, acos, atan */
-void katrig(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-void katan(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void katrig(klisp_State *K);
+void katan(klisp_State *K);
/* 12.9.5 sqrt */
-void ksqrt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void ksqrt(klisp_State *K);
/* 12.9.6 expt */
-void kexpt(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void kexpt(klisp_State *K);
/* REFACTOR: These should be in a knumber.h header */
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -23,8 +23,12 @@
#include "kgnumbers.h" /* for kpositivep and keintegerp */
/* 4.7.1 set-car!, set-cdr! */
-void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void set_carB(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) denv;
(void) xparams;
bind_2tp(K, ptree, "pair", ttispair, pair,
@@ -38,8 +42,12 @@ void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, KINERT);
}
-void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void set_cdrB(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
(void) denv;
(void) xparams;
bind_2tp(K, ptree, "pair", ttispair, pair,
@@ -54,9 +62,15 @@ void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helper for copy-es-immutable & copy-es */
-void copy_es(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void copy_es(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(denv);
+
/*
** xparams[0]: copy-es-immutable symbol
** xparams[1]: boolean (#t: use mutable pairs, #f: use immutable pairs)
@@ -154,9 +168,12 @@ TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj,
}
/* 5.8.1 encycle! */
-void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void encycleB(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/* ASK John: can the object be a cyclic list of length less than k1+k2?
the wording of the report seems to indicate that can't be the case,
and here it makes sense to forbid it because otherwise the list-metrics
@@ -400,9 +417,12 @@ TValue appendB_get_lss_endpoints(klisp_State *K, TValue lss, int32_t apairs,
}
/* 6.4.1 append! */
-void appendB(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void appendB(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
if (ttisnil(ptree)) {
@@ -444,8 +464,12 @@ void appendB(klisp_State *K, TValue *xparams, TValue ptree,
/* 6.4.3 assq */
/* REFACTOR: do just one pass, maybe use generalized accum function */
-void assq(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void assq(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -469,8 +493,12 @@ void assq(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 6.4.3 memq? */
/* REFACTOR: do just one pass, maybe use generalized accum function */
-void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void memqp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -491,6 +519,9 @@ void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, res);
}
+/* ?.? immutable-pair?, mutable-pair */
+/* use ftypep */
+
/* init ground */
void kinit_pair_mut_ground_env(klisp_State *K)
{
@@ -513,4 +544,9 @@ void kinit_pair_mut_ground_env(klisp_State *K)
add_applicative(K, ground_env, "assq", assq, 0);
/* 6.4.3 memq? */
add_applicative(K, ground_env, "memq?", memqp, 0);
+ /* ?.? immutable-pair?, mutable-pair? */
+ add_applicative(K, ground_env, "immutable-pair?", ftypep, 2, symbol,
+ p2tv(kimmutable_pairp));
+ add_applicative(K, ground_env, "mutable-pair?", ftypep, 2, symbol,
+ p2tv(kmutable_pairp));
}
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -23,33 +23,34 @@ TValue copy_es_immutable_h(klisp_State *K, char *name, TValue ptree,
bool mut_flag);
/* 4.7.1 set-car!, set-cdr! */
-void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void set_carB(klisp_State *K);
-void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void set_cdrB(klisp_State *K);
/* Helper for copy-es & copy-es-immutable */
-void copy_es(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void copy_es(klisp_State *K);
/* 4.7.2 copy-es-immutable */
/* uses copy_es helper */
/* 5.8.1 encycle! */
-void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void encycleB(klisp_State *K);
/* 6.4.1 append! */
-void appendB(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void appendB(klisp_State *K);
/* 6.4.2 copy-es */
/* uses copy_es helper */
/* 6.4.3 assq */
-void assq(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void assq(klisp_State *K);
/* 6.4.3 memq? */
-void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void memqp(klisp_State *K);
+
+/* ?.? immutable-pair?, mutable-pair */
+/* use ftypep */
/* init ground */
void kinit_pair_mut_ground_env(klisp_State *K);
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -32,8 +32,12 @@
/* uses typep */
/* 4.6.3 cons */
-void cons(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void cons(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
UNUSED(xparams);
bind_2p(K, ptree, car, cdr);
@@ -44,8 +48,12 @@ void cons(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 5.2.1 list */
-void list(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void list(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/* the underlying combiner of list return the complete ptree, the only list
checking is implicit in the applicative evaluation */
UNUSED(xparams);
@@ -54,8 +62,12 @@ void list(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 5.2.2 list* */
-void listS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void listS(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/* TODO:
OPTIMIZE: if this call is a result of a call to eval, we could get away
with just setting the kcdr of the next to last pair to the car of
@@ -103,8 +115,14 @@ void listS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 5.4.1 car, cdr */
/* 5.4.2 caar, cadr, ... cddddr */
-void c_ad_r( klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void c_ad_r(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ UNUSED(denv);
/*
** xparams[0]: name as symbol
@@ -177,9 +195,12 @@ void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
}
/* 5.7.1 get-list-metrics */
-void get_list_metrics(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void get_list_metrics(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -230,9 +251,12 @@ int32_t ksmallest_index(klisp_State *K, char *name, TValue obj,
/* 5.7.2 list-tail */
-void list_tail(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void list_tail(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/* ASK John: can the object be a cyclic list? the wording of the report
seems to indicate that can't be the case, but it makes sense here
(cf $encycle!) to allow cyclic lists, so that's what I do */
@@ -262,8 +286,12 @@ void list_tail(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 6.3.1 length */
-void length(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void length(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -283,8 +311,12 @@ void length(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.3.2 list-ref */
-void list_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void list_ref(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/* ASK John: can the object be an improper list? the wording of the report
seems to indicate that can't be the case, but it makes sense
(cf list-tail) For now we allow it. */
@@ -358,8 +390,12 @@ TValue append_check_copy_list(klisp_State *K, char *name, TValue obj,
}
/* 6.3.3 append */
-void append(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void append(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -420,9 +456,12 @@ void append(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.3.4 list-neighbors */
-void list_neighbors(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void list_neighbors(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -469,8 +508,11 @@ void list_neighbors(klisp_State *K, TValue *xparams, TValue ptree,
/* Helpers for filter */
/* For acyclic input lists: Return the filtered list */
-void do_ret_cdr(klisp_State *K, TValue *xparams, TValue obj)
+void do_ret_cdr(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: (dummy . complete-ls)
*/
@@ -487,8 +529,11 @@ void do_ret_cdr(klisp_State *K, TValue *xparams, TValue obj)
/* For cyclic input list: If the result cycle is non empty,
close it and return filtered list */
-void do_filter_encycle(klisp_State *K, TValue *xparams, TValue obj)
+void do_filter_encycle(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: (dummy . complete-ls)
** xparams[1]: last non-cycle pair
@@ -518,8 +563,11 @@ void do_filter_encycle(klisp_State *K, TValue *xparams, TValue obj)
kapply_cc(K, copy);
}
-void do_filter(klisp_State *K, TValue *xparams, TValue obj)
+void do_filter(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: app
** xparams[1]: (last-obj . rem-ls)
@@ -565,8 +613,11 @@ void do_filter(klisp_State *K, TValue *xparams, TValue obj)
}
}
-void do_filter_cycle(klisp_State *K, TValue *xparams, TValue obj)
+void do_filter_cycle(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: app
** xparams[1]: (dummy . res-list)
@@ -599,8 +650,12 @@ void do_filter_cycle(klisp_State *K, TValue *xparams, TValue obj)
}
/* 6.3.5 filter */
-void filter(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void filter(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "applicative", ttisapplicative, app,
@@ -640,8 +695,12 @@ void filter(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.3.6 assoc */
-void assoc(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void assoc(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -664,8 +723,12 @@ void assoc(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 6.3.7 member? */
-void memberp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void memberp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -688,8 +751,12 @@ void memberp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 6.3.8 finite-list? */
/* NOTE: can't use ftypep because the predicate marks pairs too */
-void finite_listp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void finite_listp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
int32_t pairs = check_list(K, "finite-list?", true, ptree, NULL);
@@ -716,9 +783,12 @@ void finite_listp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 6.3.9 countable-list? */
/* NOTE: can't use ftypep because the predicate marks pairs too */
-void countable_listp(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void countable_listp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
int32_t pairs = check_list(K, "countable-list?", true, ptree, NULL);
@@ -746,10 +816,13 @@ void countable_listp(klisp_State *K, TValue *xparams, TValue ptree,
/* Helpers for reduce */
/* NOTE: This is used from both do_reduce_cycle and reduce */
-void do_reduce(klisp_State *K, TValue *xparams, TValue obj);
+void do_reduce(klisp_State *K);
-void do_reduce_prec(klisp_State *K, TValue *xparams, TValue obj)
+void do_reduce_prec(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: first-pair
** xparams[1]: (old-obj . rem-ls)
@@ -783,8 +856,11 @@ void do_reduce_prec(klisp_State *K, TValue *xparams, TValue obj)
}
}
-void do_reduce_postc(klisp_State *K, TValue *xparams, TValue obj)
+void do_reduce_postc(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: postc
** xparams[1]: denv
@@ -799,8 +875,11 @@ void do_reduce_postc(klisp_State *K, TValue *xparams, TValue obj)
/* This could be avoided by contructing a list and calling
do_reduce, but the order would be backwards if the cycle
is processed after the acyclic part */
-void do_reduce_combine(klisp_State *K, TValue *xparams, TValue obj)
+void do_reduce_combine(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: acyclic result
** xparams[1]: bin
@@ -818,8 +897,11 @@ void do_reduce_combine(klisp_State *K, TValue *xparams, TValue obj)
ktail_eval(K, expr, denv);
}
-void do_reduce_cycle(klisp_State *K, TValue *xparams, TValue obj)
+void do_reduce_cycle(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: first-cpair
** xparams[1]: cpairs
@@ -879,8 +961,11 @@ void do_reduce_cycle(klisp_State *K, TValue *xparams, TValue obj)
}
/* NOTE: This is used from both do_reduce_cycle and reduce */
-void do_reduce(klisp_State *K, TValue *xparams, TValue obj)
+void do_reduce(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: remaining list
** xparams[1]: remaining pairs
@@ -920,8 +1005,12 @@ void do_reduce(klisp_State *K, TValue *xparams, TValue obj)
srfi-1 also defines reduce-left/reduce-right that work as in
kernel. The difference is the use or not of the id value if the list
is not null */
-void reduce(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void reduce(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
bind_al3tp(K, ptree, "any", anytype, ls, "applicative",
@@ -1101,4 +1190,6 @@ void kinit_pairs_lists_ground_env(klisp_State *K)
add_applicative(K, ground_env, "countable-list?", countable_listp, 0);
/* 6.3.10 reduce */
add_applicative(K, ground_env, "reduce", reduce, 0);
+
+ /* TODO add make-list, list-copy and reverse (from r7rs) */
}
diff --git a/src/kgpairs_lists.h b/src/kgpairs_lists.h
@@ -25,17 +25,17 @@
/* uses typep */
/* 4.6.3 cons */
-void cons(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void cons(klisp_State *K);
/* 5.2.1 list */
-void list(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void list(klisp_State *K);
/* 5.2.2 list* */
-void listS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void listS(klisp_State *K);
/* 5.4.1 car, cdr */
/* 5.4.2 caar, cadr, ... cddddr */
-void c_ad_r( klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void c_ad_r(klisp_State *K);
/* Helper macros to construct xparams[1] for c[ad]{1,4}r */
#define C_AD_R_PARAM(len_, br_) \
@@ -48,54 +48,51 @@ void c_ad_r( klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
(br_ & 0x1000? 0x8 : 0))
/* 5.7.1 get-list-metrics */
-void get_list_metrics(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void get_list_metrics(klisp_State *K);
/* 5.7.2 list-tail */
-void list_tail(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void list_tail(klisp_State *K);
/* 6.3.1 length */
-void length(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void length(klisp_State *K);
/* 6.3.2 list-ref */
-void list_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void list_ref(klisp_State *K);
/* 6.3.3 append */
-void append(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void append(klisp_State *K);
/* 6.3.4 list-neighbors */
-void list_neighbors(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void list_neighbors(klisp_State *K);
/* 6.3.5 filter */
-void filter(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void filter(klisp_State *K);
/* 6.3.6 assoc */
-void assoc(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void assoc(klisp_State *K);
/* 6.3.7 member? */
-void memberp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void memberp(klisp_State *K);
/* 6.3.8 finite-list? */
-void finite_listp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void finite_listp(klisp_State *K);
/* 6.3.9 countable-list? */
-void countable_listp(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void countable_listp(klisp_State *K);
/* 6.3.10 reduce */
-void reduce(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-
-
-void do_ret_cdr(klisp_State *K, TValue *xparams, TValue obj);
-void do_filter_encycle(klisp_State *K, TValue *xparams, TValue obj);
-void do_filter_cycle(klisp_State *K, TValue *xparams, TValue obj);
-void do_filter(klisp_State *K, TValue *xparams, TValue obj);
-void do_reduce_prec(klisp_State *K, TValue *xparams, TValue obj);
-void do_reduce_postc(klisp_State *K, TValue *xparams, TValue obj);
-void do_reduce_combine(klisp_State *K, TValue *xparams, TValue obj);
-void do_reduce_cycle(klisp_State *K, TValue *xparams, TValue obj);
-void do_reduce(klisp_State *K, TValue *xparams, TValue obj);
+void reduce(klisp_State *K);
+
+
+void do_ret_cdr(klisp_State *K);
+void do_filter_encycle(klisp_State *K);
+void do_filter_cycle(klisp_State *K);
+void do_filter(klisp_State *K);
+void do_reduce_prec(klisp_State *K);
+void do_reduce_postc(klisp_State *K);
+void do_reduce_combine(klisp_State *K);
+void do_reduce_cycle(klisp_State *K);
+void do_reduce(klisp_State *K);
/* init ground */
void kinit_pairs_lists_ground_env(klisp_State *K);
diff --git a/src/kgports.c b/src/kgports.c
@@ -13,6 +13,8 @@
#include "kstate.h"
#include "kobject.h"
#include "kport.h"
+#include "kstring.h"
+#include "kbytevector.h"
#include "kenvironment.h"
#include "kapplicative.h"
#include "koperative.h"
@@ -39,10 +41,24 @@
/* 15.1.2 input-port?, output-port? */
/* use ftypep */
+/* 15.1.? binary-port?, textual-port? */
+/* use ftypep */
+
+/* 15.1.? file-port?, string-port?, bytevector-port? */
+/* use ftypep */
+
+/* 15.1.? port-open? */
+/* uses ftyped_predp */
+
+/* uses ftyped_predp */
+
/* 15.1.3 with-input-from-file, with-ouput-to-file */
/* helper for with-i/o-from/to-file & call-with-i/o-file */
-void do_close_file_ret(klisp_State *K, TValue *xparams, TValue obj)
+void do_close_file_ret(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: port
*/
@@ -57,16 +73,19 @@ void do_close_file_ret(klisp_State *K, TValue *xparams, TValue obj)
the dynamic environment can be captured in the construction of the combiner
ASK John
*/
-void with_file(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void with_file(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
bool writep = bvalue(xparams[1]);
TValue key = xparams[2];
bind_2tp(K, ptree, "string", ttisstring, filename,
"combiner", ttiscombiner, comb);
- TValue new_port = kmake_port(K, filename, writep);
+ TValue new_port = kmake_fport(K, filename, writep, false);
krooted_tvs_push(K, new_port);
/* make the continuation to close the file before returning */
TValue new_cont = kmake_continuation(K, kget_cc(K),
@@ -87,9 +106,12 @@ void with_file(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 15.1.4 get-current-input-port, get-current-output-port */
-void get_current_port(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void get_current_port(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: symbol name
** xparams[1]: dynamic key
@@ -106,26 +128,109 @@ void get_current_port(klisp_State *K, TValue *xparams, TValue ptree,
/* 15.1.5 open-input-file, open-output-file */
-void open_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+/* 15.1.? open-binary-input-file, open-binary-output-file */
+void open_file(klisp_State *K)
{
- bool writep = bvalue(xparams[1]);
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
+ /*
+ ** xparams[0]: write?
+ ** xparams[1]: binary?
+ */
+ bool writep = bvalue(xparams[0]);
+ bool binaryp = bvalue(xparams[1]);
+
bind_1tp(K, ptree, "string", ttisstring, filename);
- TValue new_port = kmake_port(K, filename, writep);
+ TValue new_port = kmake_fport(K, filename, writep, binaryp);
+ kapply_cc(K, new_port);
+}
+
+/* 15.1.? open-input-string, open-output-string */
+/* 15.1.? open-input-bytevector, open-output-bytevector */
+void open_mport(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: write?
+ ** xparams[1]: binary?
+ */
+ bool writep = bvalue(xparams[0]);
+ bool binaryp = bvalue(xparams[1]);
+ UNUSED(denv);
+
+ TValue buffer;
+
+ /* This is kinda ugly but... */
+ if (writep) {
+ check_0p(K, ptree);
+ buffer = KINERT;
+ } else if (binaryp) {
+ bind_1tp(K, ptree, "bytevector", ttisbytevector, bb);
+ buffer = bb;
+ } else {
+ bind_1tp(K, ptree, "string", ttisstring, str);
+ buffer = str;
+ }
+
+ TValue new_port = kmake_mport(K, buffer, writep, binaryp);
kapply_cc(K, new_port);
}
+/* 15.1.? open-output-string, open-output-bytevector */
+
/* 15.1.6 close-input-file, close-output-file */
-void close_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void close_file(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: write?
+ */
+ bool writep = bvalue(xparams[0]);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "file port", ttisfport, port);
+
+ bool dir_ok = writep? kport_is_output(port) : kport_is_input(port);
+
+ if (dir_ok) {
+ kclose_port(K, port);
+ kapply_cc(K, KINERT);
+ } else {
+ klispE_throw_simple(K, "wrong input/output direction");
+ return;
+ }
+}
+
+/* 15.1.? close-input-port, close-output-port, close-port */
+void close_port(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: read?
+ ** xparams[1]: write?
+ */
+ bool readp = bvalue(xparams[0]);
bool writep = bvalue(xparams[1]);
UNUSED(denv);
bind_1tp(K, ptree, "port", ttisport, port);
- bool dir_ok = writep? kport_is_output(port) : kport_is_input(port);
+ bool dir_ok = !((writep && !kport_is_output(port)) ||
+ (readp && !kport_is_input(port)));
if (dir_ok) {
kclose_port(K, port);
@@ -136,20 +241,61 @@ void close_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
}
+/* 15.1.? get-output-string, get-output-bytevector */
+void get_output_buffer(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: binary?
+ */
+ bool binaryp = bvalue(xparams[0]);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "port", ttismport, port);
+
+ if (binaryp && !kport_is_binary(port)) {
+ klispE_throw_simple(K, "the port should be a bytevector port");
+ return;
+ } else if (!binaryp && !kport_is_textual(port)) {
+ klispE_throw_simple(K, "the port should be a string port");
+ return;
+ } else if (!kport_is_output(port)) {
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
+ }
+
+ TValue ret = binaryp?
+ kbytevector_new_bs(K,
+ kbytevector_buf(kmport_buf(port)),
+ kmport_off(port)) :
+ kstring_new_bs(K, kstring_buf(kmport_buf(port)), kmport_off(port));
+ kapply_cc(K, ret);
+}
+
/* 15.1.7 read */
-void read(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void gread(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
TValue port = ptree;
- if (!get_opt_tpar(K, "read", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_in_port_key); /* access directly */
- } else if (!kport_is_input(port)) {
+ }
+
+ if (!kport_is_input(port)) {
klispE_throw_simple(K, "the port should be an input port");
return;
- }
- if (kport_is_closed(port)) {
+ } else if (!kport_is_textual(port)) {
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
+ } else if (kport_is_closed(port)) {
klispE_throw_simple(K, "the port is already closed");
return;
}
@@ -160,21 +306,29 @@ void read(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 15.1.8 write */
-void write(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void gwrite(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_al1tp(K, ptree, "any", anytype, obj,
port);
- if (!get_opt_tpar(K, "write", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
- } else if (!kport_is_output(port)) {
+ }
+
+ if (!kport_is_output(port)) {
klispE_throw_simple(K, "the port should be an output port");
return;
- }
- if (kport_is_closed(port)) {
+ } else if (!kport_is_textual(port)) {
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
+ } else if (kport_is_closed(port)) {
klispE_throw_simple(K, "the port is already closed");
return;
}
@@ -188,19 +342,27 @@ void write(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* uses typep */
/* 15.1.? newline */
-void newline(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void newline(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
TValue port = ptree;
- if (!get_opt_tpar(K, "newline", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
- } else if (!kport_is_output(port)) {
+ }
+
+ if (!kport_is_output(port)) {
klispE_throw_simple(K, "the port should be an output port");
return;
- }
- if (kport_is_closed(port)) {
+ } else if (!kport_is_textual(port)) {
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
+ } else if (kport_is_closed(port)) {
klispE_throw_simple(K, "the port is already closed");
return;
}
@@ -210,21 +372,29 @@ void newline(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 15.1.? write-char */
-void write_char(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void write_char(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_al1tp(K, ptree, "char", ttischar, ch,
port);
- if (!get_opt_tpar(K, "write-char", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
- } else if (!kport_is_output(port)) {
+ }
+
+ if (!kport_is_output(port)) {
klispE_throw_simple(K, "the port should be an output port");
return;
- }
- if (kport_is_closed(port)) {
+ } else if (!kport_is_textual(port)) {
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
+ } else if (kport_is_closed(port)) {
klispE_throw_simple(K, "the port is already closed");
return;
}
@@ -234,26 +404,31 @@ void write_char(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helper for read-char and peek-char */
-void read_peek_char(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void read_peek_char(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
- ** xparams[0]: symbol name
- ** xparams[1]: ret-char-after-readp
+ ** xparams[0]: ret-char-after-readp
*/
UNUSED(denv);
- char *name = ksymbol_buf(xparams[0]);
- bool ret_charp = bvalue(xparams[1]);
+ bool ret_charp = bvalue(xparams[0]);
TValue port = ptree;
- if (!get_opt_tpar(K, name, K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_in_port_key); /* access directly */
- } else if (!kport_is_input(port)) {
+ }
+
+ if (!kport_is_input(port)) {
klispE_throw_simple(K, "the port should be an input port");
return;
- }
- if (kport_is_closed(port)) {
+ } else if (!kport_is_textual(port)) {
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
+ } else if (kport_is_closed(port)) {
klispE_throw_simple(K, "the port is already closed");
return;
}
@@ -274,19 +449,27 @@ void read_peek_char(klisp_State *K, TValue *xparams, TValue ptree,
specific code (probably select for posix & a thread for windows
(at least for files & consoles, I think pipes and sockets may
have something) */
-void char_readyp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void char_readyp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
TValue port = ptree;
- if (!get_opt_tpar(K, "char-ready?", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_in_port_key); /* access directly */
- } else if (!kport_is_input(port)) {
+ }
+
+ if (!kport_is_input(port)) {
klispE_throw_simple(K, "the port should be an input port");
return;
- }
- if (kport_is_closed(port)) {
+ } else if (!kport_is_textual(port)) {
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
+ } else if (kport_is_closed(port)) {
klispE_throw_simple(K, "the port is already closed");
return;
}
@@ -295,22 +478,130 @@ void char_readyp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, KTRUE);
}
+/* 15.1.? write-u8 */
+void write_u8(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_al1tp(K, ptree, "u8", ttisu8, u8, port);
+
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
+ port = kcdr(K->kd_out_port_key); /* access directly */
+ }
+
+ if (!kport_is_output(port)) {
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
+ } else if (!kport_is_binary(port)) {
+ klispE_throw_simple(K, "the port should be a binary port");
+ return;
+ } else if (kport_is_closed(port)) {
+ klispE_throw_simple(K, "the port is already closed");
+ return;
+ }
+
+ kwrite_u8_to_port(K, port, u8);
+ kapply_cc(K, KINERT);
+}
+
+/* Helper for read-u8 and peek-u8 */
+void read_peek_u8(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: ret-u8-after-readp
+ */
+ UNUSED(denv);
+
+ bool ret_u8p = bvalue(xparams[0]);
+
+ TValue port = ptree;
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
+ port = kcdr(K->kd_in_port_key); /* access directly */
+ }
+
+ if (!kport_is_input(port)) {
+ klispE_throw_simple(K, "the port should be an input port");
+ return;
+ } else if (!kport_is_binary(port)) {
+ klispE_throw_simple(K, "the port should be a binary port");
+ return;
+ } else if (kport_is_closed(port)) {
+ klispE_throw_simple(K, "the port is already closed");
+ return;
+ }
+
+ TValue obj = kread_peek_u8_from_port(K, port, ret_u8p);
+ kapply_cc(K, obj);
+}
+
+
+/* 15.1.? read-u8 */
+/* uses read_peek_u8 */
+
+/* 15.1.? peek-u8 */
+/* uses read_peek_u8 */
+
+/* 15.1.? u8-ready? */
+/* XXX: this always return #t, proper behaviour requires platform
+ specific code (probably select for posix & a thread for windows
+ (at least for files & consoles, I think pipes and sockets may
+ have something) */
+void u8_readyp(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ TValue port = ptree;
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
+ port = kcdr(K->kd_in_port_key); /* access directly */
+ }
+
+ if (!kport_is_input(port)) {
+ klispE_throw_simple(K, "the port should be an input port");
+ return;
+ } else if (!kport_is_binary(port)) {
+ klispE_throw_simple(K, "the port should be a binary port");
+ return;
+ } else if (kport_is_closed(port)) {
+ klispE_throw_simple(K, "the port is already closed");
+ return;
+ }
+
+ /* TODO: check if there are pending chars */
+ kapply_cc(K, KTRUE);
+}
/* 15.2.1 call-with-input-file, call-with-output-file */
/* XXX: The report is incomplete here... for now use an empty environment,
the dynamic environment can be captured in the construction of the combiner
ASK John
*/
-void call_with_file(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void call_with_file(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
bool writep = bvalue(xparams[1]);
UNUSED(denv);
bind_2tp(K, ptree, "string", ttisstring, filename,
"combiner", ttiscombiner, comb);
- TValue new_port = kmake_port(K, filename, writep);
+ TValue new_port = kmake_fport(K, filename, writep, false);
krooted_tvs_push(K, new_port);
/* make the continuation to close the file before returning */
TValue new_cont = kmake_continuation(K, kget_cc(K),
@@ -327,40 +618,13 @@ void call_with_file(klisp_State *K, TValue *xparams, TValue ptree,
/* helpers for load */
-/* read all expressions in a file, as immutable pairs */
-/* GC: assume port is rooted */
-TValue read_all_expr(klisp_State *K, TValue port)
-{
- /* GC: root dummy and obj */
- TValue tail = kget_dummy1(K);
- TValue obj = KINERT;
- krooted_vars_push(K, &obj);
-
- while(true) {
- obj = kread_from_port(K, port, false); /* read immutable pairs */
- if (ttiseof(obj)) {
- krooted_vars_pop(K);
- return kcutoff_dummy1(K);
- } else {
- TValue new_pair = kimm_cons(K, obj, KNIL);
-#if KTRACK_SI
- /* put the source info */
- /* XXX: should first read all comments and whitespace,
- then save the source info, then read the object and
- lastly put the saved source info on the new pair...
- For now this will do, but it's not technically correct */
- kset_source_info(K, new_pair, ktry_get_si(K, obj));
-#endif
- kset_cdr_unsafe(K, tail, new_pair);
- tail = new_pair;
- }
- }
-}
-
-/* interceptor for errors during reading, also for the continuat */
-void do_int_close_file(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+/* interceptor for errors during reading */
+void do_int_close_file(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: port
*/
@@ -420,15 +684,19 @@ TValue make_guarded_read_cont(klisp_State *K, TValue parent, TValue port)
applicative.
ASK John: maybe we should return the result of the last expression.
*/
-void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void load(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
bind_1tp(K, ptree, "string", ttisstring, filename);
/* the reads must be guarded to close the file if there is some error
this continuation also will return inert after the evaluation of the
last expression is done */
- TValue port = kmake_port(K, filename, false);
+ TValue port = kmake_fport(K, filename, false, false);
krooted_tvs_push(K, port);
TValue inert_cont = make_return_value_cont(K, kget_cc(K), KINERT);
@@ -439,7 +707,8 @@ void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
current continuation as parent
GC: root this obj */
kset_cc(K, guarded_cont); /* implicit rooting */
- TValue ls = read_all_expr(K, port); /* any error will close the port */
+ /* any error will close the port */
+ TValue ls = kread_list_from_port(K, port, false); /* immutable pairs */
/* now the sequence of expresions should be evaluated in denv
and #inert returned after all are done */
@@ -470,20 +739,26 @@ void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 15.2.3 get-module */
-void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void get_module(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_al1tp(K, ptree, "string", ttisstring, filename,
maybe_env);
- TValue port = kmake_port(K, filename, false);
+ TValue port = kmake_fport(K, filename, false, false);
krooted_tvs_push(K, port);
- TValue env = kmake_environment(K, K->ground_env);
+ /* std environments have hashtable for bindings */
+ TValue env = kmake_table_environment(K, K->ground_env);
+// TValue env = kmake_environment(K, K->ground_env);
krooted_tvs_push(K, env);
- if (get_opt_tpar(K, "", K_TENVIRONMENT, &maybe_env)) {
+ if (get_opt_tpar(K, maybe_env, "environment", ttisenvironment)) {
kadd_binding(K, env, K->module_params_sym, maybe_env);
}
@@ -497,7 +772,9 @@ void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
kset_cc(K, guarded_cont); /* implicit roooting */
- TValue ls = read_all_expr(K, port); /* any error will close the port */
+
+ /* any error will close the port */
+ TValue ls = kread_list_from_port(K, port, false); /* use immutable pairs */
/* now the sequence of expresions should be evaluated in the created env
and the environment returned after all are done */
@@ -527,21 +804,29 @@ void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 15.2.? display */
-void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void display(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_al1tp(K, ptree, "any", anytype, obj,
port);
- if (!get_opt_tpar(K, "display", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
- } else if (!kport_is_output(port)) {
+ }
+
+ if (!kport_is_output(port)) {
klispE_throw_simple(K, "the port should be an output port");
return;
- }
- if (kport_is_closed(port)) {
+ } else if (!kport_is_textual(port)) {
+ klispE_throw_simple(K, "the port should be a textual port");
+ return;
+ } else if (kport_is_closed(port)) {
klispE_throw_simple(K, "the port is already closed");
return;
}
@@ -552,34 +837,42 @@ void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 15.1.? flush-output-port */
-void flush(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void flush(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
TValue port = ptree;
- if (!get_opt_tpar(K, "flush-output-port", K_TPORT, &port)) {
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
port = kcdr(K->kd_out_port_key); /* access directly */
- } else if (!kport_is_output(port)) {
+ }
+
+ if (!kport_is_output(port)) {
klispE_throw_simple(K, "the port should be an output port");
return;
}
+
if (kport_is_closed(port)) {
klispE_throw_simple(K, "the port is already closed");
return;
}
- FILE *file = kport_file(port);
- if (file) { /* only do for file ports */
- UNUSED(fflush(file)); /* TEMP for now don't signal errors on flush */
- }
+ kwrite_flush_port(K, port);
kapply_cc(K, KINERT);
}
/* 15.1.? file-exists? */
-void file_existsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void file_existsp(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -597,8 +890,12 @@ void file_existsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 15.1.? delete-file */
-void delete_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void delete_file(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -618,8 +915,12 @@ void delete_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 15.1.? rename-file */
-void rename_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void rename_file(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -642,17 +943,37 @@ void rename_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* init ground */
void kinit_ports_ground_env(klisp_State *K)
{
+ /*
+ ** Some of these are from r7rs scheme
+ */
+
TValue ground_env = K->ground_env;
TValue symbol, value;
/* 15.1.1 port? */
- add_applicative(K, ground_env, "port?", typep, 2, symbol,
- i2tv(K_TPORT));
+ add_applicative(K, ground_env, "port?", ftypep, 2, symbol,
+ p2tv(kportp));
/* 15.1.2 input-port?, output-port? */
add_applicative(K, ground_env, "input-port?", ftypep, 2, symbol,
- p2tv(kis_input_port));
+ p2tv(kinput_portp));
add_applicative(K, ground_env, "output-port?", ftypep, 2, symbol,
- p2tv(kis_output_port));
+ p2tv(koutput_portp));
+ /* 15.1.? binary-port?, textual-port? */
+ add_applicative(K, ground_env, "binary-port?", ftypep, 2, symbol,
+ p2tv(kbinary_portp));
+ add_applicative(K, ground_env, "textual-port?", ftypep, 2, symbol,
+ p2tv(ktextual_portp));
+ /* 15.1.2 file-port?, string-port?, bytevector-port? */
+ add_applicative(K, ground_env, "file-port?", ftypep, 2, symbol,
+ p2tv(kfile_portp));
+ add_applicative(K, ground_env, "string-port?", ftypep, 2, symbol,
+ p2tv(kstring_portp));
+ add_applicative(K, ground_env, "bytevector-port?", ftypep, 2, symbol,
+ p2tv(kbytevector_portp));
+ /* 15.1.? port-open? */
+ add_applicative(K, ground_env, "port-open?", ftyped_predp, 3, symbol,
+ p2tv(kportp), p2tv(kport_openp));
+
/* 15.1.3 with-input-from-file, with-ouput-to-file */
/* 15.1.? with-error-to-file */
add_applicative(K, ground_env, "with-input-from-file", with_file,
@@ -670,25 +991,51 @@ void kinit_ports_ground_env(klisp_State *K)
add_applicative(K, ground_env, "get-current-error-port", get_current_port,
2, symbol, K->kd_error_port_key);
/* 15.1.5 open-input-file, open-output-file */
- add_applicative(K, ground_env, "open-input-file", open_file, 2, symbol,
- b2tv(false));
- add_applicative(K, ground_env, "open-output-file", open_file, 2, symbol,
- b2tv(true));
+ add_applicative(K, ground_env, "open-input-file", open_file, 2,
+ b2tv(false), b2tv(false));
+ add_applicative(K, ground_env, "open-output-file", open_file, 2,
+ b2tv(true), b2tv(false));
+ /* 15.1.? open-binary-input-file, open-binary-output-file */
+ add_applicative(K, ground_env, "open-binary-input-file", open_file, 2,
+ b2tv(false), b2tv(true));
+ add_applicative(K, ground_env, "open-binary-output-file", open_file, 2,
+ b2tv(true), b2tv(true));
+ /* 15.1.? open-input-string, open-output-string */
+ /* 15.1.? open-input-bytevector, open-output-bytevector */
+ add_applicative(K, ground_env, "open-input-string", open_mport, 2,
+ b2tv(false), b2tv(false));
+ add_applicative(K, ground_env, "open-output-string", open_mport, 2,
+ b2tv(true), b2tv(false));
+ add_applicative(K, ground_env, "open-input-bytevector", open_mport, 2,
+ b2tv(false), b2tv(true));
+ add_applicative(K, ground_env, "open-output-bytevector", open_mport, 2,
+ b2tv(true), b2tv(true));
+
/* 15.1.6 close-input-file, close-output-file */
/* ASK John: should this be called close-input-port & close-ouput-port
like in r5rs? that doesn't seem consistent with open thou */
- add_applicative(K, ground_env, "close-input-file", close_file, 2, symbol,
+ add_applicative(K, ground_env, "close-input-file", close_file, 1,
b2tv(false));
- add_applicative(K, ground_env, "close-output-file", close_file, 2, symbol,
+ add_applicative(K, ground_env, "close-output-file", close_file, 1,
b2tv(true));
+ /* 15.1.? Use the r7rs names, in preparation for other kind of ports */
+ add_applicative(K, ground_env, "close-input-port", close_port, 2,
+ b2tv(true), b2tv(false));
+ add_applicative(K, ground_env, "close-output-port", close_port, 2,
+ b2tv(false), b2tv(true));
+ add_applicative(K, ground_env, "close-port", close_port, 2,
+ b2tv(false), b2tv(false));
+
+ /* 15.1.? get-output-string, get-output-bytevector */
+ add_applicative(K, ground_env, "get-output-string", get_output_buffer, 1,
+ b2tv(false));
+ add_applicative(K, ground_env, "get-output-bytevector", get_output_buffer,
+ 1, b2tv(true));
+
/* 15.1.7 read */
- add_applicative(K, ground_env, "read", read, 0);
+ add_applicative(K, ground_env, "read", gread, 0);
/* 15.1.8 write */
- add_applicative(K, ground_env, "write", write, 0);
-
- /*
- ** These are from scheme (r5rs)
- */
+ add_applicative(K, ground_env, "write", gwrite, 0);
/* 15.1.? eof-object? */
add_applicative(K, ground_env, "eof-object?", typep, 2, symbol,
@@ -698,10 +1045,10 @@ void kinit_ports_ground_env(klisp_State *K)
/* 15.1.? write-char */
add_applicative(K, ground_env, "write-char", write_char, 0);
/* 15.1.? read-char */
- add_applicative(K, ground_env, "read-char", read_peek_char, 2, symbol,
+ add_applicative(K, ground_env, "read-char", read_peek_char, 1,
b2tv(false));
/* 15.1.? peek-char */
- add_applicative(K, ground_env, "peek-char", read_peek_char, 2, symbol,
+ add_applicative(K, ground_env, "peek-char", read_peek_char, 1,
b2tv(true));
/* 15.1.? char-ready? */
/* XXX: this always return #t, proper behaviour requires platform
@@ -709,6 +1056,20 @@ void kinit_ports_ground_env(klisp_State *K)
(at least for files & consoles), I think pipes and sockets may
have something */
add_applicative(K, ground_env, "char-ready?", char_readyp, 0);
+ /* 15.1.? write-u8 */
+ add_applicative(K, ground_env, "write-u8", write_u8, 0);
+ /* 15.1.? read-u8 */
+ add_applicative(K, ground_env, "read-u8", read_peek_u8, 1,
+ b2tv(false));
+ /* 15.1.? peek-u8 */
+ add_applicative(K, ground_env, "peek-u8", read_peek_u8, 1,
+ b2tv(true));
+ /* 15.1.? u8-ready? */
+ /* XXX: this always return #t, proper behaviour requires platform
+ specific code (probably select for posix, a thread for windows
+ (at least for files & consoles), I think pipes and sockets may
+ have something */
+ add_applicative(K, ground_env, "u8-ready?", u8_readyp, 0);
/* 15.2.1 call-with-input-file, call-with-output-file */
add_applicative(K, ground_env, "call-with-input-file", call_with_file,
2, symbol, b2tv(false));
@@ -721,11 +1082,11 @@ void kinit_ports_ground_env(klisp_State *K)
/* 15.2.? display */
add_applicative(K, ground_env, "display", display, 0);
- /* r7rs */
-
/* 15.1.? flush-output-port */
add_applicative(K, ground_env, "flush-output-port", flush, 0);
+ /* REFACTOR move to system module */
+
/* 15.1.? file-exists? */
add_applicative(K, ground_env, "file-exists?", file_existsp, 0);
diff --git a/src/kgports.h b/src/kgports.h
@@ -24,40 +24,56 @@
/* 15.1.2 input-port?, output-port? */
/* use ftypep */
+/* 15.1.? binary-port?, textual-port? */
+/* use ftypep */
+
+/* 15.1.? file-port?, string-port?, bytevector-port? */
+/* use ftypep */
+
+/* 15.1.? port-open? */
+/* uses ftyped_predp */
+
/* 15.1.3 with-input-from-file, with-ouput-to-file */
/* 15.1.? with-error-to-file */
-void with_file(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void with_file(klisp_State *K);
/* 15.1.4 get-current-input-port, get-current-output-port */
/* 15.1.? get-current-error-port */
-void get_current_port(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void get_current_port(klisp_State *K);
/* 15.1.5 open-input-file, open-output-file */
-void open_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void open_file(klisp_State *K);
+
+/* 15.1.? open-input-string, open-output-string */
+/* 15.1.? open-input-bytevector, open-output-bytevector */
+void open_mport(klisp_State *K);
/* 15.1.6 close-input-file, close-output-file */
-void close_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void close_file(klisp_State *K);
+
+/* 15.1.? close-port, close-input-port, close-output-port */
+void close_port(klisp_State *K);
+
+/* 15.1.? get-output-string, get-output-bytevector */
+void get_output_buffer(klisp_State *K);
/* 15.1.7 read */
-void read(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void gread(klisp_State *K);
/* 15.1.8 write */
-void write(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void gwrite(klisp_State *K);
/* 15.1.? eof-object? */
/* uses typep */
/* 15.1.? newline */
-void newline(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void newline(klisp_State *K);
/* 15.1.? write-char */
-void write_char(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void write_char(klisp_State *K);
/* Helper for read-char and peek-char */
-void read_peek_char(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void read_peek_char(klisp_State *K);
/* 15.1.? read-char */
/* uses read_peek_char */
@@ -70,34 +86,33 @@ void read_peek_char(klisp_State *K, TValue *xparams, TValue ptree,
specific code (probably select for posix, a thread for windows
(at least for files & consoles), I think pipes and sockets may
have something */
-void char_readyp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void char_readyp(klisp_State *K);
/* 15.2.1 call-with-input-file, call-with-output-file */
-void call_with_file(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void call_with_file(klisp_State *K);
/* 15.2.2 load */
-void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void load(klisp_State *K);
/* 15.2.3 get-module */
-void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void get_module(klisp_State *K);
/* 15.2.? display */
-void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void display(klisp_State *K);
-void do_close_file_ret(klisp_State *K, TValue *xparams, TValue obj);
+void do_close_file_ret(klisp_State *K);
/* 15.1.? flush-output-port */
-void flush(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void flush(klisp_State *K);
/* 15.1.? file-exists? */
-void file_existsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void file_existsp(klisp_State *K);
/* 15.1.? delete-file */
-void delete_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void delete_file(klisp_State *K);
/* 15.1.? rename-file */
-void rename_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void rename_file(klisp_State *K);
/* init ground */
void kinit_ports_ground_env(klisp_State *K);
diff --git a/src/kgpromises.c b/src/kgpromises.c
@@ -28,8 +28,11 @@
/* uses typep */
/* Helper for force */
-void do_handle_result(klisp_State *K, TValue *xparams, TValue obj)
+void do_handle_result(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: promise
*/
@@ -64,8 +67,12 @@ void do_handle_result(klisp_State *K, TValue *xparams, TValue obj)
}
/* 9.1.2 force */
-void force(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void force(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1p(K, ptree, obj);
@@ -86,8 +93,12 @@ void force(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 9.1.3 $lazy */
-void Slazy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void Slazy(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
bind_1p(K, ptree, exp);
@@ -96,8 +107,12 @@ void Slazy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 9.1.4 memoize */
-void memoize(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void memoize(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
diff --git a/src/kgpromises.h b/src/kgpromises.h
@@ -22,15 +22,15 @@
/* uses typep */
/* 9.1.2 force */
-void force(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void force(klisp_State *K);
/* 9.1.3 $lazy */
-void Slazy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void Slazy(klisp_State *K);
/* 9.1.4 memoize */
-void memoize(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void memoize(klisp_State *K);
-void do_handle_result(klisp_State *K, TValue *xparams, TValue obj);
+void do_handle_result(klisp_State *K);
/* init ground */
void kinit_promises_ground_env(klisp_State *K);
diff --git a/src/kground.c b/src/kground.c
@@ -35,7 +35,8 @@
#include "kgstrings.h"
#include "kgchars.h"
#include "kgports.h"
-#include "kgblobs.h"
+#include "kgbytevectors.h"
+#include "kgvectors.h"
#include "kgsystem.h"
#include "kgerror.h"
@@ -67,11 +68,11 @@ void kinit_cont_names(klisp_State *K)
Table *t = tv2table(K->cont_name_table);
/* REPL, root-continuation & error-continuation */
- add_cont_name(K, t, do_repl_exit, "exit");
+ add_cont_name(K, t, do_root_exit, "exit");
+ add_cont_name(K, t, do_error_exit, "error");
add_cont_name(K, t, do_repl_read, "repl-read");
add_cont_name(K, t, do_repl_eval, "repl-eval");
add_cont_name(K, t, do_repl_loop, "repl-loop");
- add_cont_name(K, t, do_repl_error, "repl-report-error");
/* SCRIPT, root-continuation & error-continuation */
add_cont_name(K, t, do_script_exit, "script-exit");
@@ -142,7 +143,8 @@ void kinit_ground_env(klisp_State *K)
kinit_strings_ground_env(K);
kinit_chars_ground_env(K);
kinit_ports_ground_env(K);
- kinit_blobs_ground_env(K);
+ kinit_bytevectors_ground_env(K);
+ kinit_vectors_ground_env(K);
kinit_system_ground_env(K);
kinit_error_ground_env(K);
#if KUSE_LIBFFI
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -29,16 +29,23 @@
/* 13.1.1? string? */
/* uses typep */
+/* 13.1.? immutable-string?, mutable-string? */
+/* use ftypep */
+
/* 13.1.2? make-string */
-void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void make_string(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s,
maybe_char);
char fill = ' ';
- if (get_opt_tpar(K, "make-string", K_TCHAR, &maybe_char))
+ if (get_opt_tpar(K, maybe_char, "char", ttischar))
fill = chvalue(maybe_char);
if (knegativep(tv_s)) {
@@ -54,9 +61,12 @@ void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 13.1.3? string-length */
-void string_length(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void string_length(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "string", ttisstring, str);
@@ -66,8 +76,12 @@ void string_length(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 13.1.4? string-ref */
-void string_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void string_ref(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "string", ttisstring, str,
@@ -91,8 +105,12 @@ void string_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 13.1.5? string-set! */
-void string_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void string_setS(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_3tp(K, ptree, "string", ttisstring, str,
@@ -145,8 +163,12 @@ inline TValue list_to_string_h(klisp_State *K, char *name, TValue ls)
}
/* 13.2.1? string */
-void string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void string(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -239,9 +261,15 @@ bool kstring_ci_gep(TValue str1, TValue str2)
}
/* 13.2.5? substring */
-/* Note: This will return an mutable string iff the source string is mutable */
-void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+/* TEMP: at least for now this always returns mutable strings (like in Racket and
+ following the Kernel Report where it says that object returned should be mutable
+ unless stated) */
+void substring(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_3tp(K, ptree, "string", ttisstring, str,
@@ -276,10 +304,9 @@ void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* the if isn't strictly necessary but it's clearer this way */
if (size == 0) {
new_str = K->empty_string;
- } else if (kstring_mutablep(str)) {
- new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
} else {
- new_str = kstring_new_bs_imm(K, kstring_buf(str)+start, size);
+ /* always returns mutable strings */
+ new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
}
kapply_cc(K, new_str);
}
@@ -287,9 +314,12 @@ void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* 13.2.6? string-append */
/* TEMP: at least for now this always returns mutable strings */
/* TEMP: this does 3 passes over the list */
-void string_append(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void string_append(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
int32_t dummy;
@@ -336,9 +366,12 @@ void string_append(klisp_State *K, TValue *xparams, TValue ptree,
/* 13.2.7? string->list, list->string */
-void string_to_list(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void string_to_list(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -357,9 +390,12 @@ void string_to_list(klisp_State *K, TValue *xparams, TValue ptree,
kapply_cc(K, kcutoff_dummy1(K));
}
-void list_to_string(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void list_to_string(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
@@ -372,8 +408,12 @@ void list_to_string(klisp_State *K, TValue *xparams, TValue ptree,
/* 13.2.8? string-copy */
/* TEMP: at least for now this always returns mutable strings */
-void string_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void string_copy(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "string", ttisstring, str);
@@ -389,9 +429,12 @@ void string_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* 13.2.9? string->immutable-string */
-void string_to_immutable_string(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+void string_to_immutable_string(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "string", ttisstring, str);
@@ -406,8 +449,12 @@ void string_to_immutable_string(klisp_State *K, TValue *xparams,
}
/* 13.2.10? string-fill! */
-void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void string_fillS(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_2tp(K, ptree, "string", ttisstring, str,
@@ -438,6 +485,11 @@ void kinit_strings_ground_env(klisp_State *K)
/* 13.1.1? string? */
add_applicative(K, ground_env, "string?", typep, 2, symbol,
i2tv(K_TSTRING));
+ /* 13.? immutable-string?, mutable-string? */
+ add_applicative(K, ground_env, "immutable-string?", ftypep, 2, symbol,
+ p2tv(kimmutable_stringp));
+ add_applicative(K, ground_env, "mutable-string?", ftypep, 2, symbol,
+ p2tv(kmutable_stringp));
/* 13.1.2? make-string */
add_applicative(K, ground_env, "make-string", make_string, 0);
/* 13.1.3? string-length */
@@ -484,7 +536,6 @@ void kinit_strings_ground_env(klisp_State *K)
add_applicative(K, ground_env, "string->immutable-string",
string_to_immutable_string, 0);
- /* TODO: add string-immutable? or general immutable? */
/* TODO: add string-upcase and string-downcase like in r7rs-draft */
/* 13.2.10? string-fill! */
diff --git a/src/kgstrings.h b/src/kgstrings.h
@@ -21,21 +21,23 @@
/* 13.1.1? string? */
/* uses typep */
+/* 13.1.? immutable-string?, mutable-string? */
+/* use ftypep */
+
/* 13.1.2? make-string */
-void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void make_string(klisp_State *K);
/* 13.1.3? string-length */
-void string_length(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void string_length(klisp_State *K);
/* 13.1.4? string-ref */
-void string_ref (klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void string_ref (klisp_State *K);
/* 13.1.5? string-set! */
-void string_setS (klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void string_setS (klisp_State *K);
/* 13.2.1? string */
-void string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void string(klisp_State *K);
/* 13.2.2? string=?, string-ci=? */
/* use ftyped_bpredp */
@@ -63,27 +65,23 @@ bool kstring_ci_gep(TValue str1, TValue str2);
/* 13.2.5? substring */
-void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void substring(klisp_State *K);
/* 13.2.6? string-append */
-void string_append(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void string_append(klisp_State *K);
/* 13.2.7? string->list, list->string */
-void list_to_string(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
-void string_to_list(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void list_to_string(klisp_State *K);
+void string_to_list(klisp_State *K);
/* 13.2.8? string-copy */
-void string_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void string_copy(klisp_State *K);
/* 13.2.9? string->immutable-string */
-void string_to_immutable_string(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv);
+void string_to_immutable_string(klisp_State *K);
/* 13.2.10? string-fill! */
-void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void string_fillS(klisp_State *K);
/* Helpers */
bool kstringp(TValue obj);
diff --git a/src/kgsymbols.c b/src/kgsymbols.c
@@ -27,9 +27,12 @@
/* 13.3.1? symbol->string */
/* The strings in symbols are immutable so we can just return that */
-void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void symbol_to_string(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "symbol", ttissymbol, sym);
@@ -48,9 +51,12 @@ void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
again must be equal? which happens here
*/
/* If the string is mutable it is copied */
-void string_to_symbol(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void string_to_symbol(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, ptree, "string", ttisstring, str);
diff --git a/src/kgsymbols.h b/src/kgsymbols.h
@@ -22,8 +22,7 @@
/* uses typep */
/* ?.?.1? symbol->string */
-void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void symbol_to_string(klisp_State *K);
/* ?.?.2? string->symbol */
/* TEMP: for now this can create symbols with no external representation
@@ -35,8 +34,7 @@ void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
because the report only says that read objects when written and read
again must be equal? which happens here
*/
-void string_to_symbol(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void string_to_symbol(klisp_State *K);
/* init ground */
void kinit_symbols_ground_env(klisp_State *K);
diff --git a/src/kgsystem.c b/src/kgsystem.c
@@ -23,9 +23,16 @@
*/
/* ??.?.? current-second */
-void current_second(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void current_second(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ check_0p(K, ptree);
time_t now = time(NULL);
if (now == -1) {
klispE_throw_simple(K, "couldn't get time");
@@ -43,9 +50,16 @@ void current_second(klisp_State *K, TValue *xparams, TValue ptree,
}
/* ??.?.? current-jiffy */
-void current_jiffy(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void current_jiffy(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ check_0p(K, ptree);
/* TODO, this may wrap around... use time+clock to a better number */
/* XXX doesn't seem to work... should probably use gettimeofday
in posix anyways */
@@ -66,9 +80,16 @@ void current_jiffy(klisp_State *K, TValue *xparams, TValue ptree,
}
/* ??.?.? jiffies-per-second */
-void jiffies_per_second(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
+void jiffies_per_second(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ check_0p(K, ptree);
if (CLOCKS_PER_SEC > INT32_MAX) {
/* XXX/TODO create bigint */
klispE_throw_simple(K, "integer too big");
diff --git a/src/kgsystem.h b/src/kgsystem.h
@@ -19,11 +19,9 @@
#include "kghelpers.h"
/* ??.?.? current-second */
-void current_second(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void current_second(klisp_State *K);
/* ??.?.? current-jiffy */
-void current_jiffy(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv);
+void current_jiffy(klisp_State *K);
/* init ground */
void kinit_system_ground_env(klisp_State *K);
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -0,0 +1,245 @@
+/*
+** kgvectors.c
+** Vector (heterogenous array) features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kapplicative.h"
+#include "koperative.h"
+#include "kcontinuation.h"
+#include "kerror.h"
+#include "kvector.h"
+#include "kpair.h"
+
+#include "kghelpers.h"
+#include "kgvectors.h"
+#include "kgnumbers.h" /* for keintegerp & knegativep */
+
+/* (R7RS 3rd draft 6.3.6) vector? */
+/* uses typep */
+
+/* ?.?.? immutable-vector?, mutable-vector? */
+/* use ftypep */
+
+/* (R7RS 3rd draft 6.3.6) make-vector */
+void make_vector(klisp_State *K)
+{
+ klisp_assert(ttisenvironment(K->next_env));
+ TValue ptree = K->next_value;
+
+ bind_al1tp(K, ptree, "exact integer", keintegerp, tv_s, fill);
+ if (!get_opt_tpar(K, fill, "any", anytype))
+ fill = KINERT;
+
+ if (knegativep(tv_s)) {
+ klispE_throw_simple(K, "negative vector length");
+ return;
+ } else if (!ttisfixint(tv_s)) {
+ klispE_throw_simple(K, "vector length is too big");
+ return;
+ }
+ TValue new_vector = (ivalue(tv_s) == 0)
+ ? K->empty_vector
+ : kvector_new_sf(K, ivalue(tv_s), fill);
+ kapply_cc(K, new_vector);
+}
+
+/* (R7RS 3rd draft 6.3.6) vector-length */
+void vector_length(klisp_State *K)
+{
+ klisp_assert(ttisenvironment(K->next_env));
+ TValue ptree = K->next_value;
+
+ bind_1tp(K, ptree, "vector", ttisvector, vector);
+
+ TValue res = i2tv(kvector_length(vector));
+ kapply_cc(K, res);
+}
+
+/* (R7RS 3rd draft 6.3.6) vector-ref */
+void vector_ref(klisp_State *K)
+{
+ klisp_assert(ttisenvironment(K->next_env));
+
+ TValue ptree = K->next_value;
+ bind_2tp(K, ptree, "vector", ttisvector, vector,
+ "exact integer", keintegerp, tv_i);
+
+ if (!ttisfixint(tv_i)) {
+ klispE_throw_simple_with_irritants(K, "vector index out of bounds",
+ 1, tv_i);
+ return;
+ }
+ int32_t i = ivalue(tv_i);
+ if (i < 0 || i >= kvector_length(vector)) {
+ klispE_throw_simple_with_irritants(K, "vector index out of bounds",
+ 1, tv_i);
+ return;
+ }
+ kapply_cc(K, kvector_array(vector)[i]);
+}
+
+/* (R7RS 3rd draft 6.3.6) vector-set! */
+void vector_setS(klisp_State *K)
+{
+ klisp_assert(ttisenvironment(K->next_env));
+
+ TValue ptree = K->next_value;
+ bind_3tp(K, ptree, "vector", ttisvector, vector,
+ "exact integer", keintegerp, tv_i, "any", anytype, tv_new_value);
+
+ if (!ttisfixint(tv_i)) {
+ klispE_throw_simple_with_irritants(K, "vector index out of bounds",
+ 1, tv_i);
+ return;
+ } else if (kvector_immutablep(vector)) {
+ klispE_throw_simple(K, "immutable vector");
+ return;
+ }
+
+ int32_t i = ivalue(tv_i);
+ if (i < 0 || i >= kvector_length(vector)) {
+ klispE_throw_simple_with_irritants(K, "vector index out of bounds",
+ 1, tv_i);
+ return;
+ }
+
+ kvector_array(vector)[i] = tv_new_value;
+ kapply_cc(K, KINERT);
+}
+
+/* (R7RS 3rd draft 6.3.6) vector-copy */
+/* TEMP: at least for now this always returns mutable vectors */
+void vector_copy(klisp_State *K)
+{
+ klisp_assert(ttisenvironment(K->next_env));
+ TValue ptree = K->next_value;
+
+ bind_1tp(K, ptree, "vector", ttisvector, v);
+
+ TValue new_vector = kvector_emptyp(v)?
+ v
+ : kvector_new_bs_g(K, true, kvector_array(v), kvector_length(v));
+ kapply_cc(K, new_vector);
+}
+
+static TValue list_to_vector_h(klisp_State *K, const char *name, TValue ls)
+{
+ int32_t dummy;
+ int32_t pairs = check_list(K, name, false, ls, &dummy);
+
+ if (pairs == 0) {
+ return K->empty_vector;
+ } else {
+ TValue res = kvector_new_sf(K, pairs, KINERT);
+ for (int i = 0; i < pairs; i++) {
+ kvector_array(res)[i] = kcar(ls);
+ ls = kcdr(ls);
+ }
+ return res;
+ }
+}
+
+/* (R7RS 3rd draft 6.3.6) vector */
+void vector(klisp_State *K)
+{
+ klisp_assert(ttisenvironment(K->next_env));
+
+ TValue ptree = K->next_value;
+ kapply_cc(K, list_to_vector_h(K, "vector", ptree));
+}
+
+/* (R7RS 3rd draft 6.3.6) list->vector */
+void list_to_vector(klisp_State *K)
+{
+ klisp_assert(ttisenvironment(K->next_env));
+
+ TValue ptree = K->next_value;
+ bind_1p(K, ptree, ls);
+ kapply_cc(K, list_to_vector_h(K, "list->vector", ls));
+}
+
+/* (R7RS 3rd draft 6.3.6) vector->list */
+void vector_to_list(klisp_State *K)
+{
+ klisp_assert(ttisenvironment(K->next_env));
+
+ TValue ptree = K->next_value;
+ bind_1tp(K, ptree, "vector", ttisvector, v);
+
+ TValue tail = KNIL;
+ krooted_vars_push(K, &tail);
+ size_t i = kvector_length(v);
+ while (i-- > 0)
+ tail = kcons(K, kvector_array(v)[i], tail);
+ krooted_vars_pop(K);
+ kapply_cc(K, tail);
+}
+
+/* ??.?.? vector->immutable-vector */
+void vector_to_immutable_vector(klisp_State *K)
+{
+ klisp_assert(ttisenvironment(K->next_env));
+
+ TValue ptree = K->next_value;
+ bind_1tp(K, ptree, "vector", ttisvector, v);
+
+ TValue res = kvector_immutablep(v)?
+ v
+ : kvector_new_bs_g(K, false, kvector_array(v), kvector_length(v));
+ kapply_cc(K, res);
+}
+
+/* init ground */
+void kinit_vectors_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /*
+ ** This section is not in the report. The bindings here are
+ ** taken from the r7rs scheme draft and should not be considered standard.
+ ** They are provided in the meantime to allow programs to use vectors.
+ */
+
+ /* (R7RS 3rd draft 6.3.6) vector? */
+ add_applicative(K, ground_env, "vector?", typep, 2, symbol,
+ i2tv(K_TVECTOR));
+ /* ??.? immutable-vector?, mutable-vector? */
+ add_applicative(K, ground_env, "immutable-vector?", ftypep, 2, symbol,
+ p2tv(kimmutable_vectorp));
+ add_applicative(K, ground_env, "mutable-vector?", ftypep, 2, symbol,
+ p2tv(kmutable_vectorp));
+ /* (R7RS 3rd draft 6.3.6) make-vector */
+ add_applicative(K, ground_env, "make-vector", make_vector, 0);
+ /* (R7RS 3rd draft 6.3.6) vector-length */
+ add_applicative(K, ground_env, "vector-length", vector_length, 0);
+
+ /* (R7RS 3rd draft 6.3.6) vector-ref vector-set! */
+ add_applicative(K, ground_env, "vector-ref", vector_ref, 0);
+ add_applicative(K, ground_env, "vector-set!", vector_setS, 0);
+
+ /* (R7RS 3rd draft 6.3.6) vector, vector->list, list->vector */
+ add_applicative(K, ground_env, "vector", vector, 0);
+ add_applicative(K, ground_env, "vector->list", vector_to_list, 0);
+ add_applicative(K, ground_env, "list->vector", list_to_vector, 0);
+
+ /* ??.1.?? vector-copy */
+ add_applicative(K, ground_env, "vector-copy", vector_copy, 0);
+
+ /* TODO: vector->string, string->vector, vector-fill */
+ /* TODO: vector-copy! vector-copy-partial vector-copy-partial! */
+
+ /* ??.1.?? vector->immutable-vector */
+ add_applicative(K, ground_env, "vector->immutable-vector",
+ vector_to_immutable_vector, 0);
+}
diff --git a/src/kgvectors.h b/src/kgvectors.h
@@ -0,0 +1,15 @@
+/*
+** kgvectors.h
+** Vector (heterogenous array) features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgvectors_h
+#define kgvectors_h
+
+#include "kstate.h"
+
+/* init ground */
+void kinit_vectors_ground_env(klisp_State *K);
+
+#endif
diff --git a/src/klimits.h b/src/klimits.h
@@ -67,4 +67,14 @@
/* at last count, there were about 200 bindings in ground env */
#define ENVTABSIZE 512
+/* starting size for string port buffers */
+#ifndef MINSTRINGPORTBUFFER
+#define MINSTRINGPORTBUFFER 256
+#endif
+
+/* starting size for bytevector port buffers */
+#ifndef MINBYTEVECTORPORTBUFFER
+#define MINBYTEVECTORPORTBUFFER 256
+#endif
+
#endif
diff --git a/src/klisp.c b/src/klisp.c
@@ -4,7 +4,13 @@
** See Copyright Notice in klisp.h
*/
+/*
+** TODO This needs a serious clean up, I hacked it together during
+** an all nighter...
+*/
+
#include <stdio.h>
+#include <string.h>
#include <stdlib.h>
#include <assert.h>
@@ -15,22 +21,568 @@
#include "klisp.h"
#include "kstate.h"
#include "kauxlib.h"
+
+#include "kstring.h"
+#include "kcontinuation.h"
+#include "koperative.h"
+#include "kenvironment.h"
+#include "kport.h"
+#include "kread.h"
+#include "kwrite.h"
+#include "kerror.h"
+#include "kgcontinuations.h" /* for do_pass_value */
+#include "kgcontrol.h" /* for do_seq */
#include "kscript.h"
+#include "krepl.h"
-int main(int argc, char *argv[])
+/* TODO update dependencies in makefile */
+
+static const char *progname = KLISP_PROGNAME;
+
+static void print_usage (void)
+{
+ fprintf(stderr,
+ "usage: %s [options] [script [args]].\n"
+ "Available options are:\n"
+ " -e exp eval string " KLISP_QL("exp") "\n"
+// " -l name require library " KLISP_QL("name") "\n"
+ " -i enter interactive mode after executing "
+ KLISP_QL("script") "\n"
+ " -v show version information\n"
+ " -- stop handling options\n"
+ " - execute stdin and stop handling options\n"
+ ,
+ progname);
+ fflush(stderr);
+}
+
+static void k_message (const char *pname, const char *msg)
+{
+ if (pname)
+ fprintf(stderr, "%s: ", pname);
+ fprintf(stderr, "%s\n", msg);
+ fflush(stderr);
+}
+
+/* TODO move this to a common place to use it from elsewhere
+(like the repl) */
+static void show_error(klisp_State *K, TValue obj) {
+ /* FOR NOW used only for irritant list */
+ TValue port = kcdr(K->kd_error_port_key);
+ klisp_assert(ttisfport(port) && kfport_file(port) == stderr);
+
+ /* TEMP: obj should be an error obj */
+ if (ttiserror(obj)) {
+ Error *err_obj = tv2error(obj);
+ TValue who = err_obj->who;
+ char *who_str;
+ /* TEMP? */
+ if (ttiscontinuation(who))
+ who = tv2cont(who)->comb;
+
+ if (ttisstring(who)) {
+ who_str = kstring_buf(who);
+#if KTRACK_NAMES
+ } else if (khas_name(who)) {
+ TValue name = kget_name(K, who);
+ who_str = ksymbol_buf(name);
+#endif
+ } else {
+ who_str = "?";
+ }
+ char *msg = kstring_buf(err_obj->msg);
+ fprintf(stderr, "\n*ERROR*: \n");
+ fprintf(stderr, "%s: %s", who_str, msg);
+
+ krooted_tvs_push(K, obj);
+
+ /* Msg + irritants */
+ /* TODO move to a new function */
+ if (!ttisnil(err_obj->irritants)) {
+ fprintf(stderr, ": ");
+ kwrite_display_to_port(K, port, err_obj->irritants, false);
+ }
+ kwrite_newline_to_port(K, port);
+
+#if KTRACK_NAMES
+#if KTRACK_SI
+ /* Location */
+ /* TODO move to a new function */
+ /* MAYBE: remove */
+ if (khas_name(who) || khas_si(who)) {
+ fprintf(stderr, "Location: ");
+ kwrite_display_to_port(K, port, who, false);
+ kwrite_newline_to_port(K, port);
+ }
+
+ /* Backtrace */
+ /* TODO move to a new function */
+ TValue tv_cont = err_obj->cont;
+ fprintf(stderr, "Backtrace: \n");
+ while(ttiscontinuation(tv_cont)) {
+ kwrite_display_to_port(K, port, tv_cont, false);
+ kwrite_newline_to_port(K, port);
+ Continuation *cont = tv2cont(tv_cont);
+ tv_cont = cont->parent;
+ }
+ /* add extra newline at the end */
+ kwrite_newline_to_port(K, port);
+#endif
+#endif
+ krooted_tvs_pop(K);
+ } else {
+ fprintf(stderr, "\n*ERROR*: not an error object passed to "
+ "error continuation");
+ }
+ fflush(stderr);
+}
+
+static int report (klisp_State *K, int status)
+{
+ if (status != 0) {
+ const char *msg = "Error!";
+ k_message(progname, msg);
+ show_error(K, K->next_value);
+ }
+ return status;
+}
+
+static void print_version(void)
+{
+ k_message(NULL, KLISP_RELEASE " " KLISP_COPYRIGHT);
+}
+
+/* REFACTOR maybe these should be moved to a general place to be used
+ from any program */
+void do_str_eval(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]: dynamic environment
+ */
+ TValue denv = xparams[0];
+ ktail_eval(K, obj, denv);
+}
+
+void do_str_read(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]: port
+ */
+ TValue port = xparams[0];
+ UNUSED(obj);
+ /* read just one value (as mutable data) */
+ TValue obj1 = kread_from_port(K, port, true);
+
+ /* obj may be eof, that's not a problem, it just won't do anything */
+
+ krooted_tvs_push(K, obj1);
+ TValue obj2 = kread_from_port(K, port, true);
+ krooted_tvs_pop(K);
+
+ if (!ttiseof(obj2)) {
+ klispE_throw_simple_with_irritants(K, "More than one expression read",
+ 1, port);
+ return;
+ }
+
+ /* all ok, just one exp read (or none and obj1 is eof) */
+ kapply_cc(K, obj1);
+}
+
+void do_int_mark_error(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: errorp pointer
+ */
+ UNUSED(denv);
+ bool *errorp = (bool *) pvalue(xparams[0]);
+ *errorp = true;
+ /* ptree is (object divert) */
+ TValue error_obj = kcar(ptree);
+ /* pass the error along after setting the flag */
+ kapply_cc(K, error_obj);
+}
+
+static int dostring (klisp_State *K, const char *s, const char *name)
+{
+ bool errorp = false; /* may be set to true in error handler */
+
+ UNUSED(name); /* could use as filename?? */
+ /* create a string input port */
+ TValue str = kstring_new_b(K, s);
+ krooted_tvs_push(K, str);
+ TValue port = kmake_mport(K, str, false, false);
+ krooted_tvs_pop(K);
+ krooted_tvs_push(K, port);
+
+ /* create the guard set error flag after errors */
+ TValue exit_int = kmake_operative(K, do_int_mark_error,
+ 1, p2tv(&errorp));
+ krooted_tvs_push(K, exit_int);
+ TValue exit_guard = kcons(K, K->error_cont, exit_int);
+ krooted_tvs_pop(K); /* already in guard */
+ krooted_tvs_push(K, exit_guard);
+ TValue exit_guards = kcons(K, exit_guard, KNIL);
+ krooted_tvs_pop(K); /* already in guards */
+ krooted_tvs_push(K, exit_guards);
+
+ TValue entry_guards = KNIL;
+
+ /* this is needed for interception code */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ TValue outer_cont = kmake_continuation(K, K->root_cont,
+ do_pass_value, 2, entry_guards, env);
+ kset_outer_cont(outer_cont);
+ krooted_tvs_push(K, outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont,
+ do_pass_value, 2, exit_guards, env);
+ kset_inner_cont(inner_cont);
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
+
+ /* only port remains in the root stack */
+ krooted_tvs_push(K, inner_cont);
+
+ /* XXX This should probably be an extra param to the function */
+ env = K->next_env; /* this is the standard env that should be used for
+ evaluation */
+ TValue eval_cont = kmake_continuation(K, inner_cont, do_str_eval,
+ 1, env);
+ krooted_tvs_pop(K); /* pop inner cont */
+ krooted_tvs_push(K, eval_cont);
+ TValue read_cont = kmake_continuation(K, eval_cont, do_str_read,
+ 1, port);
+ krooted_tvs_pop(K); /* pop eval cont */
+ krooted_tvs_pop(K); /* pop port */
+ kset_cc(K, read_cont); /* this will protect all conts from gc */
+ klispS_apply_cc(K, KINERT);
+
+ klispS_run(K);
+
+ int status = errorp? 1 : 0;
+
+ /* get the standard environment again in K->next_env */
+ K->next_env = env;
+ return report(K, status);
+}
+
+void do_file_eval(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]: dynamic environment
+ */
+ TValue denv = xparams[0];
+ TValue ls = obj;
+ if (!ttisnil(ls)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, ls, denv);
+ kset_cc(K, new_cont);
+ }
+ kapply_cc(K, KINERT);
+}
+
+void do_file_read(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ UNUSED(obj);
+ TValue port = xparams[0];
+ /* read all file as a list (as immutable data) */
+ TValue ls = kread_list_from_port(K, port, false);
+
+ /* all ok, just one exp read (or none and obj1 is eof) */
+ kapply_cc(K, ls);
+}
+
+/* name = NULL means use stdin */
+static int dofile(klisp_State *K, const char *name)
{
- if (argc <= 1) {
- klisp_State *K = klispL_newstate();
- klispS_init_repl(K);
- klispS_run(K);
- klisp_close(K);
- return 0;
+ bool errorp = false; /* may be set to true in error handler */
+
+ /* create a file input port (unless it's stdin, then just use) */
+ TValue port;
+
+ /* XXX better do this in a continuation */
+ if (name == NULL) {
+ port = kcdr(K->kd_in_port_key);
} else {
- klisp_State *K = klispL_newstate();
- kinit_script(K, argc - 1, argv + 1);
- klispS_run(K);
- int exit_code = K->script_exit_code;
- klisp_close(K);
- return exit_code;
+ FILE *file = fopen(name, "r");
+ if (file == NULL) {
+ TValue mode_str = kstring_new_b(K, "r");
+ krooted_tvs_push(K, mode_str);
+ TValue name_str = kstring_new_b(K, name);
+ krooted_tvs_push(K, mode_str);
+ TValue error_obj = klispE_new_simple_with_errno_irritants
+ (K, "fopen", 2, name_str, mode_str);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ K->next_value = error_obj;
+ return report(K, 1);
+ }
+
+ TValue name_str = kstring_new_b(K, name);
+ krooted_tvs_push(K, name_str);
+ port = kmake_std_fport(K, name_str, false, false, file);
+ krooted_tvs_pop(K);
+ }
+
+ krooted_tvs_push(K, port);
+ /* TODO this is exactly the same as in string, factor the code out */
+ /* create the guard set error flag after errors */
+ TValue exit_int = kmake_operative(K, do_int_mark_error,
+ 1, p2tv(&errorp));
+ krooted_tvs_push(K, exit_int);
+ TValue exit_guard = kcons(K, K->error_cont, exit_int);
+ krooted_tvs_pop(K); /* already in guard */
+ krooted_tvs_push(K, exit_guard);
+ TValue exit_guards = kcons(K, exit_guard, KNIL);
+ krooted_tvs_pop(K); /* already in guards */
+ krooted_tvs_push(K, exit_guards);
+
+ TValue entry_guards = KNIL;
+
+ /* this is needed for interception code */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ TValue outer_cont = kmake_continuation(K, K->root_cont,
+ do_pass_value, 2, entry_guards, env);
+ kset_outer_cont(outer_cont);
+ krooted_tvs_push(K, outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont,
+ do_pass_value, 2, exit_guards, env);
+ kset_inner_cont(inner_cont);
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
+
+ /* only port remains in the root stack */
+ krooted_tvs_push(K, inner_cont);
+
+ /* XXX This should probably be an extra param to the function */
+ env = K->next_env; /* this is the standard env that should be used for
+ evaluation */
+ TValue eval_cont = kmake_continuation(K, inner_cont, do_file_eval,
+ 1, env);
+ krooted_tvs_pop(K); /* pop inner cont */
+ krooted_tvs_push(K, eval_cont);
+ TValue read_cont = kmake_continuation(K, eval_cont, do_file_read,
+ 1, port);
+ krooted_tvs_pop(K); /* pop eval cont */
+ krooted_tvs_pop(K); /* pop port */
+ kset_cc(K, read_cont); /* this will protect all conts from gc */
+ klispS_apply_cc(K, KINERT);
+
+ klispS_run(K);
+
+ int status = errorp? 1 : 0;
+
+ /* get the standard environment again in K->next_env */
+ K->next_env = env;
+ return report(K, status);
+}
+
+static void dotty(klisp_State *K)
+{
+ TValue env = K->next_env;
+ kinit_repl(K);
+ klispS_run(K);
+ /* get the standard environment again in K->next_env */
+ K->next_env = env;
+}
+
+static int handle_script(klisp_State *K, char **argv, int n)
+{
+ const char *fname;
+ /* XXX/TODO save arguments to script */
+// int narg = getargs(L, argv, n); /* collect arguments */
+// lua_setglobal(L, "arg");
+ fname = argv[n];
+ if (strcmp(fname, "-") == 0 && strcmp(argv[n-1], "--") != 0)
+ fname = NULL; /* stdin */
+
+ return dofile(K, fname);
+}
+
+/* check that argument has no extra characters at the end */
+#define notail(x) {if ((x)[2] != '\0') return -1;}
+
+static int collectargs (char **argv, bool *pi, bool *pv, bool *pe)
+{
+ int i;
+ for (i = 1; argv[i] != NULL; i++) {
+ if (argv[i][0] != '-') /* not an option? */
+ return i;
+ switch (argv[i][1]) { /* option */
+ case '-':
+ notail(argv[i]);
+ return (argv[i+1] != NULL ? i+1 : 0);
+ case '\0':
+ return i;
+ case 'i':
+ notail(argv[i]);
+ *pi = true; /* go through */
+ case 'v':
+ notail(argv[i]);
+ *pv = true;
+ break;
+ case 'e':
+ *pe = true; /* go through */
+// case 'l': /* No library for now */
+ if (argv[i][2] == '\0') {
+ i++;
+ if (argv[i] == NULL)
+ return -1;
+ }
+ break;
+ default:
+ return -1; /* invalid option */
+ }
+ }
+ return 0;
+}
+
+static int runargs (klisp_State *K, char **argv, int n)
+{
+ /* There is a standard env in K->next_env, a common one is used for all
+ evaluations (init, expression args, script/repl) */
+ TValue env = K->next_env;
+ UNUSED(env);
+
+ for (int i = 1; i < n; i++) {
+ if (argv[i] == NULL)
+ continue;
+
+ klisp_assert(argv[i][0] == '-');
+
+ switch (argv[i][1]) { /* option */
+ case 'e': {
+ const char *chunk = argv[i] + 2;
+ if (*chunk == '\0')
+ chunk = argv[++i];
+ klisp_assert(chunk != NULL);
+
+ if (dostring(K, chunk, "=(command line)") != 0)
+ return 1;
+ break;
+ }
+// case 'l': /* no libraries for now */
+ default:
+ break;
+ }
+ }
+ return 0;
+}
+
+static int handle_klispinit(klisp_State *K)
+{
+ const char *init = getenv(KLISP_INIT);
+ if (init == NULL)
+ return 0; /* status OK */
+ else
+ return dostring(K, init, "=" KLISP_INIT);
+}
+
+/* This is weird but was done to follow lua scheme */
+struct Smain {
+ int argc;
+ char **argv;
+ int status;
+};
+
+static int pmain(klisp_State *K)
+{
+ /* This is weird but was done to follow lua scheme */
+ struct Smain *s = (struct Smain *) pvalue(K->next_value);
+ char **argv = s->argv;
+ s->status = 0;
+
+ /* There is a standard env in K->next_env, a common one is used for all
+ evaluations (init, expression args, script/repl) */
+ //TValue env = K->next_env;
+
+ if (argv[0] && argv[0][0])
+ progname = argv[0];
+
+ /* TODO Here we should load libraries, however we don't have any
+ non native bindings in the ground environment yet */
+
+ /* RATIONALE I wanted to write all bindings in c, so that I can later on
+ profile them against non native versions and see how they fare.
+ Also by writing all in c it's easy to be consistent, especially with
+ error messages */
+
+ /* init (eval KLISP_INIT env variable contents) */
+ s->status = handle_klispinit(K);
+ if (s->status != 0)
+ return 0;
+
+ bool has_i = false, has_v = false, has_e = false;
+ int script = collectargs(argv, &has_i, &has_v, &has_e);
+
+ if (script < 0) { /* invalid args? */
+ print_usage();
+ s->status = 1;
+ return 0;
}
+
+ if (has_v)
+ print_version();
+
+ s->status = runargs(K, argv, (script > 0) ? script : s->argc);
+
+ if (s->status != 0)
+ return 0;
+
+ if (script > 0) {
+ s->status = handle_script(K, argv, script);
+ }
+
+ if (s->status != 0)
+ return 0;
+
+ if (has_i) {
+ dotty(K);
+ } else if (script == 0 && !has_e && !has_v) {
+ if (true) {
+ print_version();
+ dotty(K);
+ } else {
+ s->status = dofile(K, NULL);
+ }
+ }
+
+ return 0;
+}
+
+int main(int argc, char *argv[])
+{
+ int status;
+ struct Smain s;
+ klisp_State *K = klispL_newstate();
+
+ if (K == NULL) {
+ k_message(argv[0], "cannot create state: not enough memory");
+ return EXIT_FAILURE;
+ }
+
+ /* This is weird but was done to follow lua scheme */
+ s.argc = argc;
+ s.argv = argv;
+ K->next_value = p2tv(&s);
+ status = pmain(K);
+
+ klisp_close(K);
+
+ return (status || s.status)? EXIT_FAILURE : EXIT_SUCCESS;
}
diff --git a/src/klisp.h b/src/klisp.h
@@ -16,6 +16,12 @@
** SOURCE NOTE: This is mostly from Lua.
*/
+#define KLISP_VERSION "klisp 0.2"
+#define KLISP_RELEASE "klisp 0.2"
+#define KLISP_VERSION_NUM 02
+#define KLISP_COPYRIGHT "Copyright (C) 2011 Andres Navarro, Oto Havle"
+#define KLISP_AUTHORS "Andres Navarro, Oto Havle"
+
typedef struct klisp_State klisp_State;
/*
diff --git a/src/klispconf.h b/src/klispconf.h
@@ -13,6 +13,101 @@
#include <stdint.h>
#include <stdbool.h>
+/*
+** ==================================================================
+** Search for "@@" to find all configurable definitions.
+** ===================================================================
+*/
+
+/*
+@@ KLISP_ANSI controls the use of non-ansi features.
+** CHANGE it (define it) if you want Klisp to avoid the use of any
+** non-ansi feature or library.
+*/
+#if defined(__STRICT_ANSI__)
+#define KLISP_ANSI
+#endif
+
+
+#if !defined(KLISP_ANSI) && defined(_WIN32)
+#define KLISP_WIN
+#endif
+
+#if defined(KLISP_USE_LINUX)
+#define KLISP_USE_POSIX
+#define KLISP_USE_DLOPEN /* needs an extra library: -ldl */
+#define KLISP_USE_READLINE /* needs some extra libraries */
+#endif
+
+#if defined(KLISP_USE_MACOSX)
+#define KLISP_USE_POSIX
+#define KLISP_DL_DYLD /* does not need extra library */
+#endif
+
+/*
+@@ KLISP_PROGNAME is the default name for the stand-alone klisp program.
+** CHANGE it if your stand-alone interpreter has a different name and
+** your system is not able to detect that name automatically.
+*/
+#define KLISP_PROGNAME "klisp"
+
+/*
+@@ KLISP_QL describes how error messages quote program elements.
+** CHANGE it if you want a different appearance.
+*/
+#define KLISP_QL(x) "'" x "'"
+#define KLISP_QS KLISP_QL("%s")
+/* /TODO */
+
+/*
+@@ KLISP_USE_POSIX includes all functionallity listed as X/Open System
+@* Interfaces Extension (XSI).
+** CHANGE it (define it) if your system is XSI compatible.
+*/
+#if defined(KLISP_USE_POSIX)
+#define KLISP_USE_MKSTEMP
+#define KLISP_USE_ISATTY
+#define KLISP_USE_POPEN
+#define KLISP_USE_ULONGJMP
+#endif
+
+/*
+@@ LUA_PATH and LUA_CPATH are the names of the environment variables that
+@* Lua check to set its paths.
+@@ KLISP_INIT is the name of the environment variable that klisp
+@* checks for initialization code.
+** CHANGE them if you want different names.
+*/
+//#define LUA_PATH "LUA_PATH"
+//#define LUA_CPATH "LUA_CPATH"
+#define KLISP_INIT "KLISP_INIT"
+
+/*
+@@ klisp_stdin_is_tty detects whether the standard input is a 'tty' (that
+@* is, whether we're running klisp interactively).
+** CHANGE it if you have a better definition for non-POSIX/non-Windows
+** systems.
+*/
+#if defined(KLISP_USE_ISATTY)
+#include <unistd.h>
+#define klisp_stdin_is_tty() isatty(0)
+#elif defined(KLISP_WIN)
+#include <io.h>
+#include <stdio.h>
+#define klisp_stdin_is_tty() _isatty(_fileno(stdin))
+#else
+#define klisp_stdin_is_tty() 1 /* assume stdin is a tty */
+#endif
+
+/*
+@@ KLISP_PROMPT is the default prompt used by stand-alone Klisp.
+@@ KLISP_PROMPT2 is not currently used.
+** CHANGE them if you want different prompts.
+*/
+#define KLISP_PROMPT "klisp> "
+/* XXX not used for now */
+#define KLISP_PROMPT2 ">> "
+
/* temp defines till gc is stabilized */
#define KUSE_GC 1
/* Print msgs when starting and ending gc */
diff --git a/src/kobject.c b/src/kobject.c
@@ -30,6 +30,7 @@ const TValue kfree = KFREE_;
/*
** The name strings for all TValue types
+** This should be updated if types are modified in kobject.h
*/
char *ktv_names[] = {
[K_TFIXINT] = "fixint",
@@ -39,11 +40,12 @@ char *ktv_names[] = {
[K_TEINF] = "einf",
[K_TDOUBLE] = "double",
[K_TBDOUBLE] = "bdouble",
+ [K_TIINF] = "einf",
[K_TIINF] = "iinf",
[K_TRWNPV] = "rwnpv",
- [K_TUNDEFINED] = "undefined",
[K_TCOMPLEX] = "complex",
+ [K_TUNDEFINED] = "undefined",
[K_TNIL] = "nil",
[K_TIGNORE] = "ignore",
@@ -51,7 +53,7 @@ char *ktv_names[] = {
[K_TEOF] = "eof",
[K_TBOOLEAN] = "boolean",
[K_TCHAR] = "char",
- [K_TCHAR] = "free entry",
+ [K_TFREE] = "free entry",
[K_TDEADKEY] = "dead key",
[K_TUSER] = "user pointer",
@@ -65,19 +67,13 @@ char *ktv_names[] = {
[K_TAPPLICATIVE] = "applicative",
[K_TENCAPSULATION] = "encapsulation",
[K_TPROMISE] = "promise",
- [K_TPORT] = "port"
+ [K_TTABLE] = "table",
+ [K_TERROR] = "error",
+ [K_TBYTEVECTOR] = "bytevector",
+ [K_TFPORT] = "file port",
+ [K_TMPORT] = "mem port"
};
-bool kis_input_port(TValue o)
-{
- return ttisport(o) && kport_is_input(o);
-}
-
-bool kis_output_port(TValue o)
-{
- return ttisport(o) && kport_is_output(o);
-}
-
int32_t klispO_log2 (uint32_t x) {
static const uint8_t log_2[256] = {
0,1,2,2,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
diff --git a/src/kobject.h b/src/kobject.h
@@ -46,7 +46,7 @@ typedef union GCObject GCObject;
** included in other objects)
*/
#define CommonHeader GCObject *next; uint8_t tt; uint8_t kflags; \
- uint16_t gct; GCObject *si; GCObject *gclist;
+ uint16_t gct; GCObject *si; GCObject *gclist
/* NOTE: the gc flags are called marked in lua, but we reserve that them
for marks used in cycle traversal. The field kflags is also missing
@@ -127,6 +127,10 @@ typedef struct __attribute__ ((__packed__)) GCheader {
*/
/* LUA NOTE: In Lua the corresponding defines are in lua.h */
+/*
+** The name strings for all TValue types are in kobject.c
+** Thoseshould be updated if types here are modified
+*/
#define K_TFIXINT 0
#define K_TBIGINT 1
#define K_TFIXRAT 2
@@ -158,10 +162,12 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAPPLICATIVE 36
#define K_TENCAPSULATION 37
#define K_TPROMISE 38
-#define K_TPORT 39
-#define K_TTABLE 40
-#define K_TERROR 41
-#define K_TBLOB 42
+#define K_TTABLE 39
+#define K_TERROR 40
+#define K_TBYTEVECTOR 41
+#define K_TFPORT 42
+#define K_TMPORT 43
+#define K_TVECTOR 44
/* for tables */
#define K_TDEADKEY 60
@@ -211,11 +217,12 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAG_APPLICATIVE K_MAKE_VTAG(K_TAPPLICATIVE)
#define K_TAG_ENCAPSULATION K_MAKE_VTAG(K_TENCAPSULATION)
#define K_TAG_PROMISE K_MAKE_VTAG(K_TPROMISE)
-#define K_TAG_PORT K_MAKE_VTAG(K_TPORT)
#define K_TAG_TABLE K_MAKE_VTAG(K_TTABLE)
#define K_TAG_ERROR K_MAKE_VTAG(K_TERROR)
-#define K_TAG_BLOB K_MAKE_VTAG(K_TBLOB)
-
+#define K_TAG_BYTEVECTOR K_MAKE_VTAG(K_TBYTEVECTOR)
+#define K_TAG_FPORT K_MAKE_VTAG(K_TFPORT)
+#define K_TAG_MPORT K_MAKE_VTAG(K_TMPORT)
+#define K_TAG_VECTOR K_MAKE_VTAG(K_TVECTOR)
/*
** Macros to test types
@@ -237,6 +244,9 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttisbigint(o) (tbasetype_(o) == K_TAG_BIGINT)
#define ttiseinteger(o_) ({ int32_t t_ = tbasetype_(o_); \
t_ == K_TAG_FIXINT || t_ == K_TAG_BIGINT;})
+#define ttisu8(o) ({ \
+ TValue o__ = (o); \
+ (ttisfixint(o__) && ivalue(o__) >= 0 && ivalue(o__) < 256); })
#define ttisinteger(o) ({ TValue o__ = (o); \
(ttiseinteger(o__) || \
(ttisdouble(o__) && (floor(dvalue(o__)) == dvalue(o__))));})
@@ -293,10 +303,14 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttiscontinuation(o) (tbasetype_(o) == K_TAG_CONTINUATION)
#define ttisencapsulation(o) (tbasetype_(o) == K_TAG_ENCAPSULATION)
#define ttispromise(o) (tbasetype_(o) == K_TAG_PROMISE)
-#define ttisport(o) (tbasetype_(o) == K_TAG_PORT)
#define ttistable(o) (tbasetype_(o) == K_TAG_TABLE)
#define ttiserror(o) (tbasetype_(o) == K_TAG_ERROR)
-#define ttisblob(o) (tbasetype_(o) == K_TAG_BLOB)
+#define ttisbytevector(o) (tbasetype_(o) == K_TAG_BYTEVECTOR)
+#define ttisfport(o) (tbasetype_(o) == K_TAG_FPORT)
+#define ttismport(o) (tbasetype_(o) == K_TAG_MPORT)
+#define ttisport(o_) ({ int32_t t_ = tbasetype_(o_); \
+ t_ == K_TAG_FPORT || t_ == K_TAG_MPORT;})
+#define ttisvector(o) (tbasetype_(o) == K_TAG_VECTOR)
/* macros to easily check boolean values */
#define kis_true(o_) (tv_equal((o_), KTRUE))
@@ -430,17 +444,30 @@ typedef struct __attribute__ ((__packed__)) {
sharing the pair */
} Promise;
+/* common fields for all types of ports */
+/* TEMP: for now source code info is in fixints */
+#define PortCommonFields TValue filename; int32_t row; int32_t col
+
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader;
+ PortCommonFields;
+} Port;
+
/* input/output direction and open/close status are in kflags */
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
- TValue filename;
- /* TEMP: for now source code info is in fixints */
- int32_t row;
- int32_t col;
+ PortCommonFields;
FILE *file;
-} Port;
+} FPort;
/* input/output direction and open/close status are in kflags */
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader;
+ PortCommonFields;
+ TValue buf;
+ uint32_t off;
+} MPort;
+
/*
** Hashtables
@@ -481,14 +508,22 @@ typedef struct __attribute__ ((__packed__)) {
TValue irritants; /* list of extra objs */
} Error;
-/* Blobs (binary vectors) */
+/* Bytevectors */
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
TValue mark; /* for cycle/sharing aware algorithms */
uint32_t size;
- int32_t __dummy; /* for alignment to 64 bits */
+ uint32_t hash; /* only used for immutable strings */
uint8_t b[]; /* buffer */
-} Blob;
+} Bytevector;
+
+/* Vectors (heterogenous arrays) */
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader;
+ TValue mark; /* for cycle/sharing aware algorithms */
+ uint32_t sizearray; /* number of elements in array[] */
+ TValue array[]; /* array of elements */
+} Vector;
/*
** `module' operation for hashing (size is always a power of 2)
@@ -546,9 +581,12 @@ union GCObject {
Applicative app;
Encapsulation enc;
Promise prom;
- Port port;
Table table;
- Blob blob;
+ Bytevector bytevector;
+ Port port; /* common fields for all types of ports */
+ FPort fport;
+ MPort mport;
+ Vector vector;
};
@@ -647,10 +685,12 @@ const TValue kfree;
#define gc2app(o_) (gc2tv(K_TAG_APPLICATIVE, o_))
#define gc2enc(o_) (gc2tv(K_TAG_ENCAPSULATION, o_))
#define gc2prom(o_) (gc2tv(K_TAG_PROMISE, o_))
-#define gc2port(o_) (gc2tv(K_TAG_PORT, o_))
+#define gc2fport(o_) (gc2tv(K_TAG_FPORT, o_))
+#define gc2mport(o_) (gc2tv(K_TAG_MPORT, o_))
#define gc2table(o_) (gc2tv(K_TAG_TABLE, o_))
#define gc2error(o_) (gc2tv(K_TAG_ERROR, o_))
-#define gc2blob(o_) (gc2tv(K_TAG_BLOB, o_))
+#define gc2bytevector(o_) (gc2tv(K_TAG_BYTEVECTOR, o_))
+#define gc2vector(o_) (gc2tv(K_TAG_VECTOR, o_))
#define gc2deadkey(o_) (gc2tv(K_TAG_DEADKEY, o_))
/* Macro to convert a TValue into a specific heap allocated object */
@@ -665,10 +705,13 @@ const TValue kfree;
#define tv2app(v_) ((Applicative *) gcvalue(v_))
#define tv2enc(v_) ((Encapsulation *) gcvalue(v_))
#define tv2prom(v_) ((Promise *) gcvalue(v_))
-#define tv2port(v_) ((Port *) gcvalue(v_))
#define tv2table(v_) ((Table *) gcvalue(v_))
#define tv2error(v_) ((Error *) gcvalue(v_))
-#define tv2blob(v_) ((Blob *) gcvalue(v_))
+#define tv2bytevector(v_) ((Bytevector *) gcvalue(v_))
+#define tv2vector(v_) ((Vector *) gcvalue(v_))
+#define tv2fport(v_) ((FPort *) gcvalue(v_))
+#define tv2mport(v_) ((MPort *) gcvalue(v_))
+#define tv2port(v_) ((Port *) gcvalue(v_))
#define tv2gch(v_) ((GCheader *) gcvalue(v_))
#define tv2mgch(v_) ((MGCheader *) gcvalue(v_))
@@ -789,14 +832,20 @@ int32_t kmark_count;
#define K_FLAG_OUTPUT_PORT 0x01
#define K_FLAG_INPUT_PORT 0x02
#define K_FLAG_CLOSED_PORT 0x04
+/* At least for now ports are either binary or textual */
+#define K_FLAG_BINARY_PORT 0x08
#define kport_set_input(o_) (tv_get_kflags(o_) |= K_FLAG_INPUT_PORT)
#define kport_set_output(o_) (tv_get_kflags(o_) |= K_FLAG_INPUT_PORT)
#define kport_set_closed(o_) (tv_get_kflags(o_) |= K_FLAG_CLOSED_PORT)
+#define kport_set_binary(o_) (tv_get_kflags(o_) |= K_FLAG_BINARY_PORT)
#define kport_is_input(o_) ((tv_get_kflags(o_) & K_FLAG_INPUT_PORT) != 0)
#define kport_is_output(o_) ((tv_get_kflags(o_) & K_FLAG_OUTPUT_PORT) != 0)
+#define kport_is_open(o_) ((tv_get_kflags(o_) & K_FLAG_CLOSED_PORT) == 0)
#define kport_is_closed(o_) ((tv_get_kflags(o_) & K_FLAG_CLOSED_PORT) != 0)
+#define kport_is_binary(o_) ((tv_get_kflags(o_) & K_FLAG_BINARY_PORT) != 0)
+#define kport_is_textual(o_) ((tv_get_kflags(o_) & K_FLAG_BINARY_PORT) == 0)
#define K_FLAG_WEAK_KEYS 0x01
#define K_FLAG_WEAK_VALUES 0x02
@@ -807,11 +856,6 @@ int32_t kmark_count;
#define ktable_has_weak_values(o_) \
((tv_get_kflags(o_) & K_FLAG_WEAK_VALUES) != 0)
-/* can't be inline because we also use pointers to them,
- (at least gcc doesn't bother to create them and the linker fails) */
-bool kis_input_port(TValue o);
-bool kis_output_port(TValue o);
-
/* Macro to test the most basic equality on TValues */
#define tv_equal(tv1_, tv2_) ((tv1_).raw == (tv2_).raw)
diff --git a/src/koperative.c b/src/koperative.c
@@ -13,7 +13,7 @@
#include "kgc.h"
/* GC: Assumes all argps are rooted */
-TValue kmake_operative(klisp_State *K, klisp_Ofunc fn, int32_t xcount, ...)
+TValue kmake_operative(klisp_State *K, klisp_CFunction fn, int32_t xcount, ...)
{
va_list argp;
diff --git a/src/koperative.h b/src/koperative.h
@@ -13,6 +13,7 @@
/* TODO: make some specialized constructors for 0, 1 and 2 parameters */
/* GC: Assumes all argps are rooted */
-TValue kmake_operative(klisp_State *K, klisp_Ofunc fn, int xcount, ...);
+TValue kmake_operative(klisp_State *K, klisp_CFunction fn, int32_t xcount,
+ ...);
#endif
diff --git a/src/kpair.c b/src/kpair.c
@@ -58,3 +58,11 @@ TValue klist_g(klisp_State *K, bool m, int32_t n, ...)
bool kpairp(TValue obj) { return ttispair(obj); }
+bool kimmutable_pairp(TValue obj)
+{
+ return ttispair(obj) && kis_immutable(obj);
+}
+bool kmutable_pairp(TValue obj)
+{
+ return ttispair(obj) && kis_mutable(obj);
+}
diff --git a/src/kpair.h b/src/kpair.h
@@ -14,11 +14,8 @@
/* can't be inlined... */
bool kpairp(TValue obj);
-
-inline bool kmutable_pairp(TValue obj)
-{
- return ttispair(obj) && kis_mutable(obj);
-}
+bool kimmutable_pairp(TValue obj);
+bool kmutable_pairp(TValue obj);
inline TValue kcar(TValue p)
{
diff --git a/src/kport.c b/src/kport.c
@@ -6,6 +6,7 @@
#include <stdio.h>
#include <assert.h>
+#include <string.h>
#include "kport.h"
#include "kobject.h"
@@ -13,9 +14,62 @@
#include "kmem.h"
#include "kerror.h"
#include "kstring.h"
+#include "kbytevector.h"
#include "kgc.h"
#include "kpair.h"
+bool kportp(TValue o)
+{
+ return ttisport(o);
+}
+
+bool kinput_portp(TValue o)
+{
+ return ttisport(o) && kport_is_input(o);
+}
+
+bool koutput_portp(TValue o)
+{
+ return ttisport(o) && kport_is_output(o);
+}
+
+bool kbinary_portp(TValue o)
+{
+ return ttisport(o) && kport_is_binary(o);
+}
+
+bool ktextual_portp(TValue o)
+{
+ return ttisport(o) && kport_is_textual(o);
+}
+
+bool kfile_portp(TValue o)
+{
+ return ttisfport(o);
+}
+
+bool kstring_portp(TValue o)
+{
+ return ttismport(o) && kport_is_textual(o);
+}
+
+bool kbytevector_portp(TValue o)
+{
+ return ttismport(o) && kport_is_binary(o);
+}
+
+bool kport_openp(TValue o)
+{
+ klisp_assert(ttisport(o));
+ return kport_is_open(o);
+}
+
+bool kport_closedp(TValue o)
+{
+ klisp_assert(ttisport(o));
+ return kport_is_closed(o);
+}
+
/* XXX: per the c spec, this truncates the file if it exists! */
/* Ask John: what would be best? Probably should also include delete,
file-exists? and a mechanism to truncate or append to a file, or
@@ -23,16 +77,23 @@
Should use open, but it is non standard (fcntl.h, POSIX only) */
/* GC: Assumes filename is rooted */
-TValue kmake_port(klisp_State *K, TValue filename, bool writep)
+TValue kmake_fport(klisp_State *K, TValue filename, bool writep, bool binaryp)
{
/* for now always use text mode */
- FILE *f = fopen(kstring_buf(filename), writep? "w": "r");
+ char *mode;
+ if (binaryp)
+ mode = writep? "wb": "rb";
+ else
+ mode = writep? "w": "r";
+
+ FILE *f = fopen(kstring_buf(filename), mode);
if (f == NULL) {
- klispE_throw_errno_with_irritants(K, "fopen", 2, filename,
- kstring_new_b_imm(K, writep? "w": "r"));
+ TValue mode_str = kstring_new_b(K, mode);
+ krooted_tvs_push(K, mode_str);
+ klispE_throw_errno_with_irritants(K, "fopen", 2, filename, mode_str);
return KINERT;
} else {
- return kmake_std_port(K, filename, writep, f);
+ return kmake_std_fport(K, filename, writep, binaryp, f);
}
}
@@ -40,20 +101,21 @@ TValue kmake_port(klisp_State *K, TValue filename, bool writep)
also a helper for the above */
/* GC: Assumes filename, name & si are rooted */
-TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
- FILE *file)
+TValue kmake_std_fport(klisp_State *K, TValue filename, bool writep,
+ bool binaryp, FILE *file)
{
- Port *new_port = klispM_new(K, Port);
+ FPort *new_port = klispM_new(K, FPort);
/* header + gc_fields */
- klispC_link(K, (GCObject *) new_port, K_TPORT,
+ klispC_link(K, (GCObject *) new_port, K_TFPORT,
K_FLAG_CAN_HAVE_NAME |
- (writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT));
+ (writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT) |
+ (binaryp? K_FLAG_BINARY_PORT : 0));
/* port specific fields */
new_port->filename = filename;
new_port->file = file;
- TValue tv_port = gc2port(new_port);
+ TValue tv_port = gc2fport(new_port);
/* line is 1-based and col is 0-based */
kport_line(tv_port) = 1;
kport_col(tv_port) = 0;
@@ -61,16 +123,51 @@ TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
return tv_port;
}
+TValue kmake_mport(klisp_State *K, TValue buffer, bool writep, bool binaryp)
+{
+ klisp_assert(!writep || ttisinert(buffer));
+ klisp_assert(writep || (ttisbytevector(buffer) && binaryp) ||
+ (ttisstring(buffer) && !binaryp));
+
+ if (writep) {
+ buffer = binaryp? kbytevector_new_s(K, MINBYTEVECTORPORTBUFFER) :
+ kstring_new_s(K, MINSTRINGPORTBUFFER);
+ }
+
+ krooted_tvs_push(K, buffer);
+
+ MPort *new_port = klispM_new(K, MPort);
+
+ /* header + gc_fields */
+ klispC_link(K, (GCObject *) new_port, K_TMPORT,
+ K_FLAG_CAN_HAVE_NAME |
+ (writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT) |
+ (binaryp? K_FLAG_BINARY_PORT : 0));
+
+ /* port specific fields */
+ TValue tv_port = gc2mport(new_port);
+ kport_filename(tv_port) = K->empty_string; /* XXX for now no filename */
+ /* line is 1-based and col is 0-based */
+ kport_line(tv_port) = 1;
+ kport_col(tv_port) = 0;
+ kmport_buf(tv_port) = buffer;
+ kmport_off(tv_port) = 0; /* no bytes read/written */
+ krooted_tvs_pop(K);
+ return tv_port;
+}
+
/* if the port is already closed do nothing */
+/* This is also called from GC, so it shouldn't throw any error */
void kclose_port(klisp_State *K, TValue port)
{
assert(ttisport(port));
if (!kport_is_closed(port)) {
- FILE *f = tv2port(port)->file;
- if (f != stdin && f != stderr && f != stdout)
- fclose(f); /* it isn't necessary to check the close ret val */
-
+ if (ttisfport(port)) {
+ FILE *f = tv2fport(port)->file;
+ if (f != stdin && f != stderr && f != stdout)
+ fclose(f); /* it isn't necessary to check the close ret val */
+ }
kport_set_closed(port);
}
@@ -89,3 +186,45 @@ void kport_update_source_info(TValue port, int32_t line, int32_t col)
kport_line(port) = line;
kport_col(port) = col;
}
+
+/* Always grow by doubling the size (until min_size is reached) */
+/* GC: port should be rooted */
+void kmport_resize_buffer(klisp_State *K, TValue port, size_t min_size)
+{
+ klisp_assert(ttismport(port));
+ klisp_assert(kport_is_output(port));
+
+ uint32_t old_size = (kport_is_binary(port))?
+ kbytevector_size(kmport_buf(port)) :
+ kstring_size(kmport_buf(port));
+ uint64_t new_size = old_size;
+
+ while (new_size < min_size) {
+ new_size *= 2;
+ if (new_size > SIZE_MAX)
+ klispM_toobig(K);
+ }
+
+ if (new_size == old_size)
+ return;
+
+ if (kport_is_binary(port)) {
+ TValue new_bb = kbytevector_new_s(K, new_size);
+ uint32_t off = kmport_off(port);
+ if (off != 0) {
+ memcpy(kbytevector_buf(new_bb),
+ kbytevector_buf(kmport_buf(port)),
+ off);
+ }
+ kmport_buf(port) = new_bb;
+ } else {
+ TValue new_str = kstring_new_s(K, new_size);
+ uint32_t off = kmport_off(port);
+ if (off != 0) {
+ memcpy(kstring_buf(new_str),
+ kstring_buf(kmport_buf(port)),
+ off);
+ }
+ kmport_buf(port) = new_str;
+ }
+}
diff --git a/src/kport.h b/src/kport.h
@@ -12,27 +12,49 @@
#include "kobject.h"
#include "kstate.h"
+/* can't be inline because we also use pointers to them,
+ (at least gcc doesn't bother to create them and the linker fails) */
+bool kportp(TValue o);
+bool kinput_portp(TValue o);
+bool koutput_portp(TValue o);
+bool kbinary_portp(TValue o);
+bool ktextual_portp(TValue o);
+bool kfile_portp(TValue o);
+bool kstring_portp(TValue o);
+bool kbytevector_portp(TValue o);
+bool kport_openp(TValue o);
+bool kport_closedp(TValue o);
+
/* GC: Assumes filename is rooted */
-TValue kmake_port(klisp_State *K, TValue filename, bool writep);
+TValue kmake_fport(klisp_State *K, TValue filename, bool writep, bool binaryp);
/* this is for creating ports for stdin/stdout/stderr &
helper for the one above */
/* GC: Assumes filename, name & si are rooted */
-TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
- FILE *file);
+TValue kmake_std_fport(klisp_State *K, TValue filename, bool writep,
+ bool binaryp, FILE *file);
+
+/* GC: buffer doesn't need to be rooted, but should probably do it anyways */
+TValue kmake_mport(klisp_State *K, TValue buffer, bool writep, bool binaryp);
-/* This closes the underlying FILE * (unless it is a std port) and also
- set the closed flag to true, this shouldn't throw errors because it
- is also called when deallocating all objs. If errors need to be thrown
+/* This closes the underlying FILE * (unless it is a std port or memory port)
+ and also set the closed flag to true, this shouldn't throw errors because
+ it is also called when deallocating all objs. If errors need to be thrown
fork this function instead of simply modifying */
void kclose_port(klisp_State *K, TValue port);
-#define kport_file(p_) (tv2port(p_)->file)
#define kport_filename(p_) (tv2port(p_)->filename)
#define kport_line(p_) (tv2port(p_)->row)
#define kport_col(p_) (tv2port(p_)->col)
+#define kfport_file(p_) (tv2fport(p_)->file)
+
+#define kmport_off(p_) (tv2mport(p_)->off)
+#define kmport_buf(p_) (tv2mport(p_)->buf)
+
void kport_reset_source_info(TValue port);
void kport_update_source_info(TValue port, int32_t line, int32_t col);
+/* GC: port should be rooted */
+void kmport_resize_buffer(klisp_State *K, TValue port, uint32_t min_size);
#endif
diff --git a/src/kread.c b/src/kread.c
@@ -6,7 +6,6 @@
#include <stdio.h>
#include <stdlib.h>
-#include <assert.h>
#include "kread.h"
#include "kobject.h"
@@ -36,12 +35,18 @@
** info as above (but no pair with last pair).
** ST_SHARED_DEF: a pair with car: shared def token and cdr: source
** info of the shared def token.
-**
+** ST_SEXP_COMMENT: the source info of the comment token
+** ST_FIRST_EOF_LIST: first pair of the list (with source info, start of file)
+** ST_MIDDLE_EOF_LIST: two elements, first below, second on top:
+** - a pair with car: first pair of the list (with source info corrected
+** to car of list) and cdr: source info of the start of file.
+** - last pair of the list so far.
*/
typedef enum {
ST_READ, ST_SHARED_DEF, ST_LAST_ILIST, ST_PAST_LAST_ILIST,
- ST_FIRST_LIST, ST_MIDDLE_LIST
+ ST_FIRST_LIST, ST_MIDDLE_LIST, ST_SEXP_COMMENT, ST_FIRST_EOF_LIST,
+ ST_MIDDLE_EOF_LIST
} state_t;
#define push_state(kst_, st_) (ks_spush(kst_, (i2tv((int32_t)(st_)))))
@@ -56,7 +61,12 @@ typedef enum {
/*
** Error management
*/
-void kread_error(klisp_State *K, char *str)
+#define kread_error(K, str) \
+ kread_error_g(K, str, false, KINERT)
+#define kread_error_extra(K, str, extra) \
+ kread_error_g(K, str, true, extra)
+
+void kread_error_g(klisp_State *K, char *str, bool extra, TValue extra_value)
{
/* all cleaning is done in throw
(stacks, shared_dict, rooted objs) */
@@ -65,10 +75,18 @@ void kread_error(klisp_State *K, char *str)
kport_update_source_info(K->curr_port, K->ktok_source_info.line,
K->ktok_source_info.col);
- /* include the source info in the error */
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si); /* will be popped by throw */
- klispE_throw_with_irritants(K, str, si);
+ /* include the source info (and extra value if present) in the error */
+ TValue irritants;
+ if (extra) {
+ krooted_tvs_push(K, extra_value); /* will be popped by throw */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si); /* will be popped by throw */
+ irritants = klist_g(K, false, 2, si, extra_value);
+ } else {
+ irritants = ktok_get_source_info(K);
+ }
+ krooted_tvs_push(K, irritants); /* will be popped by throw */
+ klispE_throw_with_irritants(K, str, irritants);
}
/*
@@ -89,7 +107,7 @@ TValue try_shared_ref(klisp_State *K, TValue ref_token)
tail = kcdr(tail);
}
- kread_error(K, "undefined shared ref found");
+ kread_error_extra(K, "undefined shared ref found", i2tv(ref_num));
/* avoid warning */
return KINERT;
}
@@ -103,7 +121,7 @@ void try_shared_def(klisp_State *K, TValue def_token, TValue value)
while (!ttisnil(tail)) {
TValue head = kcar(tail);
if (ref_num == ivalue(kcar(head))) {
- kread_error(K, "duplicate shared def found");
+ kread_error_extra(K, "duplicate shared def found", i2tv(ref_num));
/* avoid warning */
return;
}
@@ -132,29 +150,92 @@ void change_shared_def(klisp_State *K, TValue def_token, TValue value)
}
tail = kcdr(tail);
}
- /* NOTE: can't really happen */
+ klisp_assert(0); /* shouldn't happen */
+ return;
+}
+
+/* NOTE: the shared def is guaranteed to exist */
+void remove_shared_def(klisp_State *K, TValue def_token)
+{
+ /* IMPLEMENTATION RESTRICTION: only allow fixints in shared tokens */
+ int32_t ref_num = ivalue(kcdr(def_token));
+ TValue tail = K->shared_dict;
+ TValue last_pair = KNIL;
+ while (!ttisnil(tail)) {
+ TValue head = kcar(tail);
+ if (ref_num == ivalue(kcar(head))) {
+ if (ttisnil(last_pair)) {
+ /* this is the first value */
+ K->shared_dict = kcdr(tail);
+ } else {
+ kset_cdr(last_pair, kcdr(tail));
+ }
+ return;
+ }
+ last_pair = tail;
+ tail = kcdr(tail);
+ }
+ klisp_assert(0); /* shouldn't happen */
return;
}
/*
** Reader FSM
*/
+
+/*
+** listp:
+** false: read one value
+** true: read all values as a list
+*/
+
/* TEMP: For now we'll use just one big function */
-TValue kread_fsm(klisp_State *K)
+TValue kread_fsm(klisp_State *K, bool listp)
{
- assert(ks_sisempty(K));
- assert(ttisnil(K->shared_dict));
+ /* TODO add more specific sexp comment error msgs */
+ /* TODO replace some read errors with asserts where appropriate */
+ klisp_assert(ks_sisempty(K));
+ klisp_assert(ttisnil(K->shared_dict));
+
push_state(K, ST_READ);
+ if (listp) { /* read a list of values */
+ /* create the first pair */
+ TValue np = kcons_g(K, K->read_mconsp, KINERT, KNIL);
+ krooted_tvs_push(K, np);
+ /*
+ ** NOTE: the source info of the start of file is temporarily
+ ** saved in np (later it will be replace by the source info
+ ** of the car of the list)
+ */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si);
+#if KTRACK_SI
+ kset_source_info(K, np, si);
+#endif
+ krooted_tvs_pop(K);
+ push_data(K, np);
+ krooted_tvs_pop(K);
+ push_state(K, ST_FIRST_EOF_LIST);
+ }
+
/* read next token or process obj */
bool read_next_token = true;
/* the obj just read/completed */
TValue obj = KINERT; /* put some value for gc */
/* the source code information of that obj */
TValue obj_si = KNIL; /* put some value for gc */
+ int32_t sexp_comments = 0;
+ TValue last_sexp_comment_si = KNIL; /* put some value for gc */
+ /* list of shared list, each element represent a nested sexp comment,
+ each is a list of shared defs in that particular level, to be
+ undefined after the sexp comment ends */
+ TValue sexp_comment_shared = KNIL;
krooted_vars_push(K, &obj);
krooted_vars_push(K, &obj_si);
+ krooted_vars_push(K, &last_sexp_comment_si);
+ krooted_vars_push(K, &sexp_comment_shared);
while (!(get_state(K) == ST_READ && !read_next_token)) {
if (read_next_token) {
@@ -218,6 +299,7 @@ TValue kread_fsm(klisp_State *K)
obj_si = kget_source_info(K, fp_with_old_si);
#else
UNUSED(fp_with_old_si);
+ obj_si = KNIL;
#endif
read_next_token = false;
break;
@@ -246,7 +328,14 @@ TValue kread_fsm(klisp_State *K)
"in shared def");
/* avoid warning */
return KINERT;
+ case ST_SEXP_COMMENT:
+ kread_error_extra(K, "unmatched closing paren found in "
+ "sexp comment", last_sexp_comment_si);
+ /* avoid warning */
+ return KINERT;
case ST_READ:
+ case ST_FIRST_EOF_LIST:
+ case ST_MIDDLE_EOF_LIST:
kread_error(K, "unmatched closing paren found");
/* avoid warning */
return KINERT;
@@ -280,7 +369,14 @@ TValue kread_fsm(klisp_State *K)
kread_error(K, "dot found in shared def");
/* avoid warning */
return KINERT;
+ case ST_SEXP_COMMENT:
+ kread_error_extra(K, "dot found outside list in sexp "
+ "comment", last_sexp_comment_si);
+ /* avoid warning */
+ return KINERT;
case ST_READ:
+ case ST_FIRST_EOF_LIST:
+ case ST_MIDDLE_EOF_LIST:
kread_error(K, "dot found outside list");
/* avoid warning */
return KINERT;
@@ -307,7 +403,13 @@ TValue kread_fsm(klisp_State *K)
default: {
krooted_tvs_push(K, tok);
try_shared_def(K, tok, KNIL);
- /* token ok, read defined object */
+ /* token ok */
+ /* save the token for later undefining */
+ if (sexp_comments > 0) {
+ kset_car(sexp_comment_shared,
+ kcons(K, tok, kcar(sexp_comment_shared)));
+ }
+ /* read defined object */
/* NOTE: save the source info to return it
after the defined object is read */
TValue si = ktok_get_source_info(K);
@@ -344,6 +446,17 @@ TValue kread_fsm(klisp_State *K)
}
break;
}
+ case ';': { /* sexp comment */
+ klisp_assert(sexp_comments < 1000);
+ ++sexp_comments;
+ sexp_comment_shared =
+ kcons(K, KNIL, sexp_comment_shared);
+ push_data(K, last_sexp_comment_si);
+ push_state(K, ST_SEXP_COMMENT);
+ last_sexp_comment_si = ktok_get_source_info(K);
+ read_next_token = true;
+ break;
+ }
default:
/* shouldn't happen */
kread_error(K, "unknown special token");
@@ -352,10 +465,42 @@ TValue kread_fsm(klisp_State *K)
}
} else if (ttiseof(tok)) {
switch (get_state(K)) {
+ case ST_SEXP_COMMENT:
+ kread_error_extra(K, "EOF found while reading sexp "
+ " comment", last_sexp_comment_si);
+ /* avoid warning */
+ return KINERT;
+ case ST_FIRST_EOF_LIST: {
+ pop_state(K);
+ TValue fp_with_old_si = get_data(K);
+ pop_data(K);
+ obj = KNIL;
+ #if KTRACK_SI
+ obj_si = kget_source_info(K, fp_with_old_si);
+ #else
+ UNUSED(fp_with_old_si);
+ obj_si = KNIL;
+ #endif
+ read_next_token = false;
+ break;
+ }
+ case ST_MIDDLE_EOF_LIST: {
+ pop_state(K);
+ /* discard info on last pair */
+ pop_data(K);
+ pop_state(K);
+ TValue fp_old_si = get_data(K);
+ pop_data(K);
+ /* list read ok, process it in next iteration */
+ obj = kcar(fp_old_si);
+ obj_si = kcdr(fp_old_si);
+ read_next_token = false;
+ break;
+ }
case ST_READ:
- /* will exit in next loop */
obj = tok;
obj_si = ktok_get_source_info(K);
+ /* will exit in next loop */
read_next_token = false;
break;
case ST_FIRST_LIST:
@@ -395,7 +540,9 @@ TValue kread_fsm(klisp_State *K)
} else { /* if(read_next_token) */
/* process the object just read */
switch(get_state(K)) {
+ case ST_FIRST_EOF_LIST:
case ST_FIRST_LIST: {
+ state_t state = get_state(K);
/* get the state out of the way */
pop_state(K);
TValue fp = get_data(K);
@@ -421,13 +568,22 @@ TValue kread_fsm(klisp_State *K)
push_data(K, kcons (K, fp, fp_old_si));
krooted_tvs_pop(K);
krooted_tvs_pop(K);
- push_state(K, ST_FIRST_LIST);
+ push_state(K, state);
push_data(K, fp);
- push_state(K, ST_MIDDLE_LIST);
+ if (state == ST_FIRST_LIST) {
+ push_state(K, ST_MIDDLE_LIST);
+ } else {
+ push_state(K, ST_MIDDLE_EOF_LIST);
+ /* shared dict must be cleared after every element
+ of an eof list */
+ clear_shared_dict(K);
+ }
read_next_token = true;
break;
}
- case ST_MIDDLE_LIST: {
+ case ST_MIDDLE_LIST:
+ case ST_MIDDLE_EOF_LIST: {
+ state_t state = get_state(K);
/* get the state out of the way */
pop_state(K);
/* construct the list with the correct type of pair */
@@ -441,7 +597,12 @@ TValue kread_fsm(klisp_State *K)
/* replace last pair of the (still incomplete) read next obj */
pop_data(K);
push_data(K, np);
- push_state(K, ST_MIDDLE_LIST);
+ push_state(K, state);
+ if (state == ST_MIDDLE_EOF_LIST) {
+ /* shared dict must be cleared after every element
+ of an eof list */
+ clear_shared_dict(K);
+ }
krooted_tvs_pop(K);
read_next_token = true;
break;
@@ -473,6 +634,22 @@ TValue kread_fsm(klisp_State *K)
kread_error(K, "invalid read state (read in while)");
/* avoid warning */
return KINERT;
+ case ST_SEXP_COMMENT:
+ klisp_assert(sexp_comments > 0);
+ --sexp_comments;
+ /* undefine all shared obj defined in the context
+ of this sexp comment */
+ while(!ttisnil(kcar(sexp_comment_shared))) {
+ TValue first = kcaar(sexp_comment_shared);
+ remove_shared_def(K, first);
+ kset_car(sexp_comment_shared, kcdar(sexp_comment_shared));
+ }
+ sexp_comment_shared = kcdr(sexp_comment_shared);
+ pop_state(K);
+ last_sexp_comment_si = get_data(K);
+ pop_data(K);
+ read_next_token = true;
+ break;
default:
/* shouldn't happen */
kread_error(K, "unknown read state in process obj");
@@ -484,24 +661,26 @@ TValue kread_fsm(klisp_State *K)
krooted_vars_pop(K);
krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
pop_state(K);
- assert(ks_sisempty(K));
+ klisp_assert(ks_sisempty(K));
return obj;
}
/*
** Reader Main Function
*/
-TValue kread(klisp_State *K)
+TValue kread(klisp_State *K, bool listp)
{
TValue obj;
- assert(ttisnil(K->shared_dict));
- /* TEMP: workaround repl problem with eofs */
+ klisp_assert(ttisnil(K->shared_dict));
+ /* WORKAROUND: for repl problem with eofs */
K->ktok_seen_eof = false;
- obj = kread_fsm(K);
+ obj = kread_fsm(K, listp);
/* NOTE: clear after function to allow earlier gc */
clear_shared_dict(K);
@@ -509,23 +688,32 @@ TValue kread(klisp_State *K)
return obj;
}
-
-TValue kread_from_port(klisp_State *K, TValue port, bool mut)
+/* port is protected from GC in curr_port */
+TValue kread_from_port_g(klisp_State *K, TValue port, bool mut, bool listp)
{
K->curr_port = port;
- K->curr_in = kport_file(port);
K->read_mconsp = mut;
ktok_set_source_info(K, kport_filename(port),
kport_line(port), kport_col(port));
- TValue obj = kread(K);
+ TValue obj = kread(K, listp);
kport_update_source_info(port, K->ktok_source_info.line,
K->ktok_source_info.col);
return obj;
}
+TValue kread_from_port(klisp_State *K, TValue port, bool mut)
+{
+ return kread_from_port_g(K, port, mut, false);
+}
+
+TValue kread_list_from_port(klisp_State *K, TValue port, bool mut)
+{
+ return kread_from_port_g(K, port, mut, true);
+}
+
TValue kread_peek_char_from_port(klisp_State *K, TValue port, bool peek)
{
/* Reset the EOF flag in the tokenizer. The flag is shared,
@@ -533,7 +721,6 @@ TValue kread_peek_char_from_port(klisp_State *K, TValue port, bool peek)
K->ktok_seen_eof = false;
K->curr_port = port;
- K->curr_in = kport_file(port);
int ch;
if (peek) {
ch = ktok_peekc(K);
@@ -547,13 +734,33 @@ TValue kread_peek_char_from_port(klisp_State *K, TValue port, bool peek)
return ch == EOF? KEOF : ch2tv((char)ch);
}
+TValue kread_peek_u8_from_port(klisp_State *K, TValue port, bool peek)
+{
+ /* Reset the EOF flag in the tokenizer. The flag is shared,
+ by operations on all ports. */
+ K->ktok_seen_eof = false;
+ K->curr_port = port;
+ int32_t u8;
+ if (peek) {
+ u8 = ktok_peekc(K);
+ } else {
+ ktok_set_source_info(K, kport_filename(port),
+ kport_line(port), kport_col(port));
+ u8 = ktok_getc(K);
+ kport_update_source_info(port, K->ktok_source_info.line,
+ K->ktok_source_info.col);
+ }
+ return u8 == EOF? KEOF : i2tv(u8 & 0xff);
+}
+
/* This is needed by the repl to ignore trailing spaces (especially newlines)
that could affect the source info */
+/* XXX This should be replaced somehow, as it doesn't work for sexp and
+ multi line comments */
void kread_ignore_whitespace_and_comments_from_port(klisp_State *K,
TValue port)
{
K->curr_port = port;
- K->curr_in = kport_file(port);
/* source code info isn't important because it will be reset later */
ktok_ignore_whitespace_and_comments(K);
}
diff --git a/src/kread.h b/src/kread.h
@@ -14,7 +14,9 @@
** Reader interface
*/
TValue kread_from_port(klisp_State *K, TValue port, bool mut);
+TValue kread_list_from_port(klisp_State *K, TValue port, bool mut);
TValue kread_peek_char_from_port(klisp_State *K, TValue port, bool peek);
+TValue kread_peek_u8_from_port(klisp_State *K, TValue port, bool peek);
void kread_ignore_whitespace_and_comments_from_port(klisp_State *K,
TValue port);
diff --git a/src/krepl.c b/src/krepl.c
@@ -22,31 +22,25 @@
#include "kgerror.h"
/* for names */
#include "ktable.h"
+/* for do_pass_value */
+#include "kgcontinuations.h"
/* TODO add names & source info to the repl continuations */
-/* the exit continuation, it exits the loop */
-void do_repl_exit(klisp_State *K, TValue *xparams, TValue obj)
-{
- UNUSED(xparams);
- UNUSED(obj);
-
- /* force the loop to terminate */
- K->next_func = NULL;
- return;
-}
-
/* the underlying function of the read cont */
-void do_repl_read(klisp_State *K, TValue *xparams, TValue obj)
+void do_repl_read(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
UNUSED(xparams);
UNUSED(obj);
/* show prompt */
- fprintf(stdout, "klisp> ");
+ fprintf(stdout, KLISP_PROMPT);
TValue port = kcdr(K->kd_in_port_key);
- klisp_assert(kport_file(port) == stdin);
+ klisp_assert(kfport_file(port) == stdin);
#if 0 /* Let's disable this for now */
/* workaround to the problem of the dangling '\n' in repl
(from previous line) */
@@ -59,8 +53,11 @@ void do_repl_read(klisp_State *K, TValue *xparams, TValue obj)
}
/* the underlying function of the eval cont */
-void do_repl_eval(klisp_State *K, TValue *xparams, TValue obj)
+void do_repl_eval(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: dynamic environment
*/
@@ -71,6 +68,7 @@ void do_repl_eval(klisp_State *K, TValue *xparams, TValue obj)
/* this will in turn call main_cont */
/* print a newline to allow the shell a fresh line */
printf("\n");
+ /* This is ok because there is no interception possible */
kset_cc(K, K->root_cont);
kapply_cc(K, KINERT);
} else {
@@ -84,15 +82,46 @@ void do_repl_eval(klisp_State *K, TValue *xparams, TValue obj)
}
}
-void do_repl_loop(klisp_State *K, TValue *xparams, TValue obj);
+void do_repl_loop(klisp_State *K);
+void do_int_repl_error(klisp_State *K);
/* this is called from both do_repl_loop and do_repl_error */
/* GC: assumes denv is NOT rooted */
-inline void create_loop(klisp_State *K, TValue denv)
+void create_loop(klisp_State *K, TValue denv)
{
krooted_tvs_push(K, denv);
+
+ /* TODO this should be factored out, it is quite common */
+ TValue error_int = kmake_operative(K, do_int_repl_error, 1, denv);
+ krooted_tvs_pop(K); /* already in cont */
+ krooted_tvs_push(K, error_int);
+ TValue exit_guard = kcons(K, K->error_cont, error_int);
+ krooted_tvs_pop(K); /* already in guard */
+ krooted_tvs_push(K, exit_guard);
+ TValue exit_guards = kcons(K, exit_guard, KNIL);
+ krooted_tvs_pop(K); /* already in guards */
+ krooted_tvs_push(K, exit_guards);
+
+ TValue entry_guards = KNIL;
+
+ /* this is needed for interception code */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ TValue outer_cont = kmake_continuation(K, K->root_cont,
+ do_pass_value, 2, entry_guards, env);
+ kset_outer_cont(outer_cont);
+ krooted_tvs_push(K, outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont,
+ do_pass_value, 2, exit_guards, env);
+ kset_inner_cont(inner_cont);
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
+
+ /* stack is empty now */
+ krooted_tvs_push(K, inner_cont);
+
TValue loop_cont =
- kmake_continuation(K, K->root_cont, do_repl_loop, 1, denv);
+ kmake_continuation(K, inner_cont, do_repl_loop, 1, denv);
+ krooted_tvs_pop(K); /* in loop cont */
krooted_tvs_push(K, loop_cont);
TValue eval_cont = kmake_continuation(K, loop_cont, do_repl_eval, 1, denv);
krooted_tvs_pop(K); /* in eval cont */
@@ -100,19 +129,21 @@ inline void create_loop(klisp_State *K, TValue denv)
TValue read_cont = kmake_continuation(K, eval_cont, do_repl_read, 0);
kset_cc(K, read_cont);
krooted_tvs_pop(K);
- krooted_tvs_pop(K);
kapply_cc(K, KINERT);
}
/* the underlying function of the write & loop cont */
-void do_repl_loop(klisp_State *K, TValue *xparams, TValue obj)
+void do_repl_loop(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: dynamic environment
*/
TValue port = kcdr(K->kd_out_port_key);
- klisp_assert(kport_file(port) == stdout);
+ klisp_assert(kfport_file(port) == stdout);
/* false: quote strings, escape chars */
kwrite_display_to_port(K, port, obj, false);
@@ -123,15 +154,27 @@ void do_repl_loop(klisp_State *K, TValue *xparams, TValue obj)
}
/* the underlying function of the error cont */
-void do_repl_error(klisp_State *K, TValue *xparams, TValue obj)
+void do_int_repl_error(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
/*
** xparams[0]: dynamic environment
*/
+ UNUSED(denv);
+
+ /*
+ ** ptree is (object divert)
+ */
+ TValue obj = kcar(ptree);
+ TValue divert = kcadr(ptree);
+
/* FOR NOW used only for irritant list */
TValue port = kcdr(K->kd_error_port_key);
- klisp_assert(kport_file(port) == stderr);
+ klisp_assert(ttisfport(port) && kfport_file(port) == stderr);
/* TEMP: obj should be an error obj */
if (ttiserror(obj)) {
@@ -197,76 +240,17 @@ void do_repl_error(klisp_State *K, TValue *xparams, TValue obj)
"error continuation");
}
- TValue denv = xparams[0];
- create_loop(K, denv);
+ UNUSED(divert);
+ TValue old_denv = xparams[0];
+ /* this is the same as a divert */
+ create_loop(K, old_denv);
}
/* call this to init the repl in a newly created klisp state */
+/* the standard environment should be in K->next_env */
void kinit_repl(klisp_State *K)
{
- TValue std_env = kmake_environment(K, K->ground_env);
- krooted_tvs_push(K, std_env);
-
- /* set up the continuations */
- TValue root_cont = kmake_continuation(K, KNIL, do_repl_exit, 0);
- krooted_tvs_push(K, root_cont);
-
- TValue error_cont = kmake_continuation(K, root_cont, do_repl_error,
- 1, std_env);
- krooted_tvs_push(K, error_cont);
-
- /* update the ground environment with these two conts */
- TValue symbol;
- /* TODO si */
- symbol = ksymbol_new(K, "root-continuation", KNIL);
- krooted_tvs_push(K, symbol);
- kadd_binding(K, K->ground_env, symbol, root_cont);
- krooted_tvs_pop(K);
-
- #if KTRACK_SI
- /* TODO: find a cleaner way of doing this..., maybe disable gc */
- /* Add source info to the cont */
- TValue str = kstring_new_b_imm(K, __FILE__);
- krooted_tvs_push(K, str);
- TValue tail = kcons(K, i2tv(__LINE__), i2tv(0));
- krooted_tvs_push(K, tail);
- TValue si = kcons(K, str, tail);
- krooted_tvs_push(K, si);
- kset_source_info(K, root_cont, si);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- #endif
-
- /* TODO si */
- symbol = ksymbol_new(K, "error-continuation", KNIL);
- krooted_tvs_push(K, symbol);
- kadd_binding(K, K->ground_env, symbol, error_cont);
- krooted_tvs_pop(K);
-
- #if KTRACK_SI
- str = kstring_new_b_imm(K, __FILE__);
- krooted_tvs_push(K, str);
- tail = kcons(K, i2tv(__LINE__), i2tv(0));
- krooted_tvs_push(K, tail);
- si = kcons(K, str, tail);
- krooted_tvs_push(K, si);
- kset_source_info(K, error_cont, si);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- #endif
-
- /* and save them in the structure */
- K->root_cont = root_cont;
- K->error_cont = error_cont;
-
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
-
- /* Create error continuation hierarchy. */
- kinit_error_hierarchy(K);
+ TValue std_env = K->next_env;
#if KTRACK_SI
/* save the root cont in next_si to let the loop continuations have
diff --git a/src/krepl.h b/src/krepl.h
@@ -14,10 +14,10 @@
void kinit_repl(klisp_State *K);
/* continuation functions */
-void do_repl_exit(klisp_State *K, TValue *xparams, TValue obj);
-void do_repl_read(klisp_State *K, TValue *xparams, TValue obj);
-void do_repl_eval(klisp_State *K, TValue *xparams, TValue obj);
-void do_repl_loop(klisp_State *K, TValue *xparams, TValue obj);
-void do_repl_error(klisp_State *K, TValue *xparams, TValue obj);
+void do_repl_exit(klisp_State *K);
+void do_repl_read(klisp_State *K);
+void do_repl_eval(klisp_State *K);
+void do_repl_loop(klisp_State *K);
+void do_repl_error(klisp_State *K);
#endif
diff --git a/src/kscript.c b/src/kscript.c
@@ -42,8 +42,11 @@ static inline TValue krooted_tvs_pass_si(klisp_State *K, TValue v, TValue si)
#endif
/* the exit continuation, it exits the loop */
-void do_script_exit(klisp_State *K, TValue *xparams, TValue obj)
+void do_script_exit(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
UNUSED(xparams);
/* save exit code */
@@ -68,15 +71,18 @@ void do_script_exit(klisp_State *K, TValue *xparams, TValue obj)
/* the underlying function of the error cont */
-void do_script_error(klisp_State *K, TValue *xparams, TValue obj)
+void do_script_error(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]: dynamic environment
*/
-
+ UNUSED(xparams);
/* FOR NOW used only for irritant list */
TValue port = kcdr(K->kd_error_port_key);
- klisp_assert(kport_file(port) == stderr);
+ klisp_assert(kfport_file(port) == stderr);
/* TEMP: obj should be an error obj */
if (ttiserror(obj)) {
diff --git a/src/kscript.h b/src/kscript.h
@@ -15,8 +15,8 @@
void kinit_script(klisp_State *K, int argc, char *argv[]);
/* continuation functions */
-void do_script_exit(klisp_State *K, TValue *xparams, TValue obj);
-void do_script_error(klisp_State *K, TValue *xparams, TValue obj);
+void do_script_exit(klisp_State *K);
+void do_script_error(klisp_State *K);
/* default exit code in case of error according to SRFI-22 */
diff --git a/src/kstate.c b/src/kstate.c
@@ -35,9 +35,11 @@
#include "kstring.h"
#include "kport.h"
#include "ktable.h"
-#include "kblob.h"
+#include "kbytevector.h"
+#include "kvector.h"
#include "kgpairs_lists.h" /* for creating list_app */
+#include "kgerror.h" /* for creating error hierarchy */
#include "kgc.h" /* for memory freeing & gc init */
@@ -85,8 +87,6 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->ud = ud;
/* current input and output */
- K->curr_in = NULL; /* set on each call to read */
- K->curr_out = NULL; /* set on each call to write */
K->curr_port = KINERT; /* set on each call to read/write */
/* input / output for dynamic keys */
@@ -153,11 +153,15 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* MAYBE: fix it so we can remove empty_string from roots */
K->empty_string = kstring_new_b_imm(K, "");
- /* Empty blob */
- /* MAYBE: fix it so we can remove empty_blob from roots */
+ /* Empty bytevector */
+ /* MAYBE: fix it so we can remove empty_bytevector from roots */
/* XXX: find a better way to do this */
- K->empty_blob = KNIL; /* trick constructor to create empty blob */
- K->empty_blob = kblob_new_imm(K, 0);
+ K->empty_bytevector = KNIL; /* trick constructor to create empty bytevector */
+ K->empty_bytevector = kbytevector_new_bs_imm(K, NULL, 0);
+
+ /* Empty vector */
+ /* MAYBE: see above */
+ K->empty_vector = kvector_new_bs_g(K, false, NULL, 0);
/* initialize tokenizer */
@@ -172,6 +176,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->ktok_lparen = kcons(K, ch2tv('('), KNIL);
K->ktok_rparen = kcons(K, ch2tv(')'), KNIL);
K->ktok_dot = kcons(K, ch2tv('.'), KNIL);
+ K->ktok_sexp_comment = kcons(K, ch2tv(';'), KNIL);
/* TEMP: For now just hardcode it to 8 spaces tab-stop */
K->ktok_source_info.tab_width = 8;
@@ -180,6 +185,8 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->ktok_source_info.line = 1;
K->ktok_source_info.col = 0;
+ K->ktok_nested_comments = 0;
+
ktok_init(K);
/* initialize reader */
@@ -198,12 +205,12 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->sbuf = (TValue *)s;
/* the dynamic ports and the keys for the dynamic ports */
- TValue in_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDIN*"),
- false, stdin);
- TValue out_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDOUT*"),
- true, stdout);
- TValue error_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDERR*"),
- true, stderr);
+ TValue in_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDIN*"),
+ false, false, stdin);
+ TValue out_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDOUT*"),
+ true, false, stdout);
+ TValue error_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDERR*"),
+ true, false, stderr);
K->kd_in_port_key = kcons(K, KTRUE, in_port);
K->kd_out_port_key = kcons(K, KTRUE, out_port);
K->kd_error_port_key = kcons(K, KTRUE, error_port);
@@ -237,8 +244,35 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* TODO si */
K->module_params_sym = ksymbol_new(K, "module-parameters", KNIL);
+ /* Create the root and error continuation (will be added to the
+ environment in kinit_ground_env) */
+ K->root_cont = kmake_continuation(K, KNIL, do_root_exit, 0);
+
+ #if KTRACK_SI
+ /* Add source info to the cont */
+ TValue str = kstring_new_b_imm(K, __FILE__);
+ TValue tail = kcons(K, i2tv(__LINE__), i2tv(0));
+ si = kcons(K, str, tail);
+ kset_source_info(K, K->root_cont, si);
+ #endif
+
+ K->error_cont = kmake_continuation(K, K->root_cont, do_error_exit, 0);
+
+ #if KTRACK_SI
+ str = kstring_new_b_imm(K, __FILE__);
+ tail = kcons(K, i2tv(__LINE__), i2tv(0));
+ si = kcons(K, str, tail);
+ kset_source_info(K, K->error_cont, si);
+ #endif
+
+ /* this must be done before calling kinit_ground_env */
+ kinit_error_hierarchy(K);
+
kinit_ground_env(K);
+ /* create a std environment and leave it in K->next_env */
+ K->next_env = kmake_table_environment(K, K->ground_env);
+
/* set the threshold for gc start now that we have allocated all mem */
K->GCthreshold = 4*K->totalbytes;
@@ -246,6 +280,33 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
}
/*
+** Root and Error continuations
+*/
+void do_root_exit(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ UNUSED(xparams);
+
+ /* Just save the value and end the loop */
+ K->next_value = obj;
+ K->next_func = NULL; /* force the loop to terminate */
+ return;
+}
+
+void do_error_exit(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ UNUSED(xparams);
+
+ /* TEMP Just pass the error to the root continuation */
+ kapply_cc(K, obj);
+}
+
+/*
** Stacks memory management
*/
@@ -448,16 +509,23 @@ inline TValue create_interception_list(klisp_State *K, TValue src_cont,
}
/* this passes the operand tree to the continuation */
-void cont_app(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+void cont_app(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
UNUSED(denv);
TValue cont = xparams[0];
/* guards and dynamic variables are handled in kcall_cont() */
kcall_cont(K, cont, ptree);
}
-void do_interception(klisp_State *K, TValue *xparams, TValue obj)
+void do_interception(klisp_State *K)
{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
/*
** xparams[0]:
** xparams[1]: dst cont
@@ -545,16 +613,11 @@ void klispS_run(klisp_State *K)
} else {
/* all ok, continue with next func */
while (K->next_func) {
- if (ttisnil(K->next_env)) {
- /* continuation application */
- klisp_Cfunc fn = (klisp_Cfunc) K->next_func;
- (*fn)(K, K->next_xparams, K->next_value);
- } else {
- /* operative calling */
- klisp_Ofunc fn = (klisp_Ofunc) K->next_func;
- (*fn)(K, K->next_xparams, K->next_value, K->next_env);
- }
+ /* next_func is either operative or continuation
+ but in any case the call is the same */
+ (*(K->next_func))(K);
}
+ /* K->next_func is NULL, this means we should exit already */
break;
}
}
diff --git a/src/kstate.h b/src/kstate.h
@@ -21,6 +21,12 @@
#include "ktoken.h"
#include "kmem.h"
+/*
+** prototype for underlying c functions of continuations &
+** operatives
+*/
+typedef void (*klisp_CFunction) (klisp_State *K);
+
/* XXX: for now, lines and column names are fixints */
/* MAYBE: this should be in tokenizer */
typedef struct {
@@ -51,13 +57,13 @@ struct klisp_State {
TValue curr_cont;
/*
- ** If next_env is NIL, then the next_func is of type klisp_Cfunc
- ** (from a continuation) and otherwise next_func is of type
- ** klisp_Ofunc (from an operative)
+ ** If next_env is NIL, then the next_func from a continuation
+ ** and otherwise next_func is from an operative
*/
TValue next_obj; /* this is the operative or continuation to call
must be here to protect it from gc */
- void *next_func; /* the next function to call (operative or cont) */
+ klisp_CFunction next_func; /* the next function to call
+ (operative or continuation) */
TValue next_value; /* the value to be passed to the next function */
TValue next_env; /* either NIL or an environment for next operative */
TValue *next_xparams;
@@ -99,10 +105,8 @@ struct klisp_State {
/* TEMP: error handling */
jmp_buf error_jb;
- /* input and output files in use (for read & write) */
+ /* input/output port in use (for read & write) */
TValue curr_port; /* save the port to update source info on errors */
- FILE *curr_in;
- FILE *curr_out;
/* for current-input-port, current-output-port, current-error-port */
TValue kd_in_port_key;
@@ -115,14 +119,19 @@ struct klisp_State {
/* Strings */
TValue empty_string;
- /* Blobs */
- TValue empty_blob;
+ /* Bytevectors */
+ TValue empty_bytevector;
+
+ /* Vectors */
+ TValue empty_vector;
+
/* tokenizer */
/* special tokens, see ktoken.c for rationale */
TValue ktok_lparen;
TValue ktok_rparen;
TValue ktok_dot;
+ TValue ktok_sexp_comment;
/* WORKAROUND for repl */
bool ktok_seen_eof;
@@ -132,6 +141,8 @@ struct klisp_State {
int32_t ktok_buffer_idx;
char *ktok_buffer;
+ int32_t ktok_nested_comments;
+
/* reader */
/* TODO: replace the list with a hashtable */
TValue shared_dict;
@@ -141,6 +152,7 @@ struct klisp_State {
bool write_displayp;
/* script */
+ /* REFACTOR rename to exit_code */
int script_exit_code;
/* auxiliary stack */
@@ -346,14 +358,6 @@ inline void krooted_vars_clear(klisp_State *K) { K->rooted_vars_top = 0; }
/* dummy functions will be in kpair.h, because we can't include
it from here */
-/*
-** prototypes for underlying c functions of continuations &
-** operatives
-*/
-typedef void (*klisp_Cfunc) (klisp_State*K, TValue *ud, TValue val);
-typedef void (*klisp_Ofunc) (klisp_State *K, TValue *ud, TValue ptree,
- TValue env);
-
/* XXX: this is ugly but we can't include kpair.h here so... */
/* MAYBE: move car & cdr to kobject.h */
#define kstate_car(p_) (tv2pair(p_)->car)
@@ -466,6 +470,7 @@ inline void klispS_tail_call_si(klisp_State *K, TValue top, TValue ptree,
K->next_func = op->fn;
K->next_value = ptree;
/* NOTE: this is what differentiates a tail call from a return */
+ klisp_assert(ttisenvironment(env));
K->next_env = env;
K->next_xparams = op->extra;
K->next_si = si;
@@ -488,13 +493,17 @@ inline void klispS_tail_call_si(klisp_State *K, TValue top, TValue ptree,
return; }
/* helper for continuation->applicative & kcall_cont */
-void cont_app(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+void cont_app(klisp_State *K);
void kcall_cont(klisp_State *K, TValue dst_cont, TValue obj);
void klispS_init_repl(klisp_State *K);
void klispS_run(klisp_State *K);
void klisp_close (klisp_State *K);
-void do_interception(klisp_State *K, TValue *xparams, TValue obj);
+void do_interception(klisp_State *K);
+
+/* for root and error continuations */
+void do_root_exit(klisp_State *K);
+void do_error_exit(klisp_State *K);
/* simple accessors for dynamic keys */
diff --git a/src/kstring.c b/src/kstring.c
@@ -15,7 +15,7 @@
#include "kmem.h"
#include "kgc.h"
-/* for immutable string/symbols table */
+/* for immutable string/symbols/bytevector table */
void klispS_resize (klisp_State *K, int32_t newsize)
{
GCObject **newhash;
@@ -30,8 +30,8 @@ void klispS_resize (klisp_State *K, int32_t newsize)
for (i = 0; i < tb->size; i++) {
GCObject *p = tb->hash[i];
while (p) { /* for each node in the list */
- /* imm string & symbols aren't chained with all other
- objs, but with each other in strt */
+ /* imm string, imm bytevectors & symbols aren't chained with
+ all other objs, but with each other in strt */
GCObject *next = p->gch.next; /* save next */
uint32_t h = 0;
@@ -40,6 +40,8 @@ void klispS_resize (klisp_State *K, int32_t newsize)
h = ((Symbol *) p)->hash;
} else if (p->gch.tt == K_TSTRING) {
h = ((String *) p)->hash;
+ } else if (p->gch.tt == K_TBYTEVECTOR) {
+ h = ((Bytevector *) p)->hash;
} else {
klisp_assert(0);
}
@@ -85,10 +87,11 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
String *ts = NULL;
if (o->gch.tt == K_TSTRING) {
ts = (String *) o;
- } else if (o->gch.tt == K_TSYMBOL) {
+ } else if (o->gch.tt == K_TSYMBOL || o->gch.tt == K_TBYTEVECTOR) {
continue;
} else {
- klisp_assert(0); /* only symbols and immutable strings */
+ /* only symbols, immutable bytevectors and immutable strings */
+ klisp_assert(0);
}
if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
/* string may be dead */
@@ -101,7 +104,7 @@ TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
/* REFACTOR: move all of these to a new function */
String *new_str;
- if (size+1 > (SIZE_MAX - sizeof(String)))
+ if (size > (SIZE_MAX - sizeof(String) - 1))
klispM_toobig(K);
new_str = (String *) klispM_malloc(K, sizeof(String) + size + 1);
@@ -156,6 +159,7 @@ TValue kstring_new_s(klisp_State *K, uint32_t size)
String *new_str;
if (size == 0) {
+ klisp_assert(ttisstring(K->empty_string));
return K->empty_string;
}
@@ -217,3 +221,11 @@ bool kstring_equalp(TValue obj1, TValue obj2)
}
bool kstringp(TValue obj) { return ttisstring(obj); }
+bool kimmutable_stringp(TValue obj)
+{
+ return ttisstring(obj) && kis_immutable(obj);
+}
+bool kmutable_stringp(TValue obj)
+{
+ return ttisstring(obj) && kis_mutable(obj);
+}
diff --git a/src/kstring.h b/src/kstring.h
@@ -46,27 +46,6 @@ TValue kstring_new_b(klisp_State *K, const char *buf);
/* with size & fill char */
TValue kstring_new_sf(klisp_State *K, uint32_t size, char fill);
-/* macros for mutable & immutable versions of the above */
-#if 0
-#define kstring_new_s(K_, size_) \
- kstring_new_s_g(K_, true, size_)
-#define kstring_new_bs(K_, buf_, size_) \
- kstring_new_bs_g(K_, true, buf_, size_)
-#define kstring_new_b(K_, buf_) \
- kstring_new_b_g(K_, true, buf_)
-#define kstring_new_sf(K_, size_, fill_) \
- kstring_new_sf_g(K_, true, size_, fill_)
-
-#define kstring_new_s_imm(K_, size_) \
- kstring_new_s_g(K_, false, size_)
-#define kstring_new_bs_imm(K_, buf_, size_) \
- kstring_new_bs_g(K_, false, buf_, size_)
-#define kstring_new_b_imm(K_, buf_) \
- kstring_new_b_g(K_, false, buf_)
-#define kstring_new_sf_imm(K_, size_, fill_) \
- kstring_new_sf_g(K_, false, size_, fill_)
-#endif
-
/* some macros to access the parts of the string */
#define kstring_buf(tv_) (tv2str(tv_)->b)
#define kstring_size(tv_) (tv2str(tv_)->size)
@@ -79,5 +58,7 @@ TValue kstring_new_sf(klisp_State *K, uint32_t size, char fill);
and doesn't differentiate immutable from mutable strings */
bool kstring_equalp(TValue obj1, TValue obj2);
bool kstringp(TValue obj);
+bool kimmutable_stringp(TValue obj);
+bool kmutable_stringp(TValue obj);
#endif
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -13,6 +13,8 @@
#include "kstate.h"
#include "kmem.h"
#include "kgc.h"
+/* for immutable table */
+#include "kstring.h"
/* NOTE: symbols can have source info, they should be compared with
tv_sym_equal, NOT tv_equal */
@@ -39,12 +41,13 @@ TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
for (o = K->strt.hash[lmod(h, K->strt.size)];
o != NULL; o = o->gch.next) {
String *ts = NULL;
- if (o->gch.tt == K_TSTRING) {
+ if (o->gch.tt == K_TSTRING || o->gch.tt == K_TBYTEVECTOR) {
continue;
} else if (o->gch.tt == K_TSYMBOL) {
ts = tv2str(((Symbol *) o)->str);
} else {
- klisp_assert(0); /* only symbols and immutable strings */
+ /* only symbols, immutable bytevectors and immutable strings */
+ klisp_assert(0);
}
if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
/* symbol may be dead */
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -26,7 +26,6 @@
*/
#include <stdio.h>
#include <stdlib.h>
-#include <assert.h>
#include <string.h>
#include <ctype.h>
#include <stdint.h>
@@ -40,6 +39,7 @@
#include "kreal.h"
#include "kpair.h"
#include "kstring.h"
+#include "kbytevector.h"
#include "ksymbol.h"
#include "kerror.h"
#include "kport.h"
@@ -134,7 +134,10 @@ void clear_shared_dict(klisp_State *K)
K->shared_dict = KNIL;
}
-void ktok_error(klisp_State *K, char *str)
+#define ktok_error(K, str) ktok_error_g(K, str, false, KINERT)
+#define ktok_error_extra(K, str, extra) ktok_error_g(K, str, true, extra)
+
+void ktok_error_g(klisp_State *K, char *str, bool extra, TValue extra_value)
{
/* all cleaning is done in throw
(stacks, shared_dict, rooted objs) */
@@ -143,69 +146,137 @@ void ktok_error(klisp_State *K, char *str)
kport_update_source_info(K->curr_port, K->ktok_source_info.line,
K->ktok_source_info.col);
- /* include the source info in the error */
- TValue si = ktok_get_source_info(K);
- krooted_tvs_push(K, si); /* will be popped by throw */
- klispE_throw_with_irritants(K, str, si);
+ /* include the source info (and extra value if present) in the error */
+ TValue irritants;
+ if (extra) {
+ krooted_tvs_push(K, extra_value); /* will be popped by throw */
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si); /* will be popped by throw */
+ irritants = klist_g(K, false, 2, si, extra_value);
+ } else {
+ irritants = ktok_get_source_info(K);
+ }
+ krooted_tvs_push(K, irritants); /* will be popped by throw */
+ klispE_throw_with_irritants(K, str, irritants);
}
/*
** Underlying stream interface & source code location tracking
*/
-/* TODO check for error if getc returns EOF */
-int ktok_getc(klisp_State *K) {
- /* WORKAROUND: for stdin line buffering & reading of EOF */
- /* Is this really necessary?? double check */
- if (K->ktok_seen_eof) {
- return EOF;
- } else {
- int chi = getc(K->curr_in);
+/* TODO/OPTIMIZE We should use buffering to shorten the
+ average code path to read each char */
+/* this reads one character from curr_port */
+int ktok_ggetc(klisp_State *K)
+{
+ /* XXX when full unicode is used (uint32_t) a different way should
+ be use to signal EOF */
+
+ TValue port = K->curr_port;
+ if (ttisfport(port)) {
+ /* fport */
+ FILE *file = kfport_file(port);
+ int chi = getc(file);
if (chi == EOF) {
/* NOTE: eof doesn't change source code location info */
- if (ferror(K->curr_in) != 0) {
+ if (ferror(file) != 0) {
/* clear error marker to allow retries later */
- clearerr(K->curr_in);
+ clearerr(file);
+ /* TODO put error info on the error obj */
ktok_error(K, "reading error");
return 0;
- } else { /* if (feof(K->curr_in) != 0) */
+ } else { /* if (feof(file) != 0) */
/* let the eof marker set */
K->ktok_seen_eof = true;
return EOF;
}
- }
-
- /* track source code location before returning the char */
- if (chi == '\t') {
- /* align column to next tab stop */
- K->ktok_source_info.col =
- (K->ktok_source_info.col + K->ktok_source_info.tab_width) -
- (K->ktok_source_info.col % K->ktok_source_info.tab_width);
- return '\t';
- } else if (chi == '\n') {
- K->ktok_source_info.line++;
- K->ktok_source_info.col = 0;
- return '\n';
+ } else
+ return chi;
+ } else {
+ /* mport */
+ if (kport_is_binary(port)) {
+ /* bytevector port */
+ if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) {
+ K->ktok_seen_eof = true;
+ return EOF;
+ }
+ int chi = kbytevector_buf(kmport_buf(port))[kmport_off(port)];
+ ++kmport_off(port);
+ return chi;
} else {
- K->ktok_source_info.col++;
+ /* string port */
+ if (kmport_off(port) >= kstring_size(kmport_buf(port))) {
+ K->ktok_seen_eof = true;
+ return EOF;
+ }
+ int chi = kstring_buf(kmport_buf(port))[kmport_off(port)];
+ ++kmport_off(port);
return chi;
}
}
}
-int ktok_peekc(klisp_State *K) {
- /* WORKAROUND: for stdin line buffering & reading of EOF */
- /* Is this really necessary?? double check */
- if (K->ktok_seen_eof) {
- return EOF;
+/* this returns one character to curr_port */
+void ktok_gungetc(klisp_State *K, int chi)
+{
+ if (chi == EOF)
+ return;
+
+ TValue port = K->curr_port;
+ if (ttisfport(port)) {
+ /* fport */
+ FILE *file = kfport_file(port);
+
+ if (ungetc(chi, file) == EOF) {
+ if (ferror(file) != 0) {
+ /* clear error marker to allow retries later */
+ clearerr(file);
+ }
+ /* TODO put error info on the error obj */
+ ktok_error(K, "reading error");
+ return;
+ }
} else {
- int chi = getc(K->curr_in);
- if (chi == EOF)
- K->ktok_seen_eof = true;
- else
- ungetc(chi, K->curr_in);
+ /* mport */
+ if (kport_is_binary(port)) {
+ /* bytevector port */
+ --kmport_off(port);
+ } else {
+ /* string port */
+ --kmport_off(port);
+ }
+ }
+}
+
+int ktok_peekc_getc(klisp_State *K, bool peekp)
+{
+ /* WORKAROUND: for stdin line buffering & reading of EOF, this flag
+ is reset on every read */
+ /* Otherwise, at least in linux, after reading or peeking an EOF from the
+ console, the next char isn't eof anymore */
+ if (K->ktok_seen_eof)
+ return EOF;
+
+ int chi = ktok_ggetc(K);
+
+ if (peekp) {
+ ktok_gungetc(K, chi);
return chi;
}
+
+ /* track source code location before returning the char */
+ if (chi == '\t') {
+ /* align column to next tab stop */
+ K->ktok_source_info.col =
+ (K->ktok_source_info.col + K->ktok_source_info.tab_width) -
+ (K->ktok_source_info.col % K->ktok_source_info.tab_width);
+ } else if (chi == '\n') {
+ K->ktok_source_info.line++;
+ K->ktok_source_info.col = 0;
+ } else {
+ K->ktok_source_info.col++;
+ }
+ return chi;
}
void ktok_save_source_info(klisp_State *K)
@@ -240,6 +311,7 @@ void ktok_set_source_info(klisp_State *K, TValue filename, int32_t line,
*/
void ktok_ignore_whitespace(klisp_State *K);
void ktok_ignore_single_line_comment(klisp_State *K);
+void ktok_ignore_multi_line_comment(klisp_State *K);
bool ktok_check_delimiter(klisp_State *K);
TValue ktok_read_string(klisp_State *K);
TValue ktok_read_special(klisp_State *K);
@@ -255,7 +327,7 @@ int ktok_read_until_delimiter(klisp_State *K);
*/
TValue ktok_read_token(klisp_State *K)
{
- assert(ks_tbisempty(K));
+ klisp_assert(ks_tbisempty(K));
while(true) {
ktok_ignore_whitespace(K);
@@ -293,12 +365,26 @@ TValue ktok_read_token(klisp_State *K)
case '#': {
ktok_getc(K);
chi = ktok_peekc(K);
- if ((chi != EOF) && (char) chi == '!') {
+
+ switch(chi) {
+ case EOF:
+ ktok_error(K, "# constant is too short");
+ /* avoid warning */
+ return KINERT;
+ case '!': /* single line comment (alternative syntax) */
/* this handles the #! style script header too! */
ktok_ignore_single_line_comment(K);
continue;
- } else {
- /* also handles EOF case */
+ case '|': /* nested/multiline comment */
+ ktok_getc(K); /* discard the '|' */
+ klisp_assert(K->ktok_nested_comments == 0);
+ K->ktok_nested_comments = 1;
+ ktok_ignore_multi_line_comment(K);
+ continue;
+ case ';': /* sexp comment */
+ ktok_getc(K); /* discard the ';' */
+ return K->ktok_sexp_comment;
+ default:
return ktok_read_special(K);
}
}
@@ -330,9 +416,22 @@ TValue ktok_read_token(klisp_State *K)
** identifier-first-char (in the cases above)
*/
return ktok_read_identifier(K);
- default:
+ case '|':
+ ktok_getc(K);
+ chi = ktok_peekc(K);
+ if (chi == EOF || chi != '#') {
+ chi = '|';
+ goto unrecognized_error;
+ }
ktok_getc(K);
- ktok_error(K, "unrecognized token starting char");
+ ktok_error(K, "unmatched multiline comment close (\"|#\")");
+ /* avoid warning */
+ return KINERT;
+ default:
+ chi = ktok_getc(K);
+ /* TODO add char to error */
+ unrecognized_error:
+ ktok_error_extra(K, "unrecognized token starting char", ch2tv((char) chi));
/* avoid warning */
return KINERT;
}
@@ -350,6 +449,63 @@ void ktok_ignore_single_line_comment(klisp_State *K)
} while (chi != EOF && chi != '\n');
}
+void ktok_ignore_multi_line_comment(klisp_State *K)
+{
+ /* the first "#|' was already read */
+ klisp_assert(K->ktok_nested_comments == 1);
+ int chi;
+ TValue last_nested_comment_si = ktok_get_source_info(K);
+ krooted_vars_push(K, &last_nested_comment_si);
+ ks_spush(K, KNIL);
+
+ while(K->ktok_nested_comments > 0) {
+ chi = ktok_peekc(K);
+ while (chi != EOF && chi != '|' && chi != '#') {
+ UNUSED(ktok_getc(K));
+ chi = ktok_peekc(K);
+ }
+ if (chi == EOF)
+ goto eof_error;
+
+ char first_char = (char) chi;
+
+ /* this first char will actually be the same just peeked, that's no
+ problem, it will save the source info the first time around the
+ loop */
+ chi = ktok_peekc(K);
+ while (chi != EOF && chi == first_char) {
+ ktok_save_source_info(K);
+ UNUSED(ktok_getc(K));
+ chi = ktok_peekc(K);
+ }
+ if (chi == EOF)
+ goto eof_error;
+
+ UNUSED(ktok_getc(K));
+
+ if (chi == '#') {
+ /* close comment (first char was '|', so the seq is "|#") */
+ --K->ktok_nested_comments;
+ last_nested_comment_si = ks_spop(K);
+ } else if (chi == '|') {
+ /* open comment (first char was '#', so the seq is "#|") */
+ klisp_assert(K->ktok_nested_comments < 1000);
+ ++K->ktok_nested_comments;
+ ks_spush(K, last_nested_comment_si);
+ last_nested_comment_si = ktok_get_source_info(K);
+ }
+ /* else lone '#' or '|', just continue */
+ }
+ krooted_vars_pop(K);
+ return;
+eof_error:
+ K->ktok_nested_comments = 0;
+ ktok_save_source_info(K);
+ UNUSED(ktok_getc(K));
+ krooted_vars_pop(K);
+ ktok_error_extra(K, "unterminated multi line comment", last_nested_comment_si);
+}
+
void ktok_ignore_whitespace(klisp_State *K)
{
/* NOTE: if it's not whitespace do nothing (even on eof) */
@@ -728,7 +884,8 @@ TValue ktok_read_special(klisp_State *K)
has_radixp = true;
break;
default:
- ktok_error(K, "unexpected char in number after #");
+ ktok_error(K, "unknown # constant or "
+ "unexpected char in number after #");
/* avoid warning */
return KINERT;
}
diff --git a/src/ktoken.h b/src/ktoken.h
@@ -26,9 +26,11 @@ void ktok_set_source_info(klisp_State *K, TValue filename, int32_t line,
/* This is needed here to allow cleanup of shared dict from tokenizer */
void clear_shared_dict(klisp_State *K);
-/* This is used in for peek-char & read-char */
-int ktok_getc(klisp_State *K);
-int ktok_peekc(klisp_State *K);
+/* These are used in peek-char, peek-u8, read-char & read-u8 */
+int ktok_peekc_getc(klisp_State *K, bool peekp);
+inline int ktok_getc(klisp_State *K) { return ktok_peekc_getc(K, false); }
+inline int ktok_peekc(klisp_State *K) { return ktok_peekc_getc(K, true); }
+
/* needed by the repl */
void ktok_ignore_whitespace_and_comments(klisp_State *K);
diff --git a/src/kvector.c b/src/kvector.c
@@ -0,0 +1,65 @@
+/*
+** kvector.c
+** Kernel Vectors (heterogenous arrays)
+** See Copyright Notice in klisp.h
+*/
+
+#include <string.h>
+
+#include "kvector.h"
+#include "kobject.h"
+#include "kstate.h"
+#include "kmem.h"
+#include "kgc.h"
+
+/* helper function allocating vectors */
+
+static Vector *kvector_alloc(klisp_State *K, bool m, uint32_t length)
+{
+ Vector *new_vector;
+
+ if (length > (SIZE_MAX - sizeof(Vector)) / sizeof(TValue))
+ klispM_toobig(K);
+
+ klisp_assert(!m || length > 0);
+
+ size_t size = sizeof(Vector) + length * sizeof(TValue);
+ new_vector = (Vector *) klispM_malloc(K, size);
+ klispC_link(K, (GCObject *) new_vector, K_TVECTOR,
+ (m? 0 : K_FLAG_IMMUTABLE));
+ new_vector->mark = KFALSE;
+ new_vector->sizearray = length;
+
+ return new_vector;
+}
+
+TValue kvector_new_sf(klisp_State *K, uint32_t length, TValue fill)
+{
+ Vector *v = kvector_alloc(K, true, length);
+ for (int i = 0; i < length; i++)
+ v->array[i] = fill;
+ return gc2vector(v);
+}
+
+TValue kvector_new_bs_g(klisp_State *K, bool m,
+ const TValue *buf, uint32_t length)
+{
+ Vector *v = kvector_alloc(K, m, length);
+ memcpy(v->array, buf, sizeof(TValue) * length);
+ return gc2vector(v);
+}
+
+bool kvectorp(TValue obj)
+{
+ return ttisvector(obj);
+}
+
+bool kimmutable_vectorp(TValue obj)
+{
+ return ttisvector(obj) && kis_immutable(obj);
+}
+
+bool kmutable_vectorp(TValue obj)
+{
+ return ttisvector(obj) && kis_mutable(obj);
+}
diff --git a/src/kvector.h b/src/kvector.h
@@ -0,0 +1,34 @@
+/*
+** kvector.h
+** Kernel Vectors (heterogenous arrays)
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kvector_h
+#define kvector_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+/* constructors */
+
+TValue kvector_new_sf(klisp_State *K, uint32_t length, TValue fill);
+TValue kvector_new_bs_g(klisp_State *K, bool m,
+ const TValue *buf, uint32_t length);
+
+/* predicates */
+
+bool kvectorp(TValue obj);
+bool kimmutable_vectorp(TValue obj);
+bool kmutable_vectorp(TValue obj);
+
+/* some macros to access the parts of vectors */
+
+#define kvector_array(tv_) (tv2vector(tv_)->array)
+#define kvector_length(tv_) (tv2vector(tv_)->sizearray)
+
+#define kvector_emptyp(tv_) (kvector_length(tv_) == 0)
+#define kvector_mutablep(tv_) (kis_mutable(tv_))
+#define kvector_immutablep(tv_) (kis_immutable(tv_))
+
+#endif
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -6,6 +6,7 @@
#include <stdio.h>
#include <stdlib.h>
+#include <stdarg.h>
#include <assert.h>
#include <inttypes.h>
#include <string.h>
@@ -23,7 +24,8 @@
#include "ktable.h"
#include "kport.h"
#include "kenvironment.h"
-#include "kblob.h"
+#include "kbytevector.h"
+#include "kvector.h"
/*
** Stack for the write FSM
@@ -34,27 +36,70 @@
#define get_data(ks_) (ks_sget(ks_))
#define data_is_empty(ks_) (ks_sisempty(ks_))
-/* macro for printing */
-#define kw_printf(ks_, ...) \
- if (fprintf((ks_)->curr_out, __VA_ARGS__) < 0) { \
- clearerr((ks_)->curr_out); /* clear error for next time */ \
- kwrite_error(ks_, "error writing"); \
- }
-
-#define kw_flush(ks_) \
- if (fflush((ks_)->curr_out) == EOF) { \
- clearerr((ks_)->curr_out); /* clear error for next time */ \
- kwrite_error(ks_, "error writing"); \
- }
-
void kwrite_error(klisp_State *K, char *msg)
{
/* all cleaning is done in throw
(stacks, shared_dict, rooted objs) */
-
klispE_throw_simple(K, msg);
}
+void kw_printf(klisp_State *K, const char *format, ...)
+{
+ va_list argp;
+ TValue port = K->curr_port;
+
+ if (ttisfport(port)) {
+ FILE *file = kfport_file(port);
+ va_start(argp, format);
+ int ret = vfprintf(file, format, argp);
+ va_end(argp);
+
+ if (ret < 0) {
+ clearerr(file); /* clear error for next time */
+ kwrite_error(K, "error writing");
+ return;
+ }
+ } else if (ttismport(port)) {
+ /* bytevector ports shouldn't write chars */
+ klisp_assert(kport_is_textual(port));
+ /* string port */
+ uint32_t size;
+ int written;
+ uint32_t off = kmport_off(port);
+
+ size = kstring_size(kmport_buf(port)) -
+ kmport_off(port) + 1;
+
+ /* size is always at least 1 (for the '\0') */
+ va_start(argp, format);
+ written = vsnprintf(kstring_buf(kmport_buf(port)) + off,
+ size, format, argp);
+ va_end(argp);
+
+ if (written >= size) { /* space wasn't enough */
+ kmport_resize_buffer(K, port, off + written);
+ /* size may be greater than off + written, so get again */
+ size = kstring_size(kmport_buf(port)) - off + 1;
+ va_start(argp, format);
+ written = vsnprintf(kstring_buf(kmport_buf(port)) + off,
+ size, format, argp);
+ va_end(argp);
+ if (written < 0 || written >= size) {
+ /* shouldn't happen */
+ kwrite_error(K, "error writing");
+ return;
+ }
+ }
+ kmport_off(port) = off + written;
+ } else {
+ kwrite_error(K, "unknown port type");
+ return;
+ }
+}
+
+void kw_flush(klisp_State *K) { kwrite_flush_port(K, K->curr_port); }
+
+
/* TODO: check for return codes and throw error if necessary */
#define KDEFAULT_NUMBER_RADIX 10
void kw_print_bigint(klisp_State *K, TValue bigint)
@@ -421,9 +466,22 @@ void kwrite_simple(klisp_State *K, TValue obj)
/* TODO try to get the name */
kw_printf(K, "#[promise]");
break;
- case K_TPORT:
- /* TODO try to get the name/ I/O direction / filename */
- kw_printf(K, "#[%s port", kport_is_input(obj)? "input" : "output");
+ case K_TFPORT:
+ /* TODO try to get the filename */
+ kw_printf(K, "#[%s %s file port",
+ kport_is_binary(obj)? "binary" : "textual",
+ kport_is_input(obj)? "input" : "output");
+ #if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+ #endif
+ kw_printf(K, "]");
+ break;
+ case K_TMPORT:
+ kw_printf(K, "#[%s %s port",
+ kport_is_binary(obj)? "bytevector" : "string",
+ kport_is_input(obj)? "input" : "output");
#if KTRACK_NAMES
if (khas_name(obj)) {
kw_print_name(K, obj);
@@ -443,8 +501,8 @@ void kwrite_simple(klisp_State *K, TValue obj)
kw_printf(K, "]");
break;
}
- case K_TBLOB:
- kw_printf(K, "#[blob");
+ case K_TBYTEVECTOR:
+ kw_printf(K, "#[bytevector");
#if KTRACK_NAMES
if (khas_name(obj)) {
kw_print_name(K, obj);
@@ -452,6 +510,15 @@ void kwrite_simple(klisp_State *K, TValue obj)
#endif
kw_printf(K, "]");
break;
+ case K_TVECTOR:
+ kw_printf(K, "#[vector");
+ #if KTRACK_NAMES
+ if (khas_name(obj)) {
+ kw_print_name(K, obj);
+ }
+ #endif
+ kw_printf(K, "]");
+ break;
default:
/* shouldn't happen */
kwrite_error(K, "unknown object type");
@@ -565,12 +632,6 @@ void kwrite(klisp_State *K, TValue obj)
krooted_tvs_pop(K);
}
-void kwrite_newline(klisp_State *K)
-{
- kw_printf(K, "\n");
- kw_flush(K);
-}
-
/*
** Interface
*/
@@ -578,27 +639,98 @@ void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
bool displayp)
{
K->curr_port = port;
- K->curr_out = kport_file(port);
K->write_displayp = displayp;
kwrite(K, obj);
}
void kwrite_newline_to_port(klisp_State *K, TValue port)
{
+ K->curr_port = port; /* this isn't needed but all other
+ i/o functions set it */
kwrite_char_to_port(K, port, ch2tv('\n'));
}
void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch)
{
- K->curr_port = port;
- K->curr_out = kport_file(port);
- int res = fputc(chvalue(ch), K->curr_out);
- /* implicit flush, MAYBE add flush call */
- if (res != EOF)
- res = fflush(K->curr_out);
-
- if (res == EOF) {
- clearerr(K->curr_out); /* clear error for next time */
- kwrite_error(K, "error writing char");
+ K->curr_port = port; /* this isn't needed but all other
+ i/o functions set it */
+
+ if (ttisfport(port)) {
+ FILE *file = kfport_file(port);
+ int res = fputc(chvalue(ch), file);
+
+ if (res == EOF) {
+ clearerr(file); /* clear error for next time */
+ kwrite_error(K, "error writing char");
+ }
+ } else if (ttismport(port)) {
+ if (kport_is_binary(port)) {
+ /* bytebuffer port */
+ if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) {
+ kmport_resize_buffer(K, port, kmport_off(port) + 1);
+ }
+ kbytevector_buf(kmport_buf(port))[kmport_off(port)] = chvalue(ch);
+ ++kmport_off(port);
+ } else {
+ /* string port */
+ if (kmport_off(port) >= kstring_size(kmport_buf(port))) {
+ kmport_resize_buffer(K, port, kmport_off(port) + 1);
+ }
+ kstring_buf(kmport_buf(port))[kmport_off(port)] = chvalue(ch);
+ ++kmport_off(port);
+ }
+ } else {
+ kwrite_error(K, "unknown port type");
+ return;
+ }
+}
+
+void kwrite_u8_to_port(klisp_State *K, TValue port, TValue u8)
+{
+ K->curr_port = port; /* this isn't needed but all other
+ i/o functions set it */
+ if (ttisfport(port)) {
+ FILE *file = kfport_file(port);
+ int res = fputc(ivalue(u8), file);
+
+ if (res == EOF) {
+ clearerr(file); /* clear error for next time */
+ kwrite_error(K, "error writing u8");
+ }
+ } else if (ttismport(port)) {
+ if (kport_is_binary(port)) {
+ /* bytebuffer port */
+ if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) {
+ kmport_resize_buffer(K, port, kmport_off(port) + 1);
+ }
+ kbytevector_buf(kmport_buf(port))[kmport_off(port)] =
+ (uint8_t) ivalue(u8);
+ ++kmport_off(port);
+ } else {
+ /* string port */
+ if (kmport_off(port) >= kstring_size(kmport_buf(port))) {
+ kmport_resize_buffer(K, port, kmport_off(port) + 1);
+ }
+ kstring_buf(kmport_buf(port))[kmport_off(port)] =
+ (char) ivalue(u8);
+ ++kmport_off(port);
+ }
+ } else {
+ kwrite_error(K, "unknown port type");
+ return;
+ }
+}
+
+void kwrite_flush_port(klisp_State *K, TValue port)
+{
+ K->curr_port = port; /* this isn't needed but all other
+ i/o functions set it */
+ if (ttisfport(port)) { /* only necessary for file ports */
+ FILE *file = kfport_file(port);
+ klisp_assert(file);
+ if ((fflush(file)) == EOF) {
+ clearerr(file); /* clear error for next time */
+ kwrite_error(K, "error writing");
+ }
}
}
diff --git a/src/kwrite.h b/src/kwrite.h
@@ -17,6 +17,8 @@ void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
bool displayp);
void kwrite_newline_to_port(klisp_State *K, TValue port);
void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch);
+void kwrite_u8_to_port(klisp_State *K, TValue port, TValue u8);
+void kwrite_flush_port(klisp_State *K, TValue port);
#endif
diff --git a/src/rep_op_c.sed b/src/rep_op_c.sed
@@ -0,0 +1,78 @@
+# This is a collection of sed commands to refactor operatives underlying
+# functions to just take a kernel state pointer (instead of also taking extra
+# params, ptree and denv).
+
+# All these tests are run one at a time with sed -n
+
+# This is a collection of sed commands to refactor operatives underlying
+# functions to just take a kernel state pointer (instead of also taking extra
+# params, ptree and denv).
+
+# All these tests are run one at a time with sed -n
+
+# detect single line function definition
+# There are 0
+#/^void \(.*\)[(]klisp_State \*K, TValue \*xparams, TValue ptree, TValue denv[)];/P
+
+# All the single line definitions done
+
+# try to detect multi line function definition
+# There are 1, do_int_repl_error
+#/^void \(.*\)[(]klisp_State \*K,/{
+#N
+#/^void \(.*\)[(]klisp_State \*K,[[:space:]]*TValue \*xparams,[[:space:]]*TValue ptree,[[:space:]]*TValue denv);/P
+#}
+
+# replace it
+#/^void \(.*\)[(]klisp_State \*K,/{
+#N
+#s/^void \(.*\)[(]klisp_State \*K,[[:space:]]*TValue \*xparams,[[:space:]]*TValue ptree,[[:space:]]*#TValue denv);/void \1(klisp_State *K);/
+#}
+
+# done!
+
+# Detect all with simple brace
+# There are 101
+#/^void \(.*\)[(]klisp_State \*K, TValue \*xparams, TValue ptree, TValue denv[)]/{
+#N
+#/^void \(.*\)[(]klisp_State \*K, TValue \*xparams, TValue ptree, TValue denv[)].*\n[{]/P
+#}
+
+# replace them
+# This is used to modify in place with sed -i -f <this-file> *.c
+#/^void \(.*\)[(]klisp_State \*K, TValue \*xparams, TValue ptree, TValue denv[)]/{
+#N
+#s/^void \(.*\)[(]klisp_State \*K, TValue \*xparams, TValue ptree, TValue denv[)].*\n[{]/void \1(klisp_State *K)\
+#\{\
+# TValue *xparams = K->next_xparams;\
+# TValue ptree = K->next_value;\
+# TValue denv = K->next_env;\
+# klisp_assert(ttisenvironment(K->next_env));/
+#}
+
+# Detect the ones in two lines (with braces)
+# There are 84
+#/^void \(.*\)[(]klisp_State \*K,/{
+#N
+#N
+#/^void \(.*\)[(]klisp_State \*K,[[:space:]]*TValue \*xparams,[[:space:]]*TValue ptree,[[:space:]]*TValue denv[)][[:space:]]*[{]/P
+#}
+
+# replace them
+# This is used to modify in place with sed -i -f <this-file> *.c
+/^void \(.*\)[(]klisp_State \*K,/{
+N
+N
+s/^void \(.*\)[(]klisp_State \*K,[[:space:]]*TValue \*xparams,[[:space:]]*TValue ptree,[[:space:]]*TValue denv[)][[:space:]]*[{]/void \1(klisp_State *K)\
+\{\
+ TValue *xparams = K->next_xparams;\
+ TValue ptree = K->next_value;\
+ TValue denv = K->next_env;\
+ klisp_assert(ttisenvironment(K->next_env));/
+}
+
+# keval_ofn was changed manually because the name of denv was env
+# (denv was reserved for the den param in ptree)
+# do_vau was changed manually because the name of ptree was obj
+# (ptree was reserved for the ptree param)
+# ffi_type_ref and ffi_type_ref were changed manually (were static)
diff --git a/src/rep_op_h.sed b/src/rep_op_h.sed
@@ -0,0 +1,31 @@
+# This is a collection of sed commands to refactor operatives underlying
+# functions to just take a kernel state pointer (instead of also taking extra
+# params, ptree and denv).
+
+# All these tests are run one at a time with sed -n
+
+# detect single line function definition
+# There are 97
+/^void \(.*\)[(]klisp_State \*K, TValue \*xparams, TValue ptree, TValue denv[)];/P
+
+# Replace them in place with sed -i -f <this-file> *.h
+#s/^void \(.*\)[(]klisp_State \*K, TValue \*xparams, TValue ptree, TValue denv[)];/void \1(klisp_State *K);/
+
+# All the single line definitions done
+
+# try to detect multi line function definition
+# There are 62
+#/^void \(.*\)[(]klisp_State \*K,/{
+#N
+#/^void \(.*\)[(]klisp_State \*K,[[:space:]]*TValue \*xparams,[[:space:]]*TValue ptree,[[:space:]]*TValue denv);/P
+#}
+
+# replace them
+# equalp had a type (was xparas instead of xparams), correct first
+s/xparas/xparams/
+/^void \(.*\)[(]klisp_State \*K,/{
+N
+s/^void \(.*\)[(]klisp_State \*K,[[:space:]]*TValue \*xparams,[[:space:]]*TValue ptree,[[:space:]]*TValue denv);/void \1(klisp_State *K);/
+}
+
+# Done!
+\ No newline at end of file
diff --git a/src/tests/bytevectors.k b/src/tests/bytevectors.k
@@ -0,0 +1,170 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of bytevector features.
+;;
+
+;; helper functions
+;;
+;; (list->bytevector INTEGERS) converts list of integers to bytevector
+;; The elements of INTEGERS must be in the range 0...255.
+;;
+;; (u8 X_0 X_1 ... X_{N-1}) returns a bytevector B of length N,
+;; such that B[k] = X_k
+;;
+;; (u16 X_0 X_1 ... X_{N-1}) returns a bytevector B of length 2N,
+;; such that the bytes B[2k], B[2k+1], combined into 16-bit
+;; unsigned integer, represent the number X_k
+;;
+;; (u32 X_0 X_1 ... X_{N-1}) returns a bytevector of length 4N
+;; such that the bytes B[4k] ... B[4k+3], combined into 32-bit
+;; unsigned integer, represent the number X_k
+;;
+($define! list->bytevector
+ ($lambda (bytes)
+ ($let*
+ ( (n (length bytes))
+ (v (make-bytevector n)) )
+ ($letrec
+ ((loop ($lambda (i xs)
+ ($if (<? i n)
+ ($sequence
+ (bytevector-u8-set! v i (car xs))
+ (loop (+ i 1) (cdr xs)))
+ #inert))))
+ (loop 0 bytes)
+ v))))
+
+($define! u8
+ ($lambda bytes (list->bytevector bytes)))
+
+;; TODO: endianess
+($define! u16
+ ($let
+ ((decompose ($lambda (w) (list (mod w 256) (div w 256)))))
+ ($lambda words
+ (list->bytevector (apply append (map decompose words))))))
+
+;; TODO: endianess
+($define! u32
+ ($let
+ ((decompose
+ ($lambda (w)
+ (list (mod w 256) (mod (div w 256) 256)
+ (mod (div w 65536) 256) (div w 16777216)))))
+ ($lambda words
+ (list->bytevector (apply append (map decompose words))))))
+
+
+;; XXX bytevector?
+
+($check-predicate (bytevector?))
+($check-predicate (bytevector? (make-bytevector 0)))
+($check-predicate (bytevector? (make-bytevector 1)))
+
+($check-not-predicate (bytevector? 0))
+($check-not-predicate (bytevector? ""))
+($check-not-predicate (bytevector? ()))
+
+;; XXX immutable-bytevector? mutable-bytevector?
+
+($check-predicate (immutable-bytevector?))
+($check-predicate (immutable-bytevector? (make-bytevector 0)))
+
+($check-predicate (mutable-bytevector?))
+($check-predicate (mutable-bytevector? (make-bytevector 1)))
+
+;; (R7RS 3rd draft, section 6.3.7) make-bytevector bytevector-length
+
+($check equal? (bytevector-length (make-bytevector 0)) 0)
+($check equal? (bytevector-length (make-bytevector 0 0)) 0)
+($check equal? (bytevector-length (make-bytevector 1)) 1)
+($check equal? (bytevector-length (make-bytevector 1 2)) 1)
+($check equal? (bytevector-length (make-bytevector 8192)) 8192)
+
+;; (R7RS 3rd draft, section 6.3.7) bytevector-u8-ref
+
+($check equal? (bytevector-u8-ref (make-bytevector 10 0) 1) 0)
+($check equal? (bytevector-u8-ref (make-bytevector 10 123) 5) 123)
+($check equal? (bytevector-u8-ref (make-bytevector 10 255) 9) 255)
+
+;; (R7RS 3rd draft, section 6.3.7) bytevector-u8-set!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let*
+ ((v (make-bytevector 10))
+ (w (bytevector->immutable-bytevector v)))
+ ($check equal? (bytevector-u8-set! v 0 1) #inert)
+ ($check equal? (bytevector-u8-ref v 0) 1)
+ ($check equal? (bytevector-u8-set! v 0 32) #inert)
+ ($check equal? (bytevector-u8-ref v 0) 32)
+ ($check equal? (bytevector-u8-set! v 6 42) #inert)
+ ($check equal? (bytevector-u8-ref v 0) 32)
+ ($check equal? (bytevector-u8-ref v 6) 42)
+ ($check-error (bytevector-u8-ref v -1))
+ ($check-error (bytevector-u8-ref v 10))
+ ($check-error (bytevector-u8-ref v 12345))
+ ($check-error (bytevector-u8-set! v -1 0))
+ ($check-error (bytevector-u8-set! v 10 255))
+ ($check-error (bytevector-u8-set! v 5 -1))
+ ($check-error (bytevector-u8-set! v 9 256))
+ ($check-error (bytevector-u8-set! v 9 #\x))
+ ($check-error (bytevector-u8-set! v 9 #f))
+ ($check-error (bytevector-u8-set! w 0 0)))
+
+;; (R7RS 3rd draft, section 6.3.7) bytevector-copy
+;;
+($check equal? (bytevector-copy (u8 1 2 3)) (u8 1 2 3))
+($check-predicate (mutable-bytevector? (bytevector-copy (u8 1 2 3))))
+
+($check-predicate
+ (mutable-bytevector?
+ (bytevector-copy (bytevector->immutable-bytevector (u8 1 2 3)))))
+
+;; XXX bytevector-copy!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let ((v (make-bytevector 5 0)))
+ ($check equal? (bytevector-copy! (u8 1 2 3 4 5) v) #inert)
+ ($check equal? v (u8 1 2 3 4 5))
+ ($check-no-error (bytevector-copy! (bytevector->immutable-bytevector (u8 9 9)) v))
+ ($check equal? v (u8 9 9 3 4 5))
+ ($check-error (bytevector-copy! (u8 1 2 3 4 5 6) v))
+ ($check-error
+ (bytevector-copy!
+ (u8 1)
+ (bytevector->immutable-bytevector (u8 1)))))
+
+;; (R7RS 3rd draft, section 6.3.7) bytevector-copy-partial
+
+($check equal? (bytevector-copy-partial (u8 1 2 3) 0 0) (u8))
+($check equal? (bytevector-copy-partial (u8 1 2 3) 0 2) (u8 1 2))
+($check equal? (bytevector-copy-partial (u8 1 2 3) 2 3) (u8 3))
+($check equal? (bytevector-copy-partial (u8 1 2 3) 3 3) (u8))
+($check-error (bytevector-copy-partial (u8 1 2 3) 2 4))
+($check-error (bytevector-copy-partial (u8 1 2 3) -1 0))
+
+;; R7RS 3rd draft, section 6.3.7) bytevector-copy-partial!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let*
+ ((v (make-bytevector 5 9))
+ (w (bytevector->immutable-bytevector v)))
+ ($check equal? (bytevector-copy-partial! (u8 1 2) 0 2 v 0) #inert)
+ ($check equal? v (u8 1 2 9 9 9))
+ ($check equal? (bytevector-copy-partial! (u8 5 6) 1 2 v 4) #inert)
+ ($check equal? v (u8 1 2 9 9 6))
+ ($check-error (bytevector-copy-partial! (u8 1 2) 0 2 v -1))
+ ($check-error (bytevector-copy-partial! (u8 1 2) 0 2 v 4))
+ ($check-error (bytevector-copy-partial! (u8 1 2) 2 3 v 0))
+ ($check-error (bytevector-copy-partial! (u8 1 2) -1 0 v 0))
+ ($check-error (bytevector-copy-partial! (u8 1 2) 0 2 w 0)))
+
+;; XXX bytevector->immutable-bytevector
+
+($check-predicate
+ (immutable-bytevector? (bytevector->immutable-bytevector (u8 1 2))))
+($check-not-predicate
+ (mutable-bytevector? (bytevector->immutable-bytevector (u8 1 2))))
diff --git a/src/tests/environments.k b/src/tests/environments.k
@@ -4,6 +4,399 @@
;;; Basic Functionality
;;;
-;; environment
+;; 4.8.1 environment?
+
($check-predicate (applicative? environment?))
-;; ....
+($check-predicate (environment?))
+($check-predicate (environment? (get-current-environment)))
+($check-not-predicate (environment? ()))
+
+;; 4.8.2 ignore?
+
+($check-predicate (applicative? ignore?))
+($check-predicate (ignore?))
+($check-predicate (ignore? #ignore))
+($check-not-predicate (ignore? #f))
+($check-not-predicate (ignore? 0))
+($check-not-predicate (ignore? ()))
+($check-not-predicate (ignore? #inert))
+($check-not-predicate (ignore? #undefined))
+
+;; 4.8.3 eval
+
+($check-predicate (applicative? eval))
+($check-error (eval))
+($check-error (eval 0))
+($check-error (eval 0 1))
+($check-error (eval 0 (get-current-environment) 2))
+
+($let*
+ ((env (make-environment))
+ ((encapsulate #ignore #ignore) (make-encapsulation-type))
+ (encapsulation (encapsulate 0))
+ (promise ($lazy (+ 1 1)))
+ (bytevector (make-bytevector 1)))
+ ($check eq? (eval #t env) #t)
+ ($check eq? (eval #inert env) #inert)
+ ($check eq? (eval () env) ())
+ ($check eq? (eval #ignore env) #ignore)
+ ($check eq? (eval env env) env)
+ ($check eq? (eval eval env) eval)
+ ($check eq? (eval $vau env) $vau)
+ ($check eq? (eval root-continuation env) root-continuation)
+ ($check eq? (eval encapsulation env) encapsulation)
+ ($check eq? (eval promise env) promise)
+ ($check eq? (eval 0 env) 0)
+ ($check eq? (eval "string" env) "string")
+ ($check eq? (eval #\c env) #\c)
+ ($check eq? (eval (get-current-input-port) env) (get-current-input-port))
+ ($check eq? (eval bytevector env) bytevector)
+ ($check-error (eval (string->symbol "eval") env))
+ ($check eq? (eval (list $quote 1) env) 1)
+ ($check equal? (eval (list + 1 1) env) 2)
+ ($check-error (eval (list* not? #t) env))
+ ($check-error (eval (list 1) env)))
+
+($let ((env ($bindings->environment (+ *))))
+ ($check equal? (eval ($quote (+ 1 1)) env) 1))
+
+;; 4.8.4 make-environment
+
+($check-predicate (applicative? make-environment))
+($check-predicate (environment? (make-environment)))
+($let*
+ ((x 0)
+ (e1 (make-environment))
+ (e2 (make-environment (get-current-environment)))
+ (e3 (make-environment e1))
+ (e4 (make-environment e2))
+ (es (list e1 e2 e3 e4)))
+ ($check-not-predicate ($binds? e1 x))
+ ($check-predicate ($binds? e2 x))
+ ($check-not-predicate ($binds? e3 x))
+ ($check-predicate ($binds? e4 x))
+ (encycle! es 1 3)
+ ($check-predicate ($binds? (apply make-environment es))))
+
+($check-not-predicate (eq? (make-environment) (make-environment)))
+($check-not-predicate (equal? (make-environment) (make-environment)))
+($check-not-predicate (equal? (make-environment) (get-current-environment)))
+
+;; 5.10.1 $let
+
+($check-predicate (operative? $let))
+($check equal? ($let () #t) #t)
+($check-error ($let (sym) #inert))
+($check-error ($let (sym 0) #inert))
+($check-error ($let loop ((x 0)) #inert))
+($check-error ($let ((sym 0 1)) #inert))
+
+($check-predicate
+ ($let
+ ((a (and?
+ (not? ($binds? (get-current-environment) a))
+ (not? ($binds? (get-current-environment) b))))
+ (b (and?
+ (not? ($binds? (get-current-environment) a))
+ (not? ($binds? (get-current-environment) b))))
+ (f ($lambda ()
+ (and?
+ (not? ($binds? (get-current-environment) f))
+ (not? ($binds? (get-current-environment) g)))))
+ (g ($lambda ()
+ (and?
+ (not? ($binds? (get-current-environment) f))
+ (not? ($binds? (get-current-environment) g))))))
+ (and? a b (f) (g))))
+
+;; 6.7.1 $binds?
+
+($check-predicate (operative? $binds?))
+($check-predicate ($binds? (make-environment)))
+
+;; 6.7.2 get-current-environment
+
+($check-predicate (applicative? get-current-environment))
+($check-predicate (environment? (get-current-environment)))
+($check-not-predicate ($binds? (get-current-environment) x))
+($let ((x 0))
+ ($check-predicate ($binds? (get-current-environment) x)))
+
+;; 6.7.3 make-kernel-standard-environment
+
+($check-predicate (applicative? make-kernel-standard-environment))
+
+($let ((x 0))
+ ($check-not-predicate
+ ($binds? (make-kernel-standard-environment) x)))
+
+;; symbols defined in the Kernel Report
+
+($check-predicate
+ ($binds? (make-kernel-standard-environment)
+ ;; 4.1 - 4.10
+ boolean?
+ eq?
+ equal?
+ symbol?
+ inert? $if
+ pair? null? cons
+ set-car! set-cdr! copy-es-immutable
+ environment? ignore? eval make-environment
+ $define!
+ operative? applicative? $vau wrap unwrap
+ ;; 5.1 - 5.10
+ $sequence
+ list list*
+ $vau $lambda
+ car cdr
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ apply
+ $cond
+ get-list-metrics list-tail
+ encycle!
+ map
+ $let
+ ;; 6.1 - 6.4, 6.7 - 6.9
+ not? and? or? $and? $or?
+ combiner?
+ length list-ref append list-neighbors filter
+ assoc member? finite-list? countable-list? reduce
+ append! copy-es assq memq?
+ $binds? get-current-environment make-kernel-standard-environment
+ $let* $letrec $letrec* $let-redirect $let-safe $remote-eval
+ $bindings->environment
+ $set! $provide! $import!
+ for-each
+ ;; 7.1 - 7.3
+ continuation? call/cc extend-continuation guard-continuation
+ continuation->applicative root-continuation error-continuation
+ apply-continuation $let/cc guard-dynamic-extent exit
+ ;; 8.1
+ make-encapsulation-type
+ ;; 9.1
+ promise? force $lazy memoize
+ ;; 10.1
+ make-keyed-dynamic-variable
+ ;; 11.1
+ make-keyed-static-variable
+ ;; 12.1 - 12.10
+ number? finite? integer?
+ =? <? <=? >=? >?
+ + * -
+ zero?
+ div mod div-and-mod
+ div0 mod0 div0-and-mod0
+ positive? negative?
+ odd? even?
+ abs
+ max min
+ lcm gcd
+ exact? inexact? robust? undefined?
+ get-real-internal-bounds get-real-exact-bounds
+ get-real-internal-primary get-real-exact-primary
+ make-inexact
+ real->inexact real->exact
+ with-strict-arithmetic get-strict-arithmetic?
+ ;; not implemented: with-narrow-arithmetic get-narrow-arithmetic?
+ rational?
+ /
+ numerator denominator
+ floor ceiling truncate round
+ rationalize simplest-rational
+ real?
+ exp log
+ sin cos tan asin acos atan
+ sqrt expt
+ ;; not implemented: complex?
+ ;; not implemented: make-rectangular real-part imag-part
+ ;; not implemented: make-polar magnitude angle
+ ;; 13.1
+ string->symbol
+ ;; 15.1 - 15.2
+ port?
+ input-port? output-port?
+ with-input-from-file with-output-to-file
+ get-current-input-port get-current-output-port
+ open-input-file open-output-file
+ close-input-file close-output-file
+ read
+ write
+ call-with-input-file call-with-output-file
+ load
+ get-module))
+
+;; Additional symbols defined in klisp.
+
+($check-predicate
+ ($binds? (make-kernel-standard-environment)
+ ;; symbols
+ symbol->string
+ ;; strings
+ string?
+ symbol->string
+ ;; TODO
+ ;; chars
+ char?
+ char=? char<? char<=? char>=? char>?
+ char->integer integer->char
+ ;; TODO
+ ;; ports
+ textual-port? binary-port?
+ with-error-to-file
+ get-current-error-port
+ open-binary-input-file open-binary-output-file
+ close-input-port close-output-port close-port
+ eof-object?
+ read-char peek-char char-ready? write-char
+ newline
+ display
+ read-u8 peek-u8 u8-ready? write-u8
+ flush-output-port
+ file-exists? delete-file rename-file
+ ;; system functions
+ current-second current-jiffy jiffies-per-second
+ ;; bytevectors
+ bytevector?
+ ;; error handling
+ error system-error-continuation))
+
+;; 6.7.4 $let*
+
+($check-predicate (operative? $let*))
+($check equal? ($let* () #f) #f)
+($check equal? ($let* () #f #t) #t)
+($check-error ($let* (sym) #inert))
+($check-error ($let* (sym 0) #inert))
+($check-error ($let* loop ((x 0)) #inert))
+($check-error ($let* ((sym 0 1)) #inert))
+
+($check-predicate
+ ($let*
+ ((a (and?
+ (not? ($binds? (get-current-environment) a))
+ (not? ($binds? (get-current-environment) b))
+ (not? ($binds? (get-current-environment) c))))
+ (b (and?
+ ($binds? (get-current-environment) a)
+ (not? ($binds? (get-current-environment) b))
+ (not? ($binds? (get-current-environment) c))))
+ (c (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) b)
+ (not? ($binds? (get-current-environment) c))))
+ (f ($lambda ()
+ (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) b)
+ ($binds? (get-current-environment) c)
+ (not? ($binds? (get-current-environment) f))
+ (not? ($binds? (get-current-environment) g)))))
+ (g ($lambda ()
+ (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) b)
+ ($binds? (get-current-environment) c)
+ ($binds? (get-current-environment) f)
+ (not? ($binds? (get-current-environment) g))))))
+ (and? a b c (f) (g))))
+
+;; 6.7.5 $letrec
+
+($check-predicate (operative? $letrec))
+($check-no-error ($letrec () #inert))
+
+($check-predicate
+ ($letrec ((x (not? ($binds? (get-current-environment) x)))) x))
+
+($check-predicate
+ ($letrec
+ ((f ($lambda ()
+ (and?
+ ($binds? (get-current-environment) f)
+ ($binds? (get-current-environment) g))))
+ (g ($lambda ()
+ (and?
+ ($binds? (get-current-environment) f)
+ ($binds? (get-current-environment) g)))))
+ (and? (f) (g))))
+
+;; 6.7.6 $letrec*
+
+($check-predicate (operative? $letrec*))
+($check equal? ($letrec* () 123) 123)
+
+($check-predicate
+ ($letrec* ((x (not? ($binds? (get-current-environment) x)))) x))
+
+($check-predicate
+ ($letrec*
+ ((a 1)
+ (f ($lambda ()
+ (and?
+ ($binds? (get-current-environment) a)
+ ($binds? (get-current-environment) f)))))
+ (f)))
+
+($check-predicate
+ ($letrec*
+ ((f ($lambda ()
+ ($binds? (get-current-environment) f)))
+ (g ($lambda ()
+ (and?
+ ($binds? (get-current-environment) f)
+ ($binds? (get-current-environment) g)))))
+ (and? (f) (g))))
+
+($check-predicate
+ ($letrec*
+ ((a 1)
+ (b 2)
+ (f ($lambda () ($binds? (get-current-environment) f))))
+ (f)))
+
+;; 6.7.7 $let-redirect
+
+($check-predicate (operative? $let-redirect))
+($check equal? ($let-redirect (make-environment) () 42) 42)
+
+($let
+ ((a 1)
+ (env ($let ((a 2)) (get-current-environment))))
+ ($check equal? ($let-redirect (get-current-environment) () a) 1)
+ ($check equal? ($let-redirect env () a) 2)
+ ($check equal? ($let-redirect env ((a 3)) a) 3)
+ ($check equal? ($let-redirect env ((a a)) a) 1))
+
+;; 6.7.8 $let-safe
+
+($check-predicate (operative? $let-safe))
+($check equal? ($let-safe () 42) 42)
+($let
+ (($lambda 42))
+ ($check equal? ($let-safe ((x $lambda)) (($lambda () x))) 42)
+ ($check-error ($let ((x $lambda)) (($lambda () x)))))
+
+;; 6.7.9 $remote-eval
+
+($check-predicate (operative? $remote-eval))
+($check equal? ($remote-eval 42 (make-environment)) 42)
+
+($let
+ ((e0 (make-kernel-standard-environment))
+ (e1 ($let ((or? not?)) (get-current-environment))))
+ ($check equal? ($remote-eval (or? #t) e0) #t)
+ ($check equal? ($remote-eval (or? #t) e1) #f))
+
+;; 6.7.10 $bindings->environment
+
+($check-predicate (operative? $bindings->environment))
+($check-predicate (environment? ($bindings->environment)))
+($let
+ ((env ($bindings->environment (a 1) (b 2))))
+ ($check-predicate ($binds? env a b))
+ ($check equal? (eval ($quote a) env) 1)
+ ($check equal? (eval ($quote b) env) 2))
diff --git a/src/tests/memory-ports.k b/src/tests/memory-ports.k
@@ -0,0 +1,98 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of string and bytevector port features.
+;;
+
+;; (R7RS 3rd draft, section 6.7.1) open-input-string
+;; TODO: char-ready?
+;; TODO: unicode input
+;; TODO: closing
+;;
+($let ((p (open-input-string "")))
+ ($check-predicate (port? p))
+ ($check-predicate (input-port? p))
+ ($check-not-predicate (output-port? p))
+ ($check-predicate (textual-port? p))
+ ($check-not-predicate (binary-port? p))
+ ($check-predicate (port-open? p))
+ ($check-predicate (eof-object? (peek-char p)))
+ ($check-predicate (eof-object? (read-char p))))
+
+($let ((p (open-input-string "abc")))
+ ($check equal? (read-char p) #\a)
+ ($check equal? (peek-char p) #\b)
+ ($check equal? (read-char p) #\b)
+ ($check equal? (read-char p) #\c)
+ ($check-predicate (eof-object? (read-char p))))
+
+($let ((p (open-input-string "(1 2 #ignore) \"x\"")))
+ ($check equal? (read p) (list 1 2 #ignore))
+ ($check equal? (read p) "x")
+ ($check-predicate (eof-object? (read p))))
+
+;; (R7RS 3rd draft, section 6.7.1) open-output-string get-output-string
+;; TODO: newline
+;;
+($let ((p (open-output-string)))
+ ($check-predicate (port? p))
+ ($check-predicate (output-port? p))
+ ($check-not-predicate (input-port? p))
+ ($check-predicate (textual-port? p))
+ ($check-not-predicate (binary-port? p))
+ ($check-predicate (port-open? p))
+ ($check equal? (get-output-string p) "")
+ ($check-no-error (write-char #\a p))
+ ($check equal? (get-output-string p) "a")
+ ($check-no-error (display "bc" p))
+ ($check equal? (get-output-string p) "abc")
+ ($check-no-error (write (list 1 "2" 3) p))
+ ($check equal? (get-output-string p) "abc(1 \"2\" 3)"))
+
+($check-error (get-output-string (get-current-input-port)))
+($check-error (get-output-string (get-current-output-port)))
+
+($let ((p (open-output-string)))
+ ($check-no-error (display (make-string 100 #\a) p))
+ ($check-no-error (display (make-string 1000 #\b) p))
+ ($check-no-error (display (make-string 10000 #\c) p))
+ ($check equal? (string-length (get-output-string p)) 11100)
+ ($check equal? (string-ref (get-output-string p) 11001) #\c))
+
+;; (R7RS 3rd draft, section 6.7.1) open-input-bytevector
+;; TODO: u8-ready?
+;; TODO: closing
+;;
+($let ((p (open-input-bytevector (make-bytevector 0))))
+ ($check-predicate (port? p))
+ ($check-predicate (input-port? p))
+ ($check-not-predicate (output-port? p))
+ ($check-predicate (binary-port? p))
+ ($check-not-predicate (textual-port? p))
+ ($check-predicate (eof-object? (peek-u8 p)))
+ ($check-predicate (eof-object? (read-u8 p))))
+
+($let*
+ ((v (make-bytevector 3 0))
+ (p ($sequence
+ (bytevector-u8-set! v 0 2)
+ (bytevector-u8-set! v 1 129)
+ (open-input-bytevector v))))
+ ($check equal? (read-u8 p) 2)
+ ($check equal? (peek-u8 p) 129)
+ ($check equal? (read-u8 p) 129)
+ ($check equal? (read-u8 p) 0)
+ ($check-predicate (eof-object? (read-u8 p))))
+
+;; (R7RS 3rd draft, section 6.7.1) open-output-bytevector get-output-bytevector
+
+($let ((p (open-output-bytevector)))
+ ($check equal? (bytevector-length (get-output-bytevector p)) 0)
+ ($check-no-error (write-u8 1 p))
+ ($check equal? (bytevector-length (get-output-bytevector p)) 1)
+ ($check-no-error (write-u8 10 p))
+ ($check-no-error (write-u8 129 p))
+ ($let ((v (get-output-bytevector p)))
+ ($check equal? (bytevector-length v) 3)
+ ($check equal? (bytevector-u8-ref v 0) 1)
+ ($check equal? (bytevector-u8-ref v 1) 10)
+ ($check equal? (bytevector-u8-ref v 2) 129)))
diff --git a/src/tests/ports.k b/src/tests/ports.k
@@ -2,6 +2,8 @@
;;
;; Tests of i/o features.
;;
+;; TODO binary ports
+;;
;; Utilities for testing input and output features:
;;
;; temp-file .......... temporary file for input and output
diff --git a/src/tests/strings.k b/src/tests/strings.k
@@ -131,9 +131,10 @@
;; immutable strings are eq? iff string=?
+;; substring generates mutable strings
;; Andres Navarro
($check-predicate
- ($let* ((p "abc") (q (substring p 0 3)))
+ ($let* ((p "abc") (q (string->immutable-string (substring p 0 3))))
(eq? p q)))
;; string-copy always generate mutable strings
@@ -142,8 +143,9 @@
($let* ((p (string-copy "abc")) (q (substring p 0 3)))
(eq? p q)))
+;; substring always generate mutable strings
($check-predicate (immutable-string? (substring "abc" 0 0)))
-($check-predicate (immutable-string? (substring "abc" 0 1)))
+($check-not-predicate (immutable-string? (substring "abc" 0 1)))
;; XXX string-append
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -1,9 +1,9 @@
(load "tests/check.k")
(load "tests/test-helpers.k")
-;(check-set-mode! check-mode-report)
+;; (check-set-mode! check-mode-report)
-;; TODO add applicative?/operative? check in pairs and lists and pair-mutation
+;; TODO add applicative?/operative? for all cominers in all test files
(load "tests/booleans.k")
(load "tests/eq-equal.k")
@@ -21,6 +21,9 @@
(load "tests/strings.k")
(load "tests/characters.k")
(load "tests/ports.k")
+(load "tests/memory-ports.k")
(load "tests/error.k")
+(load "tests/bytevectors.k")
+(load "tests/vectors.k")
(check-report)
diff --git a/src/tests/test-helpers.k b/src/tests/test-helpers.k
@@ -14,6 +14,9 @@
#inert)
denv)))
+;; mutable-pair?, immutable-pair?, mutable-string? & immutable-string?
+;; were added to the ground environment
+#|
($define! mutable-pair?
($lambda (obj)
($and? (pair? obj)
@@ -46,6 +49,9 @@
($define! immutable-string?
($lambda (obj) ($and? (string? obj) (not? (nonempty-mutable-string? obj)))))
+|#
+
+($define! nonempty-mutable-string? mutable-string?)
;; XXX/TODO Some of these could be removed if we had eager comprehension in
;; check.k (which would also complete the srfi-78 implementation). The problem
diff --git a/src/tests/vectors.k b/src/tests/vectors.k
@@ -0,0 +1,98 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of vector (heterogenous array) features.
+;;
+
+;; (R7RS 3rd draft 6.3.6) vector?
+
+($check-predicate (applicative? vector?))
+($check-predicate (vector?))
+($check-predicate (vector? (make-vector 0)))
+($check-predicate (vector? (make-vector 1)))
+
+($check-not-predicate (vector? 0))
+($check-not-predicate (vector? ""))
+($check-not-predicate (vector? ()))
+($check-not-predicate (vector? (make-bytevector 0)))
+($check-not-predicate (vector? (make-bytevector 1)))
+
+;; XXX immutable-vector? mutable-vector?
+
+($check-predicate (applicative? immutable-vector? mutable-vector?))
+
+($check-predicate (immutable-vector?))
+($check-predicate (immutable-vector? (make-vector 0)))
+($check-not-predicate (immutable-vector? (make-vector 1)))
+($check-not-predicate (immutable-vector? (make-bytevector 0)))
+
+($check-predicate (mutable-vector?))
+($check-predicate (mutable-vector? (make-vector 1)))
+($check-not-predicate (mutable-vector? (make-vector 0)))
+($check-not-predicate (mutable-vector? (make-bytevector 1)))
+
+;; (R7RS 3rd draft, section 6.3.6) make-vector vector-length
+
+($check-predicate (applicative? make-vector vector-length))
+($check equal? (vector-length (make-vector 0)) 0)
+($check equal? (vector-length (make-vector 0 "value")) 0)
+($check equal? (vector-length (make-vector 1)) 1)
+($check equal? (vector-length (make-vector 1 (list 1 2 3))) 1)
+($check equal? (vector-length (make-vector 8192)) 8192)
+
+;; (R7RS 3rd draft, section 6.3.6) vector
+
+($check-predicate (applicative? vector?))
+($check-predicate (vector? (vector)))
+($check-predicate (immutable-vector? (vector)))
+($check equal? (vector-length (vector)) 0)
+($check-predicate (mutable-vector? (vector "x" "y")))
+($check equal? (vector-length (vector "x" "y")) 2)
+
+;; (R7RS 3rd draft, section 6.3.6) vector-ref
+
+($check-predicate (applicative? vector-ref))
+($check equal? (vector-ref (make-vector 10 #t) 1) #t)
+($check equal? (vector-ref (make-vector 10 "abc") 5) "abc")
+($check equal? (vector-ref (make-vector 10 1/2) 9) 1/2)
+($check equal? (vector-ref (vector 1/2 1/3 1/4) 2) 1/4)
+
+;; (R7RS 3rd draft, section 6.3.6) vector-set!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+
+($check-predicate (applicative? vector-set!))
+
+($let*
+ ((v (make-vector 10))
+ (w (vector->immutable-vector v)))
+ ($check equal? (vector-set! v 0 1) #inert)
+ ($check equal? (vector-ref v 0) 1)
+ ($check equal? (vector-set! v 0 "abc") #inert)
+ ($check equal? (vector-ref v 0) "abc")
+ ($check equal? (vector-set! v 6 v) #inert)
+ ($check equal? (vector-ref v 0) "abc")
+ ($check eq? (vector-ref v 6) v)
+ ($check-error (vector-ref v -1))
+ ($check-error (vector-ref v 10))
+ ($check-error (vector-ref v 12345))
+ ($check-error (vector-set! v -1 0))
+ ($check-error (vector-set! v 10 1/2))
+ ($check-error (vector-set! w 0 #t)))
+
+;; (R7RS 3rd draft, section 6.3.6) list->vector, vector->list
+
+($check-predicate (applicative? list->vector))
+($check-predicate (immutable-vector? (list->vector ())))
+($check-predicate (mutable-vector? (list->vector (list "a" "b"))))
+
+;; (R7RS 3rd draft, section 6.3.6) vector-copy
+;; TODO: implement equal? for vectors first
+
+;; XXX vector->immutable-vector
+
+($check-predicate (applicative? vector->immutable-vector))
+
+($check-predicate
+ (immutable-vector? (vector->immutable-vector (vector 1 2))))
+($check-not-predicate
+ (mutable-vector? (vector->immutable-vector (vector 1 2))))
