commit 58aa1bb5f9a376eb6448f5249ffc12f377559641
parent 5a4381b470855c2038bea8c8f6de1f0b687671b3
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 6 Dec 2011 17:57:04 -0300
Merged (and closed) r7rs. All development will continue in default
Diffstat:
172 files changed, 10664 insertions(+), 7399 deletions(-)
diff --git a/TODO b/TODO
@@ -0,0 +1,58 @@
+* refactor:
+** double check combiner names to be verbs
+ (e.g. add get- where appropriate)
+** split kghelpers in appropriate parts
+ (e.g. create knumber.h knumber.c and move there kfinitep, kintegerp, etc
+ from kgnumbers)
+** use some convention for ground operative underlaying function names
+ maybe add "kgop_"
+** use a better convention for continuation underlaying function names
+** try to use krooted_vars_push more to save some lines and avoid
+ clutter (e.g. when creating continuations)
+** Study differrent c interfaces (maybe a stack like in lua would be
+ better than dealing with gc push/pop)
+** eliminate all remaining char * arguments where not needed
+** remove most of inline declarations, we may then add some
+ back after proper profiling
+** standarize either int32_t (now used in lists) or uint32_t (now used
+ in strings, vectors and bytevectors) for sizes (and maybe use a
+ typedef like lua)
+* fix:
+** fix char-ready? and u8-ready? (r7rs)
+* documentation
+** update the manual with the current features
+** add a section to the manual with the interpreter usage
+* reader/writer
+** syntax support for complex numbers (Kernel report)
+* library
+** some simplified error guarding (r7rs)
+** $case (r7rs)
+** $case-lambda + $case-vau (r7rs)
+** $named-let + $do (r7rs)
+** $define-record-type (r7rs)
+** eager comprehensions (at least for check.k) see SRFIs 42 and 78
+ (srfi)
+* other
+** restarts (r7rs/common lisp)
+** add restart support to the repl/interpreter (r7rs)
+** simple modules (something inspired in r7rs) (r7rs)
+** add modules support to the interpreter (r7rs)
+** complex numbers (Kernel report)
+** interval arithmetic (Kernel report)
+* reduce binary size
+** currently (2011/12/05) is 3megs... most of it from kg*.o
+** 1st culprite klisp_assert:
+** almost 1 meg comes from klisp_asserts, asserts also add
+ considerably to the compilation time
+** add a flag to enable assertions (maybe debug) and disable
+ it by default
+** fix warnings when assertions are turned off (probably unitialized
+ uses, unused variables, etc)
+** 2nd culprite debugging symbols:
+** 1 meg and a half comes from debugging symbols, they also add to
+ the compilation time
+** add a flag (maybe the same as for asserts, maybe another one) to
+ include debug symbols and disable it by default
+** After removing asserts & symbols the size is reduced to a more
+ manageable 500k, however it would be nice to bring that even
+ lower
diff --git a/manual/html/A-Sample-Applicative-Description.html b/doc/html/A-Sample-Applicative-Description.html
diff --git a/manual/html/Acknowledgements.html b/doc/html/Acknowledgements.html
diff --git a/manual/html/Alphabetical-Index.html b/doc/html/Alphabetical-Index.html
diff --git a/manual/html/Booleans.html b/doc/html/Booleans.html
diff --git a/manual/html/Caveats.html b/doc/html/Caveats.html
diff --git a/manual/html/Characters.html b/doc/html/Characters.html
diff --git a/manual/html/Combiners.html b/doc/html/Combiners.html
diff --git a/doc/html/Continuations.html b/doc/html/Continuations.html
@@ -0,0 +1,238 @@
+<html lang="en">
+<head>
+<title>Continuations - klisp Reference Manual</title>
+<meta http-equiv="Content-Type" content="text/html">
+<meta name="description" content="klisp Reference Manual">
+<meta name="generator" content="makeinfo 4.13">
+<link title="Top" rel="start" href="index.html#Top">
+<link rel="prev" href="Combiners.html#Combiners" title="Combiners">
+<link rel="next" href="Encapsulations.html#Encapsulations" title="Encapsulations">
+<link href="http://www.gnu.org/software/texinfo/" rel="generator-home" title="Texinfo Homepage">
+<meta http-equiv="Content-Style-Type" content="text/css">
+<style type="text/css"><!--
+ pre.display { font-family:inherit }
+ pre.format { font-family:inherit }
+ pre.smalldisplay { font-family:inherit; font-size:smaller }
+ pre.smallformat { font-family:inherit; font-size:smaller }
+ pre.smallexample { font-size:smaller }
+ pre.smalllisp { font-size:smaller }
+ span.sc { font-variant:small-caps }
+ span.roman { font-family:serif; font-weight:normal; }
+ span.sansserif { font-family:sans-serif; font-weight:normal; }
+--></style>
+</head>
+<body>
+<div class="node">
+<a name="Continuations"></a>
+<p>
+Next: <a rel="next" accesskey="n" href="Encapsulations.html#Encapsulations">Encapsulations</a>,
+Previous: <a rel="previous" accesskey="p" href="Combiners.html#Combiners">Combiners</a>,
+Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
+<hr>
+</div>
+
+<!-- node-name, next, previous, up -->
+<h2 class="chapter">9 Continuations</h2>
+
+<p><a name="index-continuations-126"></a>
+ A continuation is a plan for all future computation, parameterized
+by a value to be provided, and contingent on the states of all mutable
+data structures (which notably may include environments). When the
+Kernel evaluator is invoked, the invoker provides a continuation to
+which the result of the evaluation will normally be returned.
+
+ <p>For example, when <code>$if</code> evaluates its test operand, the
+continuation provided for the result expects to be given a boolean
+value; and, depending on which boolean it gets, it will evaluate
+either the consequent or the alternative operand as a tail context —
+that is, the continuation provided for the result of evaluating the
+selected operand is the same continuation that was provided for the
+result of the call to <code>$if</code>.
+
+ <p>A Kernel program may sometimes capture a continuation; that is,
+acquire a reference to it as a first-class object. The basic means of
+continuation capture is applicative <code>call/cc</code>. Given a
+first-class continuation <code>c</code>, a combiner can be constructed that
+will abnormally pass its operand tree to <code>c</code> (as opposed to the
+<!-- TODO add xref to abnormal pass -->
+normal return of values to continuations). In the simplest case, the
+abnormally passed value arrives at <code>c</code> as if it had been normally
+returned to <code>c</code>. In general, continuations bypassed by the
+abnormal pass may have entry/exit guards attached to them, and these
+guards can intercept the abnormal pass before it reaches <code>c</code>.
+Each entry/exit guard consists of a selector continuation, which
+designates which abnormal passes the guard will intercept, and an
+interceptor applicative that performs the interception when selected.
+<!-- TODO add xref to guard-continuation, continuation->applicative -->
+<!-- and abnormal pass -->
+
+ <p>Continuations are immutable, and are <code>equal?</code> iff <code>eq?</code>.
+The continuation type is encapsulated.
+
+<!-- TODO add dynamic extent & guard selection/interception to the intro -->
+<div class="defun">
+— Applicative: <b>continuation?</b> (<var>continuation? . objects</var>)<var><a name="index-continuation_003f-127"></a></var><br>
+<blockquote><p> The primitive type predicate for type continuation.
+<code>continuation?</code> returns true iff all the objects in
+<code>objects</code> are of type continuation.
+</p></blockquote></div>
+
+<div class="defun">
+— Applicative: <b>call/cc</b> (<var>call/cc combiner</var>)<var><a name="index-call_002fcc-128"></a></var><br>
+<blockquote><p> Calls <code>combiner</code> in the dynamic environment as a tail context,
+passing as sole operand to it the continuation to which <code>call/cc</code>
+would normally return its result. (That is, constructs such a
+combination and evaluates it in the dynamic environment.)
+<!-- TODO add xref Cf. operative $let/cc , §7.3.2. -->
+</p></blockquote></div>
+
+<div class="defun">
+— Applicative: <b>extend-continuation</b> (<var>extend-continuation continuation applicative </var>[<var>environment</var>])<var><a name="index-extend_002dcontinuation-129"></a></var><br>
+<blockquote><p> The <code>extend-continuation</code> applicative constructs and returns a
+new child of <code>continuation</code> that, when it normally receives a
+value v, calls the underlying combiner of <code>applicative</code> with
+dynamic environment <code>environment</code> (or an empty environment if
+none was specified) and operand tree <code>v</code>, the result of the call
+normally to be returned to <code>continuation</code>.
+
+ <p>The following equivalnece defines the short version:
+ <pre class="example"> (extend-continuation c a) ==
+ (extend-continuation c a (make-environment))
+</pre>
+ </blockquote></div>
+
+<div class="defun">
+— Applicative: <b>guard-continuation</b> (<var>guard-continuation entry-guards continuation exit-guards</var>)<var><a name="index-guard_002dcontinuation-130"></a></var><br>
+<blockquote><p> <code>entry-guards</code> and <code>exit-guards</code> should each be a list of
+clauses; each clause should be a list of length two, whose first
+element is a continuation, and whose second element is an applicative
+whose underlying combiner is operative.
+
+ <p>Applicative <code>guard-continuation</code> constructs two continuations:
+a child of continuation, called the <code>outer continuation</code>; and a
+child of the <code>outer continuation</code>, called the <code>inner
+continuation</code>. The <code>inner continuation</code> is returned as the
+result of the call to <code>guard-continuation</code>.
+
+ <p>When the <code>inner continuation</code> normally receives a value, it
+passes the value normally to the <code>outer continuation</code>; and when
+the <code>outer continuation</code> normally receives a value, it passes the
+value normally to <code>continuation</code>. Thus, in the absence of
+abnormal passing, the inner and outer continuations each have the same
+behavior as <code>continuation</code>.
+
+ <p>The two elements of each guard clause are called, respectively, the
+<code>selector</code> and the <code>interceptor</code>. The <code>selector</code>
+continuation is used in deciding whether to intercept a given abnormal
+pass, and the <code>interceptor</code> applicative is called to perform
+<!-- TODO add xref to selection and interception -->
+customized action when interception occurs.
+
+ <!-- TODO add xref to evaluation structure -->
+ <p>At the beginning of the call to <code>guard-continuation</code>, internal
+copies are made of the evaluation structures of <code>entry-guards</code>
+and <code>exit-guards</code>, so that the selectors and interceptors
+contained in the arguments at that time remain fixed thereafter,
+independent of any subsequent mutations to the arguments.
+</p></blockquote></div>
+
+<div class="defun">
+— Applicative: <b>continuation->applicative</b> (<var>continuation->applicative continuation</var>)<var><a name="index-continuation_002d_003eapplicative-131"></a></var><br>
+<blockquote><p> Returns an applicative whose underlying operative abnormally passes
+its operand tree to <code>continuation</code>, thus: A series of
+interceptors are selected to handle the abnormal pass, and a
+continuation is derived that will normally perform all the
+interceptions in sequence and pass some value to the destination of
+the originally abnormal pass. The operand tree is then normally
+passed to the derived continuation.
+<!-- TODO add xref to selection and interception -->
+</p></blockquote></div>
+
+<div class="defun">
+— Variable: <b>root-continuation</b><var><a name="index-root_002dcontinuation-132"></a></var><br>
+<blockquote><p> This continuation is the ancestor of all other continuations. When
+it normally receives a value, it terminates the Kernel session. (For
+example, if the system is running a read-eval-print loop, it exits the
+loop.)
+<!-- TODO add xref Cf. applicative exit, §7.3.4. -->
+</p></blockquote></div>
+
+<div class="defun">
+— Variable: <b>error-continuation</b><var><a name="index-error_002dcontinuation-133"></a></var><br>
+<blockquote><p> The dynamic extent of this continuation is mutually disjoint from
+the dynamic extent in which Kernel computation usually occurs (such as
+the dynamic extent in which the Kernel system would run a
+read-eval-print loop).
+
+ <p>When this continuation normally receives a value, it provides a
+diagnostic message to the user of the Kernel system, on the assumption
+that the received value is an attempt to describe some error that
+aborted a computation; and then resumes operation of the Kernel system
+at some point that is outside of all user-defined computation. (For
+example, if the system is running a read-eval-print loop, operation
+may resume by continuing from the top of the loop.)
+
+ <p>The diagnostic message is not made available to any Kernel
+computation, and is therefore permitted to contain information that
+violates abstractions within the system.
+
+ <!-- TODO add details about klisp error messages -->
+ <p>When an error is signaled during a Kernel computation, the signaling
+action consists of an abnormal pass to some continuation in the
+dynamic extent of <code>error-continuation</code>.
+</p></blockquote></div>
+
+<div class="defun">
+— Applicative: <b>apply-continuation</b> (<var>apply-continuation continuation object</var>)<var><a name="index-apply_002dcontinuation-134"></a></var><br>
+<blockquote><p> Applicative <code>apply-continuation</code> converts its first argument to
+an applicative as if by <code>continuation->applicative</code>, and then
+applies it as usual.
+
+ <p>That is:
+ <pre class="example"> (apply-continuation continuation object) ==
+ (apply (continuation->applicative continuation) object)
+</pre>
+ </blockquote></div>
+
+<div class="defun">
+— Operative: <b>(</b><var>$let/cc <symbol> . <objects></var>)<var><a name="index-g_t_0028-135"></a></var><br>
+<blockquote><p> A child environment <code>e</code> of the dynamic environment is created,
+containing a binding of <code><symbol></code> to the continuation to which
+the result of the call to <code>$let/cc</code> should normally return; then,
+the subexpressions of <code><objects></code> are evaluated in <code>e</code> from
+left to right, with the last (if any) evaluated as a tail context, or
+if <code><objects></code> is empty the result is inert.
+
+ <p>That is:
+ <pre class="example"> ($let/cc symbol . objects) ==
+ (call/cc ($lambda (symbol) . objects))
+</pre>
+ </blockquote></div>
+
+<div class="defun">
+— Applicative: <b>guard-dynamic-extent</b> (<var>guard-dynamic-extent entry-guards combiner exit-guards</var>)<var><a name="index-guard_002ddynamic_002dextent-136"></a></var><br>
+<blockquote><p> This applicative extends the current continuation with the specified
+guards, and calls <code>combiner</code> in the dynamic extent of the new
+continuation, with no operands and the dynamic environment of the call
+to <code>guard-dynamic-extent</code>.
+</p></blockquote></div>
+
+<div class="defun">
+— Applicative: <b>exit</b> (<var>exit </var>[<var>object</var>])<var><a name="index-exit-137"></a></var><br>
+<blockquote><!-- TODO add xref -->
+ <p>Applicative <code>exit</code> initiates an abnormal transfer of
+<code>object</code> (or <code>#inert</code> if <code>object</code> was not specified),
+to <code>root-continuation</code>.
+ That is:
+ <pre class="example"> (exit) == (apply-continuation root-continuation #inert)
+ (exit obj) == (apply-continuation root-continuation obj)
+</pre>
+ <p>SOURCE NOTE: This applicative doesn't have the optional argument in
+the report. It was added to klisp to allow a simple way to terminate
+the interpreter passing a value that is then tried to convert to an
+exit status.
+</p></blockquote></div>
+
+<!-- *-texinfo-*- -->
+ </body></html>
+
diff --git a/manual/html/Control.html b/doc/html/Control.html
diff --git a/manual/html/Conventions.html b/doc/html/Conventions.html
diff --git a/manual/html/Encapsulations.html b/doc/html/Encapsulations.html
diff --git a/manual/html/Environments.html b/doc/html/Environments.html
diff --git a/manual/html/Equivalence.html b/doc/html/Equivalence.html
diff --git a/manual/html/Error-Messages.html b/doc/html/Error-Messages.html
diff --git a/manual/html/Evaluation-Notation.html b/doc/html/Evaluation-Notation.html
diff --git a/manual/html/Format-of-Descriptions.html b/doc/html/Format-of-Descriptions.html
diff --git a/manual/html/Introduction.html b/doc/html/Introduction.html
diff --git a/manual/html/Kernel-History.html b/doc/html/Kernel-History.html
diff --git a/manual/html/Keyed-Variables.html b/doc/html/Keyed-Variables.html
diff --git a/manual/html/License.html b/doc/html/License.html
diff --git a/manual/html/Numbers.html b/doc/html/Numbers.html
diff --git a/manual/html/Pairs-and-lists.html b/doc/html/Pairs-and-lists.html
diff --git a/manual/html/Ports.html b/doc/html/Ports.html
diff --git a/manual/html/Printing-Notation.html b/doc/html/Printing-Notation.html
diff --git a/manual/html/Promises.html b/doc/html/Promises.html
diff --git a/manual/html/Some-Terms.html b/doc/html/Some-Terms.html
diff --git a/manual/html/Strings.html b/doc/html/Strings.html
diff --git a/manual/html/Symbols.html b/doc/html/Symbols.html
diff --git a/manual/html/index.html b/doc/html/index.html
diff --git a/doc/klisp.1 b/doc/klisp.1
@@ -0,0 +1,198 @@
+.TH KLISP 1 "$Date: 2011/11/23 06:35:03 $"
+.SH NAME
+klisp \- Kernel Programming Language interpreter
+.SH SYNOPSIS
+.B klisp
+[
+.I options
+]
+[
+.I script
+[
+.I args
+]
+]
+.SH DESCRIPTION
+.B klisp
+is a stand-alone klisp interpreter for
+the Kernel Programming Language.
+It loads and evaluates Kernel programs
+in textual source form.
+.B klisp
+can be used as a batch interpreter and also interactively.
+.LP
+The given
+.I options
+(see below)
+are evaluated and then
+the klisp program in file
+.I script
+is loaded and evaluated.
+All evaluations mentioned, including the initialization
+that is described below, take place in the same
+(initially) standard environment. All values that
+result from these evaluation are discarded, but
+if the root continuation or error continuation
+are passed a value, the evaluation of options
+is interrupted and the EXIT_STATUS is as described
+in the corresponding section.
+The string
+.I script
+together with all
+.I args
+are available as a list of strings
+via the applicative
+.RI ' get-script-arguments '.
+If these arguments contain spaces or other characters special to the shell,
+then they should be quoted
+(but note that the quotes will be removed by the shell).
+The complete command line
+including the name of the interpreter, options,
+the script, and its arguments
+are available as a list of strings
+via the applicative
+.RI ' get-interpreter-arguments '.
+.LP
+At the very beginning,
+before even handling the command line,
+.B klisp
+reads and evaluates the contents of the environment variable
+.BR KLISP_INIT ,
+if it is defined.
+To use an init file, just define
+.B KLISP_INIT
+to the following form
+.RI '(load
+"/path/to/init-file")'.
+.LP
+Options start with
+.B '\-'
+and are described below.
+You can use
+.B "'\--'"
+to signal the end of options.
+.LP
+If no arguments are given,
+then
+.B "\-v \-i"
+is assumed when the standard input is a terminal;
+otherwise,
+.B "\-"
+is assumed.
+.LP
+In interactive mode,
+.B klisp
+prompts the user,
+reads expressions from the standard input,
+and evaluates them as they are read.
+The default prompt is "klisp> ".
+.SH OPTIONS
+.TP
+.B \-
+load and execute the standard input as a file,
+that is,
+not interactively,
+even when the standard input is a terminal.
+.TP
+.BI \-e " expr"
+evaluate expression
+.IR expr .
+You need to quote
+.I expr
+if it contains spaces, quotes,
+or other characters special to the shell.
+.TP
+.B \-i
+enter interactive mode after
+.I script
+is executed.
+.TP
+.BI \-l " name"
+evaluate
+.BI (load " name")
+before
+.I script
+is executed.
+Typically used to do environment initialization.
+.TP
+.BI \-r " name"
+evaluate
+.BI (require " name")
+before
+.I script
+is executed.
+Typically used to load libraries.
+.TP
+.B \-v
+show version information.
+.SH EXIT STATUS
+If the
+.I script
+or
+.I stdin
+reach EOF or if there is no script,
+.B EXIT_SUCCESS
+is returned.
+If the root continuation is passed an object during
+init, arguments or script evaluation
+.B EXIT_FAILURE
+is returned.
+If the
+.I root-continuation
+is passed an object,
+.B klisp
+tries to convert the value passed to the
+.I root-continuation
+to an exit status as follows:
+.TP
+If the value is an integer it is used as exit status.
+.TP
+If the value is a boolean then
+.B EXIT_SUCCESS
+is returned for
+.I #t
+and
+.B EXIT_FAILURE
+for
+.I #f.
+.TP
+If the value is inert, then
+.B EXIT_SUCCESS
+is returned.
+.TP
+In any other case
+.B EXIT_FAILURE
+is returned.
+.SH ENVIRONMENT
+.br
+.TP
+.BI KLISP_INIT
+.br
+A Kernel expression to be evaluated before
+any arguments to the interpreter.
+.br
+To use an init file, just define
+.B KLISP_INIT
+to the following form
+.RI '(load
+"/path/to/init-file")'.
+.br
+.TP
+.BI KLISP_PATH
+.br
+A colon separated list of templates for
+controlling the search of required files.
+Each template can use the char '?' to
+be replaced by the required name at run-time.
+.SH "SEE ALSO"
+.br
+http://klisp.org/
+.br
+The klisp Manual (info & html versions available).
+.SH DIAGNOSTICS
+Error messages should be self explanatory.
+.SH AUTHORS
+Andres Navarro
+and
+Oto Havle
+.\" EOF
diff --git a/doc/klisp.info b/doc/klisp.info
@@ -0,0 +1,2840 @@
+This is ../klisp.info, produced by makeinfo version 4.13 from
+klisp.texi.
+
+This file documents klisp.
+
+ This is edition 0.2 of the klisp Reference Manual, for klisp version
+0.2.
+
+ Copyright (C) 2011 Andres Navarro
+
+ Permission is granted to copy and distribute this manual, in whole or
+in part, without fee. Please note that most text of this manual is
+derived from `The Revised(-1) Report on the Kernel Programming
+Language' by John N. Shutt. There's a clause in that reports, under
+the header "Permission to copy this report", that reads:
+
+ This report is intended to belong to the programming community,
+ and so permission is granted to copy it in whole or in part
+ without fee.
+
+
+File: klisp.info, Node: Top, Next: License, Prev: (dir), Up: (dir)
+
+ This Info file contains edition 0.2 of the klisp Reference Manual,
+corresponding to klisp version 0.2.
+
+ Copyright (C) 2011 Andres Navarro
+
+ Permission is granted to copy and distribute this manual, in whole or
+in part, without fee. Please note that most text of this manual is
+derived from `The Revised(-1) Report on the Kernel Programming
+Language' by John N. Shutt. There's a clause in that reports, under
+the header "Permission to copy this report", that reads:
+
+ This report is intended to belong to the programming community,
+ and so permission is granted to copy it in whole or in part
+ without fee.
+
+* Menu:
+
+* License:: Conditions for copying and changing klisp.
+* Introduction:: Introduction and conventions used.
+* Booleans:: Booleans module features.
+* Equivalence:: Equivalence (under & up to) mutation modules features.
+* Symbols:: Symbols module features.
+* Control:: Control module features.
+* Pairs and lists:: Pairs and lists and Pair mutation modules features.
+* Environments:: Environments and Environment mutation modules features.
+* Combiners:: Combiners module features.
+* Continuations:: Continuations module features.
+* Encapsulations:: Encapsulations module features.
+* Promises:: Promises module features.
+* Keyed Variables:: Keyed (dynamic & static) variables module features.
+* Numbers:: Numbers module features.
+* Strings:: Strings module features.
+* Characters:: Characters module features.
+* Ports:: Ports module features.
+* Alphabetical Index:: Index including concepts, functions, variables,
+ and other terms.
+
+
+File: klisp.info, Node: License, Next: Introduction, Prev: Top, Up: Top
+
+ klisp is licensed under the terms of the MIT license reproduced
+below. This means that klisp is free software and can be used for both
+academic and commercial purposes at absolutely no cost. The two
+projects whose code klisp uses, Lua & IMath, are also distributed under
+the MIT license.
+
+ * klisp Parts: Copyright (C) 2011 Andres Navarro, Oto Havle.
+
+ * Lua Parts: Copyright (C) 1994-2010 Lua.org, PUC-Rio.
+
+ * IMath Parts: Copyright (C) 2002-2007 Michael J. Fromberger.
+
+ * srfi-78: Copyright (C) 2005-2006 Sebastian Egner.
+
+MIT/X11 License
+***************
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+ The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+
+File: klisp.info, Node: Introduction, Next: Booleans, Prev: License, Up: Top
+
+1 Introduction
+**************
+
+klisp is an open source interpreter for the Kernel Programming
+Language. It aims at being comprehensive and robust as specified in
+the `Revised(-1) Report on the Kernel Programming Language', but that
+probably won't happen for some time. It is written in C99 under the
+MIT license. It draws heavily from the Lua interpreter source code &
+file structure. It uses the IMath library for arbitrary sized integers
+and rationals.
+
+ The Kernel programming language is a statically scoped and properly
+tail-recursive dialect of Lisp, descended from Scheme. It is designed
+to be simpler and more general than Scheme, with an exceptionally
+clear, simple, and versatile semantics, only one way to form compound
+expressions, and no inessential restrictions on the power of that one
+compound form. Imperative, functional, and message-passing programming
+styles (to name a few) may be conveniently expressed in Kernel.
+
+ An important property of Kernel is that all manipulable entities in
+Kernel are first-class objects. In particular, Kernel has no
+second-class combiners; instead, the roles of special forms and macros
+are subsumed by operatives, which are first-class, statically scoped
+combiners that act directly on their unevaluated operands. Kernel also
+has a second type of combiners, applicatives, which act on their evalu-
+ated arguments. Applicatives are roughly equivalent to Scheme
+procedures. However, an applicative is nothing more than a wrapper to
+induce operand evaluation, around an underlying operative (or, in
+principle, around another applicative, though that isn’t usually done);
+applicatives themselves are mere facilitators to computation.
+
+ You can read more about Kernel at
+`http://web.cs.wpi.edu/~jshutt/kernel.html'.
+
+ klisp is freely available for both academic and commercial purposes.
+See LICENSE for details. it can be downloaded at
+`https://bitbucket.org/AndresNavarro/klisp'
+
+ klisp is developed by Andres Navarro, a Computer Science
+undergraduate at Buenos Aires University (UBA). You can reach him at
+<canavarro82@gmail.com>. Significant contributions are being done by
+Oto Havle, his fork is at `https://bitbucket.org/havleoto/klisp'.
+
+ This manual describes klisp version 0.2, presuming some familiarity
+with the Lisp family of languages in general, and with the Kernel
+Programming Language in particular. There are frequent references to
+the Kernel Programming Language Report. Unlike in the report, no
+rationale is provided for any feature, only a description of the
+implemented functionality.
+
+ This is edition 0.2.
+
+* Menu:
+
+* Caveats:: Flaws and a request for help.
+* Kernel History:: Kernel is descended from Scheme.
+* Conventions:: How the manual is formatted.
+* Acknowledgements:: Contributions to this manual.
+
+
+File: klisp.info, Node: Caveats, Next: Kernel History, Prev: Introduction, Up: Introduction
+
+1.1 Caveats
+===========
+
+This is the first draft of this manual. It will be incomplete for some
+time. It will also evolve, together with klisp and the Kernel
+Programming Language, both of which, right now, are in a quite fluid
+state.
+
+ The main reference on Kernel is the preliminary report: `Revised(-1)
+Report on the Kernel Programming Language'. Some sections of the
+report are still incomplete, so both klisp and this manual will use
+specifications from other languages in these sections, trying to follow
+the Kernel spirit. These instances will be documented throughout the
+manual.
+
+ Please mail comments and corrections to <canavarro82@gmail.com>.
+
+
+ -Andres Navarro
+
+
+File: klisp.info, Node: Kernel History, Next: Conventions, Prev: Caveats, Up: Introduction
+
+1.2 Kernel History
+==================
+
+The Kernel Programming Language is a work in progress. It is being
+developed by John N. Shutt, Ph.D, who created it while studying at the
+Worcester Polytechnic Institute (I think about 2002, or so... ASK). It
+is descended from scheme, with the idea that all objects should be
+first class values. In particular, Kernel replaces macros with
+operatives (kinda like statically scoped fexprs and fsubrs) and has
+first class environments. Kernel also has the notion of encapsulated
+objects which limits the ammount of information an implementation can
+share with a Kernel program (e.g. There is no way in Kernel to get the
+parents or a complete list of bindings of an environment object).
+
+ The main reference on Kernel is the preliminary report: `Revised(-1)
+Report on the Kernel Programming Language'. Some sections of the
+report are still incomplete, so both klisp and this manual will use
+specifications from other languages in these sections, trying to follow
+the Kernel spirit. These instances will be documented throughout the
+manual.
+
+ You can read all about Kernel at John's homepage at WPI
+`http://www.cs.wpi.edu/~jshutt/', including the preliminary report on
+the language and his doctoral dissertation which gives a theorethical
+frame for fexprs. You can contact him at <jshutt@cs.wpi.edu>.
+
+
+File: klisp.info, Node: Conventions, Next: Acknowledgements, Prev: Kernel History, Up: Introduction
+
+1.3 Conventions
+===============
+
+This section explains the notational conventions that are used in this
+manual. You may want to skip this section and refer back to it later.
+
+* Menu:
+
+* Some Terms:: Explanation of terms we use in this manual.
+* Evaluation Notation:: The format we use for examples of evaluation.
+* Printing Notation:: The format we use for examples that print output.
+* Error Messages:: The format we use for examples of errors.
+* Format of Descriptions:: Notation for describing functions, variables, etc.
+
+
+File: klisp.info, Node: Some Terms, Next: Evaluation Notation, Prev: Conventions, Up: Conventions
+
+1.3.1 Some Terms
+----------------
+
+Throughout this manual, the phrases "the Kernel reader" and "the Kernel
+printer" are used to refer to those routines in Lisp that convert
+textual representations of Kernel objects into actual objects, and vice
+versa. XXX Printed Representation XXX, for more details. You, the
+person reading this manual, are assumed to be "the programmer" or "the
+user".
+
+ Examples of Kernel code appear in this font or form: `(list 1 2 3)'.
+Names that represent arguments or metasyntactic variables appear in
+this font or form: FIRST-NUMBER.
+
+
+File: klisp.info, Node: Evaluation Notation, Next: Printing Notation, Prev: Some Terms, Up: Conventions
+
+1.3.2 Evaluation Notation
+-------------------------
+
+When you evaluate a piece of Kernel code, it produces a result. In the
+examples in this manual, this is indicated with `=>':
+
+ (car (cons 1 2))
+ => 1
+
+You can read this as "`(car (cons 1 2))' evaluates to 1".
+
+ The semantics of a language feature are sometimes clarified, or even
+defined, in its entry by specifying that two expressions are
+equivalent. This is notated with `=='. For example, the semantics of
+applicative list* can be defined by following equivalences:
+ (list* arg1) == arg1
+ (list* arg1 . more-args) == (cons arg1 (list* . more-args))
+ Notice that in these kind of examples the applicatives or operatives
+referred to are the first class values and not the symbols bound to
+them in the ground environment. This definition would hold even if
+`cons' or `list*' were redefined in the current dynamic environment.
+
+
+File: klisp.info, Node: Printing Notation, Next: Error Messages, Prev: Evaluation Notation, Up: Conventions
+
+1.3.3 Printing Notation
+-----------------------
+
+Many of the examples in this manual print text when they are evaluated.
+In examples that print text, the printed text is indicated with `-|'.
+The value returned by evaluating the form (here `#t') follows on a
+separate line.
+
+ ($sequence (write 1) (write 2) #t)
+ -| 1
+ -| 2
+ => #t
+
+
+File: klisp.info, Node: Error Messages, Next: Format of Descriptions, Prev: Printing Notation, Up: Conventions
+
+1.3.4 Error Messages
+--------------------
+
+Some examples cause errors to be signaled. The report doesn't specify
+what objects are passed to the error continuation, but in klisp,
+objects passed to the error continuation are encapsulated error objects
+that have at least a message and possibly some additional objects and
+context informations (such as source code location). In the examples,
+the error message is shown on a line starting with `error-->'.
+
+ (+ 23 #t)
+ error--> Wrong type argument: (expected number) (#t)
+
+
+File: klisp.info, Node: Format of Descriptions, Prev: Error Messages, Up: Conventions
+
+1.3.5 Format of Descriptions
+----------------------------
+
+Applicatives, operatives, and other objects are described in this manual
+in a uniform format. The first line of a description contains the name
+of the item followed by its operands or arguments, if any. The
+category--operative, applicative, or whatever--appears at the beginning
+of the line. The description follows on succeeding lines, sometimes
+with examples.
+
+* Menu:
+
+* A Sample Applicative Description::
+
+
+File: klisp.info, Node: A Sample Applicative Description, Prev: Format of Descriptions, Up: Format of Descriptions
+
+1.3.5.1 A Sample Applicative Description
+........................................
+
+In an applicative description, the name of the applicative being
+described appears first. It is followed on the same line by an
+applicative combination that includes the name of the applicative and
+the arguments, as would appear in a program. The names used for the
+arguments are also used in the body of the description.
+
+ Here is a description of an imaginary applicative `foo':
+
+ -- Applicative: foo (foo integer1 integer2 . rest)
+ The applicative `foo' subtracts INTEGER1 from INTEGER2, then adds
+ all the rest of the arguments to the result.
+
+ (foo 1 5 3 9)
+ => 16
+
+ More generally,
+
+ (foo W X Y...)
+ ==
+ (+ (- X W) Y...)
+
+ Any parameter whose name contains the name of a type (e.g., INTEGER,
+INTEGER1 or CONTINUATION) is expected to be of that type. A plural of
+a type (such as NUMBERS) often means a list of objects of that type.
+Parameters named OBJECT may be of any type. Additionally parameters
+named K, or KN (for any value of N), should be exact, non-negative
+integers. (XXX Types of Lisp Object XXX, for a list of Kernel object
+types.) Parameters with other sorts of names are discussed
+specifically in the description of the combiner. In some sections,
+features common to parameters of several combiners are described at the
+beginning.
+
+ Operative descriptions have the same format, but the word
+`Applicative' is replaced by `Operative', and `Argument' is replaced
+by `Operand'. Also Operatives always have an environment parameter
+(that can be #ignore or a symbol).
+
+
+File: klisp.info, Node: Acknowledgements, Prev: Conventions, Up: Introduction
+
+1.4 Acknowledgements
+====================
+
+This manual was written by Andres Navarro.
+
+ The structure and some text for this introductory section were
+borrowed from the Elisp Manual by the Free Sofware Foundation. This
+manual also borrows freely from both the Kernel Report and the Scheme
+Reports.
+
+
+File: klisp.info, Node: Booleans, Next: Equivalence, Prev: Introduction, Up: Top
+
+2 Booleans
+**********
+
+The boolean data type consists of two values, which are called true and
+false, and have respectively external representations `#t' and `#f'.
+There are no possible mutations of either of these two values, and the
+boolean type is encapsulated.
+
+ -- Applicative: boolean? (boolean? . objects)
+ The primitive type predicate for type boolean. `boolean?' returns
+ true iff all the objects in `objects' are of type boolean.
+
+ -- Applicative: not? (not? boolean)
+ Applicative `not?' is a predicate that returns the logical
+ negation of its argument.
+
+ -- Applicative: and? (and? . booleans)
+ Applicative `and?' is a predicate that returns true unless one or
+ more of its arguments are false.
+
+ -- Applicative: or? (or? . booleans)
+ Applicative `or?' is a predicate that returns false unless one or
+ more of its arguments are true.
+
+ -- Operative: $and? ($and? . <list>)
+ The `$and?' operative performs a "short-circuit and" of its
+ operands. It evaluates them from left to right, until either an
+ operand evaluates to false, or the end of the list is reached. If
+ the end of the list is reached (which is immediate if `<list>' is
+ `nil'), the operative returns true. If an operand evaluates to
+ false, no further operand evaluations are performed, and the
+ operative returns false. If `<list>' is acyclic, and the last
+ operand is evaluated, it is evaluated as a tail context. If
+ `<list>' is cyclic, an unbounded number of operand evaluations may
+ be performed. If any of the operands evaluates to a non-boolean
+ value, an error is signaled (even if it's the last one).
+
+ -- Operative: $or? ($or? . <list>)
+ The `$or?' operative performs a "short-circuit or" of its
+ operands. It evaluates them from left to right, until either an
+ operand evaluates to true, or the end of the list is reached. If
+ the end of the list is reached (which is immediate if `<list>' is
+ `nil'), the operative returns false. If an operand evaluates to
+ true, no further operand evaluations are performed, and the
+ operative returns true. If `<list>' is acyclic, and the last
+ operand is evaluated, it is evaluated as a tail context. If
+ `<list>' is cyclic, an unbounded number of operand evaluations may
+ be performed. If any of the operands evaluates to a non-boolean
+ value, an error is signaled (even if it's the last one).
+
+
+File: klisp.info, Node: Equivalence, Next: Symbols, Prev: Booleans, Up: Top
+
+3 Equivalence
+*************
+
+Kernel has two general-purpose equivalence predicates (whereas R5RS
+Scheme has three). The two Kernel predicates correspond to the
+abstract notions of equivalence up to mutation (`equal') and
+equivalence in the presence of mutation (`eq?').
+
+ -- Applicative: eq? (eq? . objects)
+ Predicate `eq?' returns true iff all of `objects' are effectively
+ the same object, even in the presence of mutation.
+
+ -- Applicative: equal? (equal? . objects)
+ Predicate `equal?' returns true iff all of `objects' "look" the
+ same as long as nothing is mutated. This is a weaker predicate
+ than `eq?'; that is, `equal?' must return true whenever `eq?'
+ would return true.
+
+
+File: klisp.info, Node: Symbols, Next: Control, Prev: Equivalence, Up: Top
+
+4 Symbols
+*********
+
+Two symbols are eq? iff they have the same external representation.
+Symbols are immutable, and the symbol type is encapsulated. The
+external representations of symbols are usually identifiers. However,
+symbols with other external representations may be created.
+
+ -- Applicative: symbol? (symbol? . objects)
+ The primitive type predicate for type symbol. `symbol?' returns
+ true iff all the objects in `objects' are of type symbol.
+
+ -- Applicative: symbol->string (symbol->string symbol)
+ Applicative `symbol->string' returns the name of `symbol' as a
+ string. The string returned is immutable.
+
+ -- Applicative: string->symbol (string->symbol string)
+ Applicative `string->symbol' returns the symbol with name
+ `string'. The symbol is always interned, which means, that it is
+ always the case that:
+ (eq? <symbol> (string->symbol (symbol->string <symbol>)))
+ => #t
+ `string->symbol' can create symbols whose external
+ representation aren't identifiers. Right now klisp uses an
+ output-only representation, but in the near future it will
+ probably include some kind of escaping mechanism to allow
+ arbitrary symbols to have readable external representations as in
+ R7RS Scheme.
+
+
+File: klisp.info, Node: Control, Next: Pairs and lists, Prev: Symbols, Up: Top
+
+5 Control
+*********
+
+The inert data type is provided for use with control combiners. It
+consists of a single immutable value, having external representation
+`#inert'. The inert type is encapsulated.
+
+ -- Applicative: inert? (inert? . objects)
+ The primitive type predicate for type inert. `inert?' returns true
+ iff all the objects in `objects' are of type inert.
+
+ -- Operative: $if ($if <test> <consequent> <alternative>)
+ The `$if' operative first evaluates `<test>' in the dynamic
+ environment. If the result is not of type boolean, an error is
+ signaled. If the result is true, `<consequent>' is then evaluated
+ in the dynamic environment as a tail context. Otherwise,
+ `<alternative>' is evaluated in the dynamic environment as a tail
+ context.
+
+ -- Operative: $sequence ($sequence . <objects>)
+ The `$sequence' operative evaluates the elements of the list
+ `<objects>' in the dynamic environment, one at a time from left to
+ right. If `<objects>' is a cyclic list, element evaluation
+ continues indefinitely, with elements in the cycle being evaluated
+ repeatedly. If `<objects>' is a nonempty finite list, its last
+ element is evaluated as a tail context. If `<objects>' is the
+ empty list, the result is inert.
+
+ -- Operative: $cond ($cond . <clauses>)
+ `<clauses>' should be a list of clause expressions, each of the
+ form `(<test> . <body>)', where body is a list of expressions.
+
+ The following equivalences define the behaviour of the `$cond'
+ operative:
+ ($cond) == #inert
+ ($cond (<test> . <body>) . <clauses>) ==
+ ($if <test> ($sequence . <body>) ($cond . <clauses>))
+
+ -- Applicative: for-each (for-each . lists)
+ `lists' must be a nonempty list of lists; if there are two or
+ more, they should all be the same length. If lists is empty, or if
+ all of its elements are not lists of the same length, an error is
+ signaled.
+
+ `for-each' behaves identically to `map', except that instead of
+ accumulating and returning a list of the results of the
+ element-wise applications, the results of the applications are
+ discarded and the result returned by `for-each' is inert.
+
+
+File: klisp.info, Node: Pairs and lists, Next: Environments, Prev: Control, Up: Top
+
+6 Pairs and lists
+*****************
+
+A pair is an object that refers to two other objects, called its car
+and cdr. The Kernel data type pair is encapsulated.
+
+ The null data type consists of a single immutable value, called nil
+or the empty list and having external representation `()', with or
+without whitespace between the parentheses. It is immutable, and the
+null type is encapsulated.
+
+ If `a' and `d' are external representations of respectively the car
+and cdr of a pair `p', then `(a . d)' is an external representation of
+`p'. If the cdr of `p' is nil, then `(a)' is also an external
+representation of `p'. If the cdr of `p' is a pair `p2', and `(r)' is
+an external representation of `p2', then `(a r)' is an external
+representation of `p'. When a pair is output (as by write), an
+external representation with the fewest parentheses is used; in the
+case of a finite list, only one set of parentheses is required beyond
+those used in representing the elements of the list. For example, an
+object with external representation `(1 . (2 . (3 . ())))' would be
+output using, modulo whitespace, external representation `(1 2 3)'.
+
+ -- Applicative: pair? (pair? . objects)
+ The primitive type predicate for type pair. `pair?' returns true
+ iff all the objects in `objects' are of type pair.
+
+ -- Applicative: null? (null? . objects)
+ The primitive type predicate for type null. `null?' returns true
+ iff all the objects in `objects' are of type null.
+
+ -- Applicative: cons (cons object1 object2)
+ A new mutable pair object is constructed and returned, whose car
+ and cdr referents are respectively `object1' and `object2'. No
+ two objects returned by different calls to cons are `eq?' to each
+ other.
+
+ -- Applicative: set-car! (set-car! pair object)
+ -- Applicative: set-cdr! (set-cdr! pair object)
+ `pair' should be a mutable pair.
+
+ These applicatives set the referent of, respectively, the car
+ reference or the cdr reference of `pair' to `object'. The result
+ of the expression is inert.
+
+ -- Applicative: copy-es-immutable! (copy-es-immutable object)
+ The short description of this applicative is that it returns an
+ object `equal?' to `object' with an immutable evaluation
+ structure. The "-es-" in the name is short for "evaluation
+ structure".
+
+ The evaluation structure of an object `o' is defined to be the set
+ of all pairs that can be reached by following chains of references
+ from `o' without ever passing through a non-pair object. The
+ evaluation structure of a non-pair object is empty.
+
+ If `object' is not a pair, the applicative returns `object'.
+ Otherwise (if `object' is a pair), the applicative returns an
+ immutable pair whose car and cdr would be suitable results for
+ `(copy-es-immutable (car object))' and `(copy-es-immutable (cdr
+ object))', respectively. Further, the evaluation structure of the
+ returned value is isomorphic to that of `object' at the time of
+ copying, with corresponding non-pair referents being `eq?'.
+
+ NOTE: In Kernel it's undefined whether immutable pairs are copied
+ or left "as is" in the result. klisp doesn't copy immutable
+ pairs, but that behaviour should not be depended upon.
+
+ -- Applicative: list (list . objects)
+ The `list' applicative returns `objects'.
+
+ The underlying operative of `list' returns its undifferentiated
+ operand tree, regardless of whether that tree is or is not a list.
+
+ -- Applicative: list* (list* . objects)
+ `objects' should be a finite nonempty list of arguments.
+
+ The following equivalences hold:
+ (list* arg1) == arg1
+ (list* arg1 arg2 . args) == (cons arg1 (list* arg2 . args))
+
+ -- Applicative: car (car pair)
+ -- Applicative: cdr (cdr pair)
+ These applicatives return, respectively, the car and cdr of `pair'.
+
+ -- Applicative: caar (caar pair)
+ -- Applicative: cadr (cadr pair)
+ -- Applicative: cdar (cdar pair)
+ -- Applicative: cddr (cddr pair)
+ -- Applicative: caaar (caaar pair)
+ -- Applicative: caadr (caadr pair)
+ -- Applicative: cadar (cadar pair)
+ -- Applicative: caddr (caddr pair)
+ -- Applicative: cdaar (cdaar pair)
+ -- Applicative: cdadr (cdadr pair)
+ -- Applicative: cddar (cddar pair)
+ -- Applicative: cdddr (cdddr pair)
+ -- Applicative: caaaar (caaaar pair)
+ -- Applicative: caaadr (caaadr pair)
+ -- Applicative: caadar (caadar pair)
+ -- Applicative: caaddr (caaddr pair)
+ -- Applicative: cadaar (cadaar pair)
+ -- Applicative: cadadr (cadadr pair)
+ -- Applicative: caddar (caddar pair)
+ -- Applicative: cadddr (cadddr pair)
+ -- Applicative: cdaaar (cdaaar pair)
+ -- Applicative: cdaadr (cdaadr pair)
+ -- Applicative: cdadar (cdadar pair)
+ -- Applicative: cdaddr (cdaddr pair)
+ -- Applicative: cddaar (cddaar pair)
+ -- Applicative: cddadr (cddadr pair)
+ -- Applicative: cdddar (cdddar pair)
+ -- Applicative: cddddr (cddddr pair)
+ These applicatives are compositions of `car' and `cdr', with the
+ "a’s" and "d’s" in the same order as they would appear if all the
+ individual "car’s" and "cdr’s" were written out in prefix order.
+ Arbitrary compositions up to four deep are provided. There are
+ twenty-eight of these applicatives in all.
+
+ -- Applicative: get-list-metrics (get-list-metrics object)
+ By definition, an improper list is a data structure whose objects
+ are its start together with all objects reachable from the start by
+ following the cdr references of pairs, and whose internal
+ references are just the cdr references of its pairs. Every
+ object, of whatever type, is the start of an improper list. If
+ the start is not a pair, the improper list consists of just that
+ object. The acyclic prefix length of an improper list `L' is the
+ number of pairs of `L' that a naive traversal of `L' would visit
+ only once. The cycle length of `L' is the number of pairs of `L'
+ that a naive traversal would visit repeatedly. Two improper lists
+ are structurally isomorphic iff they have the same acyclic prefix
+ length and cycle length and, if they are terminated by non-pair
+ objects rather than by cycles, the non-pair objects have the same
+ type. Applicative `get-list-metrics' constructs and returns a
+ list of exact integers of the form `(p n a c)', where `p', `n',
+ `a', and `c' are, respectively, the number of pairs in, the number
+ of nil objects in, the acyclic prefix length of, and the cycle
+ length of, the improper list starting with `object'. `n' is either
+ `0' or `1', `a + c = p', and `n' and `c' cannot both be non-zero.
+ If `c = 0', the improper list is acyclic; if `n = 1', the improper
+ list is a finite list; if `n = c = 0', the improper list is not a
+ list; if `a = c = 0', `object' is not a pair.
+
+ -- Applicative: list-tail (list-tail object k)
+ `object' must be the start of an improper list containing at least
+ `k' pairs.
+
+ The `list-tail' applicative follows `k' cdr references starting
+ from `object'.
+
+ The following equivalences hold:
+ (list-tail object 0) == object
+ (list-tail object (+ k 1)) == (list-tail (cdr object) k)
+
+ -- Applicative: encycle! (encycle! object k1 k2)
+ The improper list starting at `object' must contain at least `k1 +
+ k2' pairs.
+
+ If `k2 = 0', the applicative does nothing. If `k2 > 0', the
+ applicative mutates the improper list starting at `object' to have
+ acyclic prefix length `k1' and cycle length `k2', by setting the
+ cdr of the `(k1+k2)'th pair in the list to refer to the `(k1 +
+ 1)'th pair in the list. The result returned by `encycle!' is
+ inert.
+
+ -- Applicative: map (map applicative . lists)
+ `lists' must be a nonempty list of lists; if there are two or
+ more, they must all have the same length.
+
+ The map applicative applies `applicative' element-wise to the
+ elements of the lists in lists (i.e., applies it to a list of the
+ first elements of the lists, to a list of the second elements of
+ the lists, etc.), using the dynamic environment from which map was
+ called, and returns a list of the results, in order. The
+ applications may be performed in any order, as long as their
+ results occur in the resultant list in the order of their
+ arguments in the original lists. If `lists' is a cyclic list,
+ each argument list to which `applicative' is applied is
+ structurally isomorphic to `lists'. If any of the elements of
+ `lists' is a cyclic list, they all must be, or they wouldn’t all
+ have the same length. Let `a1...an' be their acyclic prefix
+ lengths, and `c1...cn' be their cycle lengths. The acyclic prefix
+ length `a' of the resultant list will be the maximum of the `ak',
+ while the cycle length `c' of the resultant list will be the least
+ common multiple of the `ck'. In the construction of the result,
+ `applicative' is called exactly `a + c' times.
+
+ -- Applicative: length (length object)
+ Applicative `length' returns the (exact) improper-list length of
+ `object'. That is, it returns the number of consecutive cdr
+ references that can be followed starting from `object'. If
+ `object' is not a pair, it returns zero; if `object' is a cyclic
+ list, it returns positive infinity.
+
+ -- Applicative: list-ref (list-ref object k)
+ The `list-ref' applicative returns the `car' of the object
+ obtained by following `k' cdr references starting from `object'.
+
+ NOTE: In the current report, object is required to be a list. In
+ klisp, for now, we prefer the behaviour presented here, as it is
+ more in line with the applicative `list-tail'. That is, we define
+ `list-ref' by the following equivalence:
+ (list-ref object k) == (car (list-tail object k))
+
+ -- Applicative: append (append . lists)
+ Here, all the elements of `lists' except the last element (if any)
+ must be acyclic lists. The `append' applicative returns a freshly
+ allocated list of the elements of all the specified `lists', in
+ order, except that if there is a last specified element of
+ `lists', it is not copied, but is simply referenced by the cdr of
+ the preceding pair (if any) in the resultant list. If `lists' is
+ cyclic, the cycle of the result list consists of just the elements
+ of the lists specified in the cycle in `lists'. In this case, the
+ acyclic prefix length of the result is the sum of the lengths of
+ the lists specified in the acyclic prefix of `lists', and the
+ cycle length of the result is the sum of the lengths of the lists
+ specified in the cycle of `lists'.
+
+ The following equivalences hold:
+ (append) == ()
+ (append h) == h
+ (append () h . t) == (append h . t)
+ (append (cons a b) h . t) == (cons a (append b h . t))
+
+ -- Applicative: list-neighbors (list-neighbors list)
+ The `list-neighbors' applicative constructs and returns a list of
+ all the consecutive sublists of `list' of length 2, in order. If
+ `list' is nil, the result is nil. If `list' is non-nil, the
+ length of the result is one less than the length of `list'. If
+ `list' is cyclic, the result is structurally isomorphic to it
+ (i.e., has the same acyclic prefix length and cycle length).
+
+ For example:
+ (list-neighbors (list 1 2 3 4)) => ((1 2) (2 3) (3 4))
+
+ -- Applicative: filter (filter applicative list)
+ Applicative `filter' passes each of the elements of `list' as an
+ argument to `applicative', one at a time in no particular order,
+ using a fresh empty environment for each call. The result of each
+ call to `applicative' must be boolean, otherwise an error is
+ signaled. `filter' constructs and returns a list of all elements
+ of `list' on which `applicative' returned true, in the same order
+ as in `list'. `applicative' is called exactly as many times as
+ there are pairs in `list'. The resultant list has a cycle
+ containing exactly those elements accepted by `applicative' that
+ were in the cycle of `list'; if there were no such elements, the
+ result is acyclic.
+
+ -- Applicative: assoc (assoc object pairs)
+ Applicative `assoc' returns the first element of `pairs' whose car
+ is `equal?' to `object'. If there is no such element in `pairs',
+ nil is returned.
+
+ -- Applicative: member? (member? object list)
+ Applicative `member?' is a predicate that returns true iff some
+ element of `list' is `equal?' to `object'.
+
+ -- Applicative: finite-list? (finite-list? . objects)
+ This is the type predicate for type finite-list. `finite-list?'
+ returns true iff all the objects in `objects' are acyclic lists.
+
+ -- Applicative: countable-list? (countable-list? . objects)
+ This is the type predicate for type list. `countable-list?'
+ returns true iff all the objects in `objects' are lists.
+
+ -- Applicative: reduce (reduce list binary identity [precycle incycle
+ postcycle])
+ `binary' should be an applicative. If the short form is used,
+ `list' should be an acyclic. If the long form is used, `precycle',
+ `incycle', and `postcycle' should be applicatives.
+
+ If `list' is empty, applicative `reduce' returns `identity'. If
+ `list' is nonempty but acyclic, applicative `reduce' uses binary
+ operation `binary' to merge all the elements of `list' into a
+ single object, using any associative grouping of the elements.
+ That is, the sequence of objects initially found in `list' is
+ repeatedly decremented in length by applying `binary' to a list of
+ any two consecutive objects, replacing those two objects with the
+ result at the point in the sequence where they occurred; and when
+ the sequence contains only one object, that object is returned.
+ If `list' is cyclic, the long form must be used. The elements of
+ the cycle are passed, one at a time (but just once for each
+ position in the cycle), as arguments to unary applicative
+ `precycle'; the finite, cyclic sequence of results from `precycle'
+ is reduced using binary applicative `incycle'; and the result from
+ reducing the cycle is passed as an argument to unary applicative
+ `postcycle'. Binary operation `binary' is used to reduce the
+ sequence consisting of the elements of the acyclic prefix of
+ `list' followed by the result returned by `postcycle'. The only
+ constraint on the order of calls to the applicatives is that each
+ call must be made before its result is needed (thus, parts of the
+ reduction of the acyclic prefix may occur before the contribution
+ from the cycle has been completed).
+
+ Each call to `binary', `precycle', `incycle', or `postcycle' uses
+ the dynamic environment of the call to `reduce'.
+
+ If `list' is acyclic with length `n >= 1', `binary' is called `n -
+ 1' times. If `list' is cyclic with acyclic prefix length `a' and
+ cycle length `c', `binary' is called `a' times; `precycle', `c'
+ times; `incycle', `c - 1' times; and `postcycle', once.
+
+ -- Applicative: append! (append! . lists)
+ `lists' must be a nonempty list; its first element must be an
+ acyclic nonempty list, and all of its elements except the last
+ element (if any) must be acyclic lists.
+
+ The `append!' applicative sets the cdr of the last pair in each
+ nonempty list argument to refer to the next non-nil argument,
+ except that if there is a last non-nil argument, it isn’t mutated.
+ It is an error for any two of the list arguments to have the same
+ last pair. The result returned by this applicative is inert.
+
+ The following equivalences hold:
+ (append! v) == #inert
+ (append! u v . w) == ($sequence (append! u v) (append! u . w))
+
+ -- Applicative: copy-es (copy-es object)
+ Briefly, applicative `copy-es' returns an object initially
+ `equal?' to `object' with a freshly constructed evaluation
+ structure made up of mutable pairs. If `object' is not a pair,
+ the applicative returns `object'. If `object' is a pair, the
+ applicative returns a freshly constructed pair whose car and cdr
+ would be suitable results for `(copy-es (car object))' and
+ `(copy-es (cdr object))', respectively. Further, the evaluation
+ structure of the returned value is structurally isomorphic to that
+ of `object' at the time of copying, with corresponding non-pair
+ referents being `eq?'.
+
+ -- Applicative: assq (assq object pairs)
+ Applicative `assq' returns the first element of `pairs' whose car
+ is `eq?' to `object'. If there is no such element in `pairs', nil
+ is returned.
+
+ -- Applicative: memq? (memq? object list)
+ Applicative `memq?' is a predicate that returns true iff some
+ element of `list' is `eq?' to `object'.
+
+
+File: klisp.info, Node: Environments, Next: Combiners, Prev: Pairs and lists, Up: Top
+
+7 Environments
+**************
+
+An environment consists of a set of bindings, and a list of zero or
+more references to other environments called its parents. Changing the
+set of bindings of an environment, or setting the referent of the
+reference in a binding, is a mutation of the environment. (Changing the
+parent list, or a referent in the list, would be a mutation of the
+environment too, but there is no facility provided to do it.) The
+Kernel data type environment is encapsulated. Among other things,
+there is no facility provided for enumerating all the variables
+exhibited by an environment (which is not required, after all, to be a
+finite set), and no facility for identifying the parents of an
+environment. Two environments are `equal?' iff they are `eq?'.
+
+ An auxiliary data type used by combiners that perform binding is
+ignore. The ignore type consists of a single immutable value, having
+external representation `#ignore'. The ignore type is encapsulated.
+
+ -- Applicative: environment? (environment? . objects)
+ The primitive type predicate for type environment. `environment?'
+ returns true iff all the objects in `objects' are of type
+ environment.
+
+ -- Applicative: ignore? (ignore? . objects)
+ The primitive type predicate for type ignore. `ignore?' returns
+ true iff all the objects in `objects' are of type ignore.
+
+ -- Applicative: eval (eval expression environment)
+ The `eval' applicative evaluates `expression' as a tail context in
+ `environment', and returns the resulting value.
+
+ -- Applicative: make-environment (make-environment . environments)
+ The applicative constructs and returns a new environment, with
+ initially no local bindings, and parent environments the
+ environments listed in `environments'. The constructed environment
+ internally stores its list of parents independent of the
+ first-class list `environments', so that subsequent mutation of
+ `environments' will not change the parentage of the constructed
+ environment. If the provided list `environments' is cyclic, the
+ constructed environment will still check each of its parents at
+ most once, and signal an error if no binding is found locally or
+ in any of the parents. No two objects returned by different calls
+ to `make-environment' are `eq?' to each other.
+
+ -- Operative: $define! ($define! <definiend> <expression>)
+ `<definiend>' should be a formal parameter tree, as described
+ below; otherwise, an error is signaled.
+
+ The `$define!' operative evaluates `<expression>' in the dynamic
+ environment and matches `<definiend>' to the result in the dynamic
+ environment, binding each symbol in definiend in the dynamic
+ environment to the corresponding part of the result; the matching
+ process will be further described below. The ancestors of the
+ dynamic environment, if any, are unaffected by the matching
+ process, as are all bindings, local to the dynamic environment, of
+ symbols not in `<definiend>'. The result returned by `$define!' is
+ inert.
+
+ A formal parameter tree has the following context-free structure:
+ ptree:: symbol | #ignore | () | (ptree . ptree)
+
+ That is, a formal parameter tree is either a symbol, or ignore, or
+ nil, or a pair whose car and cdr referents are formal parameter
+ trees. A formal parameter tree must also be acyclic, and no one
+ symbol can occur more than once in it. It is not an error for a
+ pair in the tree to be reachable from the root by more than one
+ path, as long as there is no cycle; but if any particular symbol
+ were reachable from the root by more than one path, that would
+ count as occurring more than once. Thus, if a pair is reachable
+ by more than one path, there must be no symbols reachable from it.
+
+ Matching of a formal parameter tree `t' to an object `o' in an
+ environment `e' proceeds recursively as follows. If the matching
+ process fails, an error is signaled.
+ * If `t' is a symbol, then `t' is bound to `o' in `e'.
+
+ * If `t' is `#ignore', no action is taken.
+
+ * If `t' is nil, then `o' must be nil (else matching fails).
+
+ * If `t' is a pair, then `o' must be a pair (else matching
+ fails). The car of `t' is matched to the car of `o' in `e',
+ and the cdr of `t' is matched to the cdr of `o' in `e'.
+
+ -- Operative: $let ($let <bindings> . <objects>)
+ `<bindings>' should be a finite list of
+ formal-parameter-tree/expression pairings, each of the form
+ `(formals expression)', where each `formals' is a formal
+ parameter, and no symbol occurs in more than one of the `formals'.
+
+ The following equivalence holds:
+
+ ($let ((form1 exp1) ... (formn expn)) . objects) ==
+ (($lambda (form1 ... formn) . objects) exp1 ... expn)
+
+ Thus, the `expk' are first evaluated in the dynamic environment,
+ in any order; then a child environment `e' of the dynamic
+ environment is created, with the `formk' matched in `e' to the
+ results of the evaluations of the `expk'; and finally the
+ subexpressions of `objects' are evaluated in `e' from left to
+ right, with the last (if any) evaluated as a tail context, or if
+ `objects' is empty the result is inert.
+
+ -- Operative: $binds? ($binds? <exp> . <symbols>)
+ Operative `$binds' evaluates `<exp>' in the dynamic environment;
+ call the result `env'. `env' must be an environment. The
+ operative is a predicate that returns true iff all its later
+ operands, `<symbols>', are visibly bound in `env'.
+
+ -- Applicative: get-current-environment (get-current-environment)
+ The `get-current-environment' applicative returns the dynamic
+ environment in which it is called.
+
+ -- Applicative: make-kernel-standard-environment
+ (make-kernel-standard-environment)
+ The `make-kernel-standard-environment' applicative returns a
+ standard environment; that is, a child of the ground environment
+ with no local bindings.
+
+ -- Operative: $let* ($let* <bindings> . <body>)
+ `<bindings>' should be a finite list of
+ formal-parameter-tree/expression pairings, each of the form
+ `(formals expression)', where each `formals' is a formal parameter
+ tree; `<body>' should be a list of expressions.
+
+ The following equivalences hold:
+
+ ($let* () . body) == ($let () . body)
+
+ ($let* ((form exp) . bindings) . body) ==
+ ($let ((form exp)) ($let* bindings . body))
+
+ -- Operative: $letrec ($letrec <bindings> . <body>)
+ `<bindings>' and `<body>' should be as described for `$let'.
+
+ The following equivalence holds:
+ ($letrec ((form1 exp1) ... (formn expn)) . body) ==
+ ($let () ($define! (form1 ... formn) (list exp1 ... expn)) . body)
+
+ -- Operative: $letrec* ($letrec* <bindings> . <body>)
+ `<bindings>' and `<body>' should be as described for `$let*'.
+
+ The following equivalences hold:
+ ($letrec* () . body) == ($letrec () . body)
+
+ ($letrec* ((form exp) . bindings) . body) ==
+ ($letrec ((form exp)) ($letrec* bindings . body))
+
+ -- Operative: $let-redirect ($let-redirect <exp> <bindings> . <body>)
+ `<bindings>' and `<body>' should be as described for `$let'.
+
+ The following equivalence holds:
+
+ ($let-redirect exp ((form1 exp1) ... (formn . body) expn)) ==
+ ((eval (list $lambda (form1 ... formn) body) exp) expn ... expn)
+
+ -- Operative: $let-safe ($let-safe <bindings> . <body>)
+ `<bindings>' and `<body>' should be as described for `$let'.
+
+ The following equivalence holds:
+
+ ($let-safe bindings . body) ==
+ ($let-redirect (make-kernel-standard-environment) bindings . body)
+
+ -- Operative: $remote-eval ($remote-eval <exp1> <exp2>)
+ Operative `$remote-eval' evaluates `<exp2>' in the dynamic
+ environment, then evaluates `<exp1>' as a tail context in the
+ environment that must result from the first evaluation.
+
+ -- Operative: ($bindings-environment . <bindings>)
+ `<bindings>' should be as described for `$let'.
+
+ The following equivalence holds:
+
+ ($bindings->environment . bindings) ==
+ ($let-redirect (make-environment) bindings (get-current-environment))
+
+ -- Operative: $set! ($set! <exp1> <formals> <exp2>)
+ `<formals>' should be as described for the `$define!' operative.
+ The `$set!' operative evaluates `<exp1>' and `<exp2>' in the
+ dynamic environment; call the results `env' and `obj'. If `env'
+ is not an environment, an error is signaled. Then the operative
+ matches `<formals>' to `obj' in environment `env'. Thus, the
+ symbols of `<formals>' are bound in `env' to the corresponding
+ parts of `obj'. The result returned by `$set!' is inert.
+
+ -- Operative: $provide! ($provide! <symbols> . <body>)
+ `<symbols>' must be a finite list of symbols, containing no
+ duplicates. `<body>' must be a finite list.
+
+ The `$provide!' operative constructs a child `e' of the dynamic
+ environment `d'; evaluates the elements of `<body>' in `e', from
+ left to right, discarding all of the results; and exports all of
+ the bindings of symbols in `<symbols>' from `e' to `d', i.e.,
+ binds each symbol in `d' to the result of looking it up in `e'.
+ The result returned by `$provide!' is inert.
+
+ The following equivalence holds:
+
+ ($provide! symbols . body) ==
+ ($define! symbols ($let () ($sequence . body) (list . symbols)))
+
+ -- Operative: $import! ($import! <exp> . <symbols>)
+ `<symbols>' must be a list of symbols.
+
+ The `$import!' operative evaluates `<exp>' in the dynamic
+ environment; call the result `env'. `env' must be an environment.
+ Each distinct symbol `s' in `<symbols>' is evaluated in `env', and
+ `s' is bound in the dynamic environment to the result of this
+ evaluation.
+
+ The following equivalence holds:
+
+ ($import! exp . symbols) ==
+ ($define! symbols ($remote-eval (list symbols) exp))
+
+
+File: klisp.info, Node: Combiners, Next: Continuations, Prev: Environments, Up: Top
+
+8 Combiners
+***********
+
+There are two types of combiners in Kernel, operative and applicative.
+Both types are encapsulated. All combiners are immutable. Two
+applicatives are `eq?' iff their underlying combiners are `eq?'.
+However, `eq?'-ness of operatives is only constrained by the general
+rules for `eq?', which leave considerable leeway for variation between
+implementations. klisp only considers `eq?' those operatives
+constructed by the same call to a constructor (e.g. `$vau'). Two
+combiners are `equal?' iff they are `eq?'.
+
+ -- Applicative: operative? (operative? . objects)
+ The primitive type predicate for type operative. `operative?'
+ returns true iff all the objects in `objects' are of type
+ operative.
+
+ -- Applicative: applicative? (applicative? . objects)
+ The primitive type predicate for type applicative. `applicative?'
+ returns true iff all the objects in `objects' are of type
+ applicative.
+
+ -- Operative: $vau ($vau <formals> <eformal> . <objects>)
+ `<formals>' should be a formal parameter tree; `<eformal>' should
+ be either a symbol or `#ignore'. If `<formals>' does not have the
+ correct form for a formal parameter tree, or if `<eformal>' is a
+ symbol that also occurs in `<formals>', an error is signaled.
+
+ A `vau' expression evaluates to an operative; an operative created
+ in this way is said to be compound. The environment in which the
+ `vau' expression was evaluated is remembered as part of the
+ compound operative, called the compound operative’s static
+ environment. `<formals>' and `<objects>' are copied as by
+ `copy-es-immutable' and the copies are stored as part of the
+ operative being constructed. This avoids problem if these
+ structures are later mutated.
+
+ When the compound operative created by `$vau' is later called with
+ an object and an environment, here called respectively the operand
+ tree and the dynamic environment, the following happens:
+
+ 1. A new, initially empty environment is created, with the static
+ environment as its parent. This will be called the local
+ environment.
+
+ 2. A stored copy of the formal parameter tree formals is matched
+ in the local environment to the operand tree, locally binding
+ the symbols of formals to the corresponding parts of the
+ operand tree. eformal is matched to the dynamic environment;
+ that is, if eformal is a symbol then that symbol is bound in
+ the local environment to the dynamic environment.
+
+ 3. A stored copy of the expressions is evaluated sequentially
+ from left to right, with the last (if any) evaluated as a
+ tail context, or if the list of expressions is empty, the
+ result is inert.
+
+ NOTE: Because compound operatives are not a distinct type in
+ Kernel, they are covered by the encapsulation of type operative.
+ In particular, an implementation of Kernel cannot provide a
+ feature that supports extracting the static environment of any
+ given compound operative, nor that supports determining whether or
+ not a given operative is compound.
+
+ -- Applicative: wrap (wrap combiner)
+ The `wrap' applicative returns an applicative whose underlying
+ combiner is `combiner'.
+
+ -- Applicative: unwrap (unwrap applicative)
+ The `unwrap' applicative returns the underlying combiner of
+ `applicative'.
+
+ -- Operative: $lambda ($lambda <formals> . <objects>)
+ `<formals>' should be a formal parameter tree.
+
+ The `$lambda' operative is defined by the following equivalence:
+ ($lambda formals . objects) ==
+ (wrap ($vau formals #ignore . objects))
+
+ -- Applicative: apply (apply applicative object [environment])
+ Applicative `apply' combines the underlying combiner of
+ `applicative' with `object' in a tail context with dynamic
+ environment `environment' (if the long form is used) or in an
+ empty environment (if the short form is used).
+
+ The following equivalences hold:
+ (apply applicative object environment) ==
+ (eval (cons (unwrap applicative) object) environment)
+
+ (apply applicative object) ==
+ (apply applicative object (make-environment))
+
+ -- Applicative: map (map applicative . lists)
+ `lists' must be a nonempty list of lists; if there are two or
+ more, they must all have the same length. If `lists' is empty, or
+ if all of its elements are not lists of the same length, an error
+ is signaled.
+
+ The `map' applicative applies `applicative' element-wise to the
+ elements of the lists in `lists' (i.e., applies it to a list of
+ the first elements of the `lists', to a list of the second
+ elements of the `lists', etc.), using the dynamic environment from
+ which `map' was called, and returns a list of the results, in
+ order. The applications may be performed in any order, as long as
+ their results occur in the resultant list in the order of their
+ arguments in the original `lists'. If `lists' is a cyclic list,
+ each argument list to which `applicative' is applied is
+ structurally isomorphic to `lists'. If any of the elements of
+ `lists' is a cyclic list, they all must be, or they wouldn’t all
+ have the same length. Let `a1...an' be their acyclic prefix
+ lengths, and `c1...cn' be their cycle lengths. The acyclic prefix
+ length `a' of the resultant list will be the maximum of the `ak',
+ while the cycle length `c' of the resultant list will be the least
+ common multiple of the `ck'. In the construction of the result,
+ applicative is called exactly `a + c' times.
+
+ -- Applicative: combiner? (combiner? . objects)
+ The primitive type predicate for type combiner. `combiner?'
+ returns true iff all the objects in `objects' are of type combiner
+ (i.e. applicative or operative).
+
+
+File: klisp.info, Node: Continuations, Next: Encapsulations, Prev: Combiners, Up: Top
+
+9 Continuations
+***************
+
+A continuation is a plan for all future computation, parameterized by a
+value to be provided, and contingent on the states of all mutable data
+structures (which notably may include environments). When the Kernel
+evaluator is invoked, the invoker provides a continuation to which the
+result of the evaluation will normally be returned.
+
+ For example, when `$if' evaluates its test operand, the continuation
+provided for the result expects to be given a boolean value; and,
+depending on which boolean it gets, it will evaluate either the
+consequent or the alternative operand as a tail context — that is, the
+continuation provided for the result of evaluating the selected operand
+is the same continuation that was provided for the result of the call
+to `$if'.
+
+ A Kernel program may sometimes capture a continuation; that is,
+acquire a reference to it as a first-class object. The basic means of
+continuation capture is applicative `call/cc'. Given a first-class
+continuation `c', a combiner can be constructed that will abnormally
+pass its operand tree to `c' (as opposed to the normal return of values
+to continuations). In the simplest case, the abnormally passed value
+arrives at `c' as if it had been normally returned to `c'. In general,
+continuations bypassed by the abnormal pass may have entry/exit guards
+attached to them, and these guards can intercept the abnormal pass
+before it reaches `c'. Each entry/exit guard consists of a selector
+continuation, which designates which abnormal passes the guard will
+intercept, and an interceptor applicative that performs the
+interception when selected.
+
+ Continuations are immutable, and are `equal?' iff `eq?'. The
+continuation type is encapsulated.
+
+ -- Applicative: continuation? (continuation? . objects)
+ The primitive type predicate for type continuation.
+ `continuation?' returns true iff all the objects in `objects' are
+ of type continuation.
+
+ -- Applicative: call/cc (call/cc combiner)
+ Calls `combiner' in the dynamic environment as a tail context,
+ passing as sole operand to it the continuation to which `call/cc'
+ would normally return its result. (That is, constructs such a
+ combination and evaluates it in the dynamic environment.)
+
+ -- Applicative: extend-continuation (extend-continuation continuation
+ applicative [environment])
+ The `extend-continuation' applicative constructs and returns a new
+ child of `continuation' that, when it normally receives a value v,
+ calls the underlying combiner of `applicative' with dynamic
+ environment `environment' (or an empty environment if none was
+ specified) and operand tree `v', the result of the call normally
+ to be returned to `continuation'.
+
+ The following equivalnece defines the short version:
+ (extend-continuation c a) ==
+ (extend-continuation c a (make-environment))
+
+ -- Applicative: guard-continuation (guard-continuation entry-guards
+ continuation exit-guards)
+ `entry-guards' and `exit-guards' should each be a list of clauses;
+ each clause should be a list of length two, whose first element is
+ a continuation, and whose second element is an applicative whose
+ underlying combiner is operative.
+
+ Applicative `guard-continuation' constructs two continuations: a
+ child of continuation, called the `outer continuation'; and a
+ child of the `outer continuation', called the `inner
+ continuation'. The `inner continuation' is returned as the result
+ of the call to `guard-continuation'.
+
+ When the `inner continuation' normally receives a value, it passes
+ the value normally to the `outer continuation'; and when the
+ `outer continuation' normally receives a value, it passes the
+ value normally to `continuation'. Thus, in the absence of abnormal
+ passing, the inner and outer continuations each have the same
+ behavior as `continuation'.
+
+ The two elements of each guard clause are called, respectively, the
+ `selector' and the `interceptor'. The `selector' continuation is
+ used in deciding whether to intercept a given abnormal pass, and
+ the `interceptor' applicative is called to perform customized
+ action when interception occurs.
+
+ At the beginning of the call to `guard-continuation', internal
+ copies are made of the evaluation structures of `entry-guards' and
+ `exit-guards', so that the selectors and interceptors contained in
+ the arguments at that time remain fixed thereafter, independent of
+ any subsequent mutations to the arguments.
+
+ -- Applicative: continuation->applicative (continuation->applicative
+ continuation)
+ Returns an applicative whose underlying operative abnormally passes
+ its operand tree to `continuation', thus: A series of interceptors
+ are selected to handle the abnormal pass, and a continuation is
+ derived that will normally perform all the interceptions in
+ sequence and pass some value to the destination of the originally
+ abnormal pass. The operand tree is then normally passed to the
+ derived continuation.
+
+ -- Variable: root-continuation
+ This continuation is the ancestor of all other continuations. When
+ it normally receives a value, it terminates the Kernel session.
+ (For example, if the system is running a read-eval-print loop, it
+ exits the loop.)
+
+ -- Variable: error-continuation
+ The dynamic extent of this continuation is mutually disjoint from
+ the dynamic extent in which Kernel computation usually occurs
+ (such as the dynamic extent in which the Kernel system would run a
+ read-eval-print loop).
+
+ When this continuation normally receives a value, it provides a
+ diagnostic message to the user of the Kernel system, on the
+ assumption that the received value is an attempt to describe some
+ error that aborted a computation; and then resumes operation of
+ the Kernel system at some point that is outside of all
+ user-defined computation. (For example, if the system is running a
+ read-eval-print loop, operation may resume by continuing from the
+ top of the loop.)
+
+ The diagnostic message is not made available to any Kernel
+ computation, and is therefore permitted to contain information that
+ violates abstractions within the system.
+
+ When an error is signaled during a Kernel computation, the
+ signaling action consists of an abnormal pass to some continuation
+ in the dynamic extent of `error-continuation'.
+
+ -- Applicative: apply-continuation (apply-continuation continuation
+ object)
+ Applicative `apply-continuation' converts its first argument to an
+ applicative as if by `continuation->applicative', and then applies
+ it as usual.
+
+ That is:
+ (apply-continuation continuation object) ==
+ (apply (continuation->applicative continuation) object)
+
+ -- Operative: ($let/cc <symbol> . <objects>)
+ A child environment `e' of the dynamic environment is created,
+ containing a binding of `<symbol>' to the continuation to which
+ the result of the call to `$let/cc' should normally return; then,
+ the subexpressions of `<objects>' are evaluated in `e' from left
+ to right, with the last (if any) evaluated as a tail context, or
+ if `<objects>' is empty the result is inert.
+
+ That is:
+ ($let/cc symbol . objects) ==
+ (call/cc ($lambda (symbol) . objects))
+
+ -- Applicative: guard-dynamic-extent (guard-dynamic-extent
+ entry-guards combiner exit-guards)
+ This applicative extends the current continuation with the
+ specified guards, and calls `combiner' in the dynamic extent of
+ the new continuation, with no operands and the dynamic environment
+ of the call to `guard-dynamic-extent'.
+
+ -- Applicative: exit (exit [object])
+ Applicative `exit' initiates an abnormal transfer of `object' (or
+ `#inert' if `object' was not specified), to `root-continuation'.
+ That is:
+ (exit) == (apply-continuation root-continuation #inert)
+ (exit obj) == (apply-continuation root-continuation obj)
+
+ SOURCE NOTE: This applicative doesn't have the optional argument in
+ the report. It was added to klisp to allow a simple way to
+ terminate the interpreter passing a value that is then tried to
+ convert to an exit status.
+
+
+File: klisp.info, Node: Encapsulations, Next: Promises, Prev: Continuations, Up: Top
+
+10 Encapsulations
+*****************
+
+An encapsulation is an object that refers to another object, called its
+content. The Kernel data type encapsulation is encapsulated. Two
+encapsulations are `equal?' iff they are `eq?'. Encapsulations are
+immutable.
+
+ -- Applicative: make-encapsulation-type (make-encapsulation-type)
+ Returns a list of the form `(e p? d)', where `e', `p'?, and `d'
+ are applicatives, as follows. Each call to
+ `make-encapsulation-type' returns different applicatives `e',
+ `p?', and `d'.
+
+ * `e' is an applicative that takes one argument, and returns a
+ fresh encapsulation with the argument as content.
+ Encapsulations returned on different occasions are not `eq?'.
+
+ * `p?' is a primitive type predicate, that takes zero or more
+ arguments and returns true iff all of them are encapsulations
+ generated by `e'.
+
+ * `d' is an applicative that takes one argument; if the
+ argument is not an encapsulation generated by `e', an error
+ is signaled, otherwise the content of the encapsulation is
+ returned.
+
+ That is, the predicate `p?' only recognizes, and the decapsulator
+ `d' only extracts the content of, encapsulations created by the
+ encapsulator `e' that was returned by the same call to
+ `make-encapsulation-type'.
+
+
+File: klisp.info, Node: Promises, Next: Keyed Variables, Prev: Encapsulations, Up: Top
+
+11 Promises
+***********
+
+A promise is an object that represents the potential to determine a
+value. The value may be the result of an arbitrary computation that
+will not be performed until the value must be determined (constructor
+`$lazy'); or, in advanced usage, the value may be determined before the
+promise is constructed (constructor `memoize').
+
+ The value determined by a promise is obtained by forcing it
+(applicative `force'). A given promise cannot determine different
+values on different occasions that it is forced. Also, if a promise
+determines its value by computation, and that computation has already
+been completed, forcing the promise again will produce the previously
+determined result without re-initiating the computation to determine it.
+
+ The Kernel data type promise is encapsulated.
+
+ The general rules for predicate `eq?' only require it to distinguish
+promises if they can exhibit different behavior; the resulting leeway
+for variation between implementations is similar, in both cause and
+effect, to that for `eq?'-ness of operatives. For example, if two
+promises, constructed on different occasions, would perform the same
+computation to determine their values, and that computation has no
+side-effects and must always return the same value, the promises may or
+may not be `eq?'. Two promises are `equal?' iff they are `eq?'.
+
+ -- Applicative: promise? (promise? . objects)
+ The primitive type predicate for type promise. `promise?' returns
+ true iff all the objects in `objects' are of type promise.
+
+ -- Applicative: force (force object)
+ If `object' is a promise, applicative `force' returns the value
+ determined by promise; otherwise, it returns `object'.
+
+ The means used to force a promise depend on how the promise was
+ constructed. The description of each promise constructor specifies
+ how to force promises constructed by that constructor.
+
+ -- Operative: $lazy ($lazy expression)
+ Operative `$lazy' constructs and returns a new object of type
+ promise, representing potential evaluation of expression in the
+ dynamic environment from which `$lazy' was called.
+
+ When the promise is forced, if a value has not previously been
+ determined for it, `expression' is evaluated in the dynamic
+ environment of the constructing call to `$lazy'. If, when the
+ evaluation returns a result, a value is found to have been
+ determined for the promise during the evaluation, the result is
+ discarded in favor of the previously determined value; otherwise,
+ the result is forced, and the value returned by that forcing
+ becomes the value determined by the promise.
+
+ Forcing an undetermined lazy promise (i.e., a promise constructed
+ by $lazy for which no value has yet been determined) may cause a
+ sequential series of evaluations, each of which returns a promise
+ that is forced and thus initiates the next evaluation in the
+ series. The implementation must support series of this kind with
+ unbounded length (i.e., unbounded number of sequential
+ evaluations).
+
+ Note that forcing concerns the value determined by a given promise,
+ not the result of evaluating a given expression in a given
+ environment. Distinct promises (judged by `eq?' represent
+ different occasions of evaluation; so, even if they do represent
+ evaluation of the same expression in the same environment, forcing
+ one does not necessarily determine the value for the other, and
+ actual evaluation will take place the first time each of them is
+ forced.
+
+ -- Applicative: memoize (memoize object)
+ Applicative `memoize' constructs and returns a new object of type
+ promise, representing memoization of `object'. Whenever the
+ promise is forced, it determines `object'.
+
+
+File: klisp.info, Node: Keyed Variables, Next: Numbers, Prev: Promises, Up: Top
+
+12 Keyed Variables
+******************
+
+A keyed variable is a device that associates a non-symbolic key (in the
+form of an accessor applicative) with a value depending on the context
+in which lookup occurs. Kernel provides two types of keyed variables:
+dynamic & static. Keyed Dynamic Variables use the dynamic extent as
+context and Keyed Static Variables use the dynamic environment.
+
+12.1 Keyed Dynamic Variables
+============================
+
+A keyed dynamic variable is a device that associates a non-symbolic key
+(in the form of an accessor applicative) with a value depending on the
+dynamic extent in which lookup occurs.
+
+ -- Applicative: make-keyed-dynamic-variable
+ (make-keyed-dynamic-variable)
+ Returns a list of the form `(b a)', where `b' and `a' are
+ applicatives, as follows. Each call to
+ `make-keyed-dynamic-variable' returns different `b' and `a'.
+
+ * `b' is an applicative that takes two arguments, the second of
+ which must be a combiner. It calls its second argument with
+ no operands (nil operand tree) in a fresh empty environment,
+ and returns the result.
+
+ * `a' is an applicative that takes zero arguments. If the call
+ to `a' occurs within the dynamic extent of a call to `b', then
+ `a' returns the value of the first argument passed to `b' in
+ the smallest enclosing dynamic extent of a call to `b'. If the
+ call to `a' is not within the dynamic extent of any call to
+ `b', an error is signaled.
+
+12.2 Keyed Static Variables
+===========================
+
+A keyed static variable is a device that binds data in an environment
+by a non-symbolic key, where the key is an accessor applicative.
+
+ -- Applicative: make-keyed-static-variable (make-keyed-static-variable)
+ Returns a list of the form `(b a)', where `b' and `a' are
+ applicatives, as follows. Each call to
+ `make-keyed-static-variable' returns different `b' and `a'.
+
+ * `b' is an applicative that takes two arguments, the second of
+ which must be an environment. It constructs and returns a
+ child-environment of its second argument, with initially no
+ local bindings.
+
+ * `a' is an applicative that takes zero arguments. If the
+ dynamic environment `e' of the call to a has an improper
+ ancestor that was constructed by a call to `b', then a
+ returns the value of the first argument passed to `b' in the
+ first such environment encountered by a depth-first traversal
+ of the improper ancestors of `e'. If `e' has no improper
+ ancestors constructed via `b', an error is signaled.
+
+
+File: klisp.info, Node: Numbers, Next: Strings, Prev: Keyed Variables, Up: Top
+
+13 Numbers
+**********
+
+All numbers are immutable, and `equal?' iff `eq?'. The number type is
+encapsulated.
+
+ The external representation of an undefined number is `#undefined'.
+The external representation of a real with no primary value is `#real'
+(but this may change in the future, the report is missing the output
+representation for reals with no primary values). All other rules for
+externally representing numbers pertain only to defined numbers with
+primary values.
+
+ An external representation of a real number consists of optional
+radix and/or exactness prefixes, optional sign (`+' or `-'), and
+magnitude. The radix prefixes are `#b' (binary), `#o' (octal), `#d'
+(decimal), and `#x' (hexadecimal); the default is decimal. The
+exactness prefixes are `#e' (exact) and `#i' (inexact); by default, the
+number is inexact iff the magnitude representation uses floating point.
+If both kinds of prefixes are used, they may occur in either order. The
+magnitude is either `infinity'; an unsigned integer (nonempty sequence
+of digits); a ratio of unsigned integers (two unsigned integers with a
+`/' between, of which the second is non-zero); or a floating point
+representation. If the magnitude is `infinity', there must be an
+exactness prefix and a sign, and no radix prefix. Floating point
+representation can only be used with decimal radix; it consists of
+nonempty integer part, point (`.'), nonempty fraction part, and
+optional exponent part. The optional exponent part consists of an
+exponent letter, and an (optionally signed) integer indicating a power
+of ten by which to multiply the magnitude. The choice of exponent
+letter makes no difference in what mathematical number is indicated by
+the external representation, but does indicate internal representation
+precision. Exponent letters `s', `f', `d', `f' indicate preference for
+successively higher internal precision - short, float, double, long.
+When reading an inexact real number, exponent letter `e' accepts the
+default internal precision, which must be at least double. When
+writeing an inexact real number, exponent letter `e' may be used for
+the default internal precision, and must be used for any internal
+number format not indicated by any of the other exponent letters.
+Float and double must provide, respectively, at least as much precision
+as IEEE 32-bit and 64-bit floating point standards [IE85]. For
+example, `#i#xa/c' represents an inexact number using hexadecimal
+notation, with signed magnitude positive five sixths (ten over twelve).
+`-3.5l-2' represents an inexact number using decimal notation, with
+signed magnitude negative thirty five thousandths, and requested long
+precision (which must be at least IEEE 64-bit floating point). When
+reading an external representation of an inexact real, the bounds on
+the resulting inexact number are chosen in accordance with the
+narrow-arithmetic keyed dynamic variable.
+
+ NOTE: in klisp, all inexact numbers are stored as IEEE 64-bit
+floating point. No bounding or robustness info is kept.
+
+ -- Applicative: number? (number? . objects)
+ The primitive type predicate for type number. `number?' returns
+ true iff all the objects in `objects' are of type number.
+
+ -- Applicative: integer? (integer? . objects)
+ The primitive type predicate for number subtype integer.
+ `integer?' returns true iff all the objects in `objects' are of
+ type integer.
+
+ -- Applicative: rational? (rational? . objects)
+ The primitive type predicate for number subtype rational.
+ `rational?' returns true iff all the objects in `objects' are of
+ type rational.
+
+ -- Applicative: real? (real? . objects)
+ The primitive type predicate for number subtype real. `real?'
+ returns true iff all the objects in `objects' are of type real.
+
+ -- Applicative: finite? (finite? . numbers)
+ Predicate `finite?' returns true iff all the numbers in `numbers'
+ are finite.
+
+ -- Applicative: exact? (exact? . numbers)
+ Predicate `exact?' returns true iff all the numbers in `numbers'
+ are exact.
+
+ -- Applicative: inexact? (inexact? . numbers)
+ Predicate `inexact?' returns true iff all the numbers in `numbers'
+ are inexact.
+
+ -- Applicative: robust? (robust? . numbers)
+ Predicate `robust?' returns true iff all the numbers in `numbers'
+ are robust.
+
+ -- Applicative: undefined? (undefined? . numbers)
+ Predicate `undefined?' returns true iff all the numbers in
+ `numbers' are undefined.
+
+ -- Applicative: =? (=? . numbers)
+ Applicative `=?' is a predicate that returns true iff all its
+ arguments are numerically equal to each other. If any of its
+ arguments has no primary value, an error is signaled.
+
+ -- Applicative: <? (<? . reals)
+ -- Applicative: <=? (<=? . reals)
+ -- Applicative: >? (>? . reals)
+ -- Applicative: >=? (>=? . reals)
+ Each of these applicatives is a predicate that returns true iff
+ every two consecutive elements of `reals' have primary values in
+ the order indicated by the name of the applicative. If any
+ element of `reals' has no primary value, an error is signaled.
+
+ -- Applicative: + (+ . numbers)
+ Applicative `+' returns the sum of the elements of numbers. If
+ numbers is empty, the sum of its elements is exact zero. If a
+ positive infinity is added to a negative infinity, the result has
+ no primary value. If all the elements of a cycle are zero, the
+ sum of the cycle is zero. If the acyclic sum of the elements of a
+ cycle (i.e., the sum of an acyclic list containing just those
+ elements) is non-zero, the sum of the cycle is positive infinity
+ times the acyclic sum of the elements. If the acyclic sum of the
+ elements of a cycle is zero, but some of the elements of the cycle
+ are non-zero, the sum of the cycle has no primary value.
+
+ -- Applicative: * (* . numbers)
+ Applicative `*' returns the product of the elements of numbers.
+ If numbers is empty, the product of its elements is exact one. If
+ an infinity is multiplied by zero, the result has no primary
+ value. If the acyclic product of the elements of a cycle is real
+ greater than one, the product of the cycle is positive infinity.
+ If all the elements of a cycle are positive one, the product of
+ the cycle is positive one. If the acyclic product of the elements
+ of a cycle is positive one, but some of the elements of the cycle
+ are not positive one, the product of the cycle has no primary
+ value. If the acyclic product of the elements of a cycle has
+ magnitude less than one, the product of the cycle is zero. If the
+ acyclic product of the elements of a cycle has magnitude greater
+ than or equal to one, and is not positive real, the product of the
+ cycle has no primary value.
+
+ -- Applicative: - (- number . numbers)
+ `numbers' should be a nonempty list of numbers.
+
+ Applicative `-' returns the sum of `number' with the negation of
+ the sum of `numbers'.
+
+ -- Applicative: zero? (zero? . numbers)
+ Applicative `zero?' is a predicate that returns true iff every
+ element of `numbers' is zero. For this purpose, a real number is
+ zero if its primary value is zero. If any element of numbers has
+ no primary value an error is signaled.
+
+ -- Applicative: div (div real1 real2)
+ -- Applicative: mod (mod real1 real2)
+ -- Applicative: div-and-mod (div-and-mod real1 real2)
+ For all three applicatives, if `real1' is infinite or `real2' is
+ zero, an error is signaled.
+
+ Let `n' be the greatest integer such that `real2 * n <= real1'.
+ Applicative `div' returns `n'. Applicative `mod' returns `real1 -
+ (real2 * n)'. Applicative `div-and-mod' returns a freshly
+ allocated list of length two, whose first element is `n' and whose
+ second element is `real1 - (real2 * n)'.
+
+ NOTE: I'm not really sure about this description...
+
+ -- Applicative: div0 (div0 real1 real2)
+ -- Applicative: mod0 (mod0 real1 real2)
+ -- Applicative: div0-and-mod0 (div0-and-mod0 real1 real2)
+ For all three applicatives, if `real1' is infinite or `real2' is
+ zero, an error is signaled.
+
+ Let `n' be the greatest integer such that `real2 * n <= real1 +
+ |real2/2|'. Applicative `div0' returns `n'. Applicative `mod0'
+ returns `real1 - (real2 * n)'. Applicative `div0-and-mod0'
+ returns a freshly allocated list of length two, whose first
+ element is `n' and whose second element is `real1 - (real2 * n)'.
+
+ NOTE: I'm not really sure about this description...
+
+ -- Applicative: positive? (positive? . reals)
+ -- Applicative: negative? (negative? . reals)
+ Applicative `positive?' is a predicate that returns true iff every
+ element of `reals' is greater than zero. Applicative `negative?'
+ is a predicate that returns true iff every element of `reals' is
+ less than zero. If any argument to either applicative has no
+ primary value an error is signaled.
+
+ -- Applicative: odd? (odd? . integers)
+ -- Applicative: even? (even? . integers)
+ Applicative `odd?' is a predicate that returns true iff every
+ element of `integers' is odd. Applicative `even?' is a predicate
+ that returns true iff every element of `integers' is even. If any
+ argument to either applicative has no primary value an error is
+ signaled.
+
+ -- Applicative: (abs real)
+ Applicative `abs' returns the nonnegative real number with the
+ same magnitude as `real'; that is, if `real' is nonnegative it
+ returns `real', otherwise it returns the negation of `real'.
+
+ -- Applicative: max (max . reals)
+ -- Applicative: min (min . reals)
+ If `reals' is nil, applicative `max' returns exact negative
+ infinity, and applicative `min' returns exact positive infinity.
+ If `reals' is non-nil, applicative `max' returns the largest
+ number in `reals', and applicative `min' returns the smallest
+ number in `reals'.
+
+ -- Applicative: lcm (lcm . impints)
+ -- Applicative: gcd (gcd . impints)
+ `impints' should be a list of improper integers, that is, real
+ numbers each of which is either an integer or an infinity.
+
+ Applicative `lcm' returns the smallest positive improper integer
+ that is an improper0integer multiple of every element of `impints'
+ (that is, smallest `n >= 1' such that for every argument `nk'
+ there exists `n'k' with `nk * n'k = n'). If any of the arguments
+ is zero, the result of `lcm' has no primary value. According to
+ these rules, `lcm' with nil argument list returns `1', and `lcm'
+ with any infinite argument returns positive infinity.
+
+ Applicative `gcd' returns the largest positive improper integer
+ such that every element of `impints' is an improper-integer
+ multiple of it (that is, largest `n >= 1' such that for every
+ argument `nk' there exists `n'k' with `n * n'k = nk'). `gcd' with
+ nil argument list returns exact positive infinity. If `gcd' is
+ called with one or more arguments, and at least one of the
+ arguments is zero, but none of the arguments is a non-zero finite
+ integer, its result has no primary value. According to these
+ rules, if `gcd' is called with at least one finite non-zero
+ argument, its result is the same as if all zero and infinite
+ arguments were deleted.
+
+ -- Applicative: get-real-internal-bounds (get-real-internal-bounds
+ real)
+ -- Applicative: get-real-exact-bounds (get-real-exact-bounds real)
+ Applicative `get-real-internal-bounds' returns a freshly allocated
+ list of reals `(x1 x2)', where the primary value of `x1' is the
+ lower bound of `real', using the same internal representation as
+ the primary value of `real', and the primary value of `x2' is the
+ upper bound of `real', using the same internal representation as
+ the primary value of `real'. The `xk' are inexact iff real is
+ inexact. The `xk' are robust (i.e., tagged if the implementation
+ supports such), and the bounds of each `xk' are only required to
+ contain its primary value (i.e., the implementation is allowed to
+ make the bounds equal to the primary value).
+
+ Applicative `get-real-exact-bounds' returns a freshly allocated
+ list of exact reals `(x1 x2)', where `x1' is not greater than the
+ lower bound of `real', and `x2' is not less than the upper bound
+ of `real'.
+
+ -- Applicative: get-real-internal-primary (get-real-internal-primary
+ real)
+ -- Applicative: get-real-exact-primary (get-real-exact-primary real)
+ If `real' is exact, both applicatives return `real'. If `real'
+ has no primary value, both applicatives signal an error.
+
+ If `real' is inexact with a primary value, applicative
+ `get-real-internal-primary' returns a real number `x0' whose
+ primary value is the same as, and has the same internal format as,
+ the primary value of `real'. `x0' is robust, and its bounds are
+ only required to contain its primary value.
+
+ If `real' is inexact with a primary value, applicative
+ `get-real-exact-primary' returns an exact real number `x0' within
+ the exact bounds that would be returned for `real' by applicative
+ `get-real-exact-bounds'. Preferably, `x0' should be as close to
+ the primary value of `real' as the implementation can reasonably
+ arrange. If the implementation does not support any exact `real'
+ that reasonably approximates `real', an error may be signaled.
+
+ -- Applicative: make-inexact (make-inexact real1 real2 real3)
+ Applicative `make-inexact' returns an inexact real number, as
+ follows. If `real2' is inexact, the result has the same primary
+ value as `real2'; and if `real2' has no primary value, the result
+ has no primary value. The result has the same robustness as
+ `real2'. If possible, the result uses the same internal
+ representation as `real2'. If `real2' is exact, the primary value
+ of the result is as close to `real2' as the implementation can
+ reasonably arrange; overflow and underflow are handled as
+ described in .... The lower bound of the result is no greater than
+ the lower bound of `real1', the primary value of `real2', and the
+ primary value of the result. The upper bound of the result is no
+ less than the upper bound of `real3', the primary value of
+ `real2', and the primary value of the result.
+
+ -- Applicative: real->inexact (real->inexact real)
+ -- Applicative: real->exact (real->exact real)
+ Applicative `real->exact' behaves just as `get-real-exact-primary'.
+
+ If `real' is inexact, applicative `real->inexact' returns `real'.
+ If `real' is exact, applicative `real->inexact' returns an inexact
+ real `x0' such that `real' would be a permissible result of
+ passing `x0' to `real->exact'. If the implementation does not
+ support any such `x0', an error may be signaled. Otherwise, `x0'
+ is robust, and its bounds are only required to contain its primary
+ value and `real'.
+
+ -- Applicative: with-strict-arithmetic (with-strict-arithmetic boolean
+ combiner)
+ -- Applicative: get-string-arithmetic (get-strict-arithmetic?)
+ These applicatives are the binder and accessor of the
+ `strict-arithmetic' keyed dynamic variable. When this keyed
+ variable is true, various survivable but dubious arithmetic events
+ signal an error - notably, operation results with no primary value,
+ and over- and underflows.
+
+ -- Applicative: / (/ number . numbers)
+ `numbers' should be a nonempty list of numbers.
+
+ Applicative `/' returns `number' divided by the product of
+ `numbers'. If the product of `numbers' is zero, an error is
+ signaled. If `number' is infinite and the product of `numbers' is
+ infinite, an error is signaled.
+
+ -- Applicative: numerator (numerator rational)
+ -- Applicative: denominator (denominator rational)
+ These applicatives return the numerator and denominator of
+ `rational', in least terms (i.e., chosen for the least positive
+ denominator). Note that if `rational' is inexact, and either of
+ its bounds is not its primary value, the denominator has upper
+ bound positive infinity, and the numerator must have at least one
+ infinite bound (two infinite bounds if the bounds of rational
+ allow values of both signs).
+
+ -- Applicative: floor (floor real)
+ -- Applicative: ceiling (ceiling real)
+ -- Applicative: truncate (truncate real)
+ -- Applicative: round (round real)
+ Applicative `floor' returns the largest integer not greater than
+ `real'.
+
+ Applicative `ceiling' returns the smallest integer not less than
+ `real'.
+
+ Applicative `truncate' returns the integer closest to `real' whose
+ absolute value is not greater than that of `real'.
+
+ Applicative `round' returns the closest integer to `real',
+ rounding to even when `real' is halfway between two integers.
+
+ -- Applicative: rationalize (rationalize real1 real2)
+ -- Applicative: simplest-rational (simplest-rational real1 real2)
+ A rational number `r1' is simpler than another rational `r2' if
+ `r1 = p1 / q1' and `r2 = p2 / q2', both in lowest terms, and `|p1|
+ <= |p2|' and `|q1| <= |q2|'. Thus `3/5' is simpler than `4/7'. Not
+ all rationals are comparable in this ordering, as for example
+ `2/7' and `3/5'. However, any interval (that contains rational
+ numbers) contains a rational number that is simpler than every
+ other rational number in that interval. Note that `0 = 0/1' is
+ simpler than any other rational (so that one never has to choose
+ between `p/q' and `−p/q').
+
+ For applicative `simplest-rational', let `x0' be the simplest
+ rational mathematically not less than the primary value of `real1'
+ and not greater than the primary value of `real2'. If no such
+ `x0' exists (because the primary value of `real1' is greater, or
+ because the primary values of the arguments are equal and
+ irrational), or if either argument does not have a primary value,
+ an error is signaled.
+
+ For applicative `rationalize', let `x0' be the simplest rational
+ mathematical number within the interval bounded by the primary
+ value of `real1' plus and minus the primary value of `real2'. If
+ no such `x0' exists (because the primary value of `real1' is
+ irrational and the primary value `real2' is zero), or if either
+ argument does not have a primary value, an error is signaled.
+
+ If `real1' and `real2' are exact, the applicative (whichever it
+ is) returns exact `x0'. If one or both of `real1' and `real2' are
+ inexact, the applicative returns an inexact rational approximating
+ `x0' (as by `real->inexact'. Note that an inexact result returned
+ is not necessarily bounded by the primary values of the arguments;
+ but the result is an approximation of `x0', which is so bounded,
+ and the bounds of the result include `x0'.
+
+ -- Applicative: exp (exp number)
+ -- Applicative: log (log number)
+ TODO
+
+ -- Applicative: sin (sin number)
+ -- Applicative: cos (cos number)
+ -- Applicative: tan (tan number)
+ TODO
+
+ -- Applicative: asin (asin number)
+ -- Applicative: acos (acos number)
+ -- Applicative: atan (atan number1 [number2])
+ TODO
+
+ -- Applicative: sqrt (sqrt number)
+ -- Applicative: expt (expt number1 number2)
+ TODO
+
+
+File: klisp.info, Node: Strings, Next: Characters, Prev: Numbers, Up: Top
+
+14 Strings
+**********
+
+A string is an object that represent a sequence of characters (for now,
+only ASCII is supported in klisp, in the future, full UNICODE will be
+supported). The external representation of strings consists of a
+leading """, the characters of the string and a closing """. Some
+characters should be escaped, by preceding them with a "\": in klisp
+these are the double quote (""") and the backslash ("\"). In the
+future more advanced escape mechanism may be added (like in r7rs-draft
+scheme, for escping common ASCII control codes and arbitrary unicode
+characters). A string has a length that is fixed at creation time, and
+as many characters, indexed from `0' to `length-1'.
+
+ Strings may be mutable or immutable. If an attempt is made to
+mutate an immutable string, an error is signaled. Two immutable
+strings are "eq?" iff they are "equal?". Two mutable strings are "eq?"
+if they were created by the same constructor call. Two mutable strings
+are "equal?" iff they are "string=?". For now it is undefined if a
+mutable and an immutable strings that are "string=?" are "equal?" or
+not. The only exception is the empty string. There is only one empty
+string (all empty strings are "eq?" to each other) and it should be
+considered immutable. Even if an attempt is made to return a new empty
+string (like calling `(string)', the canonical immutable empty string
+is returned. The string type is encapsulated.
+
+ SOURCE NOTE: This section is still missing from the report. The
+features defined here were taken mostly from r5rs scheme. It is
+possible that in the future, klisp only admits immutable strings (like
+lua and java), and that operations for contructing strings are moved to
+a new type (like Java's StringBuilder/StringBuffer). But for now,
+compatibility with r5rs was preferred/simpler.
+
+ -- Applicative: string? (string? . objects)
+ The primitive type predicate for type string. `string?' returns
+ true iff all the objects in `objects' are of type string.
+
+ -- Applicative: string=? (string=? . strings)
+ -- Applicative: string<? (string<? . strings)
+ -- Applicative: string<=? (string<=? . strings)
+ -- Applicative: string>? (string>? . strings)
+ -- Applicative: string>=? (string>=? . strings)
+ These predicates compare any number of strings by their
+ lexicographic order.
+
+ -- Applicative: string-ci=? (string-ci=? . strings)
+ -- Applicative: string-ci<? (string-ci<? . strings)
+ -- Applicative: string-ci<=? (string-ci<=? . strings)
+ -- Applicative: string-ci>? (string-ci>? . strings)
+ -- Applicative: string-ci>=? (string-ci>=? . strings)
+ These predicates convert the strings to lowercase and then compare
+ them using their lexicographic order.
+
+ -- Applicative: make-string (make-string k [char])
+ Applicative `make-string' constructs and returns a new mutable
+ string of length `k'. If `char' is specified, then all characters
+ in the returned string are `char', otherwise the content of the
+ string is unspecified.
+
+ -- Applicative: string (string . chars)
+ Applicative `string' contructs and return a new mutable string
+ composed of the character arguments.
+
+ -- Applicative: string-length (string-length string)
+ Applicative `string-length' returns the length of `string'.
+
+ -- Applicative: string-ref (string-ref string k)
+ Applicative `string-ref' returns the character of `string' at
+ position `k'. If `k' is out of bounds (i.e. less than `0' or
+ greater or equal than `(length string)') an error is signaled.
+
+ -- Applicative: string-set! (string-set! string k char)
+ Applicative `string-set!' replaces the character with index `k' in
+ `string' with character `char'. If `k' is out of bounds, or
+ `string' is immutable, an error is signaled.
+
+ -- Applicative: string-fill! (string-fill! string char)
+ Applicative `string-fill!' replaces all the characters in `string'
+ with character `char'. If `string' is an immutable string, an
+ error is signaled.
+
+ -- Applicative: substring (substring string k1 k2)
+ Both `k1' & `k2' should be valid indexes in `string'. Also it
+ should be the case that `k1 <= k2'.
+
+ Applicative `substring' constructs and returns a new immutable
+ string with length `k2 - k1', with the characters from `string',
+ starting at index `k1' (inclusive) and ending at index `k2'
+ (exclusive).
+
+ -- Applicative: string-append (string-append . strings)
+ Applicative `string-append' constructs and returns a new mutable
+ string consisting of the concatenation of all its arguments.
+
+ -- Applicative: string-copy (string-copy string)
+ Applicative `string-copy' constructs and returns a new mutable
+ string with the same length and characters as `string'.
+
+ -- Applicative: string->immutable-string (string->immutable-string
+ string)
+ Applicative `string->immutable-string' constructs and returns a
+ new immutable string with the same length and characters as
+ `string'.
+
+ -- Applicative: string->list (string->list string)
+ -- Applicative: list->string (list->string chars)
+ Applicatives `string->list' and `list->string' convert between
+ strings and list of characters. The strings returned by
+ `list->string' are mutable.
+
+
+File: klisp.info, Node: Characters, Next: Ports, Prev: Strings, Up: Top
+
+15 Characters
+*************
+
+A character is an object that represents an ASCII character (for now,
+only ASCII is supported in klisp, in the future, full UNICODE will be
+supported). The external representation of characters consists of a
+leading "#\" and the character or character name. The only supported
+names for now are "newline" and "space" (both from r5rs scheme).
+Characters are immutable. The character type is encapsulated.
+
+ SOURCE NOTE: This section is still missing from the report. The
+features defined here were taken mostly from r5rs scheme.
+
+ -- Applicative: char? (char? . objects)
+ The primitive type predicate for type character. `char?' returns
+ true iff all the objects in `objects' are of type character.
+
+ -- Applicative: char=? (char=? . chars)
+ -- Applicative: char<? (char<? . chars)
+ -- Applicative: char<=? (char<=? . chars)
+ -- Applicative: char>? (char>? . chars)
+ -- Applicative: char>=? (char>=? . chars)
+ These predicates compare any number of characters using their
+ ASCII value for the comparison.
+
+ -- Applicative: char-ci=? (char-ci=? . chars)
+ -- Applicative: char-ci<? (char-ci<? . chars)
+ -- Applicative: char-ci<=? (char-ci<=? . chars)
+ -- Applicative: char-ci>? (char-ci>? . chars)
+ -- Applicative: char-ci>=? (char-ci>=? . chars)
+ These predicates convert the chars to lowercase and then compare
+ their ASCII values.
+
+ -- Applicative: char-alphabetic? (char-alphabetic? . chars)
+ -- Applicative: char-numeric? (char-numeric? . chars)
+ -- Applicative: char-whitespace? (char-whitespace? . chars)
+ These predicates return true iff all of their arguments are
+ respectively "alphabetic", "numeric", or "whitespace".
+
+ -- Applicative: char-upper-case? (char-upper-case? . chars)
+ -- Applicative: char-lower-case? (char-lower-case? . chars)
+ These predicates return true iff all of their arguments are
+ respectively "upper case, or "lower case".
+
+ -- Applicative: char-upcase (char-upcase char)
+ -- Applicative: char-downcase (char-downcase char)
+ These applicatives return a character `char2' so that:
+ (char-ci=? char char2) => #t
+
+ If `char' is alphabetic then the following holds:
+
+ (char-upper-case? (char-upcase char)) => #t
+ (char-lower-case? (char-downcase char)) => #t
+
+ -- Applicative: char->integer (char->integer char)
+ -- Applicative: integer->char (integer->char k)
+ These applicatives convert between ASCII values (as exact integers
+ between 0 and 127) and characters. If an integer that is out of
+ range for ASCII characters is passed to `integer->char', an error
+ is signaled.
+
+
+File: klisp.info, Node: Ports, Next: Alphabetical Index, Prev: Characters, Up: Top
+
+16 Ports
+********
+
+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
+output only external representation (so that it can never be the normal
+result of a call to read). The eof type is encapsulated.
+
+ SOURCE NOTE: the eof type is not in the Kernel report, it is used in
+klisp and was taken from Scheme.
+
+ -- Applicative: port? (port? . objects)
+ The primitive type predicate for type port. `port?' returns true
+ iff all the objects in `objects' are of type port.
+
+ -- Applicative: input-port? (input-port? . objects)
+ -- 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.
+
+ 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)
+ -- 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: 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)
+ -- 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: 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 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: 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 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' 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: 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)
+ 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.
+
+ The result returned by applicatives `close-input-file' and
+ `close-output-file' is inert.
+
+ SOURCE NOTE: this is enumerated in the Kernel report but the text
+ is still missing. There's probably a name error here. These
+ should probably be called close-input-port & close-output-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' 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 [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' writes an external representation of `object'
+ to the specified port. This may be an output-only representation
+ that can't be read by applicative `read' in cases where the type
+ of `object' doen't have a parseable external representation (e.g.
+ combiners and environments). The result returned by `write' is
+ inert.
+
+ SOURCE NOTE: this is enumerated in the Kernel report but the text
+ is still missing.
+
+ -- Applicative: call-with-input-file (call-with-input-file string
+ combiner)
+ -- Applicative: call-with-output-file (call-with-output-file string
+ combiner)
+ 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 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
+ it, taking the description of `get-module' that there is in the
+ report. The one detail that I think is still open, is whether to
+ return `#inert' (as is the case with klisp currently) or rather
+ return the value of the last evaluation.
+
+ -- Applicative: get-module (get-module string [environment])
+ Applicative `get-module' creates a fresh standard environment;
+ 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
+ be changed to just `eof?', for consistency with the other
+ primitive type predicates.
+
+ -- 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.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+
+ -- 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
+ 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? [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 `char-ready?' checks to see if a character is available
+ in the specified port. If it returns true, then a `read-char' or
+ `peek-char' 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-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.
+
+ Applicative `write-char' writes the `char' character (not an
+ external representation of the character) to the specified port.
+ The result returned by `write-char' is inert.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+
+ -- 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.
+
+ Applicative `newline' writes a newline to the specified port. The
+ result returned by `newline' is inert.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+
+ -- 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.
+
+ Applicative `display' behaves like `write' except that strings are
+ not enclosed in double quotes and no character is escaped within
+ those strings and character objects are output as if by
+ `write-char' instead of `read'. The result returned by `display'
+ is inert.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+
+ -- 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
+ signaled.
+
+ Applicative `flush-ouput-port' flushes any buffered data in the
+ output port to the underlying file or device. The result returned
+ by `flush-output-port' is inert.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from r7rs
+ Scheme.
+
+ -- file-exists?: (file-exists? string)
+ `string' should be the name/path for a file.
+
+ Predicate `file-exists?' checks to see if a file named `string'
+ exists.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from r7rs
+ Scheme.
+
+ -- delete-file: (delete-file string)
+ `string' should be the name/path for an existing file.
+
+ Applicative `delete-file' deletes the file named `string'. If it
+ doesn't exists or can't be deleted, an error is signaled. The
+ result returned by `delete-file' is inert.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from r7rs
+ Scheme.
+
+ -- rename-file: (rename-file string1 string2)
+ `string1' should be the name/path for an existing file, `string2'
+ should be the name/path for a non existing file.
+
+ Applicative `rename-file' renames the file named `string1' to
+ `string2'. If the file doesn't exists or can't be renamed for any
+ reason, an error is signaled. The result returned by `rename-file'
+ is inert.
+
+ SOURCE NOTE: this is missing from Kernel AND Scheme, it is taken
+ from C, being quite similar to `delete-file'.
+
+
+File: klisp.info, Node: Alphabetical Index, Next: (dir), Prev: Ports, Up: Top
+
+Index
+*****
+
+
+* Menu:
+
+* $and?: Booleans. (line 28)
+* $binds?: Environments. (line 108)
+* $cond: Control. (line 32)
+* $define!: Environments. (line 49)
+* $if: Control. (line 15)
+* $import!: Environments. (line 207)
+* $lambda: Combiners. (line 76)
+* $lazy: Promises. (line 43)
+* $let: Environments. (line 89)
+* $let*: Environments. (line 124)
+* $let-redirect: Environments. (line 153)
+* $let-safe: Environments. (line 161)
+* $letrec: Environments. (line 137)
+* $letrec*: Environments. (line 144)
+* $or?: Booleans. (line 41)
+* $provide!: Environments. (line 191)
+* $remote-eval: Environments. (line 169)
+* $sequence: Control. (line 23)
+* $set!: Environments. (line 182)
+* $vau: Combiners. (line 26)
+* ( <1>: Ports. (line 54)
+* ( <2>: Numbers. (line 193)
+* ( <3>: Continuations. (line 143)
+* (: Environments. (line 174)
+* *: Numbers. (line 121)
+* +: Numbers. (line 109)
+* -: Numbers. (line 137)
+* /: Numbers. (line 306)
+* <=?: Numbers. (line 101)
+* <?: Numbers. (line 100)
+* =?: Numbers. (line 95)
+* >=?: Numbers. (line 103)
+* >?: Numbers. (line 102)
+* acos: Numbers. (line 385)
+* and?: Booleans. (line 20)
+* append: Pairs and lists. (line 208)
+* append!: Pairs and lists. (line 306)
+* applicative descriptions: A Sample Applicative Description.
+ (line 6)
+* applicative?: Combiners. (line 21)
+* applicatives: Combiners. (line 6)
+* apply: Combiners. (line 83)
+* apply-continuation: Continuations. (line 134)
+* asin: Numbers. (line 384)
+* 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)
+* caaadr: Pairs and lists. (line 102)
+* caaar: Pairs and lists. (line 93)
+* caadar: Pairs and lists. (line 103)
+* caaddr: Pairs and lists. (line 104)
+* caadr: Pairs and lists. (line 94)
+* caar: Pairs and lists. (line 89)
+* cadaar: Pairs and lists. (line 105)
+* cadadr: Pairs and lists. (line 106)
+* cadar: Pairs and lists. (line 95)
+* caddar: Pairs and lists. (line 107)
+* cadddr: Pairs and lists. (line 108)
+* caddr: Pairs and lists. (line 96)
+* cadr: Pairs and lists. (line 90)
+* 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)
+* cdaadr: Pairs and lists. (line 110)
+* cdaar: Pairs and lists. (line 97)
+* cdadar: Pairs and lists. (line 111)
+* cdaddr: Pairs and lists. (line 112)
+* cdadr: Pairs and lists. (line 98)
+* cdar: Pairs and lists. (line 91)
+* cddaar: Pairs and lists. (line 113)
+* cddadr: Pairs and lists. (line 114)
+* cddar: Pairs and lists. (line 99)
+* cdddar: Pairs and lists. (line 115)
+* cddddr: Pairs and lists. (line 116)
+* cdddr: Pairs and lists. (line 100)
+* cddr: Pairs and lists. (line 92)
+* cdr: Pairs and lists. (line 86)
+* ceiling: Numbers. (line 325)
+* char->integer: Characters. (line 58)
+* char-alphabetic?: Characters. (line 37)
+* char-ci<=?: Characters. (line 31)
+* char-ci<?: Characters. (line 30)
+* char-ci=?: Characters. (line 29)
+* char-ci>=?: Characters. (line 33)
+* char-ci>?: Characters. (line 32)
+* char-downcase: Characters. (line 49)
+* char-lower-case?: Characters. (line 44)
+* char-numeric?: Characters. (line 38)
+* char-upcase: Characters. (line 48)
+* char-upper-case?: Characters. (line 43)
+* char-whitespace?: Characters. (line 39)
+* char<=?: Characters. (line 23)
+* char<?: Characters. (line 22)
+* char=?: Characters. (line 21)
+* char>=?: Characters. (line 25)
+* char>?: Characters. (line 24)
+* char?: Characters. (line 17)
+* characters: Characters. (line 6)
+* combiner?: Combiners. (line 120)
+* combiners: Combiners. (line 6)
+* cons: Pairs and lists. (line 35)
+* continuation->applicative: Continuations. (line 95)
+* continuation?: Continuations. (line 38)
+* continuations: Continuations. (line 6)
+* control: Control. (line 6)
+* copy-es: Pairs and lists. (line 321)
+* copy-es-immutable!: Pairs and lists. (line 49)
+* cos: Numbers. (line 380)
+* countable-list?: Pairs and lists. (line 265)
+* denominator: Numbers. (line 315)
+* description format: Format of Descriptions.
+ (line 6)
+* div: Numbers. (line 149)
+* div-and-mod: Numbers. (line 151)
+* div0: Numbers. (line 163)
+* div0-and-mod0: Numbers. (line 165)
+* documentation notation: Evaluation Notation. (line 6)
+* empty list: Pairs and lists. (line 6)
+* encapsulations: Encapsulations. (line 6)
+* encycle!: Pairs and lists. (line 158)
+* environment?: Environments. (line 23)
+* environments: Environments. (line 6)
+* eof-object?: Ports. (line 208)
+* eq?: Equivalence. (line 12)
+* equal?: Equivalence. (line 16)
+* equivalence: Equivalence. (line 6)
+* error message notation: Error Messages. (line 6)
+* error-continuation: Continuations. (line 110)
+* eval: Environments. (line 32)
+* evaluation notation: Evaluation Notation. (line 6)
+* even?: Numbers. (line 186)
+* exact?: Numbers. (line 79)
+* exit: Continuations. (line 162)
+* exp: Numbers. (line 375)
+* expt: Numbers. (line 390)
+* extend-continuation: Continuations. (line 50)
+* filter: Pairs and lists. (line 239)
+* finite-list?: Pairs and lists. (line 261)
+* finite?: Numbers. (line 75)
+* floor: Numbers. (line 324)
+* fonts: Some Terms. (line 13)
+* foo: A Sample Applicative Description.
+ (line 15)
+* for-each: Control. (line 42)
+* force: Promises. (line 35)
+* gcd: Numbers. (line 207)
+* get-current-environment: Environments. (line 114)
+* get-list-metrics: Pairs and lists. (line 123)
+* 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)
+* get-real-internal-primary: Numbers. (line 251)
+* get-string-arithmetic: Numbers. (line 299)
+* guard-continuation: Continuations. (line 63)
+* guard-dynamic-extent: Continuations. (line 156)
+* ignore: Environments. (line 6)
+* ignore?: Environments. (line 28)
+* inert: Control. (line 6)
+* inert?: Control. (line 11)
+* inexact?: Numbers. (line 83)
+* input-port?: Ports. (line 32)
+* integer->char: Characters. (line 59)
+* integer?: Numbers. (line 61)
+* Kernel history: Kernel History. (line 6)
+* keyed dynamic variables: Keyed Variables. (line 15)
+* keyed static variables: Keyed Variables. (line 40)
+* keyed variables: Keyed Variables. (line 6)
+* lcm: Numbers. (line 206)
+* length: Pairs and lists. (line 191)
+* list: Pairs and lists. (line 72)
+* list*: Pairs and lists. (line 78)
+* list->string: Strings. (line 109)
+* list-neighbors: Pairs and lists. (line 228)
+* list-ref: Pairs and lists. (line 198)
+* list-tail: Pairs and lists. (line 147)
+* lists: Pairs and lists. (line 6)
+* load: Ports. (line 185)
+* log: Numbers. (line 376)
+* make-encapsulation-type: Encapsulations. (line 12)
+* make-environment: Environments. (line 36)
+* make-inexact: Numbers. (line 270)
+* make-kernel-standard-environment: Environments. (line 119)
+* make-keyed-dynamic-variable: Keyed Variables. (line 21)
+* make-keyed-static-variable: Keyed Variables. (line 44)
+* make-string: Strings. (line 57)
+* map <1>: Combiners. (line 96)
+* map: Pairs and lists. (line 169)
+* max: Numbers. (line 198)
+* member?: Pairs and lists. (line 257)
+* memoize: Promises. (line 74)
+* memq?: Pairs and lists. (line 338)
+* min: Numbers. (line 199)
+* mod: Numbers. (line 150)
+* mod0: Numbers. (line 164)
+* negative?: Numbers. (line 178)
+* nil: Pairs and lists. (line 6)
+* not?: Booleans. (line 16)
+* null?: Pairs and lists. (line 31)
+* number?: Numbers. (line 57)
+* numbers: Numbers. (line 6)
+* numerator: Numbers. (line 314)
+* object descriptions: A Sample Applicative Description.
+ (line 6)
+* odd?: Numbers. (line 185)
+* 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 33)
+* pair?: Pairs and lists. (line 27)
+* pairs: Pairs and lists. (line 6)
+* port?: Ports. (line 28)
+* ports: Ports. (line 6)
+* positive?: Numbers. (line 177)
+* printing notation: Printing Notation. (line 6)
+* promise?: Promises. (line 31)
+* promises: Promises. (line 6)
+* rational?: Numbers. (line 66)
+* rationalize: Numbers. (line 340)
+* read: Ports. (line 144)
+* real->exact: Numbers. (line 286)
+* real->inexact: Numbers. (line 285)
+* real?: Numbers. (line 71)
+* reduce: Pairs and lists. (line 270)
+* robust?: Numbers. (line 87)
+* root-continuation: Continuations. (line 104)
+* round: Numbers. (line 327)
+* set-car!: Pairs and lists. (line 41)
+* set-cdr!: Pairs and lists. (line 42)
+* simplest-rational: Numbers. (line 341)
+* sin: Numbers. (line 379)
+* sqrt: Numbers. (line 389)
+* string: Strings. (line 63)
+* string->immutable-string: Strings. (line 103)
+* string->list: Strings. (line 108)
+* string->symbol: Symbols. (line 20)
+* string-append: Strings. (line 94)
+* string-ci<=?: Strings. (line 51)
+* string-ci<?: Strings. (line 50)
+* string-ci=?: Strings. (line 49)
+* string-ci>=?: Strings. (line 53)
+* string-ci>?: Strings. (line 52)
+* string-copy: Strings. (line 98)
+* string-fill!: Strings. (line 80)
+* string-length: Strings. (line 67)
+* string-ref: Strings. (line 70)
+* string-set!: Strings. (line 75)
+* string<=?: Strings. (line 43)
+* string<?: Strings. (line 42)
+* string=?: Strings. (line 41)
+* string>=?: Strings. (line 45)
+* string>?: Strings. (line 44)
+* string?: Strings. (line 37)
+* strings: Strings. (line 6)
+* substring: Strings. (line 85)
+* symbol->string: Symbols. (line 16)
+* 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)
+* with-strict-arithmetic: Numbers. (line 298)
+* wrap: Combiners. (line 68)
+* zero?: Numbers. (line 143)
+
+
+
+Tag Table:
+Node: Top703
+Node: License2601
+Node: Introduction4283
+Node: Caveats7213
+Node: Kernel History7999
+Node: Conventions9444
+Node: Some Terms10115
+Node: Evaluation Notation10786
+Node: Printing Notation11807
+Node: Error Messages12283
+Node: Format of Descriptions12931
+Node: A Sample Applicative Description13495
+Node: Acknowledgements15258
+Node: Booleans15644
+Node: Equivalence18186
+Node: Symbols18979
+Node: Control20345
+Node: Pairs and lists22662
+Node: Environments39685
+Node: Combiners49892
+Node: Continuations55928
+Node: Encapsulations64461
+Node: Promises65914
+Node: Keyed Variables69837
+Node: Numbers72608
+Node: Strings92107
+Node: Characters97454
+Node: Ports100164
+Node: Alphabetical Index117768
+
+End Tag Table
diff --git a/manual/src/Makefile b/doc/src/Makefile
diff --git a/manual/src/booleans.texi b/doc/src/booleans.texi
diff --git a/manual/src/characters.texi b/doc/src/characters.texi
diff --git a/manual/src/combiners.texi b/doc/src/combiners.texi
diff --git a/doc/src/continuations.texi b/doc/src/continuations.texi
@@ -0,0 +1,204 @@
+@c -*-texinfo-*-
+@setfilename ../src/continuations
+
+@node Continuations, Encapsulations, Combiners, Top
+@comment node-name, next, previous, up
+
+@chapter Continuations
+@cindex continuations
+
+ A continuation is a plan for all future computation, parameterized
+by a value to be provided, and contingent on the states of all mutable
+data structures (which notably may include environments). When the
+Kernel evaluator is invoked, the invoker provides a continuation to
+which the result of the evaluation will normally be returned.
+
+ For example, when @code{$if} evaluates its test operand, the
+continuation provided for the result expects to be given a boolean
+value; and, depending on which boolean it gets, it will evaluate
+either the consequent or the alternative operand as a tail context —
+that is, the continuation provided for the result of evaluating the
+selected operand is the same continuation that was provided for the
+result of the call to @code{$if}.
+
+ A Kernel program may sometimes capture a continuation; that is,
+acquire a reference to it as a first-class object. The basic means of
+continuation capture is applicative @code{call/cc}. Given a
+first-class continuation @code{c}, a combiner can be constructed that
+will abnormally pass its operand tree to @code{c} (as opposed to the
+@c TODO add xref to abnormal pass
+normal return of values to continuations). In the simplest case, the
+abnormally passed value arrives at @code{c} as if it had been normally
+returned to @code{c}. In general, continuations bypassed by the
+abnormal pass may have entry/exit guards attached to them, and these
+guards can intercept the abnormal pass before it reaches @code{c}.
+Each entry/exit guard consists of a selector continuation, which
+designates which abnormal passes the guard will intercept, and an
+interceptor applicative that performs the interception when selected.
+@c TODO add xref to guard-continuation, continuation->applicative
+@c and abnormal pass
+
+ Continuations are immutable, and are @code{equal?} iff @code{eq?}.
+The continuation type is encapsulated.
+
+@c TODO add dynamic extent & guard selection/interception to the intro
+@deffn Applicative continuation? (continuation? . objects)
+ The primitive type predicate for type continuation.
+@code{continuation?} returns true iff all the objects in
+@code{objects} are of type continuation.
+@end deffn
+
+@deffn Applicative call/cc (call/cc combiner)
+ Calls @code{combiner} in the dynamic environment as a tail context,
+passing as sole operand to it the continuation to which @code{call/cc}
+would normally return its result. (That is, constructs such a
+combination and evaluates it in the dynamic environment.)
+@c TODO add xref Cf. operative $let/cc , §7.3.2.
+@end deffn
+
+@deffn Applicative extend-continuation (extend-continuation continuation applicative [environment])
+ The @code{extend-continuation} applicative constructs and returns a
+new child of @code{continuation} that, when it normally receives a
+value v, calls the underlying combiner of @code{applicative} with
+dynamic environment @code{environment} (or an empty environment if
+none was specified) and operand tree @code{v}, the result of the call
+normally to be returned to @code{continuation}.
+
+ The following equivalnece defines the short version:
+@example
+(extend-continuation c a) @equiv{}
+ (extend-continuation c a (make-environment))
+@end example
+@end deffn
+
+@deffn Applicative guard-continuation (guard-continuation entry-guards continuation exit-guards)
+ @code{entry-guards} and @code{exit-guards} should each be a list of
+clauses; each clause should be a list of length two, whose first
+element is a continuation, and whose second element is an applicative
+whose underlying combiner is operative.
+
+ Applicative @code{guard-continuation} constructs two continuations:
+a child of continuation, called the @code{outer continuation}; and a
+child of the @code{outer continuation}, called the @code{inner
+continuation}. The @code{inner continuation} is returned as the
+result of the call to @code{guard-continuation}.
+
+ When the @code{inner continuation} normally receives a value, it
+passes the value normally to the @code{outer continuation}; and when
+the @code{outer continuation} normally receives a value, it passes the
+value normally to @code{continuation}. Thus, in the absence of
+abnormal passing, the inner and outer continuations each have the same
+behavior as @code{continuation}.
+
+ The two elements of each guard clause are called, respectively, the
+@code{selector} and the @code{interceptor}. The @code{selector}
+continuation is used in deciding whether to intercept a given abnormal
+pass, and the @code{interceptor} applicative is called to perform
+@c TODO add xref to selection and interception
+customized action when interception occurs.
+
+@c TODO add xref to evaluation structure
+At the beginning of the call to @code{guard-continuation}, internal
+copies are made of the evaluation structures of @code{entry-guards}
+and @code{exit-guards}, so that the selectors and interceptors
+contained in the arguments at that time remain fixed thereafter,
+independent of any subsequent mutations to the arguments.
+@end deffn
+
+@deffn Applicative continuation->applicative (continuation->applicative continuation)
+ Returns an applicative whose underlying operative abnormally passes
+its operand tree to @code{continuation}, thus: A series of
+interceptors are selected to handle the abnormal pass, and a
+continuation is derived that will normally perform all the
+interceptions in sequence and pass some value to the destination of
+the originally abnormal pass. The operand tree is then normally
+passed to the derived continuation.
+@c TODO add xref to selection and interception
+@end deffn
+
+@defvar root-continuation
+ This continuation is the ancestor of all other continuations. When
+it normally receives a value, it terminates the Kernel session. (For
+example, if the system is running a read-eval-print loop, it exits the
+loop.)
+@c TODO add xref Cf. applicative exit, §7.3.4.
+@end defvar
+
+@defvar error-continuation
+ The dynamic extent of this continuation is mutually disjoint from
+the dynamic extent in which Kernel computation usually occurs (such as
+the dynamic extent in which the Kernel system would run a
+read-eval-print loop).
+
+ When this continuation normally receives a value, it provides a
+diagnostic message to the user of the Kernel system, on the assumption
+that the received value is an attempt to describe some error that
+aborted a computation; and then resumes operation of the Kernel system
+at some point that is outside of all user-defined computation. (For
+example, if the system is running a read-eval-print loop, operation
+may resume by continuing from the top of the loop.)
+
+ The diagnostic message is not made available to any Kernel
+computation, and is therefore permitted to contain information that
+violates abstractions within the system.
+
+@c TODO add details about klisp error messages
+ When an error is signaled during a Kernel computation, the signaling
+action consists of an abnormal pass to some continuation in the
+dynamic extent of @code{error-continuation}.
+@end defvar
+
+@deffn Applicative apply-continuation (apply-continuation continuation object)
+ Applicative @code{apply-continuation} converts its first argument to
+an applicative as if by @code{continuation->applicative}, and then
+applies it as usual.
+
+ That is:
+@example
+(apply-continuation continuation object) @equiv{}
+ (apply (continuation->applicative continuation) object)
+@end example
+@end deffn
+
+@deffn Operative ($let/cc <symbol> . <objects>)
+ A child environment @code{e} of the dynamic environment is created,
+containing a binding of @code{<symbol>} to the continuation to which
+the result of the call to @code{$let/cc} should normally return; then,
+the subexpressions of @code{<objects>} are evaluated in @code{e} from
+left to right, with the last (if any) evaluated as a tail context, or
+if @code{<objects>} is empty the result is inert.
+
+ That is:
+@example
+($let/cc symbol . objects) @equiv{}
+ (call/cc ($lambda (symbol) . objects))
+@end example
+@end deffn
+
+@deffn Applicative guard-dynamic-extent (guard-dynamic-extent entry-guards combiner exit-guards)
+ This applicative extends the current continuation with the specified
+guards, and calls @code{combiner} in the dynamic extent of the new
+continuation, with no operands and the dynamic environment of the call
+to @code{guard-dynamic-extent}.
+@end deffn
+
+@deffn Applicative exit (exit [object])
+@c TODO add xref
+ Applicative @code{exit} initiates an abnormal transfer of
+@code{object} (or @code{#inert} if @code{object} was not specified),
+to @code{root-continuation}.
+ That is:
+@example
+(exit) @equiv{} (apply-continuation root-continuation #inert)
+(exit obj) @equiv{} (apply-continuation root-continuation obj)
+@end example
+
+ SOURCE NOTE: This applicative doesn't have the optional argument in
+the report. It was added to klisp to allow a simple way to terminate
+the interpreter passing a value that is then tried to convert to an
+exit status.
+@end deffn
+
+
+
+
diff --git a/manual/src/control.texi b/doc/src/control.texi
diff --git a/manual/src/encapsulations.texi b/doc/src/encapsulations.texi
diff --git a/manual/src/environments.texi b/doc/src/environments.texi
diff --git a/manual/src/equivalence.texi b/doc/src/equivalence.texi
diff --git a/manual/src/index.texi b/doc/src/index.texi
diff --git a/manual/src/intro.texi b/doc/src/intro.texi
diff --git a/manual/src/keyed_vars.texi b/doc/src/keyed_vars.texi
diff --git a/manual/src/klisp.texi b/doc/src/klisp.texi
diff --git a/manual/src/numbers.texi b/doc/src/numbers.texi
diff --git a/manual/src/pairs_lists.texi b/doc/src/pairs_lists.texi
diff --git a/manual/src/ports.texi b/doc/src/ports.texi
diff --git a/manual/src/promises.texi b/doc/src/promises.texi
diff --git a/manual/src/strings.texi b/doc/src/strings.texi
diff --git a/manual/src/symbols.texi b/doc/src/symbols.texi
diff --git a/manual/html/Continuations.html b/manual/html/Continuations.html
@@ -1,233 +0,0 @@
-<html lang="en">
-<head>
-<title>Continuations - klisp Reference Manual</title>
-<meta http-equiv="Content-Type" content="text/html">
-<meta name="description" content="klisp Reference Manual">
-<meta name="generator" content="makeinfo 4.13">
-<link title="Top" rel="start" href="index.html#Top">
-<link rel="prev" href="Combiners.html#Combiners" title="Combiners">
-<link rel="next" href="Encapsulations.html#Encapsulations" title="Encapsulations">
-<link href="http://www.gnu.org/software/texinfo/" rel="generator-home" title="Texinfo Homepage">
-<meta http-equiv="Content-Style-Type" content="text/css">
-<style type="text/css"><!--
- pre.display { font-family:inherit }
- pre.format { font-family:inherit }
- pre.smalldisplay { font-family:inherit; font-size:smaller }
- pre.smallformat { font-family:inherit; font-size:smaller }
- pre.smallexample { font-size:smaller }
- pre.smalllisp { font-size:smaller }
- span.sc { font-variant:small-caps }
- span.roman { font-family:serif; font-weight:normal; }
- span.sansserif { font-family:sans-serif; font-weight:normal; }
---></style>
-</head>
-<body>
-<div class="node">
-<a name="Continuations"></a>
-<p>
-Next: <a rel="next" accesskey="n" href="Encapsulations.html#Encapsulations">Encapsulations</a>,
-Previous: <a rel="previous" accesskey="p" href="Combiners.html#Combiners">Combiners</a>,
-Up: <a rel="up" accesskey="u" href="index.html#Top">Top</a>
-<hr>
-</div>
-
-<!-- node-name, next, previous, up -->
-<h2 class="chapter">9 Continuations</h2>
-
-<p><a name="index-continuations-126"></a>
- A continuation is a plan for all future computation, parameterized
-by a value to be provided, and contingent on the states of all mutable
-data structures (which notably may include environments). When the
-Kernel evaluator is invoked, the invoker provides a continuation to
-which the result of the evaluation will normally be returned.
-
- <p>For example, when <code>$if</code> evaluates its test operand, the
-continuation provided for the result expects to be given a boolean
-value; and, depending on which boolean it gets, it will evaluate
-either the consequent or the alternative operand as a tail context —
-that is, the continuation provided for the result of evaluating the
-selected operand is the same continuation that was provided for the
-result of the call to <code>$if</code>.
-
- <p>A Kernel program may sometimes capture a continuation; that is,
-acquire a reference to it as a first-class object. The basic means of
-continuation capture is applicative <code>call/cc</code>. Given a
-first-class continuation <code>c</code>, a combiner can be constructed that
-will abnormally pass its operand tree to <code>c</code> (as opposed to the
-<!-- TODO add xref to abnormal pass -->
-normal return of values to continuations). In the simplest case, the
-abnormally passed value arrives at <code>c</code> as if it had been normally
-returned to <code>c</code>. In general, continuations bypassed by the
-abnormal pass may have entry/exit guards attached to them, and these
-guards can intercept the abnormal pass before it reaches <code>c</code>.
-Each entry/exit guard consists of a selector continuation, which
-designates which abnormal passes the guard will intercept, and an
-interceptor applicative that performs the interception when selected.
-<!-- TODO add xref to guard-continuation, continuation->applicative -->
-<!-- and abnormal pass -->
-
- <p>Continuations are immutable, and are <code>equal?</code> iff <code>eq?</code>.
-The continuation type is encapsulated.
-
-<!-- TODO add dynamic extent & guard selection/interception to the intro -->
-<div class="defun">
-— Applicative: <b>continuation?</b> (<var>continuation? . objects</var>)<var><a name="index-continuation_003f-127"></a></var><br>
-<blockquote><p> The primitive type predicate for type continuation.
-<code>continuation?</code> returns true iff all the objects in
-<code>objects</code> are of type continuation.
-</p></blockquote></div>
-
-<div class="defun">
-— Applicative: <b>call/cc</b> (<var>call/cc combiner</var>)<var><a name="index-call_002fcc-128"></a></var><br>
-<blockquote><p> Calls <code>combiner</code> in the dynamic environment as a tail context,
-passing as sole operand to it the continuation to which <code>call/cc</code>
-would normally return its result. (That is, constructs such a
-combination and evaluates it in the dynamic environment.)
-<!-- TODO add xref Cf. operative $let/cc , §7.3.2. -->
-</p></blockquote></div>
-
-<div class="defun">
-— Applicative: <b>extend-continuation</b> (<var>extend-continuation continuation applicative </var>[<var>environment</var>])<var><a name="index-extend_002dcontinuation-129"></a></var><br>
-<blockquote><p> The <code>extend-continuation</code> applicative constructs and returns a
-new child of <code>continuation</code> that, when it normally receives a
-value v, calls the underlying combiner of <code>applicative</code> with
-dynamic environment <code>environment</code> (or an empty environment if
-none was specified) and operand tree <code>v</code>, the result of the call
-normally to be returned to <code>continuation</code>.
-
- <p>The following equivalnece defines the short version:
- <pre class="example"> (extend-continuation c a) ==
- (extend-continuation c a (make-environment))
-</pre>
- </blockquote></div>
-
-<div class="defun">
-— Applicative: <b>guard-continuation</b> (<var>guard-continuation entry-guards continuation exit-guards</var>)<var><a name="index-guard_002dcontinuation-130"></a></var><br>
-<blockquote><p> <code>entry-guards</code> and <code>exit-guards</code> should each be a list of
-clauses; each clause should be a list of length two, whose first
-element is a continuation, and whose second element is an applicative
-whose underlying combiner is operative.
-
- <p>Applicative <code>guard-continuation</code> constructs two continuations:
-a child of continuation, called the <code>outer continuation</code>; and a
-child of the <code>outer continuation</code>, called the <code>inner
-continuation</code>. The <code>inner continuation</code> is returned as the
-result of the call to <code>guard-continuation</code>.
-
- <p>When the <code>inner continuation</code> normally receives a value, it
-passes the value normally to the <code>outer continuation</code>; and when
-the <code>outer continuation</code> normally receives a value, it passes the
-value normally to <code>continuation</code>. Thus, in the absence of
-abnormal passing, the inner and outer continuations each have the same
-behavior as <code>continuation</code>.
-
- <p>The two elements of each guard clause are called, respectively, the
-<code>selector</code> and the <code>interceptor</code>. The <code>selector</code>
-continuation is used in deciding whether to intercept a given abnormal
-pass, and the <code>interceptor</code> applicative is called to perform
-<!-- TODO add xref to selection and interception -->
-customized action when interception occurs.
-
- <!-- TODO add xref to evaluation structure -->
- <p>At the beginning of the call to <code>guard-continuation</code>, internal
-copies are made of the evaluation structures of <code>entry-guards</code>
-and <code>exit-guards</code>, so that the selectors and interceptors
-contained in the arguments at that time remain fixed thereafter,
-independent of any subsequent mutations to the arguments.
-</p></blockquote></div>
-
-<div class="defun">
-— Applicative: <b>continuation->applicative</b> (<var>continuation->applicative continuation</var>)<var><a name="index-continuation_002d_003eapplicative-131"></a></var><br>
-<blockquote><p> Returns an applicative whose underlying operative abnormally passes
-its operand tree to <code>continuation</code>, thus: A series of
-interceptors are selected to handle the abnormal pass, and a
-continuation is derived that will normally perform all the
-interceptions in sequence and pass some value to the destination of
-the originally abnormal pass. The operand tree is then normally
-passed to the derived continuation.
-<!-- TODO add xref to selection and interception -->
-</p></blockquote></div>
-
-<div class="defun">
-— Variable: <b>root-continuation</b><var><a name="index-root_002dcontinuation-132"></a></var><br>
-<blockquote><p> This continuation is the ancestor of all other continuations. When
-it normally receives a value, it terminates the Kernel session. (For
-example, if the system is running a read-eval-print loop, it exits the
-loop.)
-<!-- TODO add xref Cf. applicative exit, §7.3.4. -->
-</p></blockquote></div>
-
-<div class="defun">
-— Variable: <b>error-continuation</b><var><a name="index-error_002dcontinuation-133"></a></var><br>
-<blockquote><p> The dynamic extent of this continuation is mutually disjoint from
-the dynamic extent in which Kernel computation usually occurs (such as
-the dynamic extent in which the Kernel system would run a
-read-eval-print loop).
-
- <p>When this continuation normally receives a value, it provides a
-diagnostic message to the user of the Kernel system, on the assumption
-that the received value is an attempt to describe some error that
-aborted a computation; and then resumes operation of the Kernel system
-at some point that is outside of all user-defined computation. (For
-example, if the system is running a read-eval-print loop, operation
-may resume by continuing from the top of the loop.)
-
- <p>The diagnostic message is not made available to any Kernel
-computation, and is therefore permitted to contain information that
-violates abstractions within the system.
-
- <!-- TODO add details about klisp error messages -->
- <p>When an error is signaled during a Kernel computation, the signaling
-action consists of an abnormal pass to some continuation in the
-dynamic extent of <code>error-continuation</code>.
-</p></blockquote></div>
-
-<div class="defun">
-— Applicative: <b>apply-continuation</b> (<var>apply-continuation continuation object</var>)<var><a name="index-apply_002dcontinuation-134"></a></var><br>
-<blockquote><p> Applicative <code>apply-continuation</code> converts its first argument to
-an applicative as if by <code>continuation->applicative</code>, and then
-applies it as usual.
-
- <p>That is:
- <pre class="example"> (apply-continuation continuation object) ==
- (apply (continuation->applicative continuation) object)
-</pre>
- </blockquote></div>
-
-<div class="defun">
-— Operative: <b>(</b><var>$let/cc <symbol> . <objects></var>)<var><a name="index-g_t_0028-135"></a></var><br>
-<blockquote><p> A child environment <code>e</code> of the dynamic environment is created,
-containing a binding of <code><symbol></code> to the continuation to which
-the result of the call to <code>$let/cc</code> should normally return; then,
-the subexpressions of <code><objects></code> are evaluated in <code>e</code> from
-left to right, with the last (if any) evaluated as a tail context, or
-if <code><objects></code> is empty the result is inert.
-
- <p>That is:
- <pre class="example"> ($let/cc symbol . objects) ==
- (call/cc ($lambda (symbol) . objects))
-</pre>
- </blockquote></div>
-
-<div class="defun">
-— Applicative: <b>guard-dynamic-extent</b> (<var>guard-dynamic-extent entry-guards combiner exit-guards</var>)<var><a name="index-guard_002ddynamic_002dextent-136"></a></var><br>
-<blockquote><p> This applicative extends the current continuation with the specified
-guards, and calls <code>combiner</code> in the dynamic extent of the new
-continuation, with no operands and the dynamic environment of the call
-to <code>guard-dynamic-extent</code>.
-</p></blockquote></div>
-
-<div class="defun">
-— Applicative: <b>exit</b> (<var>exit</var>)<var><a name="index-exit-137"></a></var><br>
-<blockquote><!-- TODO add xref -->
- <p>Applicative <code>exit</code> initiates an abnormal transfer of
-<code>#inert</code> to <code>root-continuation</code>.
-
- <p>That is:
- <pre class="example"> (exit ) == (apply-continuation root-continuation #inert)
-</pre>
- </blockquote></div>
-
-<!-- *-texinfo-*- -->
- </body></html>
-
diff --git a/manual/klisp.info b/manual/klisp.info
@@ -1,2835 +0,0 @@
-This is ../klisp.info, produced by makeinfo version 4.13 from
-klisp.texi.
-
-This file documents klisp.
-
- This is edition 0.2 of the klisp Reference Manual, for klisp version
-0.2.
-
- Copyright (C) 2011 Andres Navarro
-
- Permission is granted to copy and distribute this manual, in whole or
-in part, without fee. Please note that most text of this manual is
-derived from `The Revised(-1) Report on the Kernel Programming
-Language' by John N. Shutt. There's a clause in that reports, under
-the header "Permission to copy this report", that reads:
-
- This report is intended to belong to the programming community,
- and so permission is granted to copy it in whole or in part
- without fee.
-
-
-File: klisp.info, Node: Top, Next: License, Prev: (dir), Up: (dir)
-
- This Info file contains edition 0.2 of the klisp Reference Manual,
-corresponding to klisp version 0.2.
-
- Copyright (C) 2011 Andres Navarro
-
- Permission is granted to copy and distribute this manual, in whole or
-in part, without fee. Please note that most text of this manual is
-derived from `The Revised(-1) Report on the Kernel Programming
-Language' by John N. Shutt. There's a clause in that reports, under
-the header "Permission to copy this report", that reads:
-
- This report is intended to belong to the programming community,
- and so permission is granted to copy it in whole or in part
- without fee.
-
-* Menu:
-
-* License:: Conditions for copying and changing klisp.
-* Introduction:: Introduction and conventions used.
-* Booleans:: Booleans module features.
-* Equivalence:: Equivalence (under & up to) mutation modules features.
-* Symbols:: Symbols module features.
-* Control:: Control module features.
-* Pairs and lists:: Pairs and lists and Pair mutation modules features.
-* Environments:: Environments and Environment mutation modules features.
-* Combiners:: Combiners module features.
-* Continuations:: Continuations module features.
-* Encapsulations:: Encapsulations module features.
-* Promises:: Promises module features.
-* Keyed Variables:: Keyed (dynamic & static) variables module features.
-* Numbers:: Numbers module features.
-* Strings:: Strings module features.
-* Characters:: Characters module features.
-* Ports:: Ports module features.
-* Alphabetical Index:: Index including concepts, functions, variables,
- and other terms.
-
-
-File: klisp.info, Node: License, Next: Introduction, Prev: Top, Up: Top
-
- klisp is licensed under the terms of the MIT license reproduced
-below. This means that klisp is free software and can be used for both
-academic and commercial purposes at absolutely no cost. The two
-projects whose code klisp uses, Lua & IMath, are also distributed under
-the MIT license.
-
- * klisp Parts: Copyright (C) 2011 Andres Navarro, Oto Havle.
-
- * Lua Parts: Copyright (C) 1994-2010 Lua.org, PUC-Rio.
-
- * IMath Parts: Copyright (C) 2002-2007 Michael J. Fromberger.
-
- * srfi-78: Copyright (C) 2005-2006 Sebastian Egner.
-
-MIT/X11 License
-***************
-
-Permission is hereby granted, free of charge, to any person obtaining a
-copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
-
- The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
-
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
-IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
-CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
-TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
-SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-
-File: klisp.info, Node: Introduction, Next: Booleans, Prev: License, Up: Top
-
-1 Introduction
-**************
-
-klisp is an open source interpreter for the Kernel Programming
-Language. It aims at being comprehensive and robust as specified in
-the `Revised(-1) Report on the Kernel Programming Language', but that
-probably won't happen for some time. It is written in C99 under the
-MIT license. It draws heavily from the Lua interpreter source code &
-file structure. It uses the IMath library for arbitrary sized integers
-and rationals.
-
- The Kernel programming language is a statically scoped and properly
-tail-recursive dialect of Lisp, descended from Scheme. It is designed
-to be simpler and more general than Scheme, with an exceptionally
-clear, simple, and versatile semantics, only one way to form compound
-expressions, and no inessential restrictions on the power of that one
-compound form. Imperative, functional, and message-passing programming
-styles (to name a few) may be conveniently expressed in Kernel.
-
- An important property of Kernel is that all manipulable entities in
-Kernel are first-class objects. In particular, Kernel has no
-second-class combiners; instead, the roles of special forms and macros
-are subsumed by operatives, which are first-class, statically scoped
-combiners that act directly on their unevaluated operands. Kernel also
-has a second type of combiners, applicatives, which act on their evalu-
-ated arguments. Applicatives are roughly equivalent to Scheme
-procedures. However, an applicative is nothing more than a wrapper to
-induce operand evaluation, around an underlying operative (or, in
-principle, around another applicative, though that isn’t usually done);
-applicatives themselves are mere facilitators to computation.
-
- You can read more about Kernel at
-`http://web.cs.wpi.edu/~jshutt/kernel.html'.
-
- klisp is freely available for both academic and commercial purposes.
-See LICENSE for details. it can be downloaded at
-`https://bitbucket.org/AndresNavarro/klisp'
-
- klisp is developed by Andres Navarro, a Computer Science
-undergraduate at Buenos Aires University (UBA). You can reach him at
-<canavarro82@gmail.com>. Significant contributions are being done by
-Oto Havle, his fork is at `https://bitbucket.org/havleoto/klisp'.
-
- This manual describes klisp version 0.2, presuming some familiarity
-with the Lisp family of languages in general, and with the Kernel
-Programming Language in particular. There are frequent references to
-the Kernel Programming Language Report. Unlike in the report, no
-rationale is provided for any feature, only a description of the
-implemented functionality.
-
- This is edition 0.2.
-
-* Menu:
-
-* Caveats:: Flaws and a request for help.
-* Kernel History:: Kernel is descended from Scheme.
-* Conventions:: How the manual is formatted.
-* Acknowledgements:: Contributions to this manual.
-
-
-File: klisp.info, Node: Caveats, Next: Kernel History, Prev: Introduction, Up: Introduction
-
-1.1 Caveats
-===========
-
-This is the first draft of this manual. It will be incomplete for some
-time. It will also evolve, together with klisp and the Kernel
-Programming Language, both of which, right now, are in a quite fluid
-state.
-
- The main reference on Kernel is the preliminary report: `Revised(-1)
-Report on the Kernel Programming Language'. Some sections of the
-report are still incomplete, so both klisp and this manual will use
-specifications from other languages in these sections, trying to follow
-the Kernel spirit. These instances will be documented throughout the
-manual.
-
- Please mail comments and corrections to <canavarro82@gmail.com>.
-
-
- -Andres Navarro
-
-
-File: klisp.info, Node: Kernel History, Next: Conventions, Prev: Caveats, Up: Introduction
-
-1.2 Kernel History
-==================
-
-The Kernel Programming Language is a work in progress. It is being
-developed by John N. Shutt, Ph.D, who created it while studying at the
-Worcester Polytechnic Institute (I think about 2002, or so... ASK). It
-is descended from scheme, with the idea that all objects should be
-first class values. In particular, Kernel replaces macros with
-operatives (kinda like statically scoped fexprs and fsubrs) and has
-first class environments. Kernel also has the notion of encapsulated
-objects which limits the ammount of information an implementation can
-share with a Kernel program (e.g. There is no way in Kernel to get the
-parents or a complete list of bindings of an environment object).
-
- The main reference on Kernel is the preliminary report: `Revised(-1)
-Report on the Kernel Programming Language'. Some sections of the
-report are still incomplete, so both klisp and this manual will use
-specifications from other languages in these sections, trying to follow
-the Kernel spirit. These instances will be documented throughout the
-manual.
-
- You can read all about Kernel at John's homepage at WPI
-`http://www.cs.wpi.edu/~jshutt/', including the preliminary report on
-the language and his doctoral dissertation which gives a theorethical
-frame for fexprs. You can contact him at <jshutt@cs.wpi.edu>.
-
-
-File: klisp.info, Node: Conventions, Next: Acknowledgements, Prev: Kernel History, Up: Introduction
-
-1.3 Conventions
-===============
-
-This section explains the notational conventions that are used in this
-manual. You may want to skip this section and refer back to it later.
-
-* Menu:
-
-* Some Terms:: Explanation of terms we use in this manual.
-* Evaluation Notation:: The format we use for examples of evaluation.
-* Printing Notation:: The format we use for examples that print output.
-* Error Messages:: The format we use for examples of errors.
-* Format of Descriptions:: Notation for describing functions, variables, etc.
-
-
-File: klisp.info, Node: Some Terms, Next: Evaluation Notation, Prev: Conventions, Up: Conventions
-
-1.3.1 Some Terms
-----------------
-
-Throughout this manual, the phrases "the Kernel reader" and "the Kernel
-printer" are used to refer to those routines in Lisp that convert
-textual representations of Kernel objects into actual objects, and vice
-versa. XXX Printed Representation XXX, for more details. You, the
-person reading this manual, are assumed to be "the programmer" or "the
-user".
-
- Examples of Kernel code appear in this font or form: `(list 1 2 3)'.
-Names that represent arguments or metasyntactic variables appear in
-this font or form: FIRST-NUMBER.
-
-
-File: klisp.info, Node: Evaluation Notation, Next: Printing Notation, Prev: Some Terms, Up: Conventions
-
-1.3.2 Evaluation Notation
--------------------------
-
-When you evaluate a piece of Kernel code, it produces a result. In the
-examples in this manual, this is indicated with `=>':
-
- (car (cons 1 2))
- => 1
-
-You can read this as "`(car (cons 1 2))' evaluates to 1".
-
- The semantics of a language feature are sometimes clarified, or even
-defined, in its entry by specifying that two expressions are
-equivalent. This is notated with `=='. For example, the semantics of
-applicative list* can be defined by following equivalences:
- (list* arg1) == arg1
- (list* arg1 . more-args) == (cons arg1 (list* . more-args))
- Notice that in these kind of examples the applicatives or operatives
-referred to are the first class values and not the symbols bound to
-them in the ground environment. This definition would hold even if
-`cons' or `list*' were redefined in the current dynamic environment.
-
-
-File: klisp.info, Node: Printing Notation, Next: Error Messages, Prev: Evaluation Notation, Up: Conventions
-
-1.3.3 Printing Notation
------------------------
-
-Many of the examples in this manual print text when they are evaluated.
-In examples that print text, the printed text is indicated with `-|'.
-The value returned by evaluating the form (here `#t') follows on a
-separate line.
-
- ($sequence (write 1) (write 2) #t)
- -| 1
- -| 2
- => #t
-
-
-File: klisp.info, Node: Error Messages, Next: Format of Descriptions, Prev: Printing Notation, Up: Conventions
-
-1.3.4 Error Messages
---------------------
-
-Some examples cause errors to be signaled. The report doesn't specify
-what objects are passed to the error continuation, but in klisp,
-objects passed to the error continuation are encapsulated error objects
-that have at least a message and possibly some additional objects and
-context informations (such as source code location). In the examples,
-the error message is shown on a line starting with `error-->'.
-
- (+ 23 #t)
- error--> Wrong type argument: (expected number) (#t)
-
-
-File: klisp.info, Node: Format of Descriptions, Prev: Error Messages, Up: Conventions
-
-1.3.5 Format of Descriptions
-----------------------------
-
-Applicatives, operatives, and other objects are described in this manual
-in a uniform format. The first line of a description contains the name
-of the item followed by its operands or arguments, if any. The
-category--operative, applicative, or whatever--appears at the beginning
-of the line. The description follows on succeeding lines, sometimes
-with examples.
-
-* Menu:
-
-* A Sample Applicative Description::
-
-
-File: klisp.info, Node: A Sample Applicative Description, Prev: Format of Descriptions, Up: Format of Descriptions
-
-1.3.5.1 A Sample Applicative Description
-........................................
-
-In an applicative description, the name of the applicative being
-described appears first. It is followed on the same line by an
-applicative combination that includes the name of the applicative and
-the arguments, as would appear in a program. The names used for the
-arguments are also used in the body of the description.
-
- Here is a description of an imaginary applicative `foo':
-
- -- Applicative: foo (foo integer1 integer2 . rest)
- The applicative `foo' subtracts INTEGER1 from INTEGER2, then adds
- all the rest of the arguments to the result.
-
- (foo 1 5 3 9)
- => 16
-
- More generally,
-
- (foo W X Y...)
- ==
- (+ (- X W) Y...)
-
- Any parameter whose name contains the name of a type (e.g., INTEGER,
-INTEGER1 or CONTINUATION) is expected to be of that type. A plural of
-a type (such as NUMBERS) often means a list of objects of that type.
-Parameters named OBJECT may be of any type. Additionally parameters
-named K, or KN (for any value of N), should be exact, non-negative
-integers. (XXX Types of Lisp Object XXX, for a list of Kernel object
-types.) Parameters with other sorts of names are discussed
-specifically in the description of the combiner. In some sections,
-features common to parameters of several combiners are described at the
-beginning.
-
- Operative descriptions have the same format, but the word
-`Applicative' is replaced by `Operative', and `Argument' is replaced
-by `Operand'. Also Operatives always have an environment parameter
-(that can be #ignore or a symbol).
-
-
-File: klisp.info, Node: Acknowledgements, Prev: Conventions, Up: Introduction
-
-1.4 Acknowledgements
-====================
-
-This manual was written by Andres Navarro.
-
- The structure and some text for this introductory section were
-borrowed from the Elisp Manual by the Free Sofware Foundation. This
-manual also borrows freely from both the Kernel Report and the Scheme
-Reports.
-
-
-File: klisp.info, Node: Booleans, Next: Equivalence, Prev: Introduction, Up: Top
-
-2 Booleans
-**********
-
-The boolean data type consists of two values, which are called true and
-false, and have respectively external representations `#t' and `#f'.
-There are no possible mutations of either of these two values, and the
-boolean type is encapsulated.
-
- -- Applicative: boolean? (boolean? . objects)
- The primitive type predicate for type boolean. `boolean?' returns
- true iff all the objects in `objects' are of type boolean.
-
- -- Applicative: not? (not? boolean)
- Applicative `not?' is a predicate that returns the logical
- negation of its argument.
-
- -- Applicative: and? (and? . booleans)
- Applicative `and?' is a predicate that returns true unless one or
- more of its arguments are false.
-
- -- Applicative: or? (or? . booleans)
- Applicative `or?' is a predicate that returns false unless one or
- more of its arguments are true.
-
- -- Operative: $and? ($and? . <list>)
- The `$and?' operative performs a "short-circuit and" of its
- operands. It evaluates them from left to right, until either an
- operand evaluates to false, or the end of the list is reached. If
- the end of the list is reached (which is immediate if `<list>' is
- `nil'), the operative returns true. If an operand evaluates to
- false, no further operand evaluations are performed, and the
- operative returns false. If `<list>' is acyclic, and the last
- operand is evaluated, it is evaluated as a tail context. If
- `<list>' is cyclic, an unbounded number of operand evaluations may
- be performed. If any of the operands evaluates to a non-boolean
- value, an error is signaled (even if it's the last one).
-
- -- Operative: $or? ($or? . <list>)
- The `$or?' operative performs a "short-circuit or" of its
- operands. It evaluates them from left to right, until either an
- operand evaluates to true, or the end of the list is reached. If
- the end of the list is reached (which is immediate if `<list>' is
- `nil'), the operative returns false. If an operand evaluates to
- true, no further operand evaluations are performed, and the
- operative returns true. If `<list>' is acyclic, and the last
- operand is evaluated, it is evaluated as a tail context. If
- `<list>' is cyclic, an unbounded number of operand evaluations may
- be performed. If any of the operands evaluates to a non-boolean
- value, an error is signaled (even if it's the last one).
-
-
-File: klisp.info, Node: Equivalence, Next: Symbols, Prev: Booleans, Up: Top
-
-3 Equivalence
-*************
-
-Kernel has two general-purpose equivalence predicates (whereas R5RS
-Scheme has three). The two Kernel predicates correspond to the
-abstract notions of equivalence up to mutation (`equal') and
-equivalence in the presence of mutation (`eq?').
-
- -- Applicative: eq? (eq? . objects)
- Predicate `eq?' returns true iff all of `objects' are effectively
- the same object, even in the presence of mutation.
-
- -- Applicative: equal? (equal? . objects)
- Predicate `equal?' returns true iff all of `objects' "look" the
- same as long as nothing is mutated. This is a weaker predicate
- than `eq?'; that is, `equal?' must return true whenever `eq?'
- would return true.
-
-
-File: klisp.info, Node: Symbols, Next: Control, Prev: Equivalence, Up: Top
-
-4 Symbols
-*********
-
-Two symbols are eq? iff they have the same external representation.
-Symbols are immutable, and the symbol type is encapsulated. The
-external representations of symbols are usually identifiers. However,
-symbols with other external representations may be created.
-
- -- Applicative: symbol? (symbol? . objects)
- The primitive type predicate for type symbol. `symbol?' returns
- true iff all the objects in `objects' are of type symbol.
-
- -- Applicative: symbol->string (symbol->string symbol)
- Applicative `symbol->string' returns the name of `symbol' as a
- string. The string returned is immutable.
-
- -- Applicative: string->symbol (string->symbol string)
- Applicative `string->symbol' returns the symbol with name
- `string'. The symbol is always interned, which means, that it is
- always the case that:
- (eq? <symbol> (string->symbol (symbol->string <symbol>)))
- => #t
- `string->symbol' can create symbols whose external
- representation aren't identifiers. Right now klisp uses an
- output-only representation, but in the near future it will
- probably include some kind of escaping mechanism to allow
- arbitrary symbols to have readable external representations as in
- R7RS Scheme.
-
-
-File: klisp.info, Node: Control, Next: Pairs and lists, Prev: Symbols, Up: Top
-
-5 Control
-*********
-
-The inert data type is provided for use with control combiners. It
-consists of a single immutable value, having external representation
-`#inert'. The inert type is encapsulated.
-
- -- Applicative: inert? (inert? . objects)
- The primitive type predicate for type inert. `inert?' returns true
- iff all the objects in `objects' are of type inert.
-
- -- Operative: $if ($if <test> <consequent> <alternative>)
- The `$if' operative first evaluates `<test>' in the dynamic
- environment. If the result is not of type boolean, an error is
- signaled. If the result is true, `<consequent>' is then evaluated
- in the dynamic environment as a tail context. Otherwise,
- `<alternative>' is evaluated in the dynamic environment as a tail
- context.
-
- -- Operative: $sequence ($sequence . <objects>)
- The `$sequence' operative evaluates the elements of the list
- `<objects>' in the dynamic environment, one at a time from left to
- right. If `<objects>' is a cyclic list, element evaluation
- continues indefinitely, with elements in the cycle being evaluated
- repeatedly. If `<objects>' is a nonempty finite list, its last
- element is evaluated as a tail context. If `<objects>' is the
- empty list, the result is inert.
-
- -- Operative: $cond ($cond . <clauses>)
- `<clauses>' should be a list of clause expressions, each of the
- form `(<test> . <body>)', where body is a list of expressions.
-
- The following equivalences define the behaviour of the `$cond'
- operative:
- ($cond) == #inert
- ($cond (<test> . <body>) . <clauses>) ==
- ($if <test> ($sequence . <body>) ($cond . <clauses>))
-
- -- Applicative: for-each (for-each . lists)
- `lists' must be a nonempty list of lists; if there are two or
- more, they should all be the same length. If lists is empty, or if
- all of its elements are not lists of the same length, an error is
- signaled.
-
- `for-each' behaves identically to `map', except that instead of
- accumulating and returning a list of the results of the
- element-wise applications, the results of the applications are
- discarded and the result returned by `for-each' is inert.
-
-
-File: klisp.info, Node: Pairs and lists, Next: Environments, Prev: Control, Up: Top
-
-6 Pairs and lists
-*****************
-
-A pair is an object that refers to two other objects, called its car
-and cdr. The Kernel data type pair is encapsulated.
-
- The null data type consists of a single immutable value, called nil
-or the empty list and having external representation `()', with or
-without whitespace between the parentheses. It is immutable, and the
-null type is encapsulated.
-
- If `a' and `d' are external representations of respectively the car
-and cdr of a pair `p', then `(a . d)' is an external representation of
-`p'. If the cdr of `p' is nil, then `(a)' is also an external
-representation of `p'. If the cdr of `p' is a pair `p2', and `(r)' is
-an external representation of `p2', then `(a r)' is an external
-representation of `p'. When a pair is output (as by write), an
-external representation with the fewest parentheses is used; in the
-case of a finite list, only one set of parentheses is required beyond
-those used in representing the elements of the list. For example, an
-object with external representation `(1 . (2 . (3 . ())))' would be
-output using, modulo whitespace, external representation `(1 2 3)'.
-
- -- Applicative: pair? (pair? . objects)
- The primitive type predicate for type pair. `pair?' returns true
- iff all the objects in `objects' are of type pair.
-
- -- Applicative: null? (null? . objects)
- The primitive type predicate for type null. `null?' returns true
- iff all the objects in `objects' are of type null.
-
- -- Applicative: cons (cons object1 object2)
- A new mutable pair object is constructed and returned, whose car
- and cdr referents are respectively `object1' and `object2'. No
- two objects returned by different calls to cons are `eq?' to each
- other.
-
- -- Applicative: set-car! (set-car! pair object)
- -- Applicative: set-cdr! (set-cdr! pair object)
- `pair' should be a mutable pair.
-
- These applicatives set the referent of, respectively, the car
- reference or the cdr reference of `pair' to `object'. The result
- of the expression is inert.
-
- -- Applicative: copy-es-immutable! (copy-es-immutable object)
- The short description of this applicative is that it returns an
- object `equal?' to `object' with an immutable evaluation
- structure. The "-es-" in the name is short for "evaluation
- structure".
-
- The evaluation structure of an object `o' is defined to be the set
- of all pairs that can be reached by following chains of references
- from `o' without ever passing through a non-pair object. The
- evaluation structure of a non-pair object is empty.
-
- If `object' is not a pair, the applicative returns `object'.
- Otherwise (if `object' is a pair), the applicative returns an
- immutable pair whose car and cdr would be suitable results for
- `(copy-es-immutable (car object))' and `(copy-es-immutable (cdr
- object))', respectively. Further, the evaluation structure of the
- returned value is isomorphic to that of `object' at the time of
- copying, with corresponding non-pair referents being `eq?'.
-
- NOTE: In Kernel it's undefined whether immutable pairs are copied
- or left "as is" in the result. klisp doesn't copy immutable
- pairs, but that behaviour should not be depended upon.
-
- -- Applicative: list (list . objects)
- The `list' applicative returns `objects'.
-
- The underlying operative of `list' returns its undifferentiated
- operand tree, regardless of whether that tree is or is not a list.
-
- -- Applicative: list* (list* . objects)
- `objects' should be a finite nonempty list of arguments.
-
- The following equivalences hold:
- (list* arg1) == arg1
- (list* arg1 arg2 . args) == (cons arg1 (list* arg2 . args))
-
- -- Applicative: car (car pair)
- -- Applicative: cdr (cdr pair)
- These applicatives return, respectively, the car and cdr of `pair'.
-
- -- Applicative: caar (caar pair)
- -- Applicative: cadr (cadr pair)
- -- Applicative: cdar (cdar pair)
- -- Applicative: cddr (cddr pair)
- -- Applicative: caaar (caaar pair)
- -- Applicative: caadr (caadr pair)
- -- Applicative: cadar (cadar pair)
- -- Applicative: caddr (caddr pair)
- -- Applicative: cdaar (cdaar pair)
- -- Applicative: cdadr (cdadr pair)
- -- Applicative: cddar (cddar pair)
- -- Applicative: cdddr (cdddr pair)
- -- Applicative: caaaar (caaaar pair)
- -- Applicative: caaadr (caaadr pair)
- -- Applicative: caadar (caadar pair)
- -- Applicative: caaddr (caaddr pair)
- -- Applicative: cadaar (cadaar pair)
- -- Applicative: cadadr (cadadr pair)
- -- Applicative: caddar (caddar pair)
- -- Applicative: cadddr (cadddr pair)
- -- Applicative: cdaaar (cdaaar pair)
- -- Applicative: cdaadr (cdaadr pair)
- -- Applicative: cdadar (cdadar pair)
- -- Applicative: cdaddr (cdaddr pair)
- -- Applicative: cddaar (cddaar pair)
- -- Applicative: cddadr (cddadr pair)
- -- Applicative: cdddar (cdddar pair)
- -- Applicative: cddddr (cddddr pair)
- These applicatives are compositions of `car' and `cdr', with the
- "a’s" and "d’s" in the same order as they would appear if all the
- individual "car’s" and "cdr’s" were written out in prefix order.
- Arbitrary compositions up to four deep are provided. There are
- twenty-eight of these applicatives in all.
-
- -- Applicative: get-list-metrics (get-list-metrics object)
- By definition, an improper list is a data structure whose objects
- are its start together with all objects reachable from the start by
- following the cdr references of pairs, and whose internal
- references are just the cdr references of its pairs. Every
- object, of whatever type, is the start of an improper list. If
- the start is not a pair, the improper list consists of just that
- object. The acyclic prefix length of an improper list `L' is the
- number of pairs of `L' that a naive traversal of `L' would visit
- only once. The cycle length of `L' is the number of pairs of `L'
- that a naive traversal would visit repeatedly. Two improper lists
- are structurally isomorphic iff they have the same acyclic prefix
- length and cycle length and, if they are terminated by non-pair
- objects rather than by cycles, the non-pair objects have the same
- type. Applicative `get-list-metrics' constructs and returns a
- list of exact integers of the form `(p n a c)', where `p', `n',
- `a', and `c' are, respectively, the number of pairs in, the number
- of nil objects in, the acyclic prefix length of, and the cycle
- length of, the improper list starting with `object'. `n' is either
- `0' or `1', `a + c = p', and `n' and `c' cannot both be non-zero.
- If `c = 0', the improper list is acyclic; if `n = 1', the improper
- list is a finite list; if `n = c = 0', the improper list is not a
- list; if `a = c = 0', `object' is not a pair.
-
- -- Applicative: list-tail (list-tail object k)
- `object' must be the start of an improper list containing at least
- `k' pairs.
-
- The `list-tail' applicative follows `k' cdr references starting
- from `object'.
-
- The following equivalences hold:
- (list-tail object 0) == object
- (list-tail object (+ k 1)) == (list-tail (cdr object) k)
-
- -- Applicative: encycle! (encycle! object k1 k2)
- The improper list starting at `object' must contain at least `k1 +
- k2' pairs.
-
- If `k2 = 0', the applicative does nothing. If `k2 > 0', the
- applicative mutates the improper list starting at `object' to have
- acyclic prefix length `k1' and cycle length `k2', by setting the
- cdr of the `(k1+k2)'th pair in the list to refer to the `(k1 +
- 1)'th pair in the list. The result returned by `encycle!' is
- inert.
-
- -- Applicative: map (map applicative . lists)
- `lists' must be a nonempty list of lists; if there are two or
- more, they must all have the same length.
-
- The map applicative applies `applicative' element-wise to the
- elements of the lists in lists (i.e., applies it to a list of the
- first elements of the lists, to a list of the second elements of
- the lists, etc.), using the dynamic environment from which map was
- called, and returns a list of the results, in order. The
- applications may be performed in any order, as long as their
- results occur in the resultant list in the order of their
- arguments in the original lists. If `lists' is a cyclic list,
- each argument list to which `applicative' is applied is
- structurally isomorphic to `lists'. If any of the elements of
- `lists' is a cyclic list, they all must be, or they wouldn’t all
- have the same length. Let `a1...an' be their acyclic prefix
- lengths, and `c1...cn' be their cycle lengths. The acyclic prefix
- length `a' of the resultant list will be the maximum of the `ak',
- while the cycle length `c' of the resultant list will be the least
- common multiple of the `ck'. In the construction of the result,
- `applicative' is called exactly `a + c' times.
-
- -- Applicative: length (length object)
- Applicative `length' returns the (exact) improper-list length of
- `object'. That is, it returns the number of consecutive cdr
- references that can be followed starting from `object'. If
- `object' is not a pair, it returns zero; if `object' is a cyclic
- list, it returns positive infinity.
-
- -- Applicative: list-ref (list-ref object k)
- The `list-ref' applicative returns the `car' of the object
- obtained by following `k' cdr references starting from `object'.
-
- NOTE: In the current report, object is required to be a list. In
- klisp, for now, we prefer the behaviour presented here, as it is
- more in line with the applicative `list-tail'. That is, we define
- `list-ref' by the following equivalence:
- (list-ref object k) == (car (list-tail object k))
-
- -- Applicative: append (append . lists)
- Here, all the elements of `lists' except the last element (if any)
- must be acyclic lists. The `append' applicative returns a freshly
- allocated list of the elements of all the specified `lists', in
- order, except that if there is a last specified element of
- `lists', it is not copied, but is simply referenced by the cdr of
- the preceding pair (if any) in the resultant list. If `lists' is
- cyclic, the cycle of the result list consists of just the elements
- of the lists specified in the cycle in `lists'. In this case, the
- acyclic prefix length of the result is the sum of the lengths of
- the lists specified in the acyclic prefix of `lists', and the
- cycle length of the result is the sum of the lengths of the lists
- specified in the cycle of `lists'.
-
- The following equivalences hold:
- (append) == ()
- (append h) == h
- (append () h . t) == (append h . t)
- (append (cons a b) h . t) == (cons a (append b h . t))
-
- -- Applicative: list-neighbors (list-neighbors list)
- The `list-neighbors' applicative constructs and returns a list of
- all the consecutive sublists of `list' of length 2, in order. If
- `list' is nil, the result is nil. If `list' is non-nil, the
- length of the result is one less than the length of `list'. If
- `list' is cyclic, the result is structurally isomorphic to it
- (i.e., has the same acyclic prefix length and cycle length).
-
- For example:
- (list-neighbors (list 1 2 3 4)) => ((1 2) (2 3) (3 4))
-
- -- Applicative: filter (filter applicative list)
- Applicative `filter' passes each of the elements of `list' as an
- argument to `applicative', one at a time in no particular order,
- using a fresh empty environment for each call. The result of each
- call to `applicative' must be boolean, otherwise an error is
- signaled. `filter' constructs and returns a list of all elements
- of `list' on which `applicative' returned true, in the same order
- as in `list'. `applicative' is called exactly as many times as
- there are pairs in `list'. The resultant list has a cycle
- containing exactly those elements accepted by `applicative' that
- were in the cycle of `list'; if there were no such elements, the
- result is acyclic.
-
- -- Applicative: assoc (assoc object pairs)
- Applicative `assoc' returns the first element of `pairs' whose car
- is `equal?' to `object'. If there is no such element in `pairs',
- nil is returned.
-
- -- Applicative: member? (member? object list)
- Applicative `member?' is a predicate that returns true iff some
- element of `list' is `equal?' to `object'.
-
- -- Applicative: finite-list? (finite-list? . objects)
- This is the type predicate for type finite-list. `finite-list?'
- returns true iff all the objects in `objects' are acyclic lists.
-
- -- Applicative: countable-list? (countable-list? . objects)
- This is the type predicate for type list. `countable-list?'
- returns true iff all the objects in `objects' are lists.
-
- -- Applicative: reduce (reduce list binary identity [precycle incycle
- postcycle])
- `binary' should be an applicative. If the short form is used,
- `list' should be an acyclic. If the long form is used, `precycle',
- `incycle', and `postcycle' should be applicatives.
-
- If `list' is empty, applicative `reduce' returns `identity'. If
- `list' is nonempty but acyclic, applicative `reduce' uses binary
- operation `binary' to merge all the elements of `list' into a
- single object, using any associative grouping of the elements.
- That is, the sequence of objects initially found in `list' is
- repeatedly decremented in length by applying `binary' to a list of
- any two consecutive objects, replacing those two objects with the
- result at the point in the sequence where they occurred; and when
- the sequence contains only one object, that object is returned.
- If `list' is cyclic, the long form must be used. The elements of
- the cycle are passed, one at a time (but just once for each
- position in the cycle), as arguments to unary applicative
- `precycle'; the finite, cyclic sequence of results from `precycle'
- is reduced using binary applicative `incycle'; and the result from
- reducing the cycle is passed as an argument to unary applicative
- `postcycle'. Binary operation `binary' is used to reduce the
- sequence consisting of the elements of the acyclic prefix of
- `list' followed by the result returned by `postcycle'. The only
- constraint on the order of calls to the applicatives is that each
- call must be made before its result is needed (thus, parts of the
- reduction of the acyclic prefix may occur before the contribution
- from the cycle has been completed).
-
- Each call to `binary', `precycle', `incycle', or `postcycle' uses
- the dynamic environment of the call to `reduce'.
-
- If `list' is acyclic with length `n >= 1', `binary' is called `n -
- 1' times. If `list' is cyclic with acyclic prefix length `a' and
- cycle length `c', `binary' is called `a' times; `precycle', `c'
- times; `incycle', `c - 1' times; and `postcycle', once.
-
- -- Applicative: append! (append! . lists)
- `lists' must be a nonempty list; its first element must be an
- acyclic nonempty list, and all of its elements except the last
- element (if any) must be acyclic lists.
-
- The `append!' applicative sets the cdr of the last pair in each
- nonempty list argument to refer to the next non-nil argument,
- except that if there is a last non-nil argument, it isn’t mutated.
- It is an error for any two of the list arguments to have the same
- last pair. The result returned by this applicative is inert.
-
- The following equivalences hold:
- (append! v) == #inert
- (append! u v . w) == ($sequence (append! u v) (append! u . w))
-
- -- Applicative: copy-es (copy-es object)
- Briefly, applicative `copy-es' returns an object initially
- `equal?' to `object' with a freshly constructed evaluation
- structure made up of mutable pairs. If `object' is not a pair,
- the applicative returns `object'. If `object' is a pair, the
- applicative returns a freshly constructed pair whose car and cdr
- would be suitable results for `(copy-es (car object))' and
- `(copy-es (cdr object))', respectively. Further, the evaluation
- structure of the returned value is structurally isomorphic to that
- of `object' at the time of copying, with corresponding non-pair
- referents being `eq?'.
-
- -- Applicative: assq (assq object pairs)
- Applicative `assq' returns the first element of `pairs' whose car
- is `eq?' to `object'. If there is no such element in `pairs', nil
- is returned.
-
- -- Applicative: memq? (memq? object list)
- Applicative `memq?' is a predicate that returns true iff some
- element of `list' is `eq?' to `object'.
-
-
-File: klisp.info, Node: Environments, Next: Combiners, Prev: Pairs and lists, Up: Top
-
-7 Environments
-**************
-
-An environment consists of a set of bindings, and a list of zero or
-more references to other environments called its parents. Changing the
-set of bindings of an environment, or setting the referent of the
-reference in a binding, is a mutation of the environment. (Changing the
-parent list, or a referent in the list, would be a mutation of the
-environment too, but there is no facility provided to do it.) The
-Kernel data type environment is encapsulated. Among other things,
-there is no facility provided for enumerating all the variables
-exhibited by an environment (which is not required, after all, to be a
-finite set), and no facility for identifying the parents of an
-environment. Two environments are `equal?' iff they are `eq?'.
-
- An auxiliary data type used by combiners that perform binding is
-ignore. The ignore type consists of a single immutable value, having
-external representation `#ignore'. The ignore type is encapsulated.
-
- -- Applicative: environment? (environment? . objects)
- The primitive type predicate for type environment. `environment?'
- returns true iff all the objects in `objects' are of type
- environment.
-
- -- Applicative: ignore? (ignore? . objects)
- The primitive type predicate for type ignore. `ignore?' returns
- true iff all the objects in `objects' are of type ignore.
-
- -- Applicative: eval (eval expression environment)
- The `eval' applicative evaluates `expression' as a tail context in
- `environment', and returns the resulting value.
-
- -- Applicative: make-environment (make-environment . environments)
- The applicative constructs and returns a new environment, with
- initially no local bindings, and parent environments the
- environments listed in `environments'. The constructed environment
- internally stores its list of parents independent of the
- first-class list `environments', so that subsequent mutation of
- `environments' will not change the parentage of the constructed
- environment. If the provided list `environments' is cyclic, the
- constructed environment will still check each of its parents at
- most once, and signal an error if no binding is found locally or
- in any of the parents. No two objects returned by different calls
- to `make-environment' are `eq?' to each other.
-
- -- Operative: $define! ($define! <definiend> <expression>)
- `<definiend>' should be a formal parameter tree, as described
- below; otherwise, an error is signaled.
-
- The `$define!' operative evaluates `<expression>' in the dynamic
- environment and matches `<definiend>' to the result in the dynamic
- environment, binding each symbol in definiend in the dynamic
- environment to the corresponding part of the result; the matching
- process will be further described below. The ancestors of the
- dynamic environment, if any, are unaffected by the matching
- process, as are all bindings, local to the dynamic environment, of
- symbols not in `<definiend>'. The result returned by `$define!' is
- inert.
-
- A formal parameter tree has the following context-free structure:
- ptree:: symbol | #ignore | () | (ptree . ptree)
-
- That is, a formal parameter tree is either a symbol, or ignore, or
- nil, or a pair whose car and cdr referents are formal parameter
- trees. A formal parameter tree must also be acyclic, and no one
- symbol can occur more than once in it. It is not an error for a
- pair in the tree to be reachable from the root by more than one
- path, as long as there is no cycle; but if any particular symbol
- were reachable from the root by more than one path, that would
- count as occurring more than once. Thus, if a pair is reachable
- by more than one path, there must be no symbols reachable from it.
-
- Matching of a formal parameter tree `t' to an object `o' in an
- environment `e' proceeds recursively as follows. If the matching
- process fails, an error is signaled.
- * If `t' is a symbol, then `t' is bound to `o' in `e'.
-
- * If `t' is `#ignore', no action is taken.
-
- * If `t' is nil, then `o' must be nil (else matching fails).
-
- * If `t' is a pair, then `o' must be a pair (else matching
- fails). The car of `t' is matched to the car of `o' in `e',
- and the cdr of `t' is matched to the cdr of `o' in `e'.
-
- -- Operative: $let ($let <bindings> . <objects>)
- `<bindings>' should be a finite list of
- formal-parameter-tree/expression pairings, each of the form
- `(formals expression)', where each `formals' is a formal
- parameter, and no symbol occurs in more than one of the `formals'.
-
- The following equivalence holds:
-
- ($let ((form1 exp1) ... (formn expn)) . objects) ==
- (($lambda (form1 ... formn) . objects) exp1 ... expn)
-
- Thus, the `expk' are first evaluated in the dynamic environment,
- in any order; then a child environment `e' of the dynamic
- environment is created, with the `formk' matched in `e' to the
- results of the evaluations of the `expk'; and finally the
- subexpressions of `objects' are evaluated in `e' from left to
- right, with the last (if any) evaluated as a tail context, or if
- `objects' is empty the result is inert.
-
- -- Operative: $binds? ($binds? <exp> . <symbols>)
- Operative `$binds' evaluates `<exp>' in the dynamic environment;
- call the result `env'. `env' must be an environment. The
- operative is a predicate that returns true iff all its later
- operands, `<symbols>', are visibly bound in `env'.
-
- -- Applicative: get-current-environment (get-current-environment)
- The `get-current-environment' applicative returns the dynamic
- environment in which it is called.
-
- -- Applicative: make-kernel-standard-environment
- (make-kernel-standard-environment)
- The `make-kernel-standard-environment' applicative returns a
- standard environment; that is, a child of the ground environment
- with no local bindings.
-
- -- Operative: $let* ($let* <bindings> . <body>)
- `<bindings>' should be a finite list of
- formal-parameter-tree/expression pairings, each of the form
- `(formals expression)', where each `formals' is a formal parameter
- tree; `<body>' should be a list of expressions.
-
- The following equivalences hold:
-
- ($let* () . body) == ($let () . body)
-
- ($let* ((form exp) . bindings) . body) ==
- ($let ((form exp)) ($let* bindings . body))
-
- -- Operative: $letrec ($letrec <bindings> . <body>)
- `<bindings>' and `<body>' should be as described for `$let'.
-
- The following equivalence holds:
- ($letrec ((form1 exp1) ... (formn expn)) . body) ==
- ($let () ($define! (form1 ... formn) (list exp1 ... expn)) . body)
-
- -- Operative: $letrec* ($letrec* <bindings> . <body>)
- `<bindings>' and `<body>' should be as described for `$let*'.
-
- The following equivalences hold:
- ($letrec* () . body) == ($letrec () . body)
-
- ($letrec* ((form exp) . bindings) . body) ==
- ($letrec ((form exp)) ($letrec* bindings . body))
-
- -- Operative: $let-redirect ($let-redirect <exp> <bindings> . <body>)
- `<bindings>' and `<body>' should be as described for `$let'.
-
- The following equivalence holds:
-
- ($let-redirect exp ((form1 exp1) ... (formn . body) expn)) ==
- ((eval (list $lambda (form1 ... formn) body) exp) expn ... expn)
-
- -- Operative: $let-safe ($let-safe <bindings> . <body>)
- `<bindings>' and `<body>' should be as described for `$let'.
-
- The following equivalence holds:
-
- ($let-safe bindings . body) ==
- ($let-redirect (make-kernel-standard-environment) bindings . body)
-
- -- Operative: $remote-eval ($remote-eval <exp1> <exp2>)
- Operative `$remote-eval' evaluates `<exp2>' in the dynamic
- environment, then evaluates `<exp1>' as a tail context in the
- environment that must result from the first evaluation.
-
- -- Operative: ($bindings-environment . <bindings>)
- `<bindings>' should be as described for `$let'.
-
- The following equivalence holds:
-
- ($bindings->environment . bindings) ==
- ($let-redirect (make-environment) bindings (get-current-environment))
-
- -- Operative: $set! ($set! <exp1> <formals> <exp2>)
- `<formals>' should be as described for the `$define!' operative.
- The `$set!' operative evaluates `<exp1>' and `<exp2>' in the
- dynamic environment; call the results `env' and `obj'. If `env'
- is not an environment, an error is signaled. Then the operative
- matches `<formals>' to `obj' in environment `env'. Thus, the
- symbols of `<formals>' are bound in `env' to the corresponding
- parts of `obj'. The result returned by `$set!' is inert.
-
- -- Operative: $provide! ($provide! <symbols> . <body>)
- `<symbols>' must be a finite list of symbols, containing no
- duplicates. `<body>' must be a finite list.
-
- The `$provide!' operative constructs a child `e' of the dynamic
- environment `d'; evaluates the elements of `<body>' in `e', from
- left to right, discarding all of the results; and exports all of
- the bindings of symbols in `<symbols>' from `e' to `d', i.e.,
- binds each symbol in `d' to the result of looking it up in `e'.
- The result returned by `$provide!' is inert.
-
- The following equivalence holds:
-
- ($provide! symbols . body) ==
- ($define! symbols ($let () ($sequence . body) (list . symbols)))
-
- -- Operative: $import! ($import! <exp> . <symbols>)
- `<symbols>' must be a list of symbols.
-
- The `$import!' operative evaluates `<exp>' in the dynamic
- environment; call the result `env'. `env' must be an environment.
- Each distinct symbol `s' in `<symbols>' is evaluated in `env', and
- `s' is bound in the dynamic environment to the result of this
- evaluation.
-
- The following equivalence holds:
-
- ($import! exp . symbols) ==
- ($define! symbols ($remote-eval (list symbols) exp))
-
-
-File: klisp.info, Node: Combiners, Next: Continuations, Prev: Environments, Up: Top
-
-8 Combiners
-***********
-
-There are two types of combiners in Kernel, operative and applicative.
-Both types are encapsulated. All combiners are immutable. Two
-applicatives are `eq?' iff their underlying combiners are `eq?'.
-However, `eq?'-ness of operatives is only constrained by the general
-rules for `eq?', which leave considerable leeway for variation between
-implementations. klisp only considers `eq?' those operatives
-constructed by the same call to a constructor (e.g. `$vau'). Two
-combiners are `equal?' iff they are `eq?'.
-
- -- Applicative: operative? (operative? . objects)
- The primitive type predicate for type operative. `operative?'
- returns true iff all the objects in `objects' are of type
- operative.
-
- -- Applicative: applicative? (applicative? . objects)
- The primitive type predicate for type applicative. `applicative?'
- returns true iff all the objects in `objects' are of type
- applicative.
-
- -- Operative: $vau ($vau <formals> <eformal> . <objects>)
- `<formals>' should be a formal parameter tree; `<eformal>' should
- be either a symbol or `#ignore'. If `<formals>' does not have the
- correct form for a formal parameter tree, or if `<eformal>' is a
- symbol that also occurs in `<formals>', an error is signaled.
-
- A `vau' expression evaluates to an operative; an operative created
- in this way is said to be compound. The environment in which the
- `vau' expression was evaluated is remembered as part of the
- compound operative, called the compound operative’s static
- environment. `<formals>' and `<objects>' are copied as by
- `copy-es-immutable' and the copies are stored as part of the
- operative being constructed. This avoids problem if these
- structures are later mutated.
-
- When the compound operative created by `$vau' is later called with
- an object and an environment, here called respectively the operand
- tree and the dynamic environment, the following happens:
-
- 1. A new, initially empty environment is created, with the static
- environment as its parent. This will be called the local
- environment.
-
- 2. A stored copy of the formal parameter tree formals is matched
- in the local environment to the operand tree, locally binding
- the symbols of formals to the corresponding parts of the
- operand tree. eformal is matched to the dynamic environment;
- that is, if eformal is a symbol then that symbol is bound in
- the local environment to the dynamic environment.
-
- 3. A stored copy of the expressions is evaluated sequentially
- from left to right, with the last (if any) evaluated as a
- tail context, or if the list of expressions is empty, the
- result is inert.
-
- NOTE: Because compound operatives are not a distinct type in
- Kernel, they are covered by the encapsulation of type operative.
- In particular, an implementation of Kernel cannot provide a
- feature that supports extracting the static environment of any
- given compound operative, nor that supports determining whether or
- not a given operative is compound.
-
- -- Applicative: wrap (wrap combiner)
- The `wrap' applicative returns an applicative whose underlying
- combiner is `combiner'.
-
- -- Applicative: unwrap (unwrap applicative)
- The `unwrap' applicative returns the underlying combiner of
- `applicative'.
-
- -- Operative: $lambda ($lambda <formals> . <objects>)
- `<formals>' should be a formal parameter tree.
-
- The `$lambda' operative is defined by the following equivalence:
- ($lambda formals . objects) ==
- (wrap ($vau formals #ignore . objects))
-
- -- Applicative: apply (apply applicative object [environment])
- Applicative `apply' combines the underlying combiner of
- `applicative' with `object' in a tail context with dynamic
- environment `environment' (if the long form is used) or in an
- empty environment (if the short form is used).
-
- The following equivalences hold:
- (apply applicative object environment) ==
- (eval (cons (unwrap applicative) object) environment)
-
- (apply applicative object) ==
- (apply applicative object (make-environment))
-
- -- Applicative: map (map applicative . lists)
- `lists' must be a nonempty list of lists; if there are two or
- more, they must all have the same length. If `lists' is empty, or
- if all of its elements are not lists of the same length, an error
- is signaled.
-
- The `map' applicative applies `applicative' element-wise to the
- elements of the lists in `lists' (i.e., applies it to a list of
- the first elements of the `lists', to a list of the second
- elements of the `lists', etc.), using the dynamic environment from
- which `map' was called, and returns a list of the results, in
- order. The applications may be performed in any order, as long as
- their results occur in the resultant list in the order of their
- arguments in the original `lists'. If `lists' is a cyclic list,
- each argument list to which `applicative' is applied is
- structurally isomorphic to `lists'. If any of the elements of
- `lists' is a cyclic list, they all must be, or they wouldn’t all
- have the same length. Let `a1...an' be their acyclic prefix
- lengths, and `c1...cn' be their cycle lengths. The acyclic prefix
- length `a' of the resultant list will be the maximum of the `ak',
- while the cycle length `c' of the resultant list will be the least
- common multiple of the `ck'. In the construction of the result,
- applicative is called exactly `a + c' times.
-
- -- Applicative: combiner? (combiner? . objects)
- The primitive type predicate for type combiner. `combiner?'
- returns true iff all the objects in `objects' are of type combiner
- (i.e. applicative or operative).
-
-
-File: klisp.info, Node: Continuations, Next: Encapsulations, Prev: Combiners, Up: Top
-
-9 Continuations
-***************
-
-A continuation is a plan for all future computation, parameterized by a
-value to be provided, and contingent on the states of all mutable data
-structures (which notably may include environments). When the Kernel
-evaluator is invoked, the invoker provides a continuation to which the
-result of the evaluation will normally be returned.
-
- For example, when `$if' evaluates its test operand, the continuation
-provided for the result expects to be given a boolean value; and,
-depending on which boolean it gets, it will evaluate either the
-consequent or the alternative operand as a tail context — that is, the
-continuation provided for the result of evaluating the selected operand
-is the same continuation that was provided for the result of the call
-to `$if'.
-
- A Kernel program may sometimes capture a continuation; that is,
-acquire a reference to it as a first-class object. The basic means of
-continuation capture is applicative `call/cc'. Given a first-class
-continuation `c', a combiner can be constructed that will abnormally
-pass its operand tree to `c' (as opposed to the normal return of values
-to continuations). In the simplest case, the abnormally passed value
-arrives at `c' as if it had been normally returned to `c'. In general,
-continuations bypassed by the abnormal pass may have entry/exit guards
-attached to them, and these guards can intercept the abnormal pass
-before it reaches `c'. Each entry/exit guard consists of a selector
-continuation, which designates which abnormal passes the guard will
-intercept, and an interceptor applicative that performs the
-interception when selected.
-
- Continuations are immutable, and are `equal?' iff `eq?'. The
-continuation type is encapsulated.
-
- -- Applicative: continuation? (continuation? . objects)
- The primitive type predicate for type continuation.
- `continuation?' returns true iff all the objects in `objects' are
- of type continuation.
-
- -- Applicative: call/cc (call/cc combiner)
- Calls `combiner' in the dynamic environment as a tail context,
- passing as sole operand to it the continuation to which `call/cc'
- would normally return its result. (That is, constructs such a
- combination and evaluates it in the dynamic environment.)
-
- -- Applicative: extend-continuation (extend-continuation continuation
- applicative [environment])
- The `extend-continuation' applicative constructs and returns a new
- child of `continuation' that, when it normally receives a value v,
- calls the underlying combiner of `applicative' with dynamic
- environment `environment' (or an empty environment if none was
- specified) and operand tree `v', the result of the call normally
- to be returned to `continuation'.
-
- The following equivalnece defines the short version:
- (extend-continuation c a) ==
- (extend-continuation c a (make-environment))
-
- -- Applicative: guard-continuation (guard-continuation entry-guards
- continuation exit-guards)
- `entry-guards' and `exit-guards' should each be a list of clauses;
- each clause should be a list of length two, whose first element is
- a continuation, and whose second element is an applicative whose
- underlying combiner is operative.
-
- Applicative `guard-continuation' constructs two continuations: a
- child of continuation, called the `outer continuation'; and a
- child of the `outer continuation', called the `inner
- continuation'. The `inner continuation' is returned as the result
- of the call to `guard-continuation'.
-
- When the `inner continuation' normally receives a value, it passes
- the value normally to the `outer continuation'; and when the
- `outer continuation' normally receives a value, it passes the
- value normally to `continuation'. Thus, in the absence of abnormal
- passing, the inner and outer continuations each have the same
- behavior as `continuation'.
-
- The two elements of each guard clause are called, respectively, the
- `selector' and the `interceptor'. The `selector' continuation is
- used in deciding whether to intercept a given abnormal pass, and
- the `interceptor' applicative is called to perform customized
- action when interception occurs.
-
- At the beginning of the call to `guard-continuation', internal
- copies are made of the evaluation structures of `entry-guards' and
- `exit-guards', so that the selectors and interceptors contained in
- the arguments at that time remain fixed thereafter, independent of
- any subsequent mutations to the arguments.
-
- -- Applicative: continuation->applicative (continuation->applicative
- continuation)
- Returns an applicative whose underlying operative abnormally passes
- its operand tree to `continuation', thus: A series of interceptors
- are selected to handle the abnormal pass, and a continuation is
- derived that will normally perform all the interceptions in
- sequence and pass some value to the destination of the originally
- abnormal pass. The operand tree is then normally passed to the
- derived continuation.
-
- -- Variable: root-continuation
- This continuation is the ancestor of all other continuations. When
- it normally receives a value, it terminates the Kernel session.
- (For example, if the system is running a read-eval-print loop, it
- exits the loop.)
-
- -- Variable: error-continuation
- The dynamic extent of this continuation is mutually disjoint from
- the dynamic extent in which Kernel computation usually occurs
- (such as the dynamic extent in which the Kernel system would run a
- read-eval-print loop).
-
- When this continuation normally receives a value, it provides a
- diagnostic message to the user of the Kernel system, on the
- assumption that the received value is an attempt to describe some
- error that aborted a computation; and then resumes operation of
- the Kernel system at some point that is outside of all
- user-defined computation. (For example, if the system is running a
- read-eval-print loop, operation may resume by continuing from the
- top of the loop.)
-
- The diagnostic message is not made available to any Kernel
- computation, and is therefore permitted to contain information that
- violates abstractions within the system.
-
- When an error is signaled during a Kernel computation, the
- signaling action consists of an abnormal pass to some continuation
- in the dynamic extent of `error-continuation'.
-
- -- Applicative: apply-continuation (apply-continuation continuation
- object)
- Applicative `apply-continuation' converts its first argument to an
- applicative as if by `continuation->applicative', and then applies
- it as usual.
-
- That is:
- (apply-continuation continuation object) ==
- (apply (continuation->applicative continuation) object)
-
- -- Operative: ($let/cc <symbol> . <objects>)
- A child environment `e' of the dynamic environment is created,
- containing a binding of `<symbol>' to the continuation to which
- the result of the call to `$let/cc' should normally return; then,
- the subexpressions of `<objects>' are evaluated in `e' from left
- to right, with the last (if any) evaluated as a tail context, or
- if `<objects>' is empty the result is inert.
-
- That is:
- ($let/cc symbol . objects) ==
- (call/cc ($lambda (symbol) . objects))
-
- -- Applicative: guard-dynamic-extent (guard-dynamic-extent
- entry-guards combiner exit-guards)
- This applicative extends the current continuation with the
- specified guards, and calls `combiner' in the dynamic extent of
- the new continuation, with no operands and the dynamic environment
- of the call to `guard-dynamic-extent'.
-
- -- Applicative: exit (exit)
- Applicative `exit' initiates an abnormal transfer of `#inert' to
- `root-continuation'.
-
- That is:
- (exit ) == (apply-continuation root-continuation #inert)
-
-
-File: klisp.info, Node: Encapsulations, Next: Promises, Prev: Continuations, Up: Top
-
-10 Encapsulations
-*****************
-
-An encapsulation is an object that refers to another object, called its
-content. The Kernel data type encapsulation is encapsulated. Two
-encapsulations are `equal?' iff they are `eq?'. Encapsulations are
-immutable.
-
- -- Applicative: make-encapsulation-type (make-encapsulation-type)
- Returns a list of the form `(e p? d)', where `e', `p'?, and `d'
- are applicatives, as follows. Each call to
- `make-encapsulation-type' returns different applicatives `e',
- `p?', and `d'.
-
- * `e' is an applicative that takes one argument, and returns a
- fresh encapsulation with the argument as content.
- Encapsulations returned on different occasions are not `eq?'.
-
- * `p?' is a primitive type predicate, that takes zero or more
- arguments and returns true iff all of them are encapsulations
- generated by `e'.
-
- * `d' is an applicative that takes one argument; if the
- argument is not an encapsulation generated by `e', an error
- is signaled, otherwise the content of the encapsulation is
- returned.
-
- That is, the predicate `p?' only recognizes, and the decapsulator
- `d' only extracts the content of, encapsulations created by the
- encapsulator `e' that was returned by the same call to
- `make-encapsulation-type'.
-
-
-File: klisp.info, Node: Promises, Next: Keyed Variables, Prev: Encapsulations, Up: Top
-
-11 Promises
-***********
-
-A promise is an object that represents the potential to determine a
-value. The value may be the result of an arbitrary computation that
-will not be performed until the value must be determined (constructor
-`$lazy'); or, in advanced usage, the value may be determined before the
-promise is constructed (constructor `memoize').
-
- The value determined by a promise is obtained by forcing it
-(applicative `force'). A given promise cannot determine different
-values on different occasions that it is forced. Also, if a promise
-determines its value by computation, and that computation has already
-been completed, forcing the promise again will produce the previously
-determined result without re-initiating the computation to determine it.
-
- The Kernel data type promise is encapsulated.
-
- The general rules for predicate `eq?' only require it to distinguish
-promises if they can exhibit different behavior; the resulting leeway
-for variation between implementations is similar, in both cause and
-effect, to that for `eq?'-ness of operatives. For example, if two
-promises, constructed on different occasions, would perform the same
-computation to determine their values, and that computation has no
-side-effects and must always return the same value, the promises may or
-may not be `eq?'. Two promises are `equal?' iff they are `eq?'.
-
- -- Applicative: promise? (promise? . objects)
- The primitive type predicate for type promise. `promise?' returns
- true iff all the objects in `objects' are of type promise.
-
- -- Applicative: force (force object)
- If `object' is a promise, applicative `force' returns the value
- determined by promise; otherwise, it returns `object'.
-
- The means used to force a promise depend on how the promise was
- constructed. The description of each promise constructor specifies
- how to force promises constructed by that constructor.
-
- -- Operative: $lazy ($lazy expression)
- Operative `$lazy' constructs and returns a new object of type
- promise, representing potential evaluation of expression in the
- dynamic environment from which `$lazy' was called.
-
- When the promise is forced, if a value has not previously been
- determined for it, `expression' is evaluated in the dynamic
- environment of the constructing call to `$lazy'. If, when the
- evaluation returns a result, a value is found to have been
- determined for the promise during the evaluation, the result is
- discarded in favor of the previously determined value; otherwise,
- the result is forced, and the value returned by that forcing
- becomes the value determined by the promise.
-
- Forcing an undetermined lazy promise (i.e., a promise constructed
- by $lazy for which no value has yet been determined) may cause a
- sequential series of evaluations, each of which returns a promise
- that is forced and thus initiates the next evaluation in the
- series. The implementation must support series of this kind with
- unbounded length (i.e., unbounded number of sequential
- evaluations).
-
- Note that forcing concerns the value determined by a given promise,
- not the result of evaluating a given expression in a given
- environment. Distinct promises (judged by `eq?' represent
- different occasions of evaluation; so, even if they do represent
- evaluation of the same expression in the same environment, forcing
- one does not necessarily determine the value for the other, and
- actual evaluation will take place the first time each of them is
- forced.
-
- -- Applicative: memoize (memoize object)
- Applicative `memoize' constructs and returns a new object of type
- promise, representing memoization of `object'. Whenever the
- promise is forced, it determines `object'.
-
-
-File: klisp.info, Node: Keyed Variables, Next: Numbers, Prev: Promises, Up: Top
-
-12 Keyed Variables
-******************
-
-A keyed variable is a device that associates a non-symbolic key (in the
-form of an accessor applicative) with a value depending on the context
-in which lookup occurs. Kernel provides two types of keyed variables:
-dynamic & static. Keyed Dynamic Variables use the dynamic extent as
-context and Keyed Static Variables use the dynamic environment.
-
-12.1 Keyed Dynamic Variables
-============================
-
-A keyed dynamic variable is a device that associates a non-symbolic key
-(in the form of an accessor applicative) with a value depending on the
-dynamic extent in which lookup occurs.
-
- -- Applicative: make-keyed-dynamic-variable
- (make-keyed-dynamic-variable)
- Returns a list of the form `(b a)', where `b' and `a' are
- applicatives, as follows. Each call to
- `make-keyed-dynamic-variable' returns different `b' and `a'.
-
- * `b' is an applicative that takes two arguments, the second of
- which must be a combiner. It calls its second argument with
- no operands (nil operand tree) in a fresh empty environment,
- and returns the result.
-
- * `a' is an applicative that takes zero arguments. If the call
- to `a' occurs within the dynamic extent of a call to `b', then
- `a' returns the value of the first argument passed to `b' in
- the smallest enclosing dynamic extent of a call to `b'. If the
- call to `a' is not within the dynamic extent of any call to
- `b', an error is signaled.
-
-12.2 Keyed Static Variables
-===========================
-
-A keyed static variable is a device that binds data in an environment
-by a non-symbolic key, where the key is an accessor applicative.
-
- -- Applicative: make-keyed-static-variable (make-keyed-static-variable)
- Returns a list of the form `(b a)', where `b' and `a' are
- applicatives, as follows. Each call to
- `make-keyed-static-variable' returns different `b' and `a'.
-
- * `b' is an applicative that takes two arguments, the second of
- which must be an environment. It constructs and returns a
- child-environment of its second argument, with initially no
- local bindings.
-
- * `a' is an applicative that takes zero arguments. If the
- dynamic environment `e' of the call to a has an improper
- ancestor that was constructed by a call to `b', then a
- returns the value of the first argument passed to `b' in the
- first such environment encountered by a depth-first traversal
- of the improper ancestors of `e'. If `e' has no improper
- ancestors constructed via `b', an error is signaled.
-
-
-File: klisp.info, Node: Numbers, Next: Strings, Prev: Keyed Variables, Up: Top
-
-13 Numbers
-**********
-
-All numbers are immutable, and `equal?' iff `eq?'. The number type is
-encapsulated.
-
- The external representation of an undefined number is `#undefined'.
-The external representation of a real with no primary value is `#real'
-(but this may change in the future, the report is missing the output
-representation for reals with no primary values). All other rules for
-externally representing numbers pertain only to defined numbers with
-primary values.
-
- An external representation of a real number consists of optional
-radix and/or exactness prefixes, optional sign (`+' or `-'), and
-magnitude. The radix prefixes are `#b' (binary), `#o' (octal), `#d'
-(decimal), and `#x' (hexadecimal); the default is decimal. The
-exactness prefixes are `#e' (exact) and `#i' (inexact); by default, the
-number is inexact iff the magnitude representation uses floating point.
-If both kinds of prefixes are used, they may occur in either order. The
-magnitude is either `infinity'; an unsigned integer (nonempty sequence
-of digits); a ratio of unsigned integers (two unsigned integers with a
-`/' between, of which the second is non-zero); or a floating point
-representation. If the magnitude is `infinity', there must be an
-exactness prefix and a sign, and no radix prefix. Floating point
-representation can only be used with decimal radix; it consists of
-nonempty integer part, point (`.'), nonempty fraction part, and
-optional exponent part. The optional exponent part consists of an
-exponent letter, and an (optionally signed) integer indicating a power
-of ten by which to multiply the magnitude. The choice of exponent
-letter makes no difference in what mathematical number is indicated by
-the external representation, but does indicate internal representation
-precision. Exponent letters `s', `f', `d', `f' indicate preference for
-successively higher internal precision - short, float, double, long.
-When reading an inexact real number, exponent letter `e' accepts the
-default internal precision, which must be at least double. When
-writeing an inexact real number, exponent letter `e' may be used for
-the default internal precision, and must be used for any internal
-number format not indicated by any of the other exponent letters.
-Float and double must provide, respectively, at least as much precision
-as IEEE 32-bit and 64-bit floating point standards [IE85]. For
-example, `#i#xa/c' represents an inexact number using hexadecimal
-notation, with signed magnitude positive five sixths (ten over twelve).
-`-3.5l-2' represents an inexact number using decimal notation, with
-signed magnitude negative thirty five thousandths, and requested long
-precision (which must be at least IEEE 64-bit floating point). When
-reading an external representation of an inexact real, the bounds on
-the resulting inexact number are chosen in accordance with the
-narrow-arithmetic keyed dynamic variable.
-
- NOTE: in klisp, all inexact numbers are stored as IEEE 64-bit
-floating point. No bounding or robustness info is kept.
-
- -- Applicative: number? (number? . objects)
- The primitive type predicate for type number. `number?' returns
- true iff all the objects in `objects' are of type number.
-
- -- Applicative: integer? (integer? . objects)
- The primitive type predicate for number subtype integer.
- `integer?' returns true iff all the objects in `objects' are of
- type integer.
-
- -- Applicative: rational? (rational? . objects)
- The primitive type predicate for number subtype rational.
- `rational?' returns true iff all the objects in `objects' are of
- type rational.
-
- -- Applicative: real? (real? . objects)
- The primitive type predicate for number subtype real. `real?'
- returns true iff all the objects in `objects' are of type real.
-
- -- Applicative: finite? (finite? . numbers)
- Predicate `finite?' returns true iff all the numbers in `numbers'
- are finite.
-
- -- Applicative: exact? (exact? . numbers)
- Predicate `exact?' returns true iff all the numbers in `numbers'
- are exact.
-
- -- Applicative: inexact? (inexact? . numbers)
- Predicate `inexact?' returns true iff all the numbers in `numbers'
- are inexact.
-
- -- Applicative: robust? (robust? . numbers)
- Predicate `robust?' returns true iff all the numbers in `numbers'
- are robust.
-
- -- Applicative: undefined? (undefined? . numbers)
- Predicate `undefined?' returns true iff all the numbers in
- `numbers' are undefined.
-
- -- Applicative: =? (=? . numbers)
- Applicative `=?' is a predicate that returns true iff all its
- arguments are numerically equal to each other. If any of its
- arguments has no primary value, an error is signaled.
-
- -- Applicative: <? (<? . reals)
- -- Applicative: <=? (<=? . reals)
- -- Applicative: >? (>? . reals)
- -- Applicative: >=? (>=? . reals)
- Each of these applicatives is a predicate that returns true iff
- every two consecutive elements of `reals' have primary values in
- the order indicated by the name of the applicative. If any
- element of `reals' has no primary value, an error is signaled.
-
- -- Applicative: + (+ . numbers)
- Applicative `+' returns the sum of the elements of numbers. If
- numbers is empty, the sum of its elements is exact zero. If a
- positive infinity is added to a negative infinity, the result has
- no primary value. If all the elements of a cycle are zero, the
- sum of the cycle is zero. If the acyclic sum of the elements of a
- cycle (i.e., the sum of an acyclic list containing just those
- elements) is non-zero, the sum of the cycle is positive infinity
- times the acyclic sum of the elements. If the acyclic sum of the
- elements of a cycle is zero, but some of the elements of the cycle
- are non-zero, the sum of the cycle has no primary value.
-
- -- Applicative: * (* . numbers)
- Applicative `*' returns the product of the elements of numbers.
- If numbers is empty, the product of its elements is exact one. If
- an infinity is multiplied by zero, the result has no primary
- value. If the acyclic product of the elements of a cycle is real
- greater than one, the product of the cycle is positive infinity.
- If all the elements of a cycle are positive one, the product of
- the cycle is positive one. If the acyclic product of the elements
- of a cycle is positive one, but some of the elements of the cycle
- are not positive one, the product of the cycle has no primary
- value. If the acyclic product of the elements of a cycle has
- magnitude less than one, the product of the cycle is zero. If the
- acyclic product of the elements of a cycle has magnitude greater
- than or equal to one, and is not positive real, the product of the
- cycle has no primary value.
-
- -- Applicative: - (- number . numbers)
- `numbers' should be a nonempty list of numbers.
-
- Applicative `-' returns the sum of `number' with the negation of
- the sum of `numbers'.
-
- -- Applicative: zero? (zero? . numbers)
- Applicative `zero?' is a predicate that returns true iff every
- element of `numbers' is zero. For this purpose, a real number is
- zero if its primary value is zero. If any element of numbers has
- no primary value an error is signaled.
-
- -- Applicative: div (div real1 real2)
- -- Applicative: mod (mod real1 real2)
- -- Applicative: div-and-mod (div-and-mod real1 real2)
- For all three applicatives, if `real1' is infinite or `real2' is
- zero, an error is signaled.
-
- Let `n' be the greatest integer such that `real2 * n <= real1'.
- Applicative `div' returns `n'. Applicative `mod' returns `real1 -
- (real2 * n)'. Applicative `div-and-mod' returns a freshly
- allocated list of length two, whose first element is `n' and whose
- second element is `real1 - (real2 * n)'.
-
- NOTE: I'm not really sure about this description...
-
- -- Applicative: div0 (div0 real1 real2)
- -- Applicative: mod0 (mod0 real1 real2)
- -- Applicative: div0-and-mod0 (div0-and-mod0 real1 real2)
- For all three applicatives, if `real1' is infinite or `real2' is
- zero, an error is signaled.
-
- Let `n' be the greatest integer such that `real2 * n <= real1 +
- |real2/2|'. Applicative `div0' returns `n'. Applicative `mod0'
- returns `real1 - (real2 * n)'. Applicative `div0-and-mod0'
- returns a freshly allocated list of length two, whose first
- element is `n' and whose second element is `real1 - (real2 * n)'.
-
- NOTE: I'm not really sure about this description...
-
- -- Applicative: positive? (positive? . reals)
- -- Applicative: negative? (negative? . reals)
- Applicative `positive?' is a predicate that returns true iff every
- element of `reals' is greater than zero. Applicative `negative?'
- is a predicate that returns true iff every element of `reals' is
- less than zero. If any argument to either applicative has no
- primary value an error is signaled.
-
- -- Applicative: odd? (odd? . integers)
- -- Applicative: even? (even? . integers)
- Applicative `odd?' is a predicate that returns true iff every
- element of `integers' is odd. Applicative `even?' is a predicate
- that returns true iff every element of `integers' is even. If any
- argument to either applicative has no primary value an error is
- signaled.
-
- -- Applicative: (abs real)
- Applicative `abs' returns the nonnegative real number with the
- same magnitude as `real'; that is, if `real' is nonnegative it
- returns `real', otherwise it returns the negation of `real'.
-
- -- Applicative: max (max . reals)
- -- Applicative: min (min . reals)
- If `reals' is nil, applicative `max' returns exact negative
- infinity, and applicative `min' returns exact positive infinity.
- If `reals' is non-nil, applicative `max' returns the largest
- number in `reals', and applicative `min' returns the smallest
- number in `reals'.
-
- -- Applicative: lcm (lcm . impints)
- -- Applicative: gcd (gcd . impints)
- `impints' should be a list of improper integers, that is, real
- numbers each of which is either an integer or an infinity.
-
- Applicative `lcm' returns the smallest positive improper integer
- that is an improper0integer multiple of every element of `impints'
- (that is, smallest `n >= 1' such that for every argument `nk'
- there exists `n'k' with `nk * n'k = n'). If any of the arguments
- is zero, the result of `lcm' has no primary value. According to
- these rules, `lcm' with nil argument list returns `1', and `lcm'
- with any infinite argument returns positive infinity.
-
- Applicative `gcd' returns the largest positive improper integer
- such that every element of `impints' is an improper-integer
- multiple of it (that is, largest `n >= 1' such that for every
- argument `nk' there exists `n'k' with `n * n'k = nk'). `gcd' with
- nil argument list returns exact positive infinity. If `gcd' is
- called with one or more arguments, and at least one of the
- arguments is zero, but none of the arguments is a non-zero finite
- integer, its result has no primary value. According to these
- rules, if `gcd' is called with at least one finite non-zero
- argument, its result is the same as if all zero and infinite
- arguments were deleted.
-
- -- Applicative: get-real-internal-bounds (get-real-internal-bounds
- real)
- -- Applicative: get-real-exact-bounds (get-real-exact-bounds real)
- Applicative `get-real-internal-bounds' returns a freshly allocated
- list of reals `(x1 x2)', where the primary value of `x1' is the
- lower bound of `real', using the same internal representation as
- the primary value of `real', and the primary value of `x2' is the
- upper bound of `real', using the same internal representation as
- the primary value of `real'. The `xk' are inexact iff real is
- inexact. The `xk' are robust (i.e., tagged if the implementation
- supports such), and the bounds of each `xk' are only required to
- contain its primary value (i.e., the implementation is allowed to
- make the bounds equal to the primary value).
-
- Applicative `get-real-exact-bounds' returns a freshly allocated
- list of exact reals `(x1 x2)', where `x1' is not greater than the
- lower bound of `real', and `x2' is not less than the upper bound
- of `real'.
-
- -- Applicative: get-real-internal-primary (get-real-internal-primary
- real)
- -- Applicative: get-real-exact-primary (get-real-exact-primary real)
- If `real' is exact, both applicatives return `real'. If `real'
- has no primary value, both applicatives signal an error.
-
- If `real' is inexact with a primary value, applicative
- `get-real-internal-primary' returns a real number `x0' whose
- primary value is the same as, and has the same internal format as,
- the primary value of `real'. `x0' is robust, and its bounds are
- only required to contain its primary value.
-
- If `real' is inexact with a primary value, applicative
- `get-real-exact-primary' returns an exact real number `x0' within
- the exact bounds that would be returned for `real' by applicative
- `get-real-exact-bounds'. Preferably, `x0' should be as close to
- the primary value of `real' as the implementation can reasonably
- arrange. If the implementation does not support any exact `real'
- that reasonably approximates `real', an error may be signaled.
-
- -- Applicative: make-inexact (make-inexact real1 real2 real3)
- Applicative `make-inexact' returns an inexact real number, as
- follows. If `real2' is inexact, the result has the same primary
- value as `real2'; and if `real2' has no primary value, the result
- has no primary value. The result has the same robustness as
- `real2'. If possible, the result uses the same internal
- representation as `real2'. If `real2' is exact, the primary value
- of the result is as close to `real2' as the implementation can
- reasonably arrange; overflow and underflow are handled as
- described in .... The lower bound of the result is no greater than
- the lower bound of `real1', the primary value of `real2', and the
- primary value of the result. The upper bound of the result is no
- less than the upper bound of `real3', the primary value of
- `real2', and the primary value of the result.
-
- -- Applicative: real->inexact (real->inexact real)
- -- Applicative: real->exact (real->exact real)
- Applicative `real->exact' behaves just as `get-real-exact-primary'.
-
- If `real' is inexact, applicative `real->inexact' returns `real'.
- If `real' is exact, applicative `real->inexact' returns an inexact
- real `x0' such that `real' would be a permissible result of
- passing `x0' to `real->exact'. If the implementation does not
- support any such `x0', an error may be signaled. Otherwise, `x0'
- is robust, and its bounds are only required to contain its primary
- value and `real'.
-
- -- Applicative: with-strict-arithmetic (with-strict-arithmetic boolean
- combiner)
- -- Applicative: get-string-arithmetic (get-strict-arithmetic?)
- These applicatives are the binder and accessor of the
- `strict-arithmetic' keyed dynamic variable. When this keyed
- variable is true, various survivable but dubious arithmetic events
- signal an error - notably, operation results with no primary value,
- and over- and underflows.
-
- -- Applicative: / (/ number . numbers)
- `numbers' should be a nonempty list of numbers.
-
- Applicative `/' returns `number' divided by the product of
- `numbers'. If the product of `numbers' is zero, an error is
- signaled. If `number' is infinite and the product of `numbers' is
- infinite, an error is signaled.
-
- -- Applicative: numerator (numerator rational)
- -- Applicative: denominator (denominator rational)
- These applicatives return the numerator and denominator of
- `rational', in least terms (i.e., chosen for the least positive
- denominator). Note that if `rational' is inexact, and either of
- its bounds is not its primary value, the denominator has upper
- bound positive infinity, and the numerator must have at least one
- infinite bound (two infinite bounds if the bounds of rational
- allow values of both signs).
-
- -- Applicative: floor (floor real)
- -- Applicative: ceiling (ceiling real)
- -- Applicative: truncate (truncate real)
- -- Applicative: round (round real)
- Applicative `floor' returns the largest integer not greater than
- `real'.
-
- Applicative `ceiling' returns the smallest integer not less than
- `real'.
-
- Applicative `truncate' returns the integer closest to `real' whose
- absolute value is not greater than that of `real'.
-
- Applicative `round' returns the closest integer to `real',
- rounding to even when `real' is halfway between two integers.
-
- -- Applicative: rationalize (rationalize real1 real2)
- -- Applicative: simplest-rational (simplest-rational real1 real2)
- A rational number `r1' is simpler than another rational `r2' if
- `r1 = p1 / q1' and `r2 = p2 / q2', both in lowest terms, and `|p1|
- <= |p2|' and `|q1| <= |q2|'. Thus `3/5' is simpler than `4/7'. Not
- all rationals are comparable in this ordering, as for example
- `2/7' and `3/5'. However, any interval (that contains rational
- numbers) contains a rational number that is simpler than every
- other rational number in that interval. Note that `0 = 0/1' is
- simpler than any other rational (so that one never has to choose
- between `p/q' and `−p/q').
-
- For applicative `simplest-rational', let `x0' be the simplest
- rational mathematically not less than the primary value of `real1'
- and not greater than the primary value of `real2'. If no such
- `x0' exists (because the primary value of `real1' is greater, or
- because the primary values of the arguments are equal and
- irrational), or if either argument does not have a primary value,
- an error is signaled.
-
- For applicative `rationalize', let `x0' be the simplest rational
- mathematical number within the interval bounded by the primary
- value of `real1' plus and minus the primary value of `real2'. If
- no such `x0' exists (because the primary value of `real1' is
- irrational and the primary value `real2' is zero), or if either
- argument does not have a primary value, an error is signaled.
-
- If `real1' and `real2' are exact, the applicative (whichever it
- is) returns exact `x0'. If one or both of `real1' and `real2' are
- inexact, the applicative returns an inexact rational approximating
- `x0' (as by `real->inexact'. Note that an inexact result returned
- is not necessarily bounded by the primary values of the arguments;
- but the result is an approximation of `x0', which is so bounded,
- and the bounds of the result include `x0'.
-
- -- Applicative: exp (exp number)
- -- Applicative: log (log number)
- TODO
-
- -- Applicative: sin (sin number)
- -- Applicative: cos (cos number)
- -- Applicative: tan (tan number)
- TODO
-
- -- Applicative: asin (asin number)
- -- Applicative: acos (acos number)
- -- Applicative: atan (atan number1 [number2])
- TODO
-
- -- Applicative: sqrt (sqrt number)
- -- Applicative: expt (expt number1 number2)
- TODO
-
-
-File: klisp.info, Node: Strings, Next: Characters, Prev: Numbers, Up: Top
-
-14 Strings
-**********
-
-A string is an object that represent a sequence of characters (for now,
-only ASCII is supported in klisp, in the future, full UNICODE will be
-supported). The external representation of strings consists of a
-leading """, the characters of the string and a closing """. Some
-characters should be escaped, by preceding them with a "\": in klisp
-these are the double quote (""") and the backslash ("\"). In the
-future more advanced escape mechanism may be added (like in r7rs-draft
-scheme, for escping common ASCII control codes and arbitrary unicode
-characters). A string has a length that is fixed at creation time, and
-as many characters, indexed from `0' to `length-1'.
-
- Strings may be mutable or immutable. If an attempt is made to
-mutate an immutable string, an error is signaled. Two immutable
-strings are "eq?" iff they are "equal?". Two mutable strings are "eq?"
-if they were created by the same constructor call. Two mutable strings
-are "equal?" iff they are "string=?". For now it is undefined if a
-mutable and an immutable strings that are "string=?" are "equal?" or
-not. The only exception is the empty string. There is only one empty
-string (all empty strings are "eq?" to each other) and it should be
-considered immutable. Even if an attempt is made to return a new empty
-string (like calling `(string)', the canonical immutable empty string
-is returned. The string type is encapsulated.
-
- SOURCE NOTE: This section is still missing from the report. The
-features defined here were taken mostly from r5rs scheme. It is
-possible that in the future, klisp only admits immutable strings (like
-lua and java), and that operations for contructing strings are moved to
-a new type (like Java's StringBuilder/StringBuffer). But for now,
-compatibility with r5rs was preferred/simpler.
-
- -- Applicative: string? (string? . objects)
- The primitive type predicate for type string. `string?' returns
- true iff all the objects in `objects' are of type string.
-
- -- Applicative: string=? (string=? . strings)
- -- Applicative: string<? (string<? . strings)
- -- Applicative: string<=? (string<=? . strings)
- -- Applicative: string>? (string>? . strings)
- -- Applicative: string>=? (string>=? . strings)
- These predicates compare any number of strings by their
- lexicographic order.
-
- -- Applicative: string-ci=? (string-ci=? . strings)
- -- Applicative: string-ci<? (string-ci<? . strings)
- -- Applicative: string-ci<=? (string-ci<=? . strings)
- -- Applicative: string-ci>? (string-ci>? . strings)
- -- Applicative: string-ci>=? (string-ci>=? . strings)
- These predicates convert the strings to lowercase and then compare
- them using their lexicographic order.
-
- -- Applicative: make-string (make-string k [char])
- Applicative `make-string' constructs and returns a new mutable
- string of length `k'. If `char' is specified, then all characters
- in the returned string are `char', otherwise the content of the
- string is unspecified.
-
- -- Applicative: string (string . chars)
- Applicative `string' contructs and return a new mutable string
- composed of the character arguments.
-
- -- Applicative: string-length (string-length string)
- Applicative `string-length' returns the length of `string'.
-
- -- Applicative: string-ref (string-ref string k)
- Applicative `string-ref' returns the character of `string' at
- position `k'. If `k' is out of bounds (i.e. less than `0' or
- greater or equal than `(length string)') an error is signaled.
-
- -- Applicative: string-set! (string-set! string k char)
- Applicative `string-set!' replaces the character with index `k' in
- `string' with character `char'. If `k' is out of bounds, or
- `string' is immutable, an error is signaled.
-
- -- Applicative: string-fill! (string-fill! string char)
- Applicative `string-fill!' replaces all the characters in `string'
- with character `char'. If `string' is an immutable string, an
- error is signaled.
-
- -- Applicative: substring (substring string k1 k2)
- Both `k1' & `k2' should be valid indexes in `string'. Also it
- should be the case that `k1 <= k2'.
-
- Applicative `substring' constructs and returns a new immutable
- string with length `k2 - k1', with the characters from `string',
- starting at index `k1' (inclusive) and ending at index `k2'
- (exclusive).
-
- -- Applicative: string-append (string-append . strings)
- Applicative `string-append' constructs and returns a new mutable
- string consisting of the concatenation of all its arguments.
-
- -- Applicative: string-copy (string-copy string)
- Applicative `string-copy' constructs and returns a new mutable
- string with the same length and characters as `string'.
-
- -- Applicative: string->immutable-string (string->immutable-string
- string)
- Applicative `string->immutable-string' constructs and returns a
- new immutable string with the same length and characters as
- `string'.
-
- -- Applicative: string->list (string->list string)
- -- Applicative: list->string (list->string chars)
- Applicatives `string->list' and `list->string' convert between
- strings and list of characters. The strings returned by
- `list->string' are mutable.
-
-
-File: klisp.info, Node: Characters, Next: Ports, Prev: Strings, Up: Top
-
-15 Characters
-*************
-
-A character is an object that represents an ASCII character (for now,
-only ASCII is supported in klisp, in the future, full UNICODE will be
-supported). The external representation of characters consists of a
-leading "#\" and the character or character name. The only supported
-names for now are "newline" and "space" (both from r5rs scheme).
-Characters are immutable. The character type is encapsulated.
-
- SOURCE NOTE: This section is still missing from the report. The
-features defined here were taken mostly from r5rs scheme.
-
- -- Applicative: char? (char? . objects)
- The primitive type predicate for type character. `char?' returns
- true iff all the objects in `objects' are of type character.
-
- -- Applicative: char=? (char=? . chars)
- -- Applicative: char<? (char<? . chars)
- -- Applicative: char<=? (char<=? . chars)
- -- Applicative: char>? (char>? . chars)
- -- Applicative: char>=? (char>=? . chars)
- These predicates compare any number of characters using their
- ASCII value for the comparison.
-
- -- Applicative: char-ci=? (char-ci=? . chars)
- -- Applicative: char-ci<? (char-ci<? . chars)
- -- Applicative: char-ci<=? (char-ci<=? . chars)
- -- Applicative: char-ci>? (char-ci>? . chars)
- -- Applicative: char-ci>=? (char-ci>=? . chars)
- These predicates convert the chars to lowercase and then compare
- their ASCII values.
-
- -- Applicative: char-alphabetic? (char-alphabetic? . chars)
- -- Applicative: char-numeric? (char-numeric? . chars)
- -- Applicative: char-whitespace? (char-whitespace? . chars)
- These predicates return true iff all of their arguments are
- respectively "alphabetic", "numeric", or "whitespace".
-
- -- Applicative: char-upper-case? (char-upper-case? . chars)
- -- Applicative: char-lower-case? (char-lower-case? . chars)
- These predicates return true iff all of their arguments are
- respectively "upper case, or "lower case".
-
- -- Applicative: char-upcase (char-upcase char)
- -- Applicative: char-downcase (char-downcase char)
- These applicatives return a character `char2' so that:
- (char-ci=? char char2) => #t
-
- If `char' is alphabetic then the following holds:
-
- (char-upper-case? (char-upcase char)) => #t
- (char-lower-case? (char-downcase char)) => #t
-
- -- Applicative: char->integer (char->integer char)
- -- Applicative: integer->char (integer->char k)
- These applicatives convert between ASCII values (as exact integers
- between 0 and 127) and characters. If an integer that is out of
- range for ASCII characters is passed to `integer->char', an error
- is signaled.
-
-
-File: klisp.info, Node: Ports, Next: Alphabetical Index, Prev: Characters, Up: Top
-
-16 Ports
-********
-
-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
-output only external representation (so that it can never be the normal
-result of a call to read). The eof type is encapsulated.
-
- SOURCE NOTE: the eof type is not in the Kernel report, it is used in
-klisp and was taken from Scheme.
-
- -- Applicative: port? (port? . objects)
- The primitive type predicate for type port. `port?' returns true
- iff all the objects in `objects' are of type port.
-
- -- Applicative: input-port? (input-port? . objects)
- -- 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.
-
- 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)
- -- 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: 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)
- -- 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: 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 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: 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 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' 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: 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)
- 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.
-
- The result returned by applicatives `close-input-file' and
- `close-output-file' is inert.
-
- SOURCE NOTE: this is enumerated in the Kernel report but the text
- is still missing. There's probably a name error here. These
- should probably be called close-input-port & close-output-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' 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 [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' writes an external representation of `object'
- to the specified port. This may be an output-only representation
- that can't be read by applicative `read' in cases where the type
- of `object' doen't have a parseable external representation (e.g.
- combiners and environments). The result returned by `write' is
- inert.
-
- SOURCE NOTE: this is enumerated in the Kernel report but the text
- is still missing.
-
- -- Applicative: call-with-input-file (call-with-input-file string
- combiner)
- -- Applicative: call-with-output-file (call-with-output-file string
- combiner)
- 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 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
- it, taking the description of `get-module' that there is in the
- report. The one detail that I think is still open, is whether to
- return `#inert' (as is the case with klisp currently) or rather
- return the value of the last evaluation.
-
- -- Applicative: get-module (get-module string [environment])
- Applicative `get-module' creates a fresh standard environment;
- 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
- be changed to just `eof?', for consistency with the other
- primitive type predicates.
-
- -- 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.
-
- SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
-
- -- 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
- 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? [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 `char-ready?' checks to see if a character is available
- in the specified port. If it returns true, then a `read-char' or
- `peek-char' 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-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.
-
- Applicative `write-char' writes the `char' character (not an
- external representation of the character) to the specified port.
- The result returned by `write-char' is inert.
-
- SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
-
- -- 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.
-
- Applicative `newline' writes a newline to the specified port. The
- result returned by `newline' is inert.
-
- SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
-
- -- 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.
-
- Applicative `display' behaves like `write' except that strings are
- not enclosed in double quotes and no character is escaped within
- those strings and character objects are output as if by
- `write-char' instead of `read'. The result returned by `display'
- is inert.
-
- SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
-
- -- 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
- signaled.
-
- Applicative `flush-ouput-port' flushes any buffered data in the
- output port to the underlying file or device. The result returned
- by `flush-output-port' is inert.
-
- SOURCE NOTE: this is missing from Kernel, it is taken from r7rs
- Scheme.
-
- -- file-exists?: (file-exists? string)
- `string' should be the name/path for a file.
-
- Predicate `file-exists?' checks to see if a file named `string'
- exists.
-
- SOURCE NOTE: this is missing from Kernel, it is taken from r7rs
- Scheme.
-
- -- delete-file: (delete-file string)
- `string' should be the name/path for an existing file.
-
- Applicative `delete-file' deletes the file named `string'. If it
- doesn't exists or can't be deleted, an error is signaled. The
- result returned by `delete-file' is inert.
-
- SOURCE NOTE: this is missing from Kernel, it is taken from r7rs
- Scheme.
-
- -- rename-file: (rename-file string1 string2)
- `string1' should be the name/path for an existing file, `string2'
- should be the name/path for a non existing file.
-
- Applicative `rename-file' renames the file named `string1' to
- `string2'. If the file doesn't exists or can't be renamed for any
- reason, an error is signaled. The result returned by `rename-file'
- is inert.
-
- SOURCE NOTE: this is missing from Kernel AND Scheme, it is taken
- from C, being quite similar to `delete-file'.
-
-
-File: klisp.info, Node: Alphabetical Index, Next: (dir), Prev: Ports, Up: Top
-
-Index
-*****
-
-
-* Menu:
-
-* $and?: Booleans. (line 28)
-* $binds?: Environments. (line 108)
-* $cond: Control. (line 32)
-* $define!: Environments. (line 49)
-* $if: Control. (line 15)
-* $import!: Environments. (line 207)
-* $lambda: Combiners. (line 76)
-* $lazy: Promises. (line 43)
-* $let: Environments. (line 89)
-* $let*: Environments. (line 124)
-* $let-redirect: Environments. (line 153)
-* $let-safe: Environments. (line 161)
-* $letrec: Environments. (line 137)
-* $letrec*: Environments. (line 144)
-* $or?: Booleans. (line 41)
-* $provide!: Environments. (line 191)
-* $remote-eval: Environments. (line 169)
-* $sequence: Control. (line 23)
-* $set!: Environments. (line 182)
-* $vau: Combiners. (line 26)
-* ( <1>: Ports. (line 54)
-* ( <2>: Numbers. (line 193)
-* ( <3>: Continuations. (line 143)
-* (: Environments. (line 174)
-* *: Numbers. (line 121)
-* +: Numbers. (line 109)
-* -: Numbers. (line 137)
-* /: Numbers. (line 306)
-* <=?: Numbers. (line 101)
-* <?: Numbers. (line 100)
-* =?: Numbers. (line 95)
-* >=?: Numbers. (line 103)
-* >?: Numbers. (line 102)
-* acos: Numbers. (line 385)
-* and?: Booleans. (line 20)
-* append: Pairs and lists. (line 208)
-* append!: Pairs and lists. (line 306)
-* applicative descriptions: A Sample Applicative Description.
- (line 6)
-* applicative?: Combiners. (line 21)
-* applicatives: Combiners. (line 6)
-* apply: Combiners. (line 83)
-* apply-continuation: Continuations. (line 134)
-* asin: Numbers. (line 384)
-* 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)
-* caaadr: Pairs and lists. (line 102)
-* caaar: Pairs and lists. (line 93)
-* caadar: Pairs and lists. (line 103)
-* caaddr: Pairs and lists. (line 104)
-* caadr: Pairs and lists. (line 94)
-* caar: Pairs and lists. (line 89)
-* cadaar: Pairs and lists. (line 105)
-* cadadr: Pairs and lists. (line 106)
-* cadar: Pairs and lists. (line 95)
-* caddar: Pairs and lists. (line 107)
-* cadddr: Pairs and lists. (line 108)
-* caddr: Pairs and lists. (line 96)
-* cadr: Pairs and lists. (line 90)
-* 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)
-* cdaadr: Pairs and lists. (line 110)
-* cdaar: Pairs and lists. (line 97)
-* cdadar: Pairs and lists. (line 111)
-* cdaddr: Pairs and lists. (line 112)
-* cdadr: Pairs and lists. (line 98)
-* cdar: Pairs and lists. (line 91)
-* cddaar: Pairs and lists. (line 113)
-* cddadr: Pairs and lists. (line 114)
-* cddar: Pairs and lists. (line 99)
-* cdddar: Pairs and lists. (line 115)
-* cddddr: Pairs and lists. (line 116)
-* cdddr: Pairs and lists. (line 100)
-* cddr: Pairs and lists. (line 92)
-* cdr: Pairs and lists. (line 86)
-* ceiling: Numbers. (line 325)
-* char->integer: Characters. (line 58)
-* char-alphabetic?: Characters. (line 37)
-* char-ci<=?: Characters. (line 31)
-* char-ci<?: Characters. (line 30)
-* char-ci=?: Characters. (line 29)
-* char-ci>=?: Characters. (line 33)
-* char-ci>?: Characters. (line 32)
-* char-downcase: Characters. (line 49)
-* char-lower-case?: Characters. (line 44)
-* char-numeric?: Characters. (line 38)
-* char-upcase: Characters. (line 48)
-* char-upper-case?: Characters. (line 43)
-* char-whitespace?: Characters. (line 39)
-* char<=?: Characters. (line 23)
-* char<?: Characters. (line 22)
-* char=?: Characters. (line 21)
-* char>=?: Characters. (line 25)
-* char>?: Characters. (line 24)
-* char?: Characters. (line 17)
-* characters: Characters. (line 6)
-* combiner?: Combiners. (line 120)
-* combiners: Combiners. (line 6)
-* cons: Pairs and lists. (line 35)
-* continuation->applicative: Continuations. (line 95)
-* continuation?: Continuations. (line 38)
-* continuations: Continuations. (line 6)
-* control: Control. (line 6)
-* copy-es: Pairs and lists. (line 321)
-* copy-es-immutable!: Pairs and lists. (line 49)
-* cos: Numbers. (line 380)
-* countable-list?: Pairs and lists. (line 265)
-* denominator: Numbers. (line 315)
-* description format: Format of Descriptions.
- (line 6)
-* div: Numbers. (line 149)
-* div-and-mod: Numbers. (line 151)
-* div0: Numbers. (line 163)
-* div0-and-mod0: Numbers. (line 165)
-* documentation notation: Evaluation Notation. (line 6)
-* empty list: Pairs and lists. (line 6)
-* encapsulations: Encapsulations. (line 6)
-* encycle!: Pairs and lists. (line 158)
-* environment?: Environments. (line 23)
-* environments: Environments. (line 6)
-* eof-object?: Ports. (line 208)
-* eq?: Equivalence. (line 12)
-* equal?: Equivalence. (line 16)
-* equivalence: Equivalence. (line 6)
-* error message notation: Error Messages. (line 6)
-* error-continuation: Continuations. (line 110)
-* eval: Environments. (line 32)
-* evaluation notation: Evaluation Notation. (line 6)
-* even?: Numbers. (line 186)
-* exact?: Numbers. (line 79)
-* exit: Continuations. (line 162)
-* exp: Numbers. (line 375)
-* expt: Numbers. (line 390)
-* extend-continuation: Continuations. (line 50)
-* filter: Pairs and lists. (line 239)
-* finite-list?: Pairs and lists. (line 261)
-* finite?: Numbers. (line 75)
-* floor: Numbers. (line 324)
-* fonts: Some Terms. (line 13)
-* foo: A Sample Applicative Description.
- (line 15)
-* for-each: Control. (line 42)
-* force: Promises. (line 35)
-* gcd: Numbers. (line 207)
-* get-current-environment: Environments. (line 114)
-* get-list-metrics: Pairs and lists. (line 123)
-* 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)
-* get-real-internal-primary: Numbers. (line 251)
-* get-string-arithmetic: Numbers. (line 299)
-* guard-continuation: Continuations. (line 63)
-* guard-dynamic-extent: Continuations. (line 156)
-* ignore: Environments. (line 6)
-* ignore?: Environments. (line 28)
-* inert: Control. (line 6)
-* inert?: Control. (line 11)
-* inexact?: Numbers. (line 83)
-* input-port?: Ports. (line 32)
-* integer->char: Characters. (line 59)
-* integer?: Numbers. (line 61)
-* Kernel history: Kernel History. (line 6)
-* keyed dynamic variables: Keyed Variables. (line 15)
-* keyed static variables: Keyed Variables. (line 40)
-* keyed variables: Keyed Variables. (line 6)
-* lcm: Numbers. (line 206)
-* length: Pairs and lists. (line 191)
-* list: Pairs and lists. (line 72)
-* list*: Pairs and lists. (line 78)
-* list->string: Strings. (line 109)
-* list-neighbors: Pairs and lists. (line 228)
-* list-ref: Pairs and lists. (line 198)
-* list-tail: Pairs and lists. (line 147)
-* lists: Pairs and lists. (line 6)
-* load: Ports. (line 185)
-* log: Numbers. (line 376)
-* make-encapsulation-type: Encapsulations. (line 12)
-* make-environment: Environments. (line 36)
-* make-inexact: Numbers. (line 270)
-* make-kernel-standard-environment: Environments. (line 119)
-* make-keyed-dynamic-variable: Keyed Variables. (line 21)
-* make-keyed-static-variable: Keyed Variables. (line 44)
-* make-string: Strings. (line 57)
-* map <1>: Combiners. (line 96)
-* map: Pairs and lists. (line 169)
-* max: Numbers. (line 198)
-* member?: Pairs and lists. (line 257)
-* memoize: Promises. (line 74)
-* memq?: Pairs and lists. (line 338)
-* min: Numbers. (line 199)
-* mod: Numbers. (line 150)
-* mod0: Numbers. (line 164)
-* negative?: Numbers. (line 178)
-* nil: Pairs and lists. (line 6)
-* not?: Booleans. (line 16)
-* null?: Pairs and lists. (line 31)
-* number?: Numbers. (line 57)
-* numbers: Numbers. (line 6)
-* numerator: Numbers. (line 314)
-* object descriptions: A Sample Applicative Description.
- (line 6)
-* odd?: Numbers. (line 185)
-* 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 33)
-* pair?: Pairs and lists. (line 27)
-* pairs: Pairs and lists. (line 6)
-* port?: Ports. (line 28)
-* ports: Ports. (line 6)
-* positive?: Numbers. (line 177)
-* printing notation: Printing Notation. (line 6)
-* promise?: Promises. (line 31)
-* promises: Promises. (line 6)
-* rational?: Numbers. (line 66)
-* rationalize: Numbers. (line 340)
-* read: Ports. (line 144)
-* real->exact: Numbers. (line 286)
-* real->inexact: Numbers. (line 285)
-* real?: Numbers. (line 71)
-* reduce: Pairs and lists. (line 270)
-* robust?: Numbers. (line 87)
-* root-continuation: Continuations. (line 104)
-* round: Numbers. (line 327)
-* set-car!: Pairs and lists. (line 41)
-* set-cdr!: Pairs and lists. (line 42)
-* simplest-rational: Numbers. (line 341)
-* sin: Numbers. (line 379)
-* sqrt: Numbers. (line 389)
-* string: Strings. (line 63)
-* string->immutable-string: Strings. (line 103)
-* string->list: Strings. (line 108)
-* string->symbol: Symbols. (line 20)
-* string-append: Strings. (line 94)
-* string-ci<=?: Strings. (line 51)
-* string-ci<?: Strings. (line 50)
-* string-ci=?: Strings. (line 49)
-* string-ci>=?: Strings. (line 53)
-* string-ci>?: Strings. (line 52)
-* string-copy: Strings. (line 98)
-* string-fill!: Strings. (line 80)
-* string-length: Strings. (line 67)
-* string-ref: Strings. (line 70)
-* string-set!: Strings. (line 75)
-* string<=?: Strings. (line 43)
-* string<?: Strings. (line 42)
-* string=?: Strings. (line 41)
-* string>=?: Strings. (line 45)
-* string>?: Strings. (line 44)
-* string?: Strings. (line 37)
-* strings: Strings. (line 6)
-* substring: Strings. (line 85)
-* symbol->string: Symbols. (line 16)
-* 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)
-* with-strict-arithmetic: Numbers. (line 298)
-* wrap: Combiners. (line 68)
-* zero?: Numbers. (line 143)
-
-
-
-Tag Table:
-Node: Top703
-Node: License2601
-Node: Introduction4283
-Node: Caveats7213
-Node: Kernel History7999
-Node: Conventions9444
-Node: Some Terms10115
-Node: Evaluation Notation10786
-Node: Printing Notation11807
-Node: Error Messages12283
-Node: Format of Descriptions12931
-Node: A Sample Applicative Description13495
-Node: Acknowledgements15258
-Node: Booleans15644
-Node: Equivalence18186
-Node: Symbols18979
-Node: Control20345
-Node: Pairs and lists22662
-Node: Environments39685
-Node: Combiners49892
-Node: Continuations55928
-Node: Encapsulations64102
-Node: Promises65555
-Node: Keyed Variables69478
-Node: Numbers72249
-Node: Strings91748
-Node: Characters97095
-Node: Ports99805
-Node: Alphabetical Index117409
-
-End Tag Table
diff --git a/manual/src/continuations.texi b/manual/src/continuations.texi
@@ -1,198 +0,0 @@
-@c -*-texinfo-*-
-@setfilename ../src/continuations
-
-@node Continuations, Encapsulations, Combiners, Top
-@comment node-name, next, previous, up
-
-@chapter Continuations
-@cindex continuations
-
- A continuation is a plan for all future computation, parameterized
-by a value to be provided, and contingent on the states of all mutable
-data structures (which notably may include environments). When the
-Kernel evaluator is invoked, the invoker provides a continuation to
-which the result of the evaluation will normally be returned.
-
- For example, when @code{$if} evaluates its test operand, the
-continuation provided for the result expects to be given a boolean
-value; and, depending on which boolean it gets, it will evaluate
-either the consequent or the alternative operand as a tail context —
-that is, the continuation provided for the result of evaluating the
-selected operand is the same continuation that was provided for the
-result of the call to @code{$if}.
-
- A Kernel program may sometimes capture a continuation; that is,
-acquire a reference to it as a first-class object. The basic means of
-continuation capture is applicative @code{call/cc}. Given a
-first-class continuation @code{c}, a combiner can be constructed that
-will abnormally pass its operand tree to @code{c} (as opposed to the
-@c TODO add xref to abnormal pass
-normal return of values to continuations). In the simplest case, the
-abnormally passed value arrives at @code{c} as if it had been normally
-returned to @code{c}. In general, continuations bypassed by the
-abnormal pass may have entry/exit guards attached to them, and these
-guards can intercept the abnormal pass before it reaches @code{c}.
-Each entry/exit guard consists of a selector continuation, which
-designates which abnormal passes the guard will intercept, and an
-interceptor applicative that performs the interception when selected.
-@c TODO add xref to guard-continuation, continuation->applicative
-@c and abnormal pass
-
- Continuations are immutable, and are @code{equal?} iff @code{eq?}.
-The continuation type is encapsulated.
-
-@c TODO add dynamic extent & guard selection/interception to the intro
-@deffn Applicative continuation? (continuation? . objects)
- The primitive type predicate for type continuation.
-@code{continuation?} returns true iff all the objects in
-@code{objects} are of type continuation.
-@end deffn
-
-@deffn Applicative call/cc (call/cc combiner)
- Calls @code{combiner} in the dynamic environment as a tail context,
-passing as sole operand to it the continuation to which @code{call/cc}
-would normally return its result. (That is, constructs such a
-combination and evaluates it in the dynamic environment.)
-@c TODO add xref Cf. operative $let/cc , §7.3.2.
-@end deffn
-
-@deffn Applicative extend-continuation (extend-continuation continuation applicative [environment])
- The @code{extend-continuation} applicative constructs and returns a
-new child of @code{continuation} that, when it normally receives a
-value v, calls the underlying combiner of @code{applicative} with
-dynamic environment @code{environment} (or an empty environment if
-none was specified) and operand tree @code{v}, the result of the call
-normally to be returned to @code{continuation}.
-
- The following equivalnece defines the short version:
-@example
-(extend-continuation c a) @equiv{}
- (extend-continuation c a (make-environment))
-@end example
-@end deffn
-
-@deffn Applicative guard-continuation (guard-continuation entry-guards continuation exit-guards)
- @code{entry-guards} and @code{exit-guards} should each be a list of
-clauses; each clause should be a list of length two, whose first
-element is a continuation, and whose second element is an applicative
-whose underlying combiner is operative.
-
- Applicative @code{guard-continuation} constructs two continuations:
-a child of continuation, called the @code{outer continuation}; and a
-child of the @code{outer continuation}, called the @code{inner
-continuation}. The @code{inner continuation} is returned as the
-result of the call to @code{guard-continuation}.
-
- When the @code{inner continuation} normally receives a value, it
-passes the value normally to the @code{outer continuation}; and when
-the @code{outer continuation} normally receives a value, it passes the
-value normally to @code{continuation}. Thus, in the absence of
-abnormal passing, the inner and outer continuations each have the same
-behavior as @code{continuation}.
-
- The two elements of each guard clause are called, respectively, the
-@code{selector} and the @code{interceptor}. The @code{selector}
-continuation is used in deciding whether to intercept a given abnormal
-pass, and the @code{interceptor} applicative is called to perform
-@c TODO add xref to selection and interception
-customized action when interception occurs.
-
-@c TODO add xref to evaluation structure
-At the beginning of the call to @code{guard-continuation}, internal
-copies are made of the evaluation structures of @code{entry-guards}
-and @code{exit-guards}, so that the selectors and interceptors
-contained in the arguments at that time remain fixed thereafter,
-independent of any subsequent mutations to the arguments.
-@end deffn
-
-@deffn Applicative continuation->applicative (continuation->applicative continuation)
- Returns an applicative whose underlying operative abnormally passes
-its operand tree to @code{continuation}, thus: A series of
-interceptors are selected to handle the abnormal pass, and a
-continuation is derived that will normally perform all the
-interceptions in sequence and pass some value to the destination of
-the originally abnormal pass. The operand tree is then normally
-passed to the derived continuation.
-@c TODO add xref to selection and interception
-@end deffn
-
-@defvar root-continuation
- This continuation is the ancestor of all other continuations. When
-it normally receives a value, it terminates the Kernel session. (For
-example, if the system is running a read-eval-print loop, it exits the
-loop.)
-@c TODO add xref Cf. applicative exit, §7.3.4.
-@end defvar
-
-@defvar error-continuation
- The dynamic extent of this continuation is mutually disjoint from
-the dynamic extent in which Kernel computation usually occurs (such as
-the dynamic extent in which the Kernel system would run a
-read-eval-print loop).
-
- When this continuation normally receives a value, it provides a
-diagnostic message to the user of the Kernel system, on the assumption
-that the received value is an attempt to describe some error that
-aborted a computation; and then resumes operation of the Kernel system
-at some point that is outside of all user-defined computation. (For
-example, if the system is running a read-eval-print loop, operation
-may resume by continuing from the top of the loop.)
-
- The diagnostic message is not made available to any Kernel
-computation, and is therefore permitted to contain information that
-violates abstractions within the system.
-
-@c TODO add details about klisp error messages
- When an error is signaled during a Kernel computation, the signaling
-action consists of an abnormal pass to some continuation in the
-dynamic extent of @code{error-continuation}.
-@end defvar
-
-@deffn Applicative apply-continuation (apply-continuation continuation object)
- Applicative @code{apply-continuation} converts its first argument to
-an applicative as if by @code{continuation->applicative}, and then
-applies it as usual.
-
- That is:
-@example
-(apply-continuation continuation object) @equiv{}
- (apply (continuation->applicative continuation) object)
-@end example
-@end deffn
-
-@deffn Operative ($let/cc <symbol> . <objects>)
- A child environment @code{e} of the dynamic environment is created,
-containing a binding of @code{<symbol>} to the continuation to which
-the result of the call to @code{$let/cc} should normally return; then,
-the subexpressions of @code{<objects>} are evaluated in @code{e} from
-left to right, with the last (if any) evaluated as a tail context, or
-if @code{<objects>} is empty the result is inert.
-
- That is:
-@example
-($let/cc symbol . objects) @equiv{}
- (call/cc ($lambda (symbol) . objects))
-@end example
-@end deffn
-
-@deffn Applicative guard-dynamic-extent (guard-dynamic-extent entry-guards combiner exit-guards)
- This applicative extends the current continuation with the specified
-guards, and calls @code{combiner} in the dynamic extent of the new
-continuation, with no operands and the dynamic environment of the call
-to @code{guard-dynamic-extent}.
-@end deffn
-
-@deffn Applicative exit (exit)
-@c TODO add xref
- Applicative @code{exit} initiates an abnormal transfer of
-@code{#inert} to @code{root-continuation}.
-
- That is:
-@example
-(exit ) @equiv{} (apply-continuation root-continuation #inert)
-@end example
-@end deffn
-
-
-
-
diff --git a/src/Makefile b/src/Makefile
@@ -33,14 +33,14 @@ PLATS= generic mingw posix
KRN_A= libklisp.a
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 \
+ kcontinuation.o koperative.o kapplicative.o keval.o krepl.o \
+ kencapsulation.o kpromise.o kport.o kinteger.o krational.o ksystem.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 \
+ kchar.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 kgbytevectors.o kgvectors.o kgsystem.o kgerror.o \
+ kgstrings.o kgbytevectors.o kgvectors.o kgsystem.o kgerrors.o \
$(if $(USE_LIBFFI),kgffi.o)
# TEMP: in klisp there is no distinction between core & lib
@@ -104,10 +104,9 @@ mingw:
"MINGW_LDFLAGS=$(if $(USE_LIBFFI), $(MINGW_LIBFFI_LDFLAGS) -lffi.dll)" \
"MYLDFLAGS=-s" klisp.exe
#lisp_use_posix isn't used right now...
-# TEMP: rename read() and write() here to avoid name conflicts with foreign code
posix:
$(MAKE) all \
- "MYCFLAGS=-DKLISP_USE_POSIX $(if $(USE_LIBFFI),-DKUSE_LIBFFI=1 -Dread=klisp_read -Dwrite=klisp_write)" \
+ "MYCFLAGS=-DKLISP_USE_POSIX -D_POSIX_SOURCE $(if $(USE_LIBFFI),-DKUSE_LIBFFI=1)" \
"MYLIBS=$(if $(USE_LIBFFI), -rdynamic -ldl -lffi)"
# list targets that do not create files (but not all makes understand .PHONY)
@@ -119,6 +118,7 @@ kauxlib.o: kauxlib.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.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
+kchar.o: kchar.c kobject.h klimits.h klisp.h klispconf.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 \
@@ -129,127 +129,127 @@ kenvironment.o: kenvironment.c kenvironment.h kobject.h klimits.h klisp.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 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
+ ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h kerror.h \
+ kghelpers.h kapplicative.h koperative.h ksymbol.h kstring.h ktable.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
+ kenvironment.h ktable.h kgbooleans.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
+ ksymbol.h kstring.h ktable.h kgbytevectors.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 kbytevector.h \
kvector.h kerror.h kpair.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 kchar.h kghelpers.h kenvironment.h ksymbol.h kstring.h \
+ ktable.h kgchars.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 \
- kgpair_mut.h kgenv_mut.h kgcontrol.h kgcombiners.h
+ ktable.h kgcombiners.h
kgcontinuations.o: kgcontinuations.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
kapplicative.h koperative.h ksymbol.h kstring.h kerror.h kghelpers.h \
- kgcontinuations.h kgcontrol.h
+ ktable.h kgcontinuations.h
kgcontrol.o: kgcontrol.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 \
- kgcontrol.h kgcombiners.h
+ kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h ktable.h \
+ kgcontrol.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 kpair.h kgc.h kghelpers.h kcontinuation.h \
- kenvironment.h ksymbol.h kstring.h kgencapsulations.h
+ kenvironment.h ksymbol.h kstring.h ktable.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 ktable.h \
+ kgenv_mut.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
+ ktable.h kgenvironments.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
+ kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h ktable.h \
+ kgeqp.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 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 kpair.h kgc.h kvector.h kstring.h kbytevector.h \
+ kcontinuation.h kerror.h kghelpers.h kapplicative.h koperative.h \
+ kenvironment.h ksymbol.h ktable.h kgequalp.h
+kgerrors.o: kgerrors.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
+ ktable.h kgerrors.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
+ kcontinuation.h kenvironment.h ksymbol.h kstring.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
+ koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h ktable.h \
+ kinteger.h imath.h krational.h imrat.h kbytevector.h kvector.h \
+ kencapsulation.h kpromise.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 \
- kgcontinuations.h kgkd_vars.h
+ ktable.h kgkd_vars.h
kgks_vars.o: kgks_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 \
- kgks_vars.h
+ ktable.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 \
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
+ kreal.h kghelpers.h kenvironment.h ktable.h kgnumbers.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 \
- kenvironment.h kgpair_mut.h kgeqp.h kinteger.h imath.h krational.h \
- imrat.h kgnumbers.h
+ kenvironment.h ktable.h kgpair_mut.h
kgpairs_lists.o: kgpairs_lists.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kstring.h kcontinuation.h \
kenvironment.h ksymbol.h kerror.h kghelpers.h kapplicative.h \
- koperative.h kgequalp.h kgpairs_lists.h kgnumbers.h kinteger.h imath.h
+ koperative.h ktable.h kgpairs_lists.h
kgports.o: kgports.c kstate.h klimits.h klisp.h kobject.h klispconf.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
+ ksymbol.h kread.h kwrite.h kghelpers.h ktable.h kgports.h ktable.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 \
- ksymbol.h kstring.h kgpromises.h
+ ksymbol.h kstring.h ktable.h kgpromises.h
kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kground.h kghelpers.h kerror.h kpair.h kgc.h \
kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
- kstring.h kgbooleans.h kgeqp.h kinteger.h imath.h krational.h imrat.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 kgbytevectors.h kgvectors.h kgsystem.h \
- kgerror.h kgffi.h ktable.h keval.h krepl.h kscript.h
+ kstring.h ktable.h kgbooleans.h kgeqp.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 \
+ kgbytevectors.h kgvectors.h kgsystem.h kgerrors.h \
+ kgffi.h keval.h krepl.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 \
- kpair.h kgc.h ksymbol.h kstring.h kghelpers.h kenvironment.h kgchars.h \
- kgstrings.h kgnumbers.h
+ kpair.h kgc.h ksymbol.h kstring.h kchar.h kvector.h kbytevector.h \
+ kghelpers.h kenvironment.h ktable.h kgstrings.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 \
- kerror.h kghelpers.h kapplicative.h koperative.h kenvironment.h \
+ kerror.h kghelpers.h kapplicative.h koperative.h kenvironment.h ktable.h \
kgsymbols.h
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
+ ktoken.h kmem.h kpair.h kgc.h kerror.h ksystem.h kghelpers.h \
+ kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
+ kstring.h ktable.h kgsystem.h kinteger.h kmem.h imath.h kgc.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
+ kpair.h kgc.h kvector.h kbytevector.h kghelpers.h kenvironment.h \
+ ksymbol.h kstring.h ktable.h kgvectors.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 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
+ kapplicative.h ksymbol.h kenvironment.h kport.h kread.h kwrite.h \
+ kerror.h kpair.h kgc.h krepl.h kghelpers.h ktable.h
kmem.o: kmem.c klisp.h kobject.h klimits.h klispconf.h kstate.h ktoken.h \
kmem.h kerror.h kpair.h kgc.h
kobject.o: kobject.c kobject.h klimits.h klisp.h klispconf.h
@@ -264,31 +264,32 @@ kpromise.o: kpromise.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
krational.o: krational.c krational.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kinteger.h imath.h imrat.h kgc.h
kread.o: kread.c kread.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
- ktoken.h kmem.h kpair.h kgc.h kerror.h ktable.h kport.h
+ ktoken.h kmem.h kpair.h kgc.h kerror.h ktable.h kport.h kstring.h
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 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 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
+ kread.h kwrite.h kstring.h krepl.h ksymbol.h kport.h ktable.h \
+ kghelpers.h kapplicative.h koperative.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 kbytevector.h kvector.h \
- kgpairs_lists.h kghelpers.h kerror.h kgerror.h
+ ksymbol.h kport.h ktable.h kbytevector.h kvector.h kghelpers.h kerror.h \
+ kgerrors.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 \
- kstate.h ktoken.h kmem.h kstring.h kgc.h
+ kstate.h kmem.h kstring.h kgc.h
+ksystem.o: ksystem.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
+ ktoken.h kmem.h kerror.h kpair.h kgc.h ksystem.h
+ksystem.posix.o: ksystem.posix.c kobject.h klimits.h klisp.h klispconf.h \
+ kstate.h ktoken.h kmem.h kinteger.h imath.h ksystem.h
+ksystem.win32.o: ksystem.win32.c kobject.h klimits.h klisp.h klispconf.h \
+ kstate.h ktoken.h kmem.h kinteger.h imath.h ksystem.h
ktable.o: ktable.c klisp.h kobject.h klimits.h klispconf.h kgc.h kstate.h \
- ktoken.h kmem.h ktable.h kapplicative.h koperative.h kgeqp.h kinteger.h \
- imath.h krational.h imrat.h kghelpers.h kerror.h kpair.h kcontinuation.h \
- kenvironment.h ksymbol.h kstring.h
+ ktoken.h kmem.h ktable.h kapplicative.h koperative.h kghelpers.h \
+ kerror.h kpair.h kcontinuation.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 kbytevector.h ksymbol.h kerror.h kport.h
@@ -297,7 +298,7 @@ kvector.o: kvector.c kvector.h kobject.h klimits.h klisp.h klispconf.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 kbytevector.h
+ kenvironment.h kbytevector.h kvector.h ktoken.h
imath.o: imath.c imath.h kobject.h klimits.h klisp.h klispconf.h kstate.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 \
diff --git a/src/examples/ffi-sdl.k b/src/examples/ffi-sdl.k
@@ -198,8 +198,6 @@
(#t
(event-loop screen drawing))))))
-($define! main
- ($lambda (argv)
- (with-sdl "klisp ffi demo"
- ($lambda (screen) (event-loop screen #f)))))
+(with-sdl "klisp ffi demo"
+ ($lambda (screen) (event-loop screen #f)))
diff --git a/src/examples/ffi-signal.c b/src/examples/ffi-signal.c
@@ -29,12 +29,9 @@ static void handler(int signo)
write(self_pipe[1], &message, 1);
}
-static void install_signal_handler(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+static void install_signal_handler(klisp_State *K)
{
- UNUSED(xparams);
- UNUSED(denv);
- bind_1tp(K, ptree, "string", ttisstring, signame);
+ bind_1tp(K, K->next_value, "string", ttisstring, signame);
int signo;
if (!strcmp(kstring_buf(signame), "SIGINT")) {
@@ -49,12 +46,8 @@ static void install_signal_handler(klisp_State *K, TValue *xparams,
kapply_cc(K, KINERT);
}
-static void open_signal_port(klisp_State *K, TValue *xparams,
- TValue ptree, TValue denv)
+static void open_signal_port(klisp_State *K)
{
- UNUSED(xparams);
- UNUSED(denv);
-
FILE *fw = fdopen(self_pipe[0], "r");
TValue filename = kstring_new_b_imm(K, "**SIGNAL**");
krooted_tvs_push(K, filename);
@@ -65,7 +58,7 @@ static void open_signal_port(klisp_State *K, TValue *xparams,
static void safe_add_applicative(klisp_State *K, TValue env,
const char *name,
- klisp_Ofunc fn)
+ klisp_CFunction fn)
{
TValue symbol = ksymbol_new(K, name, KNIL);
krooted_tvs_push(K, symbol);
diff --git a/src/imath.c b/src/imath.c
@@ -1866,7 +1866,7 @@ mp_result mp_int_to_string(klisp_State *K, mp_int z, mp_size radix,
return MP_RANGE;
if(CMPZ(z) == 0) {
- *str++ = s_val2ch(0, 1);
+ *str++ = s_val2ch(0, 0); /* changed to lowercase, Andres Navarro */
}
else {
mpz_t tmp;
@@ -1889,7 +1889,7 @@ mp_result mp_int_to_string(klisp_State *K, mp_int z, mp_size radix,
break;
d = s_ddiv(&tmp, (mp_digit)radix);
- *str++ = s_val2ch(d, 1);
+ *str++ = s_val2ch(d, 0); /* changed to lowercase, Andres Navarro */
}
t = str - 1;
diff --git a/src/kchar.c b/src/kchar.c
@@ -0,0 +1,40 @@
+/*
+** kchar.c
+** Kernel Characters
+** See Copyright Notice in klisp.h
+*/
+
+#include <ctype.h>
+#include <stdbool.h>
+
+#include "kobject.h"
+
+bool kcharp(TValue tv) { return ttischar(tv); }
+bool kchar_alphabeticp(TValue ch) { return isalpha(chvalue(ch)) != 0; }
+bool kchar_numericp(TValue ch) { return isdigit(chvalue(ch)) != 0; }
+bool kchar_whitespacep(TValue ch) { return isspace(chvalue(ch)) != 0; }
+bool kchar_upper_casep(TValue ch) { return isupper(chvalue(ch)) != 0; }
+bool kchar_lower_casep(TValue ch) { return islower(chvalue(ch)) != 0; }
+
+/* Helpers for binary typed predicates */
+bool kchar_eqp(TValue ch1, TValue ch2) { return chvalue(ch1) == chvalue(ch2); }
+bool kchar_ltp(TValue ch1, TValue ch2) { return chvalue(ch1) < chvalue(ch2); }
+bool kchar_lep(TValue ch1, TValue ch2) { return chvalue(ch1) <= chvalue(ch2); }
+bool kchar_gtp(TValue ch1, TValue ch2) { return chvalue(ch1) > chvalue(ch2); }
+bool kchar_gep(TValue ch1, TValue ch2) { return chvalue(ch1) >= chvalue(ch2); }
+
+bool kchar_ci_eqp(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) == tolower(chvalue(ch2)); }
+
+bool kchar_ci_ltp(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) < tolower(chvalue(ch2)); }
+
+bool kchar_ci_lep(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) <= tolower(chvalue(ch2)); }
+
+bool kchar_ci_gtp(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) > tolower(chvalue(ch2)); }
+
+bool kchar_ci_gep(TValue ch1, TValue ch2)
+{ return tolower(chvalue(ch1)) >= tolower(chvalue(ch2)); }
+
diff --git a/src/kchar.h b/src/kchar.h
@@ -0,0 +1,34 @@
+/*
+** kchar.h
+** Kernel Characters
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kchar_h
+#define kchar_h
+
+#include <stdbool.h>
+
+#include "kobject.h"
+#include "kstate.h"
+
+bool kcharp(TValue tv);
+bool kchar_alphabeticp(TValue ch);
+bool kchar_numericp(TValue ch);
+bool kchar_whitespacep(TValue ch);
+bool kchar_upper_casep(TValue ch);
+bool kchar_lower_casep(TValue ch);
+/* Helpers for binary typed predicates */
+bool kchar_eqp(TValue ch1, TValue ch2);
+bool kchar_ltp(TValue ch1, TValue ch2);
+bool kchar_lep(TValue ch1, TValue ch2);
+bool kchar_gtp(TValue ch1, TValue ch2);
+bool kchar_gep(TValue ch1, TValue ch2);
+
+bool kchar_ci_eqp(TValue ch1, TValue ch2);
+bool kchar_ci_ltp(TValue ch1, TValue ch2);
+bool kchar_ci_lep(TValue ch1, TValue ch2);
+bool kchar_ci_gtp(TValue ch1, TValue ch2);
+bool kchar_ci_gep(TValue ch1, TValue ch2);
+
+#endif
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -46,7 +46,7 @@ TValue kmake_continuation(klisp_State *K, TValue parent, klisp_CFunction fn,
TValue res = gc2cont(new_cont);
/* Add the current source info as source info (may be changed later) */
/* TODO: find all the places where this should be changed (like $and?,
- $sequence, and change it */
+ $sequence), and change it */
kset_source_info(K, res, kget_csi(K));
return res;
}
diff --git a/src/kencapsulation.c b/src/kencapsulation.c
@@ -11,6 +11,11 @@
#include "kpair.h"
#include "kgc.h"
+bool kis_encapsulation_type(TValue enc, TValue key)
+{
+ return ttisencapsulation(enc) && tv_equal(kget_enc_key(enc), key);
+}
+
/* GC: Assumes that key & val are rooted */
TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val)
{
diff --git a/src/kencapsulation.h b/src/kencapsulation.h
@@ -14,15 +14,9 @@
TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val);
TValue kmake_encapsulation_key(klisp_State *K);
-inline bool kis_encapsulation_type(TValue enc, TValue key);
+bool kis_encapsulation_type(TValue enc, TValue key);
#define kget_enc_val(e_)(tv2enc(e_)->value)
#define kget_enc_key(e_)(tv2enc(e_)->key)
-inline bool kis_encapsulation_type(TValue enc, TValue key)
-{
- return ttisencapsulation(enc) && tv_equal(kget_enc_key(enc), key);
-}
-
-
#endif
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -55,7 +55,9 @@ TValue kmake_environment(klisp_State *K, TValue parents)
} else {
/* list of parents, for now, just append them */
krooted_tvs_push(K, gc2env(new_env)); /* keep the new env rooted */
- TValue tail = kget_dummy1(K); /* keep the list rooted */
+ TValue plist = kcons(K, KNIL, KNIL); /* keep the list rooted */
+ krooted_vars_push(K, &plist);
+ TValue tail = plist;
while(!ttisnil(parents)) {
TValue parent = kcar(parents);
TValue pkparents = env_keyed_parents(parent);
@@ -74,8 +76,9 @@ TValue kmake_environment(klisp_State *K, TValue parents)
}
parents = kcdr(parents);
}
- /* all alocation done */
- kparents = kcutoff_dummy1(K);
+ /* all alocation done */
+ kparents = kcdr(plist);
+ krooted_vars_pop(K);
krooted_tvs_pop(K);
/* if it's just one env switch from (env) to env. */
if (ttispair(kparents) && ttisnil(kcdr(kparents)))
diff --git a/src/kenvironment.h b/src/kenvironment.h
@@ -23,7 +23,7 @@ TValue kmake_keyed_static_env(klisp_State *K, TValue parent, TValue key,
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
TODO: Should profile too see when it makes sense & should add code
to all operatives creating environments to see when it's appropriate
or should add code to add binding to at certain point move over to
diff --git a/src/kerror.c b/src/kerror.c
@@ -63,10 +63,6 @@ void clear_buffers(klisp_State *K)
ks_tbclear(K);
K->shared_dict = KNIL;
- UNUSED(kcutoff_dummy1(K));
- UNUSED(kcutoff_dummy2(K));
- UNUSED(kcutoff_dummy3(K));
-
krooted_tvs_clear(K);
krooted_vars_clear(K);
}
@@ -106,6 +102,8 @@ void klispE_throw_simple(klisp_State *K, char *msg)
/* GC: assumes all objs passed are rooted */
void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants)
{
+ /* it's important that this is immutable, because it's user
+ accessible */
TValue error_msg = kstring_new_b_imm(K, msg);
krooted_tvs_push(K, error_msg);
TValue error_obj =
diff --git a/src/kerror.h b/src/kerror.h
@@ -55,7 +55,7 @@ void klispE_throw_system_error_with_irritants(
TValue ls__ = klist(K__, __VA_ARGS__); \
krooted_tvs_push(K__, ls__); \
klispE_throw_system_error_with_irritants(K__, service__, errnum__, ls__); \
- }
+ }
#define klispE_throw_errno_simple(K__, service__) \
klispE_throw_system_error_with_irritants(K__, service__, errno, KNIL);
diff --git a/src/keval.c b/src/keval.c
@@ -12,6 +12,14 @@
#include "kcontinuation.h"
#include "kerror.h"
+/* for continuation name setting */
+#include "kghelpers.h"
+
+/* Continuations */
+void do_eval_ls(klisp_State *K);
+void do_combine(klisp_State *K);
+
+
/*
** Eval helpers
*/
@@ -173,4 +181,11 @@ void keval_ofn(klisp_State *K)
}
}
+/* init continuation names */
+void kinit_eval_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+ add_cont_name(K, t, do_eval_ls, "eval-list");
+ add_cont_name(K, t, do_combine, "eval-combine");
+}
diff --git a/src/keval.h b/src/keval.h
@@ -7,12 +7,10 @@
#ifndef keval_h
#define keval_h
-#include "klisp.h"
#include "kstate.h"
-#include "kobject.h"
void keval_ofn(klisp_State *K);
-void do_eval_ls(klisp_State *K);
-void do_combine(klisp_State *K);
+/* init continuation names */
+void kinit_eval_cont_names(klisp_State *K);
#endif
diff --git a/src/kgbooleans.c b/src/kgbooleans.c
@@ -17,7 +17,12 @@
#include "ksymbol.h"
#include "kcontinuation.h"
#include "kerror.h"
+
#include "kghelpers.h"
+#include "kgbooleans.h"
+
+/* Continuations */
+void do_Sandp_Sorp(klisp_State *K);
/* 4.1.1 boolean? */
/* uses typep */
@@ -38,9 +43,6 @@ void notp(klisp_State *K)
kapply_cc(K, res);
}
-/* Helper for type checking booleans */
-bool kbooleanp(TValue obj) { return ttisboolean(obj); }
-
/* 6.1.2 and? */
void andp(klisp_State *K)
{
@@ -50,9 +52,9 @@ void andp(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
+ int32_t pairs;
/* don't care about cycle pairs */
- int32_t pairs = check_typed_list(K, "and?", "boolean", kbooleanp,
- true, ptree, NULL);
+ check_typed_list(K, kbooleanp, true, ptree, &pairs, NULL);
TValue res = KTRUE;
TValue tail = ptree;
while(pairs--) {
@@ -75,9 +77,9 @@ void orp(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
+ int32_t pairs;
/* don't care about cycle pairs */
- int32_t pairs = check_typed_list(K, "or?", "boolean", kbooleanp,
- true, ptree, NULL);
+ check_typed_list(K, kbooleanp,true, ptree, &pairs, NULL);
TValue res = KFALSE;
TValue tail = ptree;
while(pairs--) {
@@ -119,7 +121,8 @@ void do_Sandp_Sorp(klisp_State *K)
TValue denv = xparams[3];
if (!ttisboolean(obj)) {
- klispE_throw_simple(K, "expected boolean");
+ klispE_throw_simple_with_irritants(K, "expected boolean", 1,
+ obj);
return;
} else if (ttisnil(ls) || tv_equal(obj, term_bool)) {
/* in both cases the value to be returned is obj:
@@ -169,7 +172,7 @@ void Sandp_Sorp(klisp_State *K)
TValue sname = xparams[0];
TValue term_bool = xparams[1];
- TValue ls = check_copy_list(K, ksymbol_buf(sname), ptree, false);
+ TValue ls = check_copy_list(K, ptree, false, NULL, NULL);
/* This will work even if ls is empty */
krooted_tvs_push(K, ls);
TValue new_cont = kmake_continuation(K, kget_cc(K), do_Sandp_Sorp, 4,
@@ -208,3 +211,10 @@ void kinit_booleans_ground_env(klisp_State *K)
/* 6.1.5 $or? */
add_operative(K, ground_env, "$or?", Sandp_Sorp, 2, symbol, KTRUE);
}
+
+/* init continuation names */
+void kinit_booleans_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+ add_cont_name(K, t, do_Sandp_Sorp, "eval-booleans");
+}
diff --git a/src/kgbooleans.h b/src/kgbooleans.h
@@ -7,43 +7,11 @@
#ifndef kgbooleans_h
#define kgbooleans_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"
-
-/* 4.1.1 boolean? */
-/* uses typep */
-
-/* 6.1.1 not? */
-void notp(klisp_State *K);
-
-/* 6.1.2 and? */
-void andp(klisp_State *K);
-
-/* 6.1.3 or? */
-void orp(klisp_State *K);
-
-/* Helpers for $and? & $or? */
-void do_Sandp_Sorp(klisp_State *K);
-void Sandp_Sorp(klisp_State *K);
-
-/* 6.1.4 $and? */
-/* uses Sandp_Sorp */
-
-/* 6.1.5 $or? */
-/* uses Sandp_Sorp */
-
-/* Helper */
-bool kbooleanp(TValue obj);
/* init ground */
void kinit_booleans_ground_env(klisp_State *K);
+/* init continuation names */
+void kinit_booleans_cont_names(klisp_State *K);
#endif
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -21,15 +21,67 @@
#include "kghelpers.h"
#include "kgbytevectors.h"
-#include "kgnumbers.h" /* for keintegerp & knegativep */
-/* 13.1.1? bytevector? */
+/* ?.? bytevector? */
/* uses typep */
-/* 13.? immutable-bytevector?, mutable-bytevector? */
+/* ?.? immutable-bytevector?, mutable-bytevector? */
/* use ftypep */
-/* 13.1.2? make-bytevector */
+/* ?.? bytevector */
+void 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);
+
+ /* don't allow cycles */
+ int32_t pairs;
+ check_typed_list(K, ku8p, false, ptree, &pairs, NULL);
+ TValue new_bb = list_to_bytevector_h(K, ptree, pairs);
+ kapply_cc(K, new_bb);
+}
+
+/* ?.? bytevector->list */
+void bytevector_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);
+
+ bind_1tp(K, ptree, "bytevector", ttisbytevector, bb);
+
+ TValue res = bytevector_to_list_h(K, bb, NULL);
+ kapply_cc(K, res);
+}
+
+/* ?.? list->bytevector */
+void list_to_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);
+
+ /* check later in list_to_bytevector_h */
+ bind_1p(K, ptree, ls);
+
+ /* don't allow cycles */
+ int32_t pairs;
+ check_typed_list(K, ku8p, false, ls, &pairs, NULL);
+ TValue new_bb = list_to_bytevector_h(K, ls, pairs);
+ kapply_cc(K, new_bb);
+}
+
+/* ?.? make-bytevector */
void make_bytevector(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -57,7 +109,7 @@ void make_bytevector(klisp_State *K)
kapply_cc(K, new_bytevector);
}
-/* 13.1.3? bytevector-length */
+/* ?.? bytevector-length */
void bytevector_length(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -72,7 +124,7 @@ void bytevector_length(klisp_State *K)
kapply_cc(K, res);
}
-/* 13.1.4? bytevector-u8-ref */
+/* ?.? bytevector-u8-ref */
void bytevector_u8_ref(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -101,8 +153,8 @@ void bytevector_u8_ref(klisp_State *K)
kapply_cc(K, res);
}
-/* 13.1.5? bytevector-u8-set! */
-void bytevector_u8_setS(klisp_State *K)
+/* ?.? bytevector-u8-set! */
+void bytevector_u8_setB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -134,7 +186,7 @@ void bytevector_u8_setS(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* 13.2.8? bytevector-copy */
+/* ?.? bytevector-copy */
/* TEMP: at least for now this always returns mutable bytevectors */
void bytevector_copy(klisp_State *K)
{
@@ -158,7 +210,7 @@ void bytevector_copy(klisp_State *K)
}
/* 13.2.9? bytevector-copy! */
-void bytevector_copyS(klisp_State *K)
+void bytevector_copyB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -186,7 +238,7 @@ void bytevector_copyS(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* 13.2.10? bytevector-copy-partial */
+/* ?.? bytevector-copy-partial */
/* TEMP: at least for now this always returns mutable bytevectors */
void bytevector_copy_partial(klisp_State *K)
{
@@ -235,8 +287,8 @@ void bytevector_copy_partial(klisp_State *K)
kapply_cc(K, new_bytevector);
}
-/* 13.2.11? bytevector-copy-partial! */
-void bytevector_copy_partialS(klisp_State *K)
+/* ?.? bytevector-copy-partial! */
+void bytevector_copy_partialB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -307,7 +359,32 @@ void bytevector_copy_partialS(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* 13.2.12? bytevector->immutable-bytevector */
+/* ?.? bytevector-u8-fill! */
+void bytevector_u8_fillB(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,
+ "u8", ttisu8, tv_byte);
+
+ if (kbytevector_immutablep(bytevector)) {
+ klispE_throw_simple(K, "immutable bytevector");
+ return;
+ }
+
+ uint32_t size = kbytevector_size(bytevector);
+ uint8_t *buf = kbytevector_buf(bytevector);
+ while(size-- > 0) {
+ *buf++ = (uint8_t) ivalue(tv_byte);
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* ?.? bytevector->immutable-bytevector */
void bytevector_to_immutable_bytevector(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -349,6 +426,12 @@ void kinit_bytevectors_ground_env(klisp_State *K)
p2tv(kimmutable_bytevectorp));
add_applicative(K, ground_env, "mutable-bytevector?", ftypep, 2, symbol,
p2tv(kmutable_bytevectorp));
+ /* ??.1.? bytevector */
+ add_applicative(K, ground_env, "bytevector", bytevector, 0);
+ /* ??.1.? list->bytevector */
+ add_applicative(K, ground_env, "list->bytevector", list_to_bytevector, 0);
+ /* ??.1.? bytevector->list */
+ add_applicative(K, ground_env, "bytevector->list", bytevector_to_list, 0);
/* ??.1.2? make-bytevector */
add_applicative(K, ground_env, "make-bytevector", make_bytevector, 0);
/* ??.1.3? bytevector-length */
@@ -357,21 +440,25 @@ void kinit_bytevectors_ground_env(klisp_State *K)
/* ??.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,
+ add_applicative(K, ground_env, "bytevector-u8-set!", bytevector_u8_setB,
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);
+ add_applicative(K, ground_env, "bytevector-copy!", bytevector_copyB, 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);
+ bytevector_copy_partialB, 0);
+ /* ??.?? bytevector-u8-fill! */
+ add_applicative(K, ground_env, "bytevector-u8-fill!",
+ bytevector_u8_fillB, 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
@@ -7,46 +7,7 @@
#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);
diff --git a/src/kgc.c b/src/kgc.c
@@ -604,6 +604,7 @@ static void markroot (klisp_State *K) {
/* NOTE: next_x_params is protected by next_obj */
markvalue(K, K->eval_op);
markvalue(K, K->list_app);
+ markvalue(K, K->memoize_app);
markvalue(K, K->ground_env);
markvalue(K, K->module_params_sym);
markvalue(K, K->root_cont);
@@ -626,9 +627,12 @@ static void markroot (klisp_State *K) {
markvalue(K, K->curr_port);
+ markvalue(K, K->require_path);
+ markvalue(K, K->require_table);
+
/* 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 */
+ (all valid indexes are below top) and all the objects in
+ the two protected areas */
markvaluearray(K, K->sbuf, K->stop);
markvaluearray(K, K->rooted_tvs_buf, K->rooted_tvs_top);
/* the area protecting variables is an array of type TValue *[] */
@@ -637,9 +641,6 @@ static void markroot (klisp_State *K) {
markvalue(K, **ptr);
}
- markvalue(K, K->dummy_pair1);
- markvalue(K, K->dummy_pair2);
- markvalue(K, K->dummy_pair3);
K->gcstate = GCSpropagate;
}
diff --git a/src/kgchars.c b/src/kgchars.c
@@ -17,6 +17,7 @@
#include "koperative.h"
#include "kcontinuation.h"
#include "kerror.h"
+#include "kchar.h"
#include "kghelpers.h"
#include "kgchars.h"
@@ -30,14 +31,6 @@
/* 14.1.3? char-upper-case?, char-lower-case? */
/* use ftyped_predp */
-/* Helpers for typed predicates */
-bool kcharp(TValue tv) { return ttischar(tv); }
-bool kchar_alphabeticp(TValue ch) { return isalpha(chvalue(ch)) != 0; }
-bool kchar_numericp(TValue ch) { return isdigit(chvalue(ch)) != 0; }
-bool kchar_whitespacep(TValue ch) { return isspace(chvalue(ch)) != 0; }
-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)
{
@@ -76,32 +69,21 @@ void kinteger_to_char(klisp_State *K)
kapply_cc(K, ch2tv((char) i));
}
-/* 14.1.4? char-upcase, char-downcase */
-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);
- char ch = chvalue(chtv);
- ch = toupper(ch);
- kapply_cc(K, ch2tv(ch));
-}
-
-void kchar_downcase(klisp_State *K)
+/* 14.1.4? char-upcase, char-downcase, char-titlecase, char-foldcase */
+void kchar_change_case(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);
+ /*
+ ** xparams[0]: conversion fn
+ */
UNUSED(denv);
bind_1tp(K, ptree, "character", ttischar, chtv);
char ch = chvalue(chtv);
- ch = tolower(ch);
+ char (*fn)(char) = pvalue(xparams[0]);
+ ch = fn(ch);
kapply_cc(K, ch2tv(ch));
}
@@ -117,27 +99,89 @@ void kchar_downcase(klisp_State *K)
/* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
/* use ftyped_bpredp */
-/* Helpers for binary typed predicates */
-bool kchar_eqp(TValue ch1, TValue ch2) { return chvalue(ch1) == chvalue(ch2); }
-bool kchar_ltp(TValue ch1, TValue ch2) { return chvalue(ch1) < chvalue(ch2); }
-bool kchar_lep(TValue ch1, TValue ch2) { return chvalue(ch1) <= chvalue(ch2); }
-bool kchar_gtp(TValue ch1, TValue ch2) { return chvalue(ch1) > chvalue(ch2); }
-bool kchar_gep(TValue ch1, TValue ch2) { return chvalue(ch1) >= chvalue(ch2); }
+/* 14.2.? char-digit?, char->digit, digit->char */
+void char_digitp(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_al1tp(K, ptree, "character", ttischar, chtv, basetv);
+
+ int base = 10; /* default */
+
+ if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) {
+ base = ivalue(basetv);
+ }
+ char ch = tolower(chvalue(chtv));
+ bool b = (isdigit(ch) && (ch - '0') < base) ||
+ (isalpha(ch) && (ch - 'a' + 10) < base);
+ kapply_cc(K, b2tv(b));
+}
+
+void char_to_digit(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_al1tp(K, ptree, "character", ttischar, chtv, basetv);
+
+ int base = 10; /* default */
+
+ if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) {
+ base = ivalue(basetv);
+ }
+ char ch = tolower(chvalue(chtv));
+ int digit = 0;
+
+ if (isdigit(ch) && (ch - '0') < base)
+ digit = ch - '0';
+ else if (isalpha(ch) && (ch - 'a' + 10) < base)
+ digit = ch - 'a' + 10;
+ else {
+ klispE_throw_simple_with_irritants(K, "Not a digit in this base",
+ 2, ch2tv(ch), i2tv(base));
+ return;
+ }
+ kapply_cc(K, i2tv(digit));
+}
-bool kchar_ci_eqp(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) == tolower(chvalue(ch2)); }
+void digit_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));
-bool kchar_ci_ltp(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) < tolower(chvalue(ch2)); }
+ UNUSED(denv);
+ UNUSED(xparams);
+ bind_al1tp(K, ptree, "exact integer", ttiseinteger, digittv, basetv);
-bool kchar_ci_lep(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) <= tolower(chvalue(ch2)); }
+ int base = 10; /* default */
-bool kchar_ci_gtp(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) > tolower(chvalue(ch2)); }
+ if (get_opt_tpar(K, basetv, "base [2-36]", ttisbase)) {
+ base = ivalue(basetv);
+ }
-bool kchar_ci_gep(TValue ch1, TValue ch2)
-{ return tolower(chvalue(ch1)) >= tolower(chvalue(ch2)); }
+ if (ttisbigint(digittv) || ivalue(digittv) < 0 ||
+ ivalue(digittv) >= base) {
+ klispE_throw_simple_with_irritants(K, "Not a digit in this base",
+ 2, digittv, i2tv(base));
+ return;
+ }
+ int digit = ivalue(digittv);
+ char ch = digit <= 9?
+ '0' + digit :
+ 'a' + (digit - 10);
+ kapply_cc(K, ch2tv(ch));
+}
/* init ground */
void kinit_chars_ground_env(klisp_State *K)
@@ -174,9 +218,15 @@ void kinit_chars_ground_env(klisp_State *K)
/* 14.1.4? char->integer, integer->char */
add_applicative(K, ground_env, "char->integer", kchar_to_integer, 0);
add_applicative(K, ground_env, "integer->char", kinteger_to_char, 0);
- /* 14.1.4? char-upcase, char-downcase */
- add_applicative(K, ground_env, "char-upcase", kchar_upcase, 0);
- add_applicative(K, ground_env, "char-downcase", kchar_downcase, 0);
+ /* 14.1.4? char-upcase, char-downcase, char-titlecase, char-foldcase */
+ add_applicative(K, ground_env, "char-upcase", kchar_change_case, 1,
+ p2tv(toupper));
+ add_applicative(K, ground_env, "char-downcase", kchar_change_case, 1,
+ p2tv(tolower));
+ add_applicative(K, ground_env, "char-titlecase", kchar_change_case, 1,
+ p2tv(toupper));
+ add_applicative(K, ground_env, "char-foldcase", kchar_change_case, 1,
+ p2tv(tolower));
/* 14.2.1? char=? */
add_applicative(K, ground_env, "char=?", ftyped_bpredp, 3,
symbol, p2tv(kcharp), p2tv(kchar_eqp));
@@ -201,4 +251,8 @@ void kinit_chars_ground_env(klisp_State *K)
symbol, p2tv(kcharp), p2tv(kchar_ci_gtp));
add_applicative(K, ground_env, "char-ci>=?", ftyped_bpredp, 3,
symbol, p2tv(kcharp), p2tv(kchar_ci_gep));
+ /* 14.2.? char-digit?, char->digit, digit->char */
+ add_applicative(K, ground_env, "char-digit?", char_digitp, 0);
+ add_applicative(K, ground_env, "char->digit", char_to_digit, 0);
+ add_applicative(K, ground_env, "digit->char", digit_to_char, 0);
}
diff --git a/src/kgchars.h b/src/kgchars.h
@@ -7,70 +7,7 @@
#ifndef kgchars_h
#define kgchars_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"
-
-/* 14.1.1? char? */
-/* uses typep */
-
-/* 14.1.2? char-alphabetic?, char-numeric?, char-whitespace? */
-/* use ftyped_predp */
-
-/* 14.1.3? char-upper-case?, char-lower-case? */
-/* use ftyped_predp */
-
-/* Helpers for typed predicates */
-/* XXX: this should probably be in a file kchar.h but there is no real need for
- that file yet */
-bool kcharp(TValue tv);
-bool kchar_alphabeticp(TValue ch);
-bool kchar_numericp(TValue ch);
-bool kchar_whitespacep(TValue ch);
-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);
-void kinteger_to_char(klisp_State *K);
-
-/* 14.1.4? char-upcase, char-downcase */
-void kchar_upcase(klisp_State *K);
-void kchar_downcase(klisp_State *K);
-
-/* 14.2.1? char=? */
-/* uses ftyped_bpredp */
-
-/* 14.2.2? char<?, char<=?, char>?, char>=? */
-/* use ftyped_bpredp */
-
-/* 14.2.3? char-ci=? */
-/* uses ftyped_bpredp */
-
-/* 14.2.4? char-ci<?, char-ci<=?, char-ci>?, char-ci>=? */
-/* use ftyped_bpredp */
-
-/* Helpers for typed binary predicates */
-/* XXX: this should probably be in a file kchar.h but there is no real need for
- that file yet */
-bool kchar_eqp(TValue ch1, TValue ch2);
-bool kchar_ltp(TValue ch1, TValue ch2);
-bool kchar_lep(TValue ch1, TValue ch2);
-bool kchar_gtp(TValue ch1, TValue ch2);
-bool kchar_gep(TValue ch1, TValue ch2);
-
-bool kchar_ci_eqp(TValue ch1, TValue ch2);
-bool kchar_ci_ltp(TValue ch1, TValue ch2);
-bool kchar_ci_lep(TValue ch1, TValue ch2);
-bool kchar_ci_gtp(TValue ch1, TValue ch2);
-bool kchar_ci_gep(TValue ch1, TValue ch2);
/* init ground */
void kinit_chars_ground_env(klisp_State *K);
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -21,14 +21,18 @@
#include "kerror.h"
#include "kghelpers.h"
-#include "kgpair_mut.h" /* for copy_es_immutable_h */
-#include "kgenv_mut.h" /* for match */
-#include "kgcontrol.h" /* for do_seq */
#include "kgcombiners.h"
-/* Helper (used by $vau & $lambda) */
+/* continuations */
void do_vau(klisp_State *K);
+void do_map(klisp_State *K);
+void do_map_ret(klisp_State *K);
+void do_map_encycle(klisp_State *K);
+void do_map_cycle(klisp_State *K);
+
+void do_array_map_ret(klisp_State *K);
+
/* 4.10.1 operative? */
/* uses typep */
@@ -47,13 +51,13 @@ void Svau(klisp_State *K)
bind_al2p(K, ptree, vptree, vpenv, vbody);
/* The ptree & body are copied to avoid mutation */
- vptree = check_copy_ptree(K, "$vau", vptree, vpenv);
+ vptree = check_copy_ptree(K, vptree, vpenv);
krooted_tvs_push(K, vptree);
/* the body should be a list */
- UNUSED(check_list(K, "$vau", true, vbody, NULL));
- vbody = copy_es_immutable_h(K, "$vau", vbody, false);
+ check_list(K, true, vbody, NULL, NULL);
+ vbody = copy_es_immutable_h(K, vbody, false);
krooted_tvs_push(K, vbody);
@@ -101,8 +105,7 @@ void do_vau(klisp_State *K)
/* protect env */
krooted_tvs_push(K, env);
- /* TODO use name from operative */
- match(K, "[user-operative]", env, op_ptree, ptree);
+ match(K, env, op_ptree, ptree);
if (!ttisignore(penv))
kadd_binding(K, env, penv, denv);
@@ -182,11 +185,11 @@ void Slambda(klisp_State *K)
bind_al1p(K, ptree, vptree, vbody);
/* The ptree & body are copied to avoid mutation */
- vptree = check_copy_ptree(K, "$lambda", vptree, KIGNORE);
+ vptree = check_copy_ptree(K, vptree, KIGNORE);
krooted_tvs_push(K, vptree);
/* the body should be a list */
- UNUSED(check_list(K, "$lambda", true, vbody, NULL));
- vbody = copy_es_immutable_h(K, "$lambda", vbody, false);
+ check_list(K, true, vbody, NULL, NULL);
+ vbody = copy_es_immutable_h(K, vbody, false);
krooted_tvs_push(K, vbody);
@@ -235,205 +238,6 @@ void apply(klisp_State *K)
ktail_eval(K, expr, env);
}
-/* Helpers for map (also used by for each) */
-void map_for_each_get_metrics(klisp_State *K, char *name, TValue lss,
- int32_t *app_apairs_out, int32_t *app_cpairs_out,
- int32_t *res_apairs_out, int32_t *res_cpairs_out)
-{
- /* avoid warnings (shouldn't happen if _No_return was used in throw) */
- *app_apairs_out = 0;
- *app_cpairs_out = 0;
- *res_apairs_out = 0;
- *res_cpairs_out = 0;
-
- /* get the metrics of the ptree of each call to app */
- int32_t app_cpairs;
- int32_t app_pairs = check_list(K, name, true, lss, &app_cpairs);
- int32_t app_apairs = app_pairs - app_cpairs;
-
- /* get the metrics of the result list */
- int32_t res_cpairs;
- /* We now that lss has at least one elem */
- int32_t res_pairs = check_list(K, name, true, kcar(lss), &res_cpairs);
- int32_t res_apairs = res_pairs - res_cpairs;
-
- if (res_cpairs == 0) {
- /* finite list of length res_pairs (all lists should
- have the same structure: acyclic with same length) */
- int32_t pairs = app_pairs - 1;
- TValue tail = kcdr(lss);
- while(pairs--) {
- int32_t first_cpairs;
- int32_t first_pairs = check_list(K, name, true, kcar(tail),
- &first_cpairs);
- tail = kcdr(tail);
-
- if (first_cpairs != 0) {
- klispE_throw_simple(K, "mixed finite and infinite lists");
- return;
- } else if (first_pairs != res_pairs) {
- klispE_throw_simple(K, "lists of different length");
- return;
- }
- }
- } else {
- /* cyclic list: all lists should be cyclic.
- result will have acyclic length equal to the
- max of all the lists and cyclic length equal to the lcm
- of all the lists. res_pairs may be broken but will be
- restored by after the loop */
- int32_t pairs = app_pairs - 1;
- TValue tail = kcdr(lss);
- while(pairs--) {
- int32_t first_cpairs;
- int32_t first_pairs = check_list(K, name, true, kcar(tail),
- &first_cpairs);
- int32_t first_apairs = first_pairs - first_cpairs;
- tail = kcdr(tail);
-
- if (first_cpairs == 0) {
- klispE_throw_simple(K, "mixed finite and infinite lists");
- return;
- }
- res_apairs = kmax32(res_apairs, first_apairs);
- /* this can throw an error if res_cpairs doesn't
- fit in 32 bits, which is a reasonable implementation
- restriction because the list wouldn't fit in memory
- anyways */
- res_cpairs = kcheck32(K, "map/for-each: result list is too big",
- klcm32_64(res_cpairs, first_cpairs));
- }
- res_pairs = kcheck32(K, "map/for-each: result list is too big",
- (int64_t) res_cpairs + (int64_t) res_apairs);
- UNUSED(res_pairs);
- }
-
- *app_apairs_out = app_apairs;
- *app_cpairs_out = app_cpairs;
- *res_apairs_out = res_apairs;
- *res_cpairs_out = res_cpairs;
-}
-
-/* Return two lists, isomorphic to lss: one list of cars and one list
- of cdrs (replacing the value of lss) */
-
-/* GC: assumes lss is rooted, and dummy1 & 2 are free in K */
-TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
- int32_t apairs, int32_t cpairs)
-{
- TValue tail = *lss;
-
- TValue lp_cars = kget_dummy1(K);
- TValue lap_cars = lp_cars;
-
- TValue lp_cdrs = kget_dummy2(K);
- TValue lap_cdrs = lp_cdrs;
-
- while(apairs != 0 || cpairs != 0) {
- int32_t pairs;
- if (apairs != 0) {
- pairs = apairs;
- } else {
- /* remember last acyclic pair of both lists to to encycle! later */
- lap_cars = lp_cars;
- lap_cdrs = lp_cdrs;
- pairs = cpairs;
- }
-
- while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
-
- /* accumulate both cars and cdrs */
- TValue np;
- np = kcons(K, kcar(first), KNIL);
- kset_cdr(lp_cars, np);
- lp_cars = np;
-
- np = kcons(K, kcdr(first), KNIL);
- kset_cdr(lp_cdrs, np);
- lp_cdrs = np;
- }
-
- if (apairs != 0) {
- apairs = 0;
- } else {
- cpairs = 0;
- /* encycle! the list of cars and the list of cdrs */
- TValue fcp, lcp;
- fcp = kcdr(lap_cars);
- lcp = lp_cars;
- kset_cdr(lcp, fcp);
-
- fcp = kcdr(lap_cdrs);
- lcp = lp_cdrs;
- kset_cdr(lcp, fcp);
- }
- }
-
- *lss = kcutoff_dummy2(K);
- return kcutoff_dummy1(K);
-}
-
-/* Transpose lss so that the result is a list of lists, each one having
- metrics (app_apairs, app_cpairs). The metrics of the returned list
- should be (res_apairs, res_cpairs) */
-
-/* GC: assumes lss is rooted */
-TValue map_for_each_transpose(klisp_State *K, TValue lss,
- int32_t app_apairs, int32_t app_cpairs,
- int32_t res_apairs, int32_t res_cpairs)
-{
- /* reserve dummy1 & 2 to get_cars_cdrs */
- TValue lp = kget_dummy3(K);
- TValue lap = lp;
-
- TValue cars = KNIL; /* put something for GC */
- TValue tail = lss;
-
- /* GC: both cars & tail vary in each loop, to protect them we need
- the vars stack */
- krooted_vars_push(K, &cars);
- krooted_vars_push(K, &tail);
-
- /* Loop over list of lists, creating a list of cars and
- a list of cdrs, accumulate the list of cars and loop
- with the list of cdrs as the new list of lists (lss) */
- while(res_apairs != 0 || res_cpairs != 0) {
- int32_t pairs;
-
- if (res_apairs != 0) {
- pairs = res_apairs;
- } else {
- pairs = res_cpairs;
- /* remember last acyclic pair to encycle! later */
- lap = lp;
- }
-
- while(pairs--) {
- /* accumulate cars and replace tail with cdrs */
- cars = map_for_each_get_cars_cdrs(K, &tail, app_apairs, app_cpairs);
- TValue np = kcons(K, cars, KNIL);
- kset_cdr(lp, np);
- lp = np;
- }
-
- if (res_apairs != 0) {
- res_apairs = 0;
- } else {
- res_cpairs = 0;
- /* encycle! the list of list of cars */
- TValue fcp = kcdr(lap);
- TValue lcp = lp;
- kset_cdr(lcp, fcp);
- }
- }
-
- krooted_vars_pop(K);
- krooted_vars_pop(K);
- return kcutoff_dummy3(K);
-}
-
/* Continuation helpers for map */
/* For acyclic input lists: Return the mapped list */
@@ -451,7 +255,7 @@ void do_map_ret(klisp_State *K)
and later mutation of the result */
/* XXX: the check isn't necessary really, but there is
no list_copy */
- TValue copy = check_copy_list(K, "map", kcdr(xparams[0]), false);
+ TValue copy = check_copy_list(K, kcdr(xparams[0]), false, NULL, NULL);
kapply_cc(K, copy);
}
@@ -478,7 +282,7 @@ void do_map_encycle(klisp_State *K)
and later mutation of the result */
/* XXX: the check isn't necessary really, but there is
no list_copy */
- TValue copy = check_copy_list(K, "map", kcdr(xparams[0]), false);
+ TValue copy = check_copy_list(K, kcdr(xparams[0]), false, NULL, NULL);
kapply_cc(K, copy);
}
@@ -517,7 +321,7 @@ void do_map(klisp_State *K)
/* copy the ptree to avoid problems with mutation */
/* XXX: no check necessary, could just use copy_list if there
was such a procedure */
- TValue first_ptree = check_copy_list(K, "map", kcar(ls), false);
+ TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL);
ls = kcdr(ls);
n = n-1;
krooted_tvs_push(K, first_ptree);
@@ -596,7 +400,7 @@ void map(klisp_State *K)
int32_t app_pairs, app_apairs, app_cpairs;
int32_t res_pairs, res_apairs, res_cpairs;
- map_for_each_get_metrics(K, "map", lss, &app_apairs, &app_cpairs,
+ map_for_each_get_metrics(K, lss, &app_apairs, &app_cpairs,
&res_apairs, &res_cpairs);
app_pairs = app_apairs + app_cpairs;
res_pairs = res_apairs + res_cpairs;
@@ -640,12 +444,142 @@ void map(klisp_State *K)
kapply_cc(K, KINERT);
}
+/*
+** These are from r7rs (except bytevector). For now just follow
+** Kernel version of (list) map. That means that the objects should
+** all have the same size, and that the dynamic environment is passed
+** to the applicatives. Continuation capturing interaction is still
+** an open issue (see comment in map).
+*/
+
+/* NOTE: the type error on the result of app are only checked after
+ all values are collected. This could be changed if necessary, by
+ having map continuations take an additional typecheck param */
+/* Helpers for array_map */
+
+/* copy the resulting list to a new vector */
+void do_array_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)
+ ** xparams[1]: list->array
+ ** xparams[2]: length
+ */
+ UNUSED(obj);
+
+ TValue ls = kcdr(xparams[0]);
+ TValue (*list_to_array)(klisp_State *K, TValue array, int32_t size) =
+ pvalue(xparams[1]);
+ int32_t length = ivalue(xparams[2]);
+
+ /* This will also avoid some problems with continuations
+ captured from within the dynamic extent to map
+ and later mutation of the result */
+ TValue copy = list_to_array(K, ls, length);
+ kapply_cc(K, copy);
+}
+
+/* 5.9.? string-map */
+/* 5.9.? vector-map */
+/* 5.9.? bytevector-map */
+void array_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));
+
+ /*
+ ** xparams[0]: list->array fn
+ ** xparams[1]: array->list fn (with type check and size ret)
+ */
+
+ TValue list_to_array_tv = xparams[0];
+ TValue (*array_to_list)(klisp_State *K, TValue array, int32_t *size) =
+ pvalue(xparams[1]);
+
+ bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
+
+ /* check that lss is a non empty list, and copy it */
+ if (ttisnil(lss)) {
+ klispE_throw_simple(K, "no arguments after applicative");
+ return;
+ }
+
+ int32_t app_pairs, app_apairs, app_cpairs;
+ /* the copied list should be protected from gc, and will host
+ the lists resulting from the conversion */
+ lss = check_copy_list(K, lss, true, &app_pairs, &app_cpairs);
+ app_apairs = app_pairs - app_cpairs;
+ krooted_tvs_push(K, lss);
+
+ /* check that all elements have the correct type and same size,
+ and convert them to lists */
+ int32_t res_pairs;
+ TValue head = kcar(lss);
+ TValue tail = kcdr(lss);
+ TValue ls = array_to_list(K, head, &res_pairs);
+ kset_car(lss, ls); /* save the first */
+ /* all array will produce acyclic lists */
+
+ for(int32_t i = 1 /* jump over first */; i < app_pairs; ++i) {
+ head = kcar(tail);
+ int32_t pairs;
+ ls = array_to_list(K, head, &pairs);
+ /* in klisp all arrays should have the same length */
+ if (pairs != res_pairs) {
+ klispE_throw_simple(K, "arguments of different length");
+ return;
+ }
+ kset_car(tail, ls);
+ tail = kcdr(tail);
+ }
+
+ /* create the list of parameters to app */
+ lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs,
+ res_pairs, 0); /* cycle pairs is always 0 */
+
+ /* ASK John: the semantics when this is mixed with continuations,
+ isn't all that great..., but what are the expectations considering
+ there is no prescribed order? */
+
+ krooted_tvs_pop(K);
+ krooted_tvs_push(K, lss);
+ /* This will be the list to be returned, but it will be transformed
+ to an array before returning (making it also play a little nicer
+ with continuations) */
+ TValue dummy = kcons(K, KINERT, KNIL);
+
+ krooted_tvs_push(K, dummy);
+
+ TValue ret_cont =
+ kmake_continuation(K, kget_cc(K), do_array_map_ret, 3, dummy,
+ list_to_array_tv, i2tv(res_pairs));
+ krooted_tvs_push(K, ret_cont);
+
+ /* schedule the mapping of the elements of the acyclic part.
+ signal dummyp = true to avoid creating a pair for
+ the inert value passed to the first continuation */
+ TValue new_cont =
+ kmake_continuation(K, ret_cont, do_map, 6, app, lss, dummy,
+ i2tv(res_pairs), denv, KTRUE);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ kset_cc(K, new_cont);
+
+ /* this will be a nop, and will continue with do_map */
+ kapply_cc(K, KINERT);
+}
+
/* 6.2.1 combiner? */
/* uses ftypedp */
-/* Helper for combiner? */
-bool kcombinerp(TValue obj) { return ttiscombiner(obj); }
-
/* init ground */
void kinit_combiners_ground_env(klisp_State *K)
{
@@ -671,7 +605,29 @@ void kinit_combiners_ground_env(klisp_State *K)
add_applicative(K, ground_env, "apply", apply, 0);
/* 5.9.1 map */
add_applicative(K, ground_env, "map", map, 0);
+ /* 5.9.? string-map, vector-map, bytevector-map */
+ add_applicative(K, ground_env, "string-map", array_map, 2,
+ p2tv(list_to_string_h), p2tv(string_to_list_h));
+ add_applicative(K, ground_env, "vector-map", array_map, 2,
+ p2tv(list_to_vector_h), p2tv(vector_to_list_h));
+ add_applicative(K, ground_env, "bytevector-map", array_map, 2,
+ p2tv(list_to_bytevector_h), p2tv(bytevector_to_list_h));
/* 6.2.1 combiner? */
add_applicative(K, ground_env, "combiner?", ftypep, 2, symbol,
p2tv(kcombinerp));
}
+
+/* init continuation names */
+void kinit_combiners_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_vau, "$vau-bind!-eval");
+
+ add_cont_name(K, t, do_map, "map-acyclic-part");
+ add_cont_name(K, t, do_map_encycle, "map-encycle!");
+ add_cont_name(K, t, do_map_ret, "map-ret");
+ add_cont_name(K, t, do_map_cycle, "map-cyclic-part");
+
+ add_cont_name(K, t, do_array_map_ret, "array-map-ret");
+}
diff --git a/src/kgcombiners.h b/src/kgcombiners.h
@@ -7,83 +7,11 @@
#ifndef kgcombiners_h
#define kgcombiners_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"
-
-/* 4.10.1 operative? */
-/* uses typep */
-
-/* 4.10.2 applicative? */
-/* uses typep */
-
-/* 4.10.3 $vau */
-/* 5.3.1 $vau */
-void Svau(klisp_State *K);
-
-/* 4.10.4 wrap */
-void wrap(klisp_State *K);
-
-/* 4.10.5 unwrap */
-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);
-
-/* 5.5.1 apply */
-void apply(klisp_State *K);
-
-/* Helpers for map (also used by for each) */
-
-/* Calculate the metrics for both the result list and the ptree
- passed to the applicative */
-void map_for_each_get_metrics(
- klisp_State *K, char *name, TValue lss, int32_t *app_apairs_out,
- int32_t *app_cpairs_out, int32_t *res_apairs_out, int32_t *res_cpairs_out);
-
-/* Return two lists, isomorphic to lss: one list of cars and one list
- of cdrs (replacing the value of lss) */
-/* GC: Assumes lss is rooted, uses dummys 2 & 3 */
-TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
- int32_t apairs, int32_t cpairs);
-
-/* Transpose lss so that the result is a list of lists, each one having
- metrics (app_apairs, app_cpairs). The metrics of the returned list
- should be (res_apairs, res_cpairs) */
-
-/* GC: Assumes lss is rooted, uses dummys 1, &
- (through get_cars_cdrs, 2, 3) */
-TValue map_for_each_transpose(klisp_State *K, TValue lss,
- int32_t app_apairs, int32_t app_cpairs,
- int32_t res_apairs, int32_t res_cpairs);
-
-/* 5.9.1 map */
-void map(klisp_State *K);
-
-/* 6.2.1 combiner? */
-/* uses ftypedp */
-
-/* Helper for combiner? */
-bool kcombinerp(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);
+/* init continuation names */
+void kinit_combiners_cont_names(klisp_State *K);
#endif
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -22,7 +22,9 @@
#include "kghelpers.h"
#include "kgcontinuations.h"
-#include "kgcontrol.h" /* for seq helpers in $let/cc */
+
+/* Continuations */
+void do_extended_cont(klisp_State *K);
/* 7.1.1 continuation? */
/* uses typep */
@@ -84,92 +86,6 @@ void extend_continuation(klisp_State *K)
kapply_cc(K, new_cont);
}
-/* Helpers for guard-continuation (& guard-dynamic-extent) */
-
-/* this is used for inner & outer continuations, it just
- 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 = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
- UNUSED(xparams);
- kapply_cc(K, obj);
-}
-
-#define singly_wrapped(obj_) (ttisapplicative(obj_) && \
- ttisoperative(kunwrap(obj_)))
-
-/* this unmarks root before throwing any error */
-/* TODO: this isn't very clean, refactor */
-
-/* GC: assumes obj & root are rooted, dummy1 is in use */
-inline TValue check_copy_single_entry(klisp_State *K, char *name,
- TValue obj, TValue root)
-{
- if (!ttispair(obj) || !ttispair(kcdr(obj)) ||
- !ttisnil(kcddr(obj))) {
- unmark_list(K, root);
- klispE_throw_simple(K, "Bad entry (expected list of length 2)");
- return KINERT;
- }
- TValue cont = kcar(obj);
- TValue app = kcadr(obj);
-
- if (!ttiscontinuation(cont)) {
- unmark_list(K, root);
- klispE_throw_simple(K, "Bad type on first element (expected "
- "continuation)");
- return KINERT;
- } else if (!singly_wrapped(app)) {
- unmark_list(K, root);
- klispE_throw_simple(K, "Bad type on second element (expected "
- "singly wrapped applicative)");
- return KINERT;
- }
-
- /* save the operative directly, don't waste space/time
- with a list, use just a pair */
- return kcons(K, cont, kunwrap(app));
-}
-
-/* the guards are probably generated on the spot so we don't check
- for immutability and copy it anyways */
-/* GC: Assumes obj is rooted */
-TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
-{
- if (ttisnil(obj)) {
- return obj;
- } else {
- TValue last_pair = kget_dummy1(K);
- TValue tail = obj;
-
- while(ttispair(tail) && !kis_marked(tail)) {
- /* this will clear the marks and throw an error if the structure
- is incorrect */
- TValue entry = check_copy_single_entry(K, name, kcar(tail), obj);
- krooted_tvs_push(K, entry);
- TValue new_pair = kcons(K, entry, KNIL);
- krooted_tvs_pop(K);
- kmark(tail);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- }
-
- /* dont close the cycle (if there is one) */
- unmark_list(K, obj);
- TValue ret = kcutoff_dummy1(K);
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
- }
- return ret;
- }
-}
-
/* 7.2.4 guard-continuation */
void guard_continuation(klisp_State *K)
{
@@ -280,7 +196,7 @@ void Slet_cc(klisp_State *K)
/* the list of instructions is copied to avoid mutation */
/* MAYBE: copy the evaluation structure, ASK John */
- TValue ls = check_copy_list(K, "$let/cc", objs, false);
+ TValue ls = check_copy_list(K, objs, false, NULL, NULL);
krooted_tvs_push(K, ls);
/* this is needed because seq continuation doesn't check for
@@ -300,47 +216,11 @@ void Slet_cc(klisp_State *K)
}
/* 7.3.3 guard-dynamic-extent */
-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,
- "combiner", ttiscombiner, comb,
- "any", anytype, exit_guards);
-
- entry_guards = check_copy_guards(K, "guard-dynamic-extent: entry guards",
- entry_guards);
- krooted_tvs_push(K, entry_guards);
- exit_guards = check_copy_guards(K, "guard-dynamic-extent: exit guards",
- exit_guards);
- krooted_tvs_push(K, exit_guards);
- /* GC: root continuations */
- /* The current continuation is guarded */
- TValue outer_cont = kmake_continuation(K, kget_cc(K), do_pass_value,
- 2, entry_guards, denv);
- kset_outer_cont(outer_cont);
- kset_cc(K, outer_cont); /* this implicitly roots outer_cont */
-
- TValue inner_cont = kmake_continuation(K, outer_cont, do_pass_value, 2,
- exit_guards, denv);
- kset_inner_cont(inner_cont);
-
- /* call combiner with no operands in the dynamic extent of inner,
- with the dynamic env of this call */
- kset_cc(K, inner_cont); /* this implicitly roots inner_cont */
- TValue expr = kcons(K, comb, KNIL);
-
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
-
- ktail_eval(K, expr, denv);
-}
+/* in kghelpers */
/* 7.3.4 exit */
+/* Unlike in the report, in klisp this takes an optional argument
+ to be passed to the root continuation (defaults to #inert) */
void kgexit(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -350,11 +230,13 @@ void kgexit(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
- check_0p(K, ptree);
+ TValue obj = ptree;
+ if (!get_opt_tpar(K, obj, "any", anytype))
+ obj = KINERT;
/* TODO: look out for guards and dynamic variables */
/* should be probably handled in kcall_cont() */
- kcall_cont(K, K->root_cont, KINERT);
+ kcall_cont(K, K->root_cont, obj);
}
/* init ground */
@@ -398,3 +280,11 @@ void kinit_continuations_ground_env(klisp_State *K)
add_applicative(K, ground_env, "exit", kgexit,
0);
}
+
+/* init continuation names */
+void kinit_continuations_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_extended_cont, "extended-cont");
+}
diff --git a/src/kgcontinuations.h b/src/kgcontinuations.h
@@ -7,56 +7,11 @@
#ifndef kgcontinuations_h
#define kgcontinuations_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"
-
-/* Helpers (also used in keyed dynamic code) */
-void do_pass_value(klisp_State *K);
-
-/* 7.1.1 continuation? */
-/* uses typep */
-
-/* 7.2.2 call/cc */
-void call_cc(klisp_State *K);
-
-/* 7.2.3 extend-continuation */
-void extend_continuation(klisp_State *K);
-
-/* 7.2.4 guard-continuation */
-void guard_continuation(klisp_State *K);
-
-/* 7.2.5 continuation->applicative */
-void continuation_applicative(klisp_State *K);
-
-/* 7.2.6 root-continuation */
-/* done in kground.c/krepl.c */
-
-/* 7.2.7 error-continuation */
-/* done in kground.c/krepl.c */
-
-/* 7.3.1 apply-continuation */
-void apply_continuation(klisp_State *K);
-
-/* 7.3.2 $let/cc */
-void Slet_cc(klisp_State *K);
-
-/* 7.3.3 guard-dynamic-extent */
-void guard_dynamic_extent(klisp_State *K);
-
-/* 7.3.4 exit */
-void kgexit(klisp_State *K);
-
-void do_extended_cont(klisp_State *K);
/* init ground */
void kinit_continuations_ground_env(klisp_State *K);
+/* init continuation names */
+void kinit_continuations_cont_names(klisp_State *K);
#endif
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -18,16 +18,18 @@
#include "kghelpers.h"
#include "kgcontrol.h"
-#include "kgcombiners.h" /* for map/for-each helpers */
+
+/* Continuations */
+void do_select_clause(klisp_State *K);
+void do_cond(klisp_State *K);
+void do_for_each(klisp_State *K);
+void do_Swhen_Sunless(klisp_State *K);
/* 4.5.1 inert? */
/* uses typep */
/* 4.5.2 $if */
-/* helpers */
-void do_select_clause(klisp_State *K);
-
/* ASK JOHN: both clauses should probably be copied (copy-es-immutable) */
void Sif(klisp_State *K)
{
@@ -35,8 +37,8 @@ void Sif(klisp_State *K)
TValue ptree = K->next_value;
TValue denv = K->next_env;
klisp_assert(ttisenvironment(K->next_env));
- (void) denv;
- (void) xparams;
+ UNUSED(denv);
+ UNUSED(xparams);
bind_3p(K, ptree, test, cons_c, alt_c);
@@ -86,7 +88,7 @@ void Ssequence(klisp_State *K)
} else {
/* the list of instructions is copied to avoid mutation */
/* MAYBE: copy the evaluation structure, ASK John */
- TValue ls = check_copy_list(K, "$sequence", ptree, false);
+ TValue ls = check_copy_list(K, ptree, false, NULL, NULL);
/* this is needed because seq continuation doesn't check for
nil sequence */
/* TODO this could be at least in an inlineable function to
@@ -108,37 +110,6 @@ void Ssequence(klisp_State *K)
}
}
-/* Helper (also used by $vau and $lambda) */
-/* 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
- */
- TValue ls = xparams[0];
- TValue first = kcar(ls);
- TValue tail = kcdr(ls);
- TValue denv = xparams[1];
-
- if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, tail,
- denv);
- kset_cc(K, new_cont);
-#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, ls));
-#endif
- }
- ktail_eval(K, first, denv);
-}
/* Helpers for cond */
@@ -154,14 +125,19 @@ void do_seq(klisp_State *K)
TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
TValue *bodies)
{
- TValue last_car_pair = kget_dummy1(K);
- TValue last_cdr_pair = kget_dummy2(K);
+ TValue cars = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &cars);
+ TValue last_car_pair = cars;
+
+ TValue cdrs = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &cdrs);
+ TValue last_cdr_pair = cdrs;
TValue tail = clauses;
int32_t count = 0;
while(ttispair(tail) && !kis_marked(tail)) {
- count++;
+ ++count;
TValue first = kcar(tail);
if (!ttispair(first)) {
unmark_list(K, clauses);
@@ -193,25 +169,26 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, "expected list (clauses)");
return KNIL;
- } else {
- /*
- check all the bodies (should be lists), and
- make a copy of the list structure.
- couldn't be done before because this uses
- marks, count is used because it may be a cyclic list
- */
- tail = kget_dummy2_tail(K);
- while(count--) {
- TValue first = kcar(tail);
- /* this uses dummy3 */
- TValue copy = check_copy_list(K, "$cond", first, false);
- kset_car(tail, copy);
- tail = kcdr(tail);
- }
+ }
- *bodies = kcutoff_dummy2(K);
- return kcutoff_dummy1(K);
+ /*
+ check all the bodies (should be lists), and
+ make a copy of the list structure.
+ couldn't be done before because this uses
+ marks, count is used because it may be a cyclic list
+ */
+ tail = kcdr(cdrs);
+ while(count--) {
+ TValue first = kcar(tail);
+ TValue copy = check_copy_list(K, first, false, NULL, NULL);
+ kset_car(tail, copy);
+ tail = kcdr(tail);
}
+
+ *bodies = kcdr(cdrs);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return kcdr(cars);
}
/* Helper for the $cond continuation */
@@ -339,7 +316,7 @@ void do_for_each(klisp_State *K)
/* copy the ptree to avoid problems with mutation */
/* XXX: no check necessary, could just use copy_list if there
was such a procedure */
- TValue first_ptree = check_copy_list(K, "for-each", kcar(ls), false);
+ TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL);
krooted_tvs_push(K, first_ptree);
ls = kcdr(ls);
n = n-1;
@@ -376,7 +353,7 @@ void for_each(klisp_State *K)
int32_t app_pairs, app_apairs, app_cpairs;
int32_t res_pairs, res_apairs, res_cpairs;
- map_for_each_get_metrics(K, "for-each", lss, &app_apairs, &app_cpairs,
+ map_for_each_get_metrics(K, lss, &app_apairs, &app_cpairs,
&res_apairs, &res_cpairs);
app_pairs = app_apairs + app_cpairs;
res_pairs = res_apairs + res_cpairs;
@@ -398,6 +375,178 @@ void for_each(klisp_State *K)
kapply_cc(K, KINERT);
}
+/* 6.9.? string-for-each, vector-for-each, bytevector-for-each */
+void array_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));
+
+ /*
+ ** xparams[1]: array->list fn (with type check and size ret)
+ */
+
+ TValue (*array_to_list)(klisp_State *K, TValue array, int32_t *size) =
+ pvalue(xparams[0]);
+
+ bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
+
+ /* check that lss is a non empty list, and copy it */
+ if (ttisnil(lss)) {
+ klispE_throw_simple(K, "no arguments after applicative");
+ return;
+ }
+
+ int32_t app_pairs, app_apairs, app_cpairs;
+ /* the copied list should be protected from gc, and will host
+ the lists resulting from the conversion */
+ lss = check_copy_list(K, lss, true, &app_pairs, &app_cpairs);
+ app_apairs = app_pairs - app_cpairs;
+ krooted_tvs_push(K, lss);
+
+ /* check that all elements have the correct type and same size,
+ and convert them to lists */
+ int32_t res_pairs;
+ TValue head = kcar(lss);
+ TValue tail = kcdr(lss);
+ TValue ls = array_to_list(K, head, &res_pairs);
+ kset_car(lss, ls); /* save the first */
+ /* all array will produce acyclic lists */
+ for(int32_t i = 1 /* jump over first */; i < app_pairs; ++i) {
+ head = kcar(tail);
+ int32_t pairs;
+ ls = array_to_list(K, head, &pairs);
+ /* in klisp all arrays should have the same length */
+ if (pairs != res_pairs) {
+ klispE_throw_simple(K, "arguments of different length");
+ return;
+ }
+ kset_car(tail, ls);
+ tail = kcdr(tail);
+ }
+
+ /* create the list of parameters to app */
+ lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs,
+ res_pairs, 0); /* cycle pairs is always 0 */
+
+ /* ASK John: the semantics when this is mixed with continuations,
+ isn't all that great..., but what are the expectations considering
+ there is no prescribed order? */
+
+ krooted_tvs_pop(K);
+ krooted_tvs_push(K, lss);
+
+ /* schedule all elements at once, this will also return #inert once
+ done. */
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_for_each, 4, app, lss,
+ i2tv(res_pairs), denv);
+ kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
+ /* this will be a nop */
+ kapply_cc(K, KINERT);
+}
+
+/* Helper for $when and $unless */
+void do_Swhen_Sunless(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+
+ /*
+ ** xparams[0]: bool condition
+ ** xparams[1]: body
+ ** xparams[2]: denv
+ ** xparams[3]: si for whole form
+ */
+ bool cond = bvalue(xparams[0]);
+ TValue ls = xparams[1];
+ TValue denv = xparams[2];
+#if KTRACK_SI
+ TValue si = xparams[3];
+#endif
+
+ if (!ttisboolean(obj)) {
+ klispE_throw_simple(K, "test is not a boolean");
+ return;
+ }
+
+ if (bvalue(obj) == cond && !ttisnil(ls)) {
+ /* only contruct the #inert returning continuation if the
+ current continuation is not of the same type */
+ if (!kis_inert_ret_cont(kget_cc(K))) {
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), do_return_value, 1, KINERT);
+ /* mark it, so that it can be detected as inert throwing cont */
+ kset_inert_ret_cont(new_cont);
+ kset_cc(K, new_cont);
+#if KTRACK_SI
+ /* put the source info of the whole form */
+ kset_source_info(K, new_cont, si);
+#endif
+ }
+ /* this is needed because seq continuation doesn't check for
+ nil sequence */
+ /* TODO this could be at least in an inlineable function to
+ allow used from $lambda, $vau, $let family, load, etc */
+ TValue tail = kcdr(ls);
+ if (ttispair(tail)) {
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
+ tail, denv);
+ kset_cc(K, new_cont);
+#if KTRACK_SI
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
+#endif
+ krooted_tvs_pop(K);
+ }
+ ktail_eval(K, kcar(ls), denv);
+ } else {
+ /* either the test failed or the body was nil */
+ kapply_cc(K, KINERT);
+ }
+}
+
+/* ASK JOHN: list is copied here (like in $sequence) */
+void Swhen_Sunless(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_al1p(K, ptree, test, body);
+
+ /*
+ ** xparams[0]: bool condition
+ */
+ TValue tv_cond = xparams[0];
+
+ /* the list of instructions is copied to avoid mutation */
+ /* MAYBE: copy the evaluation structure, ASK John */
+ TValue ls = check_copy_list(K, body, false, NULL, NULL);
+ krooted_tvs_push(K, ls);
+ /* prepare the continuation that will check the test result
+ and do the evaluation */
+ TValue si = K->next_si; /* this is the source info of the whole
+ $when/$unless form */
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_Swhen_Sunless,
+ 4, tv_cond, ls, denv, si);
+ krooted_tvs_pop(K);
+ /*
+ ** Mark as a bool checking cont, not necessary but avoids a continuation
+ ** in the last evaluation in the common use of
+ ** ($when/$unless ($or?/$and? ...) ...)
+ */
+ kset_bool_check_cont(new_cont);
+ kset_cc(K, new_cont);
+ ktail_eval(K, test, denv);
+}
+
/* init ground */
void kinit_control_ground_env(klisp_State *K)
{
@@ -415,4 +564,28 @@ void kinit_control_ground_env(klisp_State *K)
add_operative(K, ground_env, "$cond", Scond, 0);
/* 6.9.1 for-each */
add_applicative(K, ground_env, "for-each", for_each, 0);
+ /* 6.9.? string-for-each, vector-for-each, bytevector-for-each */
+ add_applicative(K, ground_env, "string-for-each", array_for_each, 1,
+ p2tv(string_to_list_h));
+ add_applicative(K, ground_env, "vector-for-each", array_for_each, 1,
+ p2tv(vector_to_list_h));
+ add_applicative(K, ground_env, "bytevector-for-each", array_for_each, 1,
+ p2tv(bytevector_to_list_h));
+ /* ?.? */
+ add_operative(K, ground_env, "$when", Swhen_Sunless, 1,
+ b2tv(true));
+ add_operative(K, ground_env, "$unless", Swhen_Sunless, 1,
+ b2tv(false));
+}
+
+/* init continuation names */
+void kinit_control_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_select_clause, "select-clause");
+ add_cont_name(K, t, do_Swhen_Sunless, "conditional-eval-sequence");
+
+ add_cont_name(K, t, do_cond, "eval-cond-list");
+ add_cont_name(K, t, do_for_each, "for-each");
}
diff --git a/src/kgcontrol.h b/src/kgcontrol.h
@@ -7,44 +7,11 @@
#ifndef kgcontrol_h
#define kgcontrol_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"
-
-/* 4.5.1 inert? */
-/* uses typep */
-
-/* 4.5.2 $if */
-
-void Sif(klisp_State *K);
-
-/* 5.1.1 $sequence */
-void Ssequence(klisp_State *K);
-
-/* Helpers for $cond */
-TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
- TValue *bodies);
-
-
-/* 5.6.1 $cond */
-void Scond(klisp_State *K);
-
-/* 6.9.1 for-each */
-void for_each(klisp_State *K);
-
-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);
+/* init continuation names */
+void kinit_control_cont_names(klisp_State *K);
#endif
diff --git a/src/kgencapsulations.c b/src/kgencapsulations.c
@@ -23,39 +23,7 @@
/* Helpers for make-encapsulation-type */
/* Type predicate for encapsulations */
-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
- */
- TValue key = xparams[0];
-
- /* check the ptree is a list while checking the predicate.
- Keep going even if the result is false to catch errors in
- ptree structure */
- bool res = true;
-
- TValue tail = ptree;
- while(ttispair(tail) && kis_unmarked(tail)) {
- kmark(tail);
- res &= kis_encapsulation_type(kcar(tail), key);
- tail = kcdr(tail);
- }
- unmark_list(K, ptree);
-
- if (ttispair(tail) || ttisnil(tail)) {
- kapply_cc(K, b2tv(res));
- } else {
- /* try to get name from encapsulation */
- klispE_throw_simple(K, "expected list");
- return;
- }
-}
+/* enc_typep(klisp_State *K), in kghelpers */
/* Constructor for encapsulations */
void enc_wrap(klisp_State *K)
diff --git a/src/kgencapsulations.h b/src/kgencapsulations.h
@@ -7,22 +7,7 @@
#ifndef kgencapsulations_h
#define kgencapsulations_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"
-
-/* needed by kgffi.c */
-void enc_typep(klisp_State *K);
-
-/* 8.1.1 make-encapsulation-type */
-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
@@ -20,7 +20,11 @@
#include "kghelpers.h"
#include "kgenv_mut.h"
-#include "kgcontrol.h" /* for do_seq */
+
+/* Continuations */
+void do_match(klisp_State *K);
+void do_set_eval_obj(klisp_State *K);
+void do_import(klisp_State *K);
/* 4.9.1 $define! */
void SdefineB(klisp_State *K)
@@ -36,7 +40,7 @@ void SdefineB(klisp_State *K)
TValue def_sym = xparams[0];
- dptree = check_copy_ptree(K, "$define!", dptree, KIGNORE);
+ dptree = check_copy_ptree(K, dptree, KIGNORE);
krooted_tvs_push(K, dptree);
@@ -61,9 +65,8 @@ void do_match(klisp_State *K)
*/
TValue ptree = xparams[0];
TValue env = xparams[1];
- char *name = ksymbol_buf(xparams[2]);
- match(K, name, env, ptree, obj);
+ match(K, env, ptree, obj);
kapply_cc(K, KINERT);
}
@@ -80,7 +83,7 @@ void SsetB(klisp_State *K)
bind_3p(K, ptree, env_exp, raw_formals, eval_exp);
- TValue formals = check_copy_ptree(K, "$set!", raw_formals, KIGNORE);
+ TValue formals = check_copy_ptree(K, raw_formals, KIGNORE);
krooted_tvs_push(K, formals);
TValue new_cont =
@@ -142,13 +145,15 @@ inline void unmark_maybe_symbol_list(klisp_State *K, TValue ls)
** Check that obj is a finite list of symbols with no duplicates and
** returns a copy of the list (cf. check_copy_ptree)
*/
-/* GC: Assumes obj is rooted, uses dummy1 */
-TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj)
+/* GC: Assumes obj is rooted */
+TValue check_copy_symbol_list(klisp_State *K, TValue obj)
{
TValue tail = obj;
bool type_errorp = false;
bool repeated_errorp = false;
- TValue last_pair = kget_dummy1(K);
+ TValue slist = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &slist);
+ TValue last_pair = slist;
while(ttispair(tail) && !kis_marked(tail)) {
/* even if there is a type error continue checking the structure */
@@ -173,14 +178,14 @@ TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj)
klispE_throw_simple(K, "expected finite list");
return KNIL;
} else if (type_errorp) {
- /* TODO put type name too */
klispE_throw_simple(K, "bad operand type (expected list of "
"symbols)");
return KNIL;
} else if (repeated_errorp) {
klispE_throw_simple(K, "repeated symbols");
}
- return kcutoff_dummy1(K);
+ krooted_vars_pop(K);
+ return kcdr(slist);
}
void do_import(klisp_State *K)
@@ -222,13 +227,12 @@ void SprovideB(klisp_State *K)
** xparams[0]: name as symbol
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, symbols, body);
- symbols = check_copy_symbol_list(K, name, symbols);
+ symbols = check_copy_symbol_list(K, symbols);
krooted_tvs_push(K, symbols);
- body = check_copy_list(K, name, body, false);
+ body = check_copy_list(K, body, false, NULL, NULL);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -293,11 +297,10 @@ void SimportB(klisp_State *K)
** xparams[0]: name as symbol
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, env_expr, symbols);
- symbols = check_copy_symbol_list(K, name, symbols);
+ symbols = check_copy_symbol_list(K, symbols);
/* REFACTOR/ASK John: another way for this kind of operative would be
to first eval the env expression and only then check the type
@@ -328,3 +331,14 @@ void kinit_env_mut_ground_env(klisp_State *K)
/* 6.8.3 $import! */
add_operative(K, ground_env, "$import!", SimportB, 1, symbol);
}
+
+/* init continuation names */
+void kinit_env_mut_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_match, "match-ptree");
+ add_cont_name(K, t, do_set_eval_obj, "set-eval-obj");
+ add_cont_name(K, t, do_import, "import-bindings");
+}
+
diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h
@@ -7,250 +7,12 @@
#ifndef kgenv_mut_h
#define kgenv_mut_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"
-
-/* helpers */
-inline void match(klisp_State *K, char *name, TValue env, TValue ptree,
- 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);
-
-/* MAYBE: don't make these inline */
-/*
-** Clear all the marks (symbols + pairs) & stacks.
-** The stack should contain only pairs, sym_ls should be
-** as above
-*/
-inline void ptree_clear_all(klisp_State *K, TValue sym_ls)
-{
- while(!ttisnil(sym_ls)) {
- TValue first = sym_ls;
- sym_ls = kget_symbol_mark(first);
- kunmark_symbol(first);
- }
-
- while(!ks_sisempty(K)) {
- kunmark(ks_sget(K));
- ks_sdpop(K);
- }
-
- ks_tbclear(K);
-}
-
-/* GC: assumes env, ptree & obj are rooted */
-inline void match(klisp_State *K, char *name, TValue env, TValue ptree,
- TValue obj)
-{
- assert(ks_sisempty(K));
- ks_spush(K, obj);
- ks_spush(K, ptree);
-
- while(!ks_sisempty(K)) {
- ptree = ks_spop(K);
- obj = ks_spop(K);
-
- switch(ttype(ptree)) {
- case K_TNIL:
- if (!ttisnil(obj)) {
- /* TODO show ptree and arguments */
- ks_sclear(K);
- klispE_throw_simple(K, "ptree doesn't match arguments");
- return;
- }
- break;
- case K_TIGNORE:
- /* do nothing */
- break;
- case K_TSYMBOL:
- kadd_binding(K, env, ptree, obj);
- break;
- case K_TPAIR:
- if (ttispair(obj)) {
- ks_spush(K, kcdr(obj));
- ks_spush(K, kcdr(ptree));
- ks_spush(K, kcar(obj));
- ks_spush(K, kcar(ptree));
- } else {
- /* TODO show ptree and arguments */
- ks_sclear(K);
- klispE_throw_simple(K, "ptree doesn't match arguments");
- return;
- }
- break;
- default:
- /* can't really happen */
- break;
- }
- }
-}
-
-/* GC: assumes ptree & penv are rooted */
-inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
- TValue penv)
-{
- /* copy is only valid if the state isn't ST_PUSH */
- /* but init anyways for gc (and avoiding warnings) */
- TValue copy = ptree;
- krooted_vars_push(K, ©);
-
- /*
- ** NIL terminated singly linked list of symbols
- ** (using the mark as next pointer)
- */
- TValue sym_ls = KNIL;
-
- assert(ks_sisempty(K));
- assert(ks_tbisempty(K));
-
- ks_tbpush(K, ST_PUSH);
- ks_spush(K, ptree);
-
- while(!ks_sisempty(K)) {
- char state = ks_tbpop(K);
- TValue top = ks_spop(K);
-
- if (state == ST_PUSH) {
- switch(ttype(top)) {
- case K_TIGNORE:
- case K_TNIL:
- copy = top;
- break;
- case K_TSYMBOL: {
- if (kis_symbol_marked(top)) {
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple_with_irritants(K, "repeated symbol "
- "in ptree", 1, top);
- return KNIL;
- } else {
- copy = top;
- /* add it to the symbol list */
- kset_symbol_mark(top, sym_ls);
- sym_ls = top;
- }
- break;
- }
- case K_TPAIR: {
- if (kis_unmarked(top)) {
- if (kis_immutable(top)) {
- /* don't copy mutable pairs, just use them */
- /* NOTE: immutable pairs can't have mutable
- car or cdr */
- /* we have to continue thou, because there could be a
- cycle */
- kset_mark(top, top);
- } else {
- /* create a new pair as copy, save it in the mark */
- TValue new_pair = kimm_cons(K, KNIL, KNIL);
- kset_mark(top, new_pair);
- /* copy the source code info */
- TValue si = ktry_get_si(K, top);
- if (!ttisnil(si))
- kset_source_info(K, new_pair, si);
- }
- /* keep the old pair and continue with the car */
- ks_tbpush(K, ST_CAR);
- ks_spush(K, top);
-
- ks_tbpush(K, ST_PUSH);
- ks_spush(K, kcar(top));
- } else {
- /* marked pair means a cycle was found */
- /* NOTE: the pair should be in the stack already so
- it isn't necessary to push it again to clear the mark */
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple(K, "cycle detected in ptree");
- /* avoid warning */
- return KNIL;
- }
- break;
- }
- default:
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple(K, "bad object type in ptree");
- /* avoid warning */
- return KNIL;
- }
- } else {
- /* last operation was a pop */
- /* top is a marked pair, the mark is the copied obj */
- /* NOTE: if top is immutable the mark is also top
- we could still do the set-car/set-cdr because the
- copy would be the same as the car/cdr, but why bother */
- if (state == ST_CAR) {
- /* only car was checked (not yet copied) */
- if (kis_mutable(top)) {
- TValue copied_pair = kget_mark(top);
- /* copied_pair may be immutable */
- kset_car_unsafe(K, copied_pair, copy);
- }
- /* put the copied pair again, continue with the cdr */
- ks_tbpush(K, ST_CDR);
- ks_spush(K, top);
-
- ks_tbpush(K, ST_PUSH);
- ks_spush(K, kcdr(top));
- } else {
- /* both car & cdr were checked (cdr not yet copied) */
- TValue copied_pair = kget_mark(top);
- /* the unmark is needed to allow diamonds */
- kunmark(top);
-
- if (kis_mutable(top)) {
- /* copied_pair may be immutable */
- kset_cdr_unsafe(K, copied_pair, copy);
- }
- copy = copied_pair;
- }
- }
- }
-
- if (ttissymbol(penv)) {
- if (kis_symbol_marked(penv)) {
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple_with_irritants(K, "same symbol in both ptree "
- "and environment parameter",
- 1, sym_ls);
- }
- } else if (!ttisignore(penv)) {
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple(K, "symbol or #ignore expected as "
- "environment parmameter");
- }
- ptree_clear_all(K, sym_ls);
- krooted_vars_pop(K);
- return copy;
-}
-
-/* 6.8.1 $set! */
-void SsetB(klisp_State *K);
-
-/* Helper for $set! */
-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);
-
-/* 6.8.2 $provide! */
-void SprovideB(klisp_State *K);
-
-/* 6.8.3 $import! */
-void SimportB(klisp_State *K);
/* init ground */
void kinit_env_mut_ground_env(klisp_State *K);
+/* init continuation names */
+void kinit_env_mut_cont_names(klisp_State *K);
+
#endif
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -20,10 +20,13 @@
#include "kghelpers.h"
#include "kgenvironments.h"
-#include "kgenv_mut.h" /* for check_ptree */
-#include "kgpair_mut.h" /* for copy_es_immutable_h */
-#include "kgcontrol.h" /* for do_seq */
-/* MAYBE: move the above to kghelpers.h */
+
+/* Continuations */
+void do_let(klisp_State *K);
+void do_let_redirect(klisp_State *K);
+void do_bindsp(klisp_State *K);
+void do_remote_eval(klisp_State *K);
+void do_b_to_env(klisp_State *K);
/* 4.8.1 environment? */
/* uses typep */
@@ -75,7 +78,7 @@ void make_environment(klisp_State *K)
} else {
/* this is the general case, copy the list but without the
cycle if there is any */
- TValue parents = check_copy_env_list(K, "make-environment", ptree);
+ TValue parents = check_copy_env_list(K, ptree);
krooted_tvs_push(K, parents);
new_env = kmake_environment(K, parents);
krooted_tvs_pop(K);
@@ -97,12 +100,16 @@ void make_environment(klisp_State *K)
** If bindings is not finite (or not a list) an error is signaled.
*/
-/* GC: assume bindings is rooted, uses dummys 1 & 2 */
-TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
+/* GC: assume bindings is rooted */
+TValue split_check_let_bindings(klisp_State *K, TValue bindings,
TValue *exprs, bool starp)
{
- TValue last_car_pair = kget_dummy1(K);
- TValue last_cadr_pair = kget_dummy2(K);
+ TValue cars = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &cars);
+ TValue last_car_pair = cars;
+ TValue cadrs = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &cadrs);
+ TValue last_cadr_pair = cadrs;
TValue tail = bindings;
@@ -139,20 +146,21 @@ TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
if (starp) {
/* all bindings are consider individual ptrees in these 'let's,
replace each ptree with its copy (after checking of course) */
- tail = kget_dummy1_tail(K);
+ tail = kcdr(cars);
while(!ttisnil(tail)) {
TValue first = kcar(tail);
- TValue copy = check_copy_ptree(K, name, first, KIGNORE);
+ TValue copy = check_copy_ptree(K, first, KIGNORE);
kset_car(tail, copy);
tail = kcdr(tail);
}
- res = kget_dummy1_tail(K);
+ res = kcdr(cars);
} else {
/* all bindings are consider one ptree in these 'let's */
- res = check_copy_ptree(K, name, kget_dummy1_tail(K), KIGNORE);
+ res = check_copy_ptree(K, kcdr(cars), KIGNORE);
}
- *exprs = kcutoff_dummy2(K);
- UNUSED(kcutoff_dummy1(K));
+ *exprs = kcdr(cadrs);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
return res;
}
}
@@ -177,7 +185,6 @@ void do_let(klisp_State *K)
** xparams[6]: body
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
TValue ptree = xparams[1];
TValue bindings = xparams[2];
TValue exprs = xparams[3];
@@ -185,7 +192,7 @@ void do_let(klisp_State *K)
bool recp = bvalue(xparams[5]);
TValue body = xparams[6];
- match(K, name, env, ptree, obj);
+ match(K, env, ptree, obj);
if (ttisnil(bindings)) {
if (ttisnil(body)) {
@@ -231,16 +238,15 @@ void Slet(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, false);
krooted_tvs_push(K, bptree);
krooted_tvs_push(K, exprs);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -304,9 +310,9 @@ void Sbindsp(klisp_State *K)
bind_al1p(K, ptree, env_expr, symbols);
/* REFACTOR replace with single function check_copy_typed_list */
- int32_t count = check_typed_list(K, "$binds?", "symbol", ksymbolp,
- true, symbols, NULL);
- symbols = check_copy_list(K, "$binds?", symbols, false);
+ int32_t count;
+ check_typed_list(K, ksymbolp, true, symbols, &count, NULL);
+ symbols = check_copy_list(K, symbols, false, NULL, NULL);
krooted_tvs_push(K, symbols);
TValue new_cont = kmake_continuation(K, kget_cc(K), do_bindsp,
@@ -356,15 +362,14 @@ void SletS(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, true);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, true);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -409,16 +414,15 @@ void Sletrec(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, false);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -450,15 +454,14 @@ void SletrecS(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, true);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, true);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -538,16 +541,15 @@ void Slet_redirect(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al2p(K, ptree, env_exp, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, false);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue eexpr = kcons(K, K->list_app, exprs);
@@ -577,17 +579,16 @@ void Slet_safe(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, false);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
+ check_list(K, true, body, NULL, NULL);
- body = copy_es_immutable_h(K, name, body, false);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
/* according to the definition of the report it should be a child
@@ -657,7 +658,7 @@ void do_b_to_env(klisp_State *K)
TValue ptree = xparams[0];
TValue env = xparams[1];
- match(K, "$bindings->environment", env, ptree, obj);
+ match(K, env, ptree, obj);
kapply_cc(K, env);
}
@@ -670,8 +671,7 @@ void Sbindings_to_environment(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, "$bindings->environment",
- ptree, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, ptree, &exprs, false);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
@@ -732,3 +732,15 @@ void kinit_environments_ground_env(klisp_State *K)
add_operative(K, ground_env, "$bindings->environment",
Sbindings_to_environment, 1, symbol);
}
+
+/* init continuation names */
+void kinit_environments_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_let, "eval-let");
+ add_cont_name(K, t, do_let_redirect, "eval-let-redirect");
+ add_cont_name(K, t, do_bindsp, "eval-$binds?-env");
+ add_cont_name(K, t, do_remote_eval, "eval-remote-eval-env");
+ add_cont_name(K, t, do_b_to_env, "bindings-to-env");
+}
diff --git a/src/kgenvironments.h b/src/kgenvironments.h
@@ -7,80 +7,11 @@
#ifndef kgenvironments_h
#define kgenvironments_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"
-
-/* 4.8.1 environment? */
-/* uses typep */
-
-/* 4.8.2 ignore? */
-/* uses typep */
-
-/* 4.8.3 eval */
-void eval(klisp_State *K);
-
-/* 4.8.4 make-environment */
-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);
-
-/* Helper for $binds? */
-void do_bindsp(klisp_State *K);
-
-/* 6.7.1 $binds? */
-void Sbindsp(klisp_State *K);
-
-/* 6.7.2 get-current-environment */
-void get_current_environment(klisp_State *K);
-
-/* 6.7.3 make-kernel-standard-environment */
-void make_kernel_standard_environment(klisp_State *K);
-
-/* 6.7.4 $let* */
-void SletS(klisp_State *K);
-
-/* 6.7.5 $letrec */
-void Sletrec(klisp_State *K);
-
-/* 6.7.6 $letrec* */
-void SletrecS(klisp_State *K);
-
-/* Helper for $let-redirect */
-void do_let_redirect(klisp_State *K);
-
-/* 6.7.7 $let-redirect */
-void Slet_redirect(klisp_State *K);
-
-/* 6.7.8 $let-safe */
-void Slet_safe(klisp_State *K);
-
-/* 6.7.9 $remote-eval */
-void Sremote_eval(klisp_State *K);
-
-/* Helper for $remote-eval */
-void do_remote_eval(klisp_State *K);
-
-/* Helper for $bindings->environment */
-void do_b_to_env(klisp_State *K);
-
-/* 6.7.10 $bindings->environment */
-void Sbindings_to_environment(klisp_State *K);
-
-void do_let(klisp_State *K);
/* init ground */
void kinit_environments_ground_env(klisp_State *K);
+/* init continuation names */
+void kinit_environments_cont_names(klisp_State *K);
#endif
diff --git a/src/kgeqp.c b/src/kgeqp.c
@@ -31,7 +31,8 @@ void eqp(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
- int32_t pairs = check_list(K, "eq?", true, ptree, NULL);
+ int32_t pairs;
+ check_list(K, true, ptree, &pairs, NULL);
/* In this case we can get away without comparing the
first and last element on a cycle because eq? is
diff --git a/src/kgeqp.h b/src/kgeqp.h
@@ -7,59 +7,7 @@
#ifndef kgeqp_h
#define kgeqp_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
#include "kstate.h"
-#include "kobject.h"
-#include "kapplicative.h" /* for unwrap */
-#include "kinteger.h" /* for kbigint_eqp */
-#include "krational.h" /* for kbigrat_eqp */
-#include "klisp.h"
-#include "kghelpers.h"
-
-/* 4.2.1 eq? */
-/* 6.5.1 eq? */
-void eqp(klisp_State *K);
-
-/* Helper (also used in equal?) */
-inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
-{
- bool res = (tv_equal(obj1, obj2));
- if (!res && (ttype(obj1) == ttype(obj2))) {
- switch (ttype(obj1)) {
- case K_TSYMBOL:
- /* symbols can't be compared with tv_equal! */
- res = tv_sym_equal(obj1, obj2);
- break;
- case K_TAPPLICATIVE:
- while(ttisapplicative(obj1) && ttisapplicative(obj2)) {
- obj1 = kunwrap(obj1);
- obj2 = kunwrap(obj2);
- }
- res = (tv_equal(obj1, obj2));
- break;
- case K_TBIGINT:
- /* it's important to know that it can't be the case
- that obj1 is bigint and obj is some other type and
- (eq? obj1 obj2) */
- res = kbigint_eqp(obj1, obj2);
- break;
- case K_TBIGRAT:
- /* it's important to know that it can't be the case
- that obj1 is bigrat and obj is some other type and
- (eq? obj1 obj2) */
- res = kbigrat_eqp(K, obj1, obj2);
- break;
- } /* immutable strings & bytevectors are interned so they are
- covered already by tv_equalp */
-
- }
- return res;
-}
/* init ground */
void kinit_eqp_ground_env(klisp_State *K);
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -13,13 +13,13 @@
#include "kstate.h"
#include "kobject.h"
#include "kpair.h"
+#include "kvector.h"
#include "kstring.h" /* for kstring_equalp */
#include "kbytevector.h" /* for kbytevector_equalp */
#include "kcontinuation.h"
#include "kerror.h"
#include "kghelpers.h"
-#include "kgeqp.h" /* for eq2p */
#include "kgequalp.h"
/* 4.3.1 equal? */
@@ -43,7 +43,8 @@ void equalp(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
- int32_t pairs = check_list(K, "equal?", true, ptree, NULL);
+ int32_t pairs;
+ check_list(K, true, ptree, &pairs, NULL);
/* In this case we can get away without comparing the
first and last element on a cycle because equal? is
@@ -65,167 +66,6 @@ void equalp(klisp_State *K)
kapply_cc(K, res);
}
-
-/*
-** Helpers
-**
-** See [2] for details of the list merging algorithm.
-** Here are the implementation details:
-** The marks of the pairs are used to store the nodes of the trees
-** that represent the set of previous comparations of each pair.
-** They serve the function of the array in [2].
-** If a pair is unmarked, it was never compared (empty comparison set).
-** If a pair is marked, the mark object is either (#f . parent-node)
-** if the node is not the root, and (#t . n) where n is the number
-** of elements in the set, if the node is the root.
-** This pair also doubles as the "name" of the set in [2].
-**
-** GC: all of these assume that arguments are rooted.
-*/
-
-/* find "name" of the set of this obj, if there isn't one create it,
- if there is one, flatten its branch */
-inline TValue equal_find(klisp_State *K, TValue obj)
-{
- /* GC: should root obj */
- if (kis_unmarked(obj)) {
- /* object wasn't compared before, create new set */
- TValue new_node = kcons(K, KTRUE, i2tv(1));
- kset_mark(obj, new_node);
- return new_node;
- } else {
- TValue node = kget_mark(obj);
-
- /* First obtain the root and a list of all the other objects in this
- branch, as said above the root is the one with #t in its car */
- /* NOTE: the stack is being used, so we must remember how many pairs we
- push, we can't just pop 'till is empty */
- int np = 0;
- while(kis_false(kcar(node))) {
- ks_spush(K, node);
- node = kcdr(node);
- ++np;
- }
- TValue root = node;
-
- /* set all parents to root, to flatten the branch */
- while(np--) {
- node = ks_spop(K);
- kset_cdr(node, root);
- }
- return root;
- }
-}
-
-/* merge the smaller set into the big one, if both are equal just pick one */
-inline void equal_merge(klisp_State *K, TValue root1, TValue root2)
-{
- /* K isn't needed but added for consistency */
- (void)K;
- int32_t size1 = ivalue(kcdr(root1));
- int32_t size2 = ivalue(kcdr(root2));
- TValue new_size = i2tv(size1 + size2);
-
- if (size1 < size2) {
- /* add root1 set (the smaller one) to root2 */
- kset_cdr(root2, new_size);
- kset_car(root1, KFALSE);
- kset_cdr(root1, root2);
- } else {
- /* add root2 set (the smaller one) to root1 */
- kset_cdr(root1, new_size);
- kset_car(root2, KFALSE);
- kset_cdr(root2, root1);
- }
-}
-
-/* check to see if two objects were already compared, and return that. If they
- weren't compared yet, merge their sets (and flatten their branches) */
-inline bool equal_find2_mergep(klisp_State *K, TValue obj1, TValue obj2)
-{
- /* GC: should root root1 and root2 */
- TValue root1 = equal_find(K, obj1);
- TValue root2 = equal_find(K, obj2);
- if (tv_equal(root1, root2)) {
- /* they are in the same set => they were already compared */
- return true;
- } else {
- equal_merge(K, root1, root2);
- return false;
- }
-}
-
-/*
-** See [1] for details, in this case the pairs form a possibly infinite "tree"
-** structure, and that can be seen as a finite automata, where each node is a
-** state, the car and the cdr are the transitions from that state to others,
-** and the leaves (the non-pair objects) are the final states.
-** Other way to see it is that, the key for determining equalness of two pairs
-** is: Check to see if they were already compared to each other.
-** If so, return #t, otherwise, mark them as compared to each other and
-** recurse on both cars and both cdrs.
-** The idea is that if assuming obj1 and obj2 are equal their components are
-** equal then they are effectively equal to each other.
-*/
-bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
-{
- assert(ks_sisempty(K));
-
- /* the stack has the elements to be compaired, always in pairs.
- So the top should be compared with the one below, the third with
- the fourth and so on */
- ks_spush(K, obj1);
- ks_spush(K, obj2);
-
- /* if the stacks becomes empty, all pairs of elements were equal */
- bool result = true;
- TValue saved_obj1 = obj1;
- TValue saved_obj2 = obj2;
-
- while(!ks_sisempty(K)) {
- obj2 = ks_spop(K);
- obj1 = ks_spop(K);
-/* REFACTOR these ifs: compare both types first, then switch on type */
- if (!eq2p(K, obj1, obj2)) {
- if (ttispair(obj1) && ttispair(obj2)) {
- /* if they were already compaired, consider equal for now
- otherwise they are equal if both their cars and cdrs are */
- if (!equal_find2_mergep(K, obj1, obj2)) {
- ks_spush(K, kcdr(obj1));
- ks_spush(K, kcdr(obj2));
- ks_spush(K, kcar(obj1));
- ks_spush(K, kcar(obj2));
- }
- } else if (ttisstring(obj1) && ttisstring(obj2)) {
- if (!kstring_equalp(obj1, obj2)) {
- result = false;
- break;
- }
- } 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;
- }
- }
- }
-
- /* if result is false, the stack may not be empty */
- ks_sclear(K);
-
- unmark_tree(K, saved_obj1);
- unmark_tree(K, saved_obj2);
-
- return result;
-}
-
-
/* init ground */
void kinit_equalp_ground_env(klisp_State *K)
{
diff --git a/src/kgequalp.h b/src/kgequalp.h
@@ -7,24 +7,7 @@
#ifndef kgequalp_h
#define kgequalp_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
#include "kstate.h"
-#include "kobject.h"
-#include "klisp.h"
-#include "kghelpers.h"
-
-/* 4.3.1 equal? */
-/* 6.6.1 equal? */
-void equalp(klisp_State *K);
-
-/* Helper (may be used in assoc and member) */
-/* compare two objects and check to see if they are "equal?". */
-bool equal2p(klisp_State *K, TValue obj1, TValue obj2);
/* init ground */
void kinit_equalp_ground_env(klisp_State *K);
diff --git a/src/kgerror.c b/src/kgerror.c
@@ -1,95 +0,0 @@
-/*
-** kgerror.c
-** Error handling features for the ground environment
-** See Copyright Notice in klisp.h
-*/
-
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kstate.h"
-#include "kobject.h"
-#include "kstring.h"
-#include "kpair.h"
-#include "kerror.h"
-
-#include "kghelpers.h"
-#include "kgerror.h"
-
-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))) {
- klispE_throw_with_irritants(K, kstring_buf(kcar(ptree)), kcdr(ptree));
- } else {
- klispE_throw_with_irritants(K, "Unknown error in user code", ptree);
- }
-}
-
-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);
- klisp_assert(ttisstring(err_obj->msg));
- kapply_cc(K, err_obj->msg);
-}
-
-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);
-}
-/* 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)
-{
- 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);
-}
-
-/* init ground */
-void kinit_error_ground_env(klisp_State *K)
-{
- TValue ground_env = K->ground_env;
- TValue symbol, value;
-
- add_applicative(K, ground_env, "error-object?", typep, 2, symbol, i2tv(K_TERROR));
- 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/kgerror.h b/src/kgerror.h
@@ -1,29 +0,0 @@
-/*
-** kgerror.h
-** Error handling features for the ground environment
-** See Copyright Notice in klisp.h
-*/
-
-#ifndef kgerror_h
-#define kgerror_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"
-
-/* init ground */
-void kinit_error_ground_env(klisp_State *K);
-
-/* Second stage of itialization of ground environment. Must be
- * called after initializing general error continuation
- * K->error_cont. */
-void kinit_error_hierarchy(klisp_State *K);
-
-#endif
diff --git a/src/kgerrors.c b/src/kgerrors.c
@@ -0,0 +1,127 @@
+/*
+** kgerrors.c
+** Error handling features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kstring.h"
+#include "kpair.h"
+#include "kerror.h"
+
+#include "kghelpers.h"
+#include "kgerrors.h"
+
+void kgerror(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, str, rest);
+ /* copy the list of irritants, to avoid modification later */
+ /* also check that is a list! */
+ TValue irritants = check_copy_list(K, rest, false, NULL, NULL);
+ krooted_tvs_push(K, irritants);
+ /* the msg is implicitly copied here */
+ klispE_throw_with_irritants(K, kstring_buf(str), irritants);
+}
+
+void kgraise(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);
+ kcall_cont(K, K->error_cont, obj);
+}
+
+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);
+ /* the string is immutable, no need to copy it */
+ klisp_assert(ttisstring(err_obj->msg));
+ kapply_cc(K, err_obj->msg);
+}
+
+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);
+}
+
+/* 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)
+{
+ 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);
+}
+
+/* init ground */
+void kinit_error_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ add_applicative(K, ground_env, "error-object?", typep, 2, symbol,
+ i2tv(K_TERROR));
+ add_applicative(K, ground_env, "error", kgerror, 0);
+ add_applicative(K, ground_env, "raise", kgraise, 0);
+ /* MAYBE add get- and remove object from these names */
+ add_applicative(K, ground_env, "error-object-message",
+ error_object_message, 0);
+ add_applicative(K, ground_env, "error-object-irritants",
+ error_object_irritants, 0);
+ /* TODO raise-continuable from r7rs doesn't make sense in the Kernel
+ system of handling continuations.
+ What we could have is a more sofisticated system
+ of restarts, which would be added to an error object
+ and would encapsulate continuations and descriptions of them.
+ It would be accessible with
+ error-object-restarts or something like that.
+ See Common Lisp and mit scheme for examples
+ */
+
+ klisp_assert(ttiscontinuation(K->system_error_cont));
+ add_value(K, ground_env, "system-error-continuation", K->system_error_cont);
+}
diff --git a/src/kgerrors.h b/src/kgerrors.h
@@ -0,0 +1,20 @@
+/*
+** kgerror.h
+** Error handling features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgerrors_h
+#define kgerrors_h
+
+#include "kstate.h"
+
+/* init ground */
+void kinit_error_ground_env(klisp_State *K);
+
+/* Second stage of itialization of ground environment. Must be
+ * called after initializing general error continuation
+ * K->error_cont. */
+void kinit_error_hierarchy(klisp_State *K);
+
+#endif
diff --git a/src/kgffi.c b/src/kgffi.c
@@ -41,9 +41,6 @@
#include "ktable.h"
#include "kghelpers.h"
-#include "kgencapsulations.h"
-#include "kgcombiners.h"
-#include "kgcontinuations.h"
#include "kgffi.h"
/* Set to 0 to ignore aligment errors during direct
@@ -79,6 +76,10 @@ typedef struct {
#define CB_INDEX_STACK 1
#define CB_INDEX_FIRST_CALLBACK 2
+/* Continuations */
+void do_ffi_callback_encode_result(klisp_State *K);
+void do_ffi_callback_return(klisp_State *K);
+
static TValue ffi_decode_void(ffi_codec_t *self, klisp_State *K, const void *buf)
{
UNUSED(self);
@@ -279,25 +280,8 @@ static void ffi_encode_sint32(ffi_codec_t *self, klisp_State *K, TValue v, void
static TValue ffi_decode_uint64(ffi_codec_t *self, klisp_State *K, const void *buf)
{
- /* TODO */
UNUSED(self);
- uint64_t x = *(uint64_t *)buf;
- if (x <= INT32_MAX) {
- return i2tv((int32_t) x);
- } else {
- TValue res = kbigint_make_simple(K);
- krooted_tvs_push(K, res);
-
- uint8_t d[8];
- for (int i = 7; i >= 0; i--) {
- d[i] = (x & 0xFF);
- x >>= 8;
- }
-
- mp_int_read_unsigned(K, tv2bigint(res), d, 8);
- krooted_tvs_pop(K);
- return res;
- }
+ return kinteger_new_uint64(K, *(uint64_t *)buf);
}
static void ffi_encode_uint64(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
@@ -499,8 +483,9 @@ void ffi_make_call_interface(klisp_State *K)
"argtypes string list", ttislist, argtypes_tv);
#undef ttislist
- size_t nargs = check_typed_list(K, "ffi-make-call-interface", "argtype string",
- kstringp, false, argtypes_tv, NULL);
+ size_t nargs;
+ check_typed_list(K, kstringp, false, argtypes_tv, (int32_t *) &nargs,
+ NULL);
/* Allocate C structure ffi_call_interface_t inside
a mutable bytevector. The structure contains C pointers
@@ -868,15 +853,21 @@ static void ffi_callback_entry(ffi_cif *cif, void *ret, void **args, void *user_
TValue exit_guard = ffi_callback_guard(cb, do_ffi_callback_exit_guard);
krooted_tvs_push(K, exit_guard);
+ /* Construct fresh dynamic environment for the callback applicative. */
+ TValue denv = kmake_empty_environment(K);
+ krooted_tvs_push(K, denv);
+
TValue ptree = kimm_list(K, 3, entry_guard, app, exit_guard);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
K->next_xparams = NULL;
K->next_value = ptree;
- /* K->next_env already has the correct value */
+ K->next_env = denv;
+
guard_dynamic_extent(K);
/* Enter new "inner" trampoline loop. */
@@ -1191,3 +1182,14 @@ void kinit_ffi_ground_env(klisp_State *K)
add_applicative(K, ground_env, "ffi-library?", enc_typep, 1, dll_key);
add_applicative(K, ground_env, "ffi-call-interface?", enc_typep, 1, cif_key);
}
+
+/* init continuation names */
+void kinit_ffi_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_ffi_callback_encode_result,
+ "ffi-callback-encode-result");
+ add_cont_name(K, t, do_ffi_callback_return,
+ "ffi-callback-ret");
+}
diff --git a/src/kgffi.h b/src/kgffi.h
@@ -10,20 +10,12 @@
#if (KUSE_LIBFFI != 1)
# error "Compiling FFI code, but KUSE_LIBFFI != 1."
#endif
-#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"
-
-void ffi_load_library(klisp_State *K);
/* init ground */
void kinit_ffi_ground_env(klisp_State *K);
+/* init continuation names */
+void kinit_ffi_cont_names(klisp_State *K);
#endif
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -4,7 +4,6 @@
** See Copyright Notice in klisp.h
*/
-#include <assert.h>
#include <stdlib.h>
#include <stdio.h>
#include <stdbool.h>
@@ -16,6 +15,144 @@
#include "klisp.h"
#include "kerror.h"
#include "ksymbol.h"
+#include "kenvironment.h"
+#include "kinteger.h"
+#include "krational.h"
+#include "kapplicative.h"
+#include "kbytevector.h"
+#include "kvector.h"
+#include "kstring.h"
+#include "kpair.h"
+#include "kcontinuation.h"
+#include "kencapsulation.h"
+#include "kpromise.h"
+
+/* Initialization of continuation names */
+void kinit_kghelpers_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+ add_cont_name(K, t, do_seq, "eval-sequence");
+ add_cont_name(K, t, do_pass_value, "pass-value");
+ add_cont_name(K, t, do_return_value, "return-value");
+ add_cont_name(K, t, do_bind, "dynamic-bind");
+ add_cont_name(K, t, do_bind, "dynamic-access");
+ add_cont_name(K, t, do_bind, "dynamic-unbind");
+ add_cont_name(K, t, do_bind, "dynamic-set!-pass");
+}
+
+/* Type predicates */
+/* TODO these should be moved to either kobject.h or the corresponding
+ files (e.g. kbooleanp to kboolean.h */
+bool kbooleanp(TValue obj) { return ttisboolean(obj); }
+bool kcombinerp(TValue obj) { return ttiscombiner(obj); }
+bool knumberp(TValue obj) { return ttisnumber(obj); }
+/* TEMP used (as a type predicate) in all predicates that need a primary value
+ (XXX it's not actually a type error, but it's close enough and otherwise
+ should define new predp & bpredp for numeric predicates...) */
+bool knumber_wpvp(TValue obj)
+{
+ return ttisnumber(obj) && !ttisrwnpv(obj) && !ttisundef(obj);
+}
+/* This is used in gcd & lcm */
+bool kimp_intp(TValue obj) { return ttisinteger(obj) || ttisinf(obj); }
+/* obj is known to be a number */
+bool kfinitep(TValue obj) { return !ttisinf(obj); }
+/* fixint, bigints & inexact integers */
+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
+ primary value (XXX it's not actually a type error, but it's close enough
+ and otherwise should define new predp & bpredp for numeric predicates...) */
+bool kreal_wpvp(TValue obj) { return ttisreal(obj) && !ttisrwnpv(obj); }
+
+bool kexactp(TValue obj) { return ttisexact(obj); }
+bool kinexactp(TValue obj) { return ttisinexact(obj); }
+bool kundefinedp(TValue obj) { return ttisundef(obj); }
+bool krobustp(TValue obj) { return ttisrobust(obj); }
+
+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
+ */
+ TValue key = xparams[0];
+
+ /* check the ptree is a list while checking the predicate.
+ Keep going even if the result is false to catch errors in
+ ptree structure */
+ bool res = true;
+
+ TValue tail = ptree;
+ while(ttispair(tail) && kis_unmarked(tail)) {
+ kmark(tail);
+ res &= kis_encapsulation_type(kcar(tail), key);
+ tail = kcdr(tail);
+ }
+ unmark_list(K, ptree);
+
+ if (ttispair(tail) || ttisnil(tail)) {
+ kapply_cc(K, b2tv(res));
+ } else {
+ /* try to get name from encapsulation */
+ klispE_throw_simple(K, "expected list");
+ return;
+ }
+}
+/* /Type predicates */
+
+/* some number functions */
+bool kpositivep(TValue n)
+{
+ switch (ttype(n)) {
+ case K_TFIXINT:
+ case K_TEINF:
+ case K_TIINF:
+ return ivalue(n) > 0;
+ case K_TBIGINT:
+ return kbigint_positivep(n);
+ case K_TBIGRAT:
+ return kbigrat_positivep(n);
+ case K_TDOUBLE:
+ return dvalue(n) > 0.0;
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
+ default:
+ klisp_assert(0);
+ return false;
+ }
+}
+
+bool knegativep(TValue n)
+{
+ switch (ttype(n)) {
+ case K_TFIXINT:
+ case K_TEINF:
+ case K_TIINF:
+ return ivalue(n) < 0;
+ case K_TBIGINT:
+ return kbigint_negativep(n);
+ case K_TBIGRAT:
+ return kbigrat_negativep(n);
+ case K_TDOUBLE:
+ return dvalue(n) < 0.0;
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
+ default:
+ klisp_assert(0);
+ return false;
+ }
+}
+/* /some number functions */
void typep(klisp_State *K)
{
@@ -100,14 +237,13 @@ void ftyped_predp(klisp_State *K)
** xparams[1]: type fn pointer (as a void * in a user TValue)
** xparams[2]: fn pointer (as a void * in a user TValue)
*/
- char *name = ksymbol_buf(xparams[0]);
bool (*typep)(TValue obj) = pvalue(xparams[1]);
bool (*predp)(TValue obj) = pvalue(xparams[2]);
/* check the ptree is a list first to allow the structure
errors to take precedence over the type errors. */
- int32_t cpairs;
- int32_t pairs = check_list(K, name, true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ptree, &pairs, &cpairs);
TValue tail = ptree;
bool res = true;
@@ -144,14 +280,13 @@ void ftyped_bpredp(klisp_State *K)
** xparams[1]: type fn pointer (as a void * in a user TValue)
** xparams[2]: fn pointer (as a void * in a user TValue)
*/
- char *name = ksymbol_buf(xparams[0]);
bool (*typep)(TValue obj) = pvalue(xparams[1]);
bool (*predp)(TValue obj1, TValue obj2) = pvalue(xparams[2]);
/* check the ptree is a list first to allow the structure
errors to take precedence over the type errors. */
- int32_t cpairs;
- int32_t pairs = check_list(K, name, true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ptree, &pairs, &cpairs);
/* cyclical list require an extra comparison of the last
& first element of the cycle */
@@ -204,15 +339,14 @@ void ftyped_kbpredp(klisp_State *K)
** xparams[1]: type fn pointer (as a void * in a user TValue)
** xparams[2]: fn pointer (as a void * in a user TValue)
*/
- char *name = ksymbol_buf(xparams[0]);
bool (*typep)(TValue obj) = pvalue(xparams[1]);
bool (*predp)(klisp_State *K, TValue obj1, TValue obj2) =
pvalue(xparams[2]);
/* check the ptree is a list first to allow the structure
errors to take precedence over the type errors. */
- int32_t cpairs;
- int32_t pairs = check_list(K, name, true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ptree, &pairs, &cpairs);
/* cyclical list require an extra comparison of the last
& first element of the cycle */
@@ -252,86 +386,299 @@ void ftyped_kbpredp(klisp_State *K)
}
/* typed finite list. Structure error should be throw before type errors */
-int32_t check_typed_list(klisp_State *K, char *name, char *typename,
- bool (*typep)(TValue), bool allow_infp, TValue obj,
- int32_t *cpairs)
+void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp,
+ TValue obj, int32_t *pairs, int32_t *cpairs)
{
TValue tail = obj;
- int32_t pairs = 0;
+ int32_t p = 0;
bool type_errorp = false;
while(ttispair(tail) && !kis_marked(tail)) {
/* even if there is a type error continue checking the structure */
type_errorp |= !(*typep)(kcar(tail));
- kset_mark(tail, i2tv(pairs));
+ kset_mark(tail, i2tv(p));
tail = kcdr(tail);
- ++pairs;
+ ++p;
}
+ if (pairs != NULL) *pairs = p;
if (cpairs != NULL)
- *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0;
+ *cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
unmark_list(K, obj);
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, allow_infp? "expected list" :
"expected finite list");
- return 0;
+ return;
} else if(ttispair(tail) && !allow_infp) {
klispE_throw_simple(K, "expected finite list");
- return 0;
+ return;
} else if (type_errorp) {
- /* TODO put type name too */
+ /* TODO put type name too, should be extracted from a
+ table of type names */
klispE_throw_simple(K, "bad operand type");
- return 0;
+ return;
}
- return pairs;
}
-int32_t check_list(klisp_State *K, const char *name, bool allow_infp,
- TValue obj, int32_t *cpairs)
+void check_list(klisp_State *K, bool allow_infp, TValue obj,
+ int32_t *pairs, int32_t *cpairs)
{
TValue tail = obj;
- int pairs = 0;
+ int32_t p = 0;
+
while(ttispair(tail) && !kis_marked(tail)) {
- kset_mark(tail, i2tv(pairs));
+ kset_mark(tail, i2tv(p));
tail = kcdr(tail);
- ++pairs;
+ ++p;
}
+ if (pairs != NULL) *pairs = p;
if (cpairs != NULL)
- *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0;
+ *cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
unmark_list(K, obj);
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, allow_infp? "expected list" :
"expected finite list");
- return 0;
+ return;
} else if(ttispair(tail) && !allow_infp) {
klispE_throw_simple(K, "expected finite list");
- return 0;
+ return;
+ }
+}
+
+
+TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
+ int32_t *pairs, int32_t *cpairs)
+{
+ int32_t p = 0;
+ if (ttisnil(obj)) {
+ if (pairs != NULL) *pairs = 0;
+ if (cpairs != NULL) *cpairs = 0;
+ return obj;
+ }
+
+ if (ttispair(obj) && kis_immutable(obj) && !force_copy) {
+ /* this will properly set pairs and cpairs */
+ check_list(K, true, obj, pairs, cpairs);
+ return obj;
} else {
- return pairs;
+ TValue copy = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, ©);
+ TValue last_pair = copy;
+ TValue tail = obj;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ TValue new_pair = kcons(K, kcar(tail), KNIL);
+ /* record the corresponding pair to simplify cycle handling */
+ kset_mark(tail, new_pair);
+ /* record the pair number in the new pair, to set cpairs */
+ kset_mark(new_pair, i2tv(p));
+ /* copy the source code info */
+ TValue si = ktry_get_si(K, tail);
+ if (!ttisnil(si))
+ kset_source_info(K, new_pair, si);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ ++p;
+ }
+
+ if (pairs != NULL) *pairs = p;
+ if (cpairs != NULL)
+ *cpairs = ttispair(tail)?
+ (p - ivalue(kget_mark(kget_mark(tail)))) :
+ 0;
+
+ if (ttispair(tail)) {
+ /* complete the cycle */
+ kset_cdr(last_pair, kget_mark(tail));
+ }
+
+ unmark_list(K, obj);
+ unmark_list(K, kcdr(copy));
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
+ }
+ krooted_vars_pop(K);
+ return kcdr(copy);
}
}
+TValue check_copy_env_list(klisp_State *K, TValue obj)
+{
+ TValue copy = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, ©);
+ TValue last_pair = copy;
+ TValue tail = obj;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ TValue first = kcar(tail);
+ if (!ttisenvironment(first)) {
+ klispE_throw_simple(K, "not an environment in parent list");
+ return KINERT;
+ }
+ TValue new_pair = kcons(K, first, KNIL);
+ kmark(tail);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ }
-/*
-** Continuation that ignores the value received and instead returns
-** a previously computed value.
-*/
-void do_return_value(klisp_State *K)
+ /* even if there was a cycle, the copy ends with nil */
+ unmark_list(K, obj);
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
+ }
+ krooted_vars_pop(K);
+ return kcdr(copy);
+}
+
+/* Helpers for string, list->string, and string-map,
+ bytevector, list->bytevector, bytevector-map,
+ vector, list->vector, and vector-map */
+/* GC: Assume ls is rooted */
+/* ls should a list of length 'length' of the correct type
+ (chars for string, u8 for bytevector, any for vector) */
+/* these type checks each element */
+
+TValue list_to_string_h(klisp_State *K, TValue ls, int32_t length)
{
- TValue *xparams = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
- /*
- ** xparams[0]: saved_obj
- */
- UNUSED(obj);
- TValue ret_obj = xparams[0];
- kapply_cc(K, ret_obj);
+ TValue new_str;
+ /* the if isn't strictly necessary but it's clearer this way */
+ if (length == 0) {
+ return K->empty_string;
+ } else {
+ new_str = kstring_new_s(K, length);
+ char *buf = kstring_buf(new_str);
+ while(length-- > 0) {
+ TValue head = kcar(ls);
+ if (!ttischar(head)) {
+ klispE_throw_simple_with_irritants(K, "Bad type (expected "
+ "char)", 1, head);
+ return KINERT;
+ }
+ *buf++ = chvalue(head);
+ ls = kcdr(ls);
+ }
+ return new_str;
+ }
+}
+
+TValue list_to_vector_h(klisp_State *K, TValue ls, int32_t length)
+{
+
+ if (length == 0) {
+ return K->empty_vector;
+ } else {
+ TValue new_vec = kvector_new_sf(K, length, KINERT);
+ TValue *buf = kvector_buf(new_vec);
+ while(length-- > 0) {
+ *buf++ = kcar(ls);
+ ls = kcdr(ls);
+ }
+ return new_vec;
+ }
+}
+
+TValue list_to_bytevector_h(klisp_State *K, TValue ls, int32_t length)
+{
+ TValue new_bb;
+ /* the if isn't strictly necessary but it's clearer this way */
+ if (length == 0) {
+ return K->empty_bytevector;
+ } else {
+ new_bb = kbytevector_new_s(K, length);
+ uint8_t *buf = kbytevector_buf(new_bb);
+ while(length-- > 0) {
+ TValue head = kcar(ls);
+ if (!ttisu8(head)) {
+ klispE_throw_simple_with_irritants(K, "Bad type (expected "
+ "u8)", 1, head);
+ return KINERT;
+ }
+ *buf++ = ivalue(head);
+ ls = kcdr(ls);
+ }
+ return new_bb;
+ }
+}
+
+/* Helpers for string->list, string-map, string-foreach,
+ bytevector->list, bytevector-map, bytevector-foreach,
+ vector->list, vector-map, and vector-foreach */
+/* GC: Assume array is rooted */
+TValue string_to_list_h(klisp_State *K, TValue obj, int32_t *length)
+{
+ if (!ttisstring(obj)) {
+ klispE_throw_simple_with_irritants(K, "Bad type (expected string)",
+ 1, obj);
+ return KINERT;
+ }
+
+ int32_t pairs = kstring_size(obj);
+ if (length != NULL) *length = pairs;
+
+ char *buf = kstring_buf(obj) + pairs - 1;
+ TValue tail = KNIL;
+ krooted_vars_push(K, &tail);
+ while(pairs-- > 0) {
+ tail = kcons(K, ch2tv(*buf), tail);
+ --buf;
+ }
+ krooted_vars_pop(K);
+ return tail;
+}
+
+TValue vector_to_list_h(klisp_State *K, TValue obj, int32_t *length)
+{
+ if (!ttisvector(obj)) {
+ klispE_throw_simple_with_irritants(K, "Bad type (expected vector)",
+ 1, obj);
+ return KINERT;
+ }
+
+ int32_t pairs = kvector_size(obj);
+ if (length != NULL) *length = pairs;
+
+ TValue *buf = kvector_buf(obj) + pairs - 1;
+ TValue tail = KNIL;
+ krooted_vars_push(K, &tail);
+ while(pairs-- > 0) {
+ tail = kcons(K, *buf, tail);
+ --buf;
+ }
+ krooted_vars_pop(K);
+ return tail;
+}
+
+TValue bytevector_to_list_h(klisp_State *K, TValue obj, int32_t *length)
+{
+ if (!ttisbytevector(obj)) {
+ klispE_throw_simple_with_irritants(K, "Bad type (expected bytevector)",
+ 1, obj);
+ return KINERT;
+ }
+
+ int32_t pairs = kbytevector_size(obj);
+ if (length != NULL) *length = pairs;
+
+ uint8_t *buf = kbytevector_buf(obj) + pairs - 1;
+ TValue tail = KNIL;
+ krooted_vars_push(K, &tail);
+ while(pairs-- > 0) {
+ tail = kcons(K, i2tv(*buf), tail);
+ --buf;
+ }
+ krooted_vars_pop(K);
+ return tail;
}
/* Some helpers for working with fixints (signed 32 bits) */
@@ -383,3 +730,1165 @@ int64_t klcm32_64(int32_t a_, int32_t b_)
/* divide first to avoid possible overflow */
return (a / gcd) * b;
}
+
+/* This is needed in kstate & promises */
+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);
+
+ bind_1p(K, ptree, exp);
+ TValue new_prom = kmake_promise(K, exp, KNIL);
+ kapply_cc(K, new_prom);
+}
+
+/* list applicative (used in kstate and kgpairs_lists) */
+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);
+ UNUSED(denv);
+ kapply_cc(K, ptree);
+}
+
+/* Helper for get-list-metrics, and list-tail, list-ref and list-set!
+ when receiving bigint indexes */
+void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
+ int32_t *a, int32_t *c)
+{
+ TValue tail = obj;
+ int32_t pairs = 0;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ /* record the pair number to simplify cycle pair counting */
+ kset_mark(tail, i2tv(pairs));
+ ++pairs;
+ tail = kcdr(tail);
+ }
+ int32_t apairs, cpairs, nils;
+ if (ttisnil(tail)) {
+ /* simple (possibly empty) list */
+ apairs = pairs;
+ nils = 1;
+ cpairs = 0;
+ } else if (ttispair(tail)) {
+ /* cyclic (maybe circular) list */
+ apairs = ivalue(kget_mark(tail));
+ cpairs = pairs - apairs;
+ nils = 0;
+ } else {
+ apairs = pairs;
+ cpairs = 0;
+ nils = 0;
+ }
+
+ unmark_list(K, obj);
+
+ if (p != NULL) *p = pairs;
+ if (n != NULL) *n = nils;
+ if (a != NULL) *a = apairs;
+ if (c != NULL) *c = cpairs;
+}
+
+/* Helper for list-tail, list-ref and list-set! */
+/* Calculate the smallest i such that
+ (eq? (list-tail obj i) (list-tail obj tk))
+ tk is a bigint and all lists have fixint range number of pairs,
+ so the list should cyclic and we should calculate an index that
+ doesn't go through the complete cycle not even once */
+int32_t ksmallest_index(klisp_State *K, TValue obj, TValue tk)
+{
+ int32_t apairs, cpairs;
+ get_list_metrics_aux(K, obj, NULL, NULL, &apairs, &cpairs);
+ if (cpairs == 0) {
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return 0;
+ }
+ TValue tv_apairs = i2tv(apairs);
+ TValue tv_cpairs = i2tv(cpairs);
+
+ /* all calculations will be done with bigints */
+ kensure_bigint(tv_apairs);
+ kensure_bigint(tv_cpairs);
+
+ TValue idx = kbigint_minus(K, tk, tv_apairs);
+ krooted_tvs_push(K, idx); /* root idx if it is a bigint */
+ /* idx may have become a fixint */
+ kensure_bigint(idx);
+ UNUSED(kbigint_div_mod(K, idx, tv_cpairs, &idx));
+ krooted_tvs_pop(K);
+ /* now idx is less than cpairs so it fits in a fixint */
+ assert(ttisfixint(idx));
+ return ivalue(idx) + apairs;
+}
+
+/* Helper for eq? and equal? */
+bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
+{
+ bool res = (tv_equal(obj1, obj2));
+ if (!res && (ttype(obj1) == ttype(obj2))) {
+ switch (ttype(obj1)) {
+ case K_TSYMBOL:
+ /* symbols can't be compared with tv_equal! */
+ res = tv_sym_equal(obj1, obj2);
+ break;
+ case K_TAPPLICATIVE:
+ while(ttisapplicative(obj1) && ttisapplicative(obj2)) {
+ obj1 = kunwrap(obj1);
+ obj2 = kunwrap(obj2);
+ }
+ res = (tv_equal(obj1, obj2));
+ break;
+ case K_TBIGINT:
+ /* it's important to know that it can't be the case
+ that obj1 is bigint and obj is some other type and
+ (eq? obj1 obj2) */
+ res = kbigint_eqp(obj1, obj2);
+ break;
+ case K_TBIGRAT:
+ /* it's important to know that it can't be the case
+ that obj1 is bigrat and obj is some other type and
+ (eq? obj1 obj2) */
+ res = kbigrat_eqp(K, obj1, obj2);
+ break;
+ } /* immutable strings & bytevectors are interned so they are
+ covered already by tv_equalp */
+
+ }
+ return res;
+}
+
+/*
+** Helpers for equal? algorithm
+**
+** See [2] for details of the list merging algorithm.
+** Here are the implementation details:
+** The marks of the pairs are used to store the nodes of the trees
+** that represent the set of previous comparations of each pair.
+** They serve the function of the array in [2].
+** If a pair is unmarked, it was never compared (empty comparison set).
+** If a pair is marked, the mark object is either (#f . parent-node)
+** if the node is not the root, and (#t . n) where n is the number
+** of elements in the set, if the node is the root.
+** This pair also doubles as the "name" of the set in [2].
+**
+** GC: all of these assume that arguments are rooted.
+*/
+
+/* find "name" of the set of this obj, if there isn't one create it,
+ if there is one, flatten its branch */
+inline TValue equal_find(klisp_State *K, TValue obj)
+{
+ /* GC: should root obj */
+ if (kis_unmarked(obj)) {
+ /* object wasn't compared before, create new set */
+ TValue new_node = kcons(K, KTRUE, i2tv(1));
+ kset_mark(obj, new_node);
+ return new_node;
+ } else {
+ TValue node = kget_mark(obj);
+
+ /* First obtain the root and a list of all the other objects in this
+ branch, as said above the root is the one with #t in its car */
+ /* NOTE: the stack is being used, so we must remember how many pairs we
+ push, we can't just pop 'till is empty */
+ int np = 0;
+ while(kis_false(kcar(node))) {
+ ks_spush(K, node);
+ node = kcdr(node);
+ ++np;
+ }
+ TValue root = node;
+
+ /* set all parents to root, to flatten the branch */
+ while(np--) {
+ node = ks_spop(K);
+ kset_cdr(node, root);
+ }
+ return root;
+ }
+}
+
+/* merge the smaller set into the big one, if both are equal just pick one */
+inline void equal_merge(klisp_State *K, TValue root1, TValue root2)
+{
+ /* K isn't needed but added for consistency */
+ UNUSED(K);
+ int32_t size1 = ivalue(kcdr(root1));
+ int32_t size2 = ivalue(kcdr(root2));
+ TValue new_size = i2tv(size1 + size2);
+
+ if (size1 < size2) {
+ /* add root1 set (the smaller one) to root2 */
+ kset_cdr(root2, new_size);
+ kset_car(root1, KFALSE);
+ kset_cdr(root1, root2);
+ } else {
+ /* add root2 set (the smaller one) to root1 */
+ kset_cdr(root1, new_size);
+ kset_car(root2, KFALSE);
+ kset_cdr(root2, root1);
+ }
+}
+
+/* check to see if two objects were already compared, and return that. If they
+ weren't compared yet, merge their sets (and flatten their branches) */
+inline bool equal_find2_mergep(klisp_State *K, TValue obj1, TValue obj2)
+{
+ /* GC: should root root1 and root2 */
+ TValue root1 = equal_find(K, obj1);
+ TValue root2 = equal_find(K, obj2);
+ if (tv_equal(root1, root2)) {
+ /* they are in the same set => they were already compared */
+ return true;
+ } else {
+ equal_merge(K, root1, root2);
+ return false;
+ }
+}
+
+/*
+** See [1] for details, in this case the pairs form a possibly infinite "tree"
+** structure, and that can be seen as a finite automata, where each node is a
+** state, the car and the cdr are the transitions from that state to others,
+** and the leaves (the non-pair objects) are the final states.
+** Other way to see it is that, the key for determining equalness of two pairs
+** is: Check to see if they were already compared to each other.
+** If so, return #t, otherwise, mark them as compared to each other and
+** recurse on both cars and both cdrs.
+** The idea is that if assuming obj1 and obj2 are equal their components are
+** equal then they are effectively equal to each other.
+*/
+bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
+{
+ assert(ks_sisempty(K));
+
+ /* the stack has the elements to be compaired, always in pairs.
+ So the top should be compared with the one below, the third with
+ the fourth and so on */
+ ks_spush(K, obj1);
+ ks_spush(K, obj2);
+
+ /* if the stacks becomes empty, all pairs of elements were equal */
+ bool result = true;
+ TValue saved_obj1 = obj1;
+ TValue saved_obj2 = obj2;
+
+ while(!ks_sisempty(K)) {
+ obj2 = ks_spop(K);
+ obj1 = ks_spop(K);
+
+ if (!eq2p(K, obj1, obj2)) {
+ /* This type comparison works because we just care about
+ pairs, vectors, strings & bytevectors */
+ if (ttype(obj1) == ttype(obj2)) {
+ switch(ttype(obj1)) {
+ case K_TPAIR:
+ /* if they were already compaired, consider equal for
+ now otherwise they are equal if both their cars
+ and cdrs are */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ ks_spush(K, kcdr(obj1));
+ ks_spush(K, kcdr(obj2));
+ ks_spush(K, kcar(obj1));
+ ks_spush(K, kcar(obj2));
+ }
+ break;
+ case K_TVECTOR:
+ if (kvector_size(obj1) == kvector_size(obj2)) {
+ /* if they were already compaired, consider equal for
+ now otherwise they are equal if all their elements
+ are equal pairwise */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ uint32_t i = kvector_size(obj1);
+ TValue *array1 = kvector_buf(obj1);
+ TValue *array2 = kvector_buf(obj1);
+ while(i-- > 0) {
+ ks_spush(K, array1[i]);
+ ks_spush(K, array2[i]);
+ }
+ }
+ } else {
+ result = false;
+ goto end;
+ }
+ break;
+ case K_TSTRING:
+ if (!kstring_equalp(obj1, obj2)) {
+ result = false;
+ goto end;
+ }
+ break;
+ case K_TBYTEVECTOR:
+ if (!kbytevector_equalp(obj1, obj2)) {
+ result = false;
+ goto end;
+ }
+ break;
+ default:
+ result = false;
+ goto end;
+ }
+ } else {
+ result = false;
+ goto end;
+ }
+ }
+ }
+end:
+ /* if result is false, the stack may not be empty */
+ ks_sclear(K);
+
+ unmark_tree(K, saved_obj1);
+ unmark_tree(K, saved_obj2);
+
+ return result;
+}
+
+/*
+** This is in a helper method to use it from $lambda, $vau, etc
+**
+** We mark each seen mutable pair with the corresponding copied
+** immutable pair to construct a structure that is isomorphic to
+** the original.
+** All objects that aren't mutable pairs are retained without
+** copying
+** sstack is used to keep track of pairs and tbstack is used
+** to keep track of which of car or cdr we were copying,
+** 0 means just pushed, 1 means return from car, 2 means return from cdr
+**
+** This also copies source code info
+**
+*/
+
+/* GC: assumes obj is rooted */
+TValue copy_es_immutable_h(klisp_State *K, TValue obj, bool mut_flag)
+{
+ TValue copy = obj;
+ krooted_vars_push(K, ©);
+
+ assert(ks_sisempty(K));
+ assert(ks_tbisempty(K));
+
+ ks_spush(K, obj);
+ ks_tbpush(K, ST_PUSH);
+
+ while(!ks_sisempty(K)) {
+ char state = ks_tbpop(K);
+ TValue top = ks_spop(K);
+
+ if (state == ST_PUSH) {
+ /* if the pair is immutable & we are constructing immutable
+ pairs there is no need to copy */
+ if (ttispair(top) && (mut_flag || kis_mutable(top))) {
+ if (kis_marked(top)) {
+ /* this pair was already seen, use the same */
+ copy = kget_mark(top);
+ } else {
+ TValue new_pair = kcons_g(K, mut_flag, KINERT, KINERT);
+ kset_mark(top, new_pair);
+ /* save the source code info on the new pair */
+ /* MAYBE: only do it if mutable */
+ TValue si = ktry_get_si(K, top);
+ if (!ttisnil(si))
+ kset_source_info(K, new_pair, si);
+ /* leave the pair in the stack, continue with the car */
+ ks_spush(K, top);
+ ks_tbpush(K, ST_CAR);
+
+ ks_spush(K, kcar(top));
+ ks_tbpush(K, ST_PUSH);
+ }
+ } else {
+ copy = top;
+ }
+ } else { /* last action was a pop */
+ TValue new_pair = kget_mark(top);
+ if (state == ST_CAR) {
+ /* new_pair may be immutable */
+ kset_car_unsafe(K, new_pair, copy);
+ /* leave the pair on the stack, continue with the cdr */
+ ks_spush(K, top);
+ ks_tbpush(K, ST_CDR);
+
+ ks_spush(K, kcdr(top));
+ ks_tbpush(K, ST_PUSH);
+ } else {
+ /* new_pair may be immutable */
+ kset_cdr_unsafe(K, new_pair, copy);
+ copy = new_pair;
+ }
+ }
+ }
+ unmark_tree(K, obj);
+ krooted_vars_pop(K);
+ return copy;
+}
+
+/* ptree handling */
+
+/*
+** Clear all the marks (symbols + pairs) & stacks.
+** The stack should contain only pairs, sym_ls should be
+** as above
+*/
+inline void ptree_clear_all(klisp_State *K, TValue sym_ls)
+{
+ while(!ttisnil(sym_ls)) {
+ TValue first = sym_ls;
+ sym_ls = kget_symbol_mark(first);
+ kunmark_symbol(first);
+ }
+
+ while(!ks_sisempty(K)) {
+ kunmark(ks_sget(K));
+ ks_sdpop(K);
+ }
+
+ ks_tbclear(K);
+}
+
+/* GC: assumes env, ptree & obj are rooted */
+void match(klisp_State *K, TValue env, TValue ptree, TValue obj)
+{
+ assert(ks_sisempty(K));
+ ks_spush(K, obj);
+ ks_spush(K, ptree);
+
+ while(!ks_sisempty(K)) {
+ ptree = ks_spop(K);
+ obj = ks_spop(K);
+
+ switch(ttype(ptree)) {
+ case K_TNIL:
+ if (!ttisnil(obj)) {
+ /* TODO show ptree and arguments */
+ ks_sclear(K);
+ klispE_throw_simple(K, "ptree doesn't match arguments");
+ return;
+ }
+ break;
+ case K_TIGNORE:
+ /* do nothing */
+ break;
+ case K_TSYMBOL:
+ kadd_binding(K, env, ptree, obj);
+ break;
+ case K_TPAIR:
+ if (ttispair(obj)) {
+ ks_spush(K, kcdr(obj));
+ ks_spush(K, kcdr(ptree));
+ ks_spush(K, kcar(obj));
+ ks_spush(K, kcar(ptree));
+ } else {
+ /* TODO show ptree and arguments */
+ ks_sclear(K);
+ klispE_throw_simple(K, "ptree doesn't match arguments");
+ return;
+ }
+ break;
+ default:
+ /* can't really happen */
+ break;
+ }
+ }
+}
+
+/* GC: assumes ptree & penv are rooted */
+TValue check_copy_ptree(klisp_State *K, TValue ptree, TValue penv)
+{
+ /* copy is only valid if the state isn't ST_PUSH */
+ /* but init anyways for gc (and avoiding warnings) */
+ TValue copy = ptree;
+ krooted_vars_push(K, ©);
+
+ /*
+ ** NIL terminated singly linked list of symbols
+ ** (using the mark as next pointer)
+ */
+ TValue sym_ls = KNIL;
+
+ assert(ks_sisempty(K));
+ assert(ks_tbisempty(K));
+
+ ks_tbpush(K, ST_PUSH);
+ ks_spush(K, ptree);
+
+ while(!ks_sisempty(K)) {
+ char state = ks_tbpop(K);
+ TValue top = ks_spop(K);
+
+ if (state == ST_PUSH) {
+ switch(ttype(top)) {
+ case K_TIGNORE:
+ case K_TNIL:
+ copy = top;
+ break;
+ case K_TSYMBOL: {
+ if (kis_symbol_marked(top)) {
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple_with_irritants(K, "repeated symbol "
+ "in ptree", 1, top);
+ return KNIL;
+ } else {
+ copy = top;
+ /* add it to the symbol list */
+ kset_symbol_mark(top, sym_ls);
+ sym_ls = top;
+ }
+ break;
+ }
+ case K_TPAIR: {
+ if (kis_unmarked(top)) {
+ if (kis_immutable(top)) {
+ /* don't copy mutable pairs, just use them */
+ /* NOTE: immutable pairs can't have mutable
+ car or cdr */
+ /* we have to continue thou, because there could be a
+ cycle */
+ kset_mark(top, top);
+ } else {
+ /* create a new pair as copy, save it in the mark */
+ TValue new_pair = kimm_cons(K, KNIL, KNIL);
+ kset_mark(top, new_pair);
+ /* copy the source code info */
+ TValue si = ktry_get_si(K, top);
+ if (!ttisnil(si))
+ kset_source_info(K, new_pair, si);
+ }
+ /* keep the old pair and continue with the car */
+ ks_tbpush(K, ST_CAR);
+ ks_spush(K, top);
+
+ ks_tbpush(K, ST_PUSH);
+ ks_spush(K, kcar(top));
+ } else {
+ /* marked pair means a cycle was found */
+ /* NOTE: the pair should be in the stack already so
+ it isn't necessary to push it again to clear the mark */
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple(K, "cycle detected in ptree");
+ /* avoid warning */
+ return KNIL;
+ }
+ break;
+ }
+ default:
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple(K, "bad object type in ptree");
+ /* avoid warning */
+ return KNIL;
+ }
+ } else {
+ /* last operation was a pop */
+ /* top is a marked pair, the mark is the copied obj */
+ /* NOTE: if top is immutable the mark is also top
+ we could still do the set-car/set-cdr because the
+ copy would be the same as the car/cdr, but why bother */
+ if (state == ST_CAR) {
+ /* only car was checked (not yet copied) */
+ if (kis_mutable(top)) {
+ TValue copied_pair = kget_mark(top);
+ /* copied_pair may be immutable */
+ kset_car_unsafe(K, copied_pair, copy);
+ }
+ /* put the copied pair again, continue with the cdr */
+ ks_tbpush(K, ST_CDR);
+ ks_spush(K, top);
+
+ ks_tbpush(K, ST_PUSH);
+ ks_spush(K, kcdr(top));
+ } else {
+ /* both car & cdr were checked (cdr not yet copied) */
+ TValue copied_pair = kget_mark(top);
+ /* the unmark is needed to allow diamonds */
+ kunmark(top);
+
+ if (kis_mutable(top)) {
+ /* copied_pair may be immutable */
+ kset_cdr_unsafe(K, copied_pair, copy);
+ }
+ copy = copied_pair;
+ }
+ }
+ }
+
+ if (ttissymbol(penv)) {
+ if (kis_symbol_marked(penv)) {
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple_with_irritants(K, "same symbol in both ptree "
+ "and environment parameter",
+ 1, sym_ls);
+ }
+ } else if (!ttisignore(penv)) {
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple(K, "symbol or #ignore expected as "
+ "environment parmameter");
+ }
+ ptree_clear_all(K, sym_ls);
+ krooted_vars_pop(K);
+ return copy;
+}
+
+/* Helpers for map (also used by for each) */
+void map_for_each_get_metrics(klisp_State *K, TValue lss,
+ int32_t *app_apairs_out, int32_t *app_cpairs_out,
+ int32_t *res_apairs_out, int32_t *res_cpairs_out)
+{
+ /* avoid warnings (shouldn't happen if _No_return was used in throw) */
+ *app_apairs_out = 0;
+ *app_cpairs_out = 0;
+ *res_apairs_out = 0;
+ *res_cpairs_out = 0;
+
+ /* get the metrics of the ptree of each call to app */
+ int32_t app_pairs, app_cpairs;
+ check_list(K, true, lss, &app_pairs, &app_cpairs);
+ int32_t app_apairs = app_pairs - app_cpairs;
+
+ /* get the metrics of the result list */
+ int32_t res_pairs, res_cpairs;
+ /* We now that lss has at least one elem */
+ check_list(K, true, kcar(lss), &res_pairs, &res_cpairs);
+ int32_t res_apairs = res_pairs - res_cpairs;
+
+ if (res_cpairs == 0) {
+ /* finite list of length res_pairs (all lists should
+ have the same structure: acyclic with same length) */
+ int32_t pairs = app_pairs - 1;
+ TValue tail = kcdr(lss);
+ while(pairs--) {
+ int32_t first_pairs, first_cpairs;
+ check_list(K, true, kcar(tail), &first_pairs, &first_cpairs);
+ tail = kcdr(tail);
+
+ if (first_cpairs != 0) {
+ klispE_throw_simple(K, "mixed finite and infinite lists");
+ return;
+ } else if (first_pairs != res_pairs) {
+ klispE_throw_simple(K, "lists of different length");
+ return;
+ }
+ }
+ } else {
+ /* cyclic list: all lists should be cyclic.
+ result will have acyclic length equal to the
+ max of all the lists and cyclic length equal to the lcm
+ of all the lists. res_pairs may be broken but will be
+ restored by after the loop */
+ int32_t pairs = app_pairs - 1;
+ TValue tail = kcdr(lss);
+ while(pairs--) {
+ int32_t first_pairs, first_cpairs;
+ check_list(K, true, kcar(tail), &first_pairs, &first_cpairs);
+ int32_t first_apairs = first_pairs - first_cpairs;
+ tail = kcdr(tail);
+
+ if (first_cpairs == 0) {
+ klispE_throw_simple(K, "mixed finite and infinite lists");
+ return;
+ }
+ res_apairs = kmax32(res_apairs, first_apairs);
+ /* this can throw an error if res_cpairs doesn't
+ fit in 32 bits, which is a reasonable implementation
+ restriction because the list wouldn't fit in memory
+ anyways */
+ res_cpairs = kcheck32(K, "map/for-each: result list is too big",
+ klcm32_64(res_cpairs, first_cpairs));
+ }
+ res_pairs = kcheck32(K, "map/for-each: result list is too big",
+ (int64_t) res_cpairs + (int64_t) res_apairs);
+ UNUSED(res_pairs);
+ }
+
+ *app_apairs_out = app_apairs;
+ *app_cpairs_out = app_cpairs;
+ *res_apairs_out = res_apairs;
+ *res_cpairs_out = res_cpairs;
+}
+
+/* Return two lists, isomorphic to lss: one list of cars and one list
+ of cdrs (replacing the value of lss) */
+
+/* GC: assumes lss is rooted */
+TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
+ int32_t apairs, int32_t cpairs)
+{
+ TValue tail = *lss;
+
+ TValue cars = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &cars);
+ TValue lp_cars = cars;
+ TValue lap_cars = lp_cars;
+
+ TValue cdrs = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &cdrs);
+ TValue lp_cdrs = cdrs;
+ TValue lap_cdrs = lp_cdrs;
+
+ while(apairs != 0 || cpairs != 0) {
+ int32_t pairs;
+ if (apairs != 0) {
+ pairs = apairs;
+ } else {
+ /* remember last acyclic pair of both lists to to encycle! later */
+ lap_cars = lp_cars;
+ lap_cdrs = lp_cdrs;
+ pairs = cpairs;
+ }
+
+ while(pairs--) {
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+
+ /* accumulate both cars and cdrs */
+ TValue np;
+ np = kcons(K, kcar(first), KNIL);
+ kset_cdr(lp_cars, np);
+ lp_cars = np;
+
+ np = kcons(K, kcdr(first), KNIL);
+ kset_cdr(lp_cdrs, np);
+ lp_cdrs = np;
+ }
+
+ if (apairs != 0) {
+ apairs = 0;
+ } else {
+ cpairs = 0;
+ /* encycle! the list of cars and the list of cdrs */
+ TValue fcp, lcp;
+ fcp = kcdr(lap_cars);
+ lcp = lp_cars;
+ kset_cdr(lcp, fcp);
+
+ fcp = kcdr(lap_cdrs);
+ lcp = lp_cdrs;
+ kset_cdr(lcp, fcp);
+ }
+ }
+
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ *lss = kcdr(cdrs);
+ return kcdr(cars);
+}
+
+/* Transpose lss so that the result is a list of lists, each one having
+ metrics (app_apairs, app_cpairs). The metrics of the returned list
+ should be (res_apairs, res_cpairs) */
+
+/* GC: assumes lss is rooted */
+TValue map_for_each_transpose(klisp_State *K, TValue lss,
+ int32_t app_apairs, int32_t app_cpairs,
+ int32_t res_apairs, int32_t res_cpairs)
+{
+ TValue tlist = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &tlist);
+ TValue lp = tlist;
+ TValue lap = lp;
+
+ TValue cars = KNIL; /* put something for GC */
+ TValue tail = lss;
+
+ /* GC: both cars & tail vary in each loop, to protect them we need
+ the vars stack */
+ krooted_vars_push(K, &cars);
+ krooted_vars_push(K, &tail);
+
+ /* Loop over list of lists, creating a list of cars and
+ a list of cdrs, accumulate the list of cars and loop
+ with the list of cdrs as the new list of lists (lss) */
+ while(res_apairs != 0 || res_cpairs != 0) {
+ int32_t pairs;
+
+ if (res_apairs != 0) {
+ pairs = res_apairs;
+ } else {
+ pairs = res_cpairs;
+ /* remember last acyclic pair to encycle! later */
+ lap = lp;
+ }
+
+ while(pairs--) {
+ /* accumulate cars and replace tail with cdrs */
+ cars = map_for_each_get_cars_cdrs(K, &tail, app_apairs, app_cpairs);
+ TValue np = kcons(K, cars, KNIL);
+ kset_cdr(lp, np);
+ lp = np;
+ }
+
+ if (res_apairs != 0) {
+ res_apairs = 0;
+ } else {
+ res_cpairs = 0;
+ /* encycle! the list of list of cars */
+ TValue fcp = kcdr(lap);
+ TValue lcp = lp;
+ kset_cdr(lcp, fcp);
+ }
+ }
+
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return kcdr(tlist);
+}
+
+/* Continuations that are used in more than one file */
+
+/* Helper for $sequence, $vau, $lambda, ... */
+/* 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
+ */
+ TValue ls = xparams[0];
+ TValue first = kcar(ls);
+ TValue tail = kcdr(ls);
+ TValue denv = xparams[1];
+
+ if (ttispair(tail)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, tail,
+ denv);
+ kset_cc(K, new_cont);
+#if KTRACK_SI
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
+#endif
+ }
+ ktail_eval(K, first, denv);
+}
+
+/* this is used for inner & outer continuations, it just
+ 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 = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ UNUSED(xparams);
+ kapply_cc(K, obj);
+}
+
+/*
+** Continuation that ignores the value received and instead returns
+** a previously computed value.
+*/
+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
+ */
+ UNUSED(obj);
+ TValue ret_obj = xparams[0];
+ kapply_cc(K, ret_obj);
+}
+
+/* binder returned */
+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
+ */
+ bind_2tp(K, ptree, "any", anytype, obj,
+ "combiner", ttiscombiner, comb);
+ UNUSED(denv); /* the combiner is called in an empty environment */
+ TValue key = xparams[0];
+ /* GC: root intermediate objs */
+ TValue new_flag = KTRUE;
+ TValue new_value = obj;
+ TValue old_flag = kcar(key);
+ TValue old_value = kcdr(key);
+ /* set the var to the new object */
+ kset_car(key, new_flag);
+ kset_cdr(key, new_value);
+ /* Old value must be protected from GC. It is no longer
+ reachable through key and not yet reachable through
+ continuation xparams. Boolean flag needn't be rooted,
+ because is not heap-allocated. */
+ krooted_tvs_push(K, old_value);
+ /* create a continuation to set the var to the correct value/flag on both
+ normal return and abnormal passes */
+ TValue new_cont = make_bind_continuation(K, key, old_flag, old_value,
+ new_flag, new_value);
+ krooted_tvs_pop(K);
+ kset_cc(K, new_cont); /* implicit rooting */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ TValue expr = kcons(K, comb, KNIL);
+ krooted_tvs_pop(K);
+ ktail_eval(K, expr, env)
+}
+
+/* accesor returned */
+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
+ */
+ check_0p(K, ptree);
+ UNUSED(denv);
+ TValue key = xparams[0];
+
+ if (kis_true(kcar(key))) {
+ kapply_cc(K, kcdr(key));
+ } else {
+ klispE_throw_simple(K, "variable is unbound");
+ return;
+ }
+}
+
+/* continuation to set the key to the old value on normal return */
+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
+ ** xparams[2]: old value
+ */
+
+ TValue key = xparams[0];
+ TValue old_flag = xparams[1];
+ TValue old_value = xparams[2];
+
+ kset_car(key, old_flag);
+ kset_cdr(key, old_value);
+ /* pass along the value returned to this continuation */
+ kapply_cc(K, obj);
+}
+
+/* operative for setting the key to the new/old flag/value */
+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
+ ** xparams[2]: value
+ */
+ TValue key = xparams[0];
+ TValue flag = xparams[1];
+ TValue value = xparams[2];
+ UNUSED(denv);
+
+ kset_car(key, flag);
+ kset_cdr(key, value);
+
+ /* pass to next interceptor/ final destination */
+ /* ptree is as for interceptors: (obj divert) */
+ TValue obj = kcar(ptree);
+ kapply_cc(K, obj);
+}
+
+/* /Continuations that are used in more than one file */
+
+/* dynamic keys */
+/* create continuation to set the key on both normal return and
+ abnormal passes */
+/* TODO: reuse the code for guards in kgcontinuations.c */
+
+/* GC: this assumes that key, old_value and new_value are rooted */
+TValue make_bind_continuation(klisp_State *K, TValue key,
+ TValue old_flag, TValue old_value,
+ TValue new_flag, TValue new_value)
+{
+ TValue unbind_cont = kmake_continuation(K, kget_cc(K),
+ do_unbind, 3, key, old_flag,
+ old_value);
+ krooted_tvs_push(K, unbind_cont);
+ /* create the guards to guarantee that the values remain consistent on
+ abnormal passes (in both directions) */
+ TValue exit_int = kmake_operative(K, do_set_pass,
+ 3, key, old_flag, old_value);
+ krooted_tvs_push(K, exit_int);
+ TValue exit_guard = kcons(K, K->root_cont, exit_int);
+ krooted_tvs_pop(K); /* already rooted in guard */
+ krooted_tvs_push(K, exit_guard);
+ TValue exit_guards = kcons(K, exit_guard, KNIL);
+ krooted_tvs_pop(K); /* already rooted in guards */
+ krooted_tvs_push(K, exit_guards);
+
+ TValue entry_int = kmake_operative(K, do_set_pass,
+ 3, key, new_flag, new_value);
+ krooted_tvs_push(K, entry_int);
+ TValue entry_guard = kcons(K, K->root_cont, entry_int);
+ krooted_tvs_pop(K); /* already rooted in guard */
+ krooted_tvs_push(K, entry_guard);
+ TValue entry_guards = kcons(K, entry_guard, KNIL);
+ krooted_tvs_pop(K); /* already rooted in guards */
+ krooted_tvs_push(K, entry_guards);
+
+
+ /* NOTE: in the stack now we have the unbind cont & two guard lists */
+ /* this is needed for interception code */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ TValue outer_cont = kmake_continuation(K, unbind_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);
+
+ /* unbind_cont & 2 guard_lists */
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
+ /* env & outer_cont */
+ krooted_tvs_pop(K); krooted_tvs_pop(K);
+
+ return inner_cont;
+}
+
+/* Helpers for guard-continuation (& guard-dynamic-extent) */
+
+#define singly_wrapped(obj_) (ttisapplicative(obj_) && \
+ ttisoperative(kunwrap(obj_)))
+
+/* this unmarks root before throwing any error */
+/* TODO: this isn't very clean, refactor */
+
+/* GC: assumes obj & root are rooted */
+inline TValue check_copy_single_entry(klisp_State *K, char *name,
+ TValue obj, TValue root)
+{
+ if (!ttispair(obj) || !ttispair(kcdr(obj)) ||
+ !ttisnil(kcddr(obj))) {
+ unmark_list(K, root);
+ klispE_throw_simple(K, "Bad entry (expected list of length 2)");
+ return KINERT;
+ }
+ TValue cont = kcar(obj);
+ TValue app = kcadr(obj);
+
+ if (!ttiscontinuation(cont)) {
+ unmark_list(K, root);
+ klispE_throw_simple(K, "Bad type on first element (expected "
+ "continuation)");
+ return KINERT;
+ } else if (!singly_wrapped(app)) {
+ unmark_list(K, root);
+ klispE_throw_simple(K, "Bad type on second element (expected "
+ "singly wrapped applicative)");
+ return KINERT;
+ }
+
+ /* save the operative directly, don't waste space/time
+ with a list, use just a pair */
+ return kcons(K, cont, kunwrap(app));
+}
+
+/* the guards are probably generated on the spot so we don't check
+ for immutability and copy it anyways */
+/* GC: Assumes obj is rooted */
+TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
+{
+ if (ttisnil(obj)) {
+ return obj;
+ } else {
+ TValue copy = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, ©);
+ TValue last_pair = copy;
+ TValue tail = obj;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ /* this will clear the marks and throw an error if the structure
+ is incorrect */
+ TValue entry = check_copy_single_entry(K, name, kcar(tail), obj);
+ krooted_tvs_push(K, entry);
+ TValue new_pair = kcons(K, entry, KNIL);
+ krooted_tvs_pop(K);
+ kmark(tail);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ }
+
+ /* dont close the cycle (if there is one) */
+ unmark_list(K, obj);
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
+ }
+ krooted_vars_pop(K);
+ return kcdr(copy);
+ }
+}
+
+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,
+ "combiner", ttiscombiner, comb,
+ "any", anytype, exit_guards);
+
+ entry_guards = check_copy_guards(K, "guard-dynamic-extent: entry guards",
+ entry_guards);
+ krooted_tvs_push(K, entry_guards);
+ exit_guards = check_copy_guards(K, "guard-dynamic-extent: exit guards",
+ exit_guards);
+ krooted_tvs_push(K, exit_guards);
+ /* GC: root continuations */
+ /* The current continuation is guarded */
+ TValue outer_cont = kmake_continuation(K, kget_cc(K), do_pass_value,
+ 2, entry_guards, denv);
+ kset_outer_cont(outer_cont);
+ kset_cc(K, outer_cont); /* this implicitly roots outer_cont */
+
+ TValue inner_cont = kmake_continuation(K, outer_cont, do_pass_value, 2,
+ exit_guards, denv);
+ kset_inner_cont(inner_cont);
+
+ /* call combiner with no operands in the dynamic extent of inner,
+ with the dynamic env of this call */
+ kset_cc(K, inner_cont); /* this implicitly roots inner_cont */
+ TValue expr = kcons(K, comb, KNIL);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ ktail_eval(K, expr, denv);
+}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -23,10 +23,83 @@
#include "kcontinuation.h"
#include "kenvironment.h"
#include "ksymbol.h"
+#include "kstring.h"
+#include "ktable.h"
+
+/*
+** REFACTOR split this file into several.
+** Some should have their own files (like knumber, kbool, etc)
+** Others are simply helpers that should be split into modules
+** (like continuation helpers, list helpers, environment helpers)
+*/
+
+/* Initialization of continuation names */
+void kinit_kghelpers_cont_names(klisp_State *K);
/* to use in type checking binds when no check is needed */
#define anytype(obj_) (true)
+/* Type predicates */
+/* TODO these should be moved to either kobject.h or the corresponding
+ files (e.g. kbooleanp to kboolean.h */
+bool kbooleanp(TValue obj);
+bool kcombinerp(TValue obj);
+bool knumberp(TValue obj);
+bool knumber_wpvp(TValue obj);
+bool kfinitep(TValue obj);
+bool kintegerp(TValue obj);
+bool keintegerp(TValue obj);
+bool krationalp(TValue obj);
+bool krealp(TValue obj);
+bool kreal_wpvp(TValue obj);
+bool kexactp(TValue obj);
+bool kinexactp(TValue obj);
+bool kundefinedp(TValue obj);
+bool krobustp(TValue obj);
+bool ku8p(TValue obj);
+/* This is used in gcd & lcm */
+bool kimp_intp(TValue obj);
+
+/* needed by kgffi.c and encapsulations */
+void enc_typep(klisp_State *K);
+
+/* /Type predicates */
+
+/* some number predicates */
+/* REFACTOR: These should be in a knumber.h header */
+
+/* Misc Helpers */
+/* TEMP: only reals (no complex numbers) */
+bool kpositivep(TValue n);
+bool knegativep(TValue n);
+
+inline bool kfast_zerop(TValue n)
+{
+ return (ttisfixint(n) && ivalue(n) == 0) ||
+ (ttisdouble(n) && dvalue(n) == 0.0);
+}
+
+inline bool kfast_onep(TValue n)
+{
+ return (ttisfixint(n) && ivalue(n) == 1) ||
+ (ttisdouble(n) && dvalue(n) == 1.0);
+}
+
+inline TValue kneg_inf(TValue i)
+{
+ if (ttiseinf(i))
+ return tv_equal(i, KEPINF)? KEMINF : KEPINF;
+ else /* ttisiinf(i) */
+ return tv_equal(i, KIPINF)? KIMINF : KIPINF;
+}
+
+inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
+{
+ return kpositivep(n1) == kpositivep(n2);
+}
+
+/* /some number predicates */
+
/*
** NOTE: these are intended to be used at the beginning of a function
** they expand to more than one statement and may evaluate some of
@@ -265,99 +338,40 @@ inline void unmark_tree(klisp_State *K, TValue obj)
/* TODO: move all bools to a flag parameter (with constants like
KCHK_LS_FORCE_COPY, KCHK_ALLOW_CYCLE, KCHK_AVOID_ENCYCLE, etc) */
-
-/* typed finite list. Structure error should be throw before type errors */
-int32_t check_typed_list(klisp_State *K, char *name, char *typename,
- bool (*typep)(TValue), bool allow_infp, TValue obj,
- int32_t *cpairs);
+/* typed finite list. Structure error are thrown before type errors */
+void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp,
+ TValue obj, int32_t *pairs, int32_t *cpairs);
/* 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, const char *name, bool allow_infp,
- TValue obj, int32_t *cpairs);
-
-/*
-** MAYBE: These shouldn't be inline really.
-*/
+void check_list(klisp_State *K, bool allow_infp, TValue obj,
+ int32_t *pairs, int32_t *cpairs);
-
-/* REFACTOR: return the number of pairs and cycle pairs in two extra params */
+/* TODO: add unchecked_copy_list */
/* TODO: add check_copy_typed_list */
-/* TODO: remove inline */
/* check that obj is a list and make a copy if it is not immutable or
force_copy is true */
-/* GC: assumes obj is rooted, use dummy3 */
-inline TValue check_copy_list(klisp_State *K, char *name, TValue obj,
- bool force_copy)
-{
- if (ttisnil(obj))
- return obj;
-
- if (ttispair(obj) && kis_immutable(obj) && !force_copy) {
- UNUSED(check_list(K, name, true, obj, NULL));
- return obj;
- } else {
- TValue last_pair = kget_dummy3(K);
- TValue tail = obj;
-
- while(ttispair(tail) && !kis_marked(tail)) {
- TValue new_pair = kcons(K, kcar(tail), KNIL);
- /* record the corresponding pair to simplify cycle handling */
- kset_mark(tail, new_pair);
- /* copy the source code info */
- TValue si = ktry_get_si(K, tail);
- if (!ttisnil(si))
- kset_source_info(K, new_pair, si);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- }
-
- if (ttispair(tail)) {
- /* complete the cycle */
- kset_cdr(last_pair, kget_mark(tail));
- }
-
- unmark_list(K, obj);
-
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
- }
- return kcutoff_dummy3(K);
- }
-}
+/* GC: assumes obj is rooted */
+TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
+ int32_t *pairs, int32_t *cpairs);
/* check that obj is a list of environments and make a copy but don't keep
the cycles */
-/* GC: assume obj is rooted, uses dummy3 */
-inline TValue check_copy_env_list(klisp_State *K, char *name, TValue obj)
-{
- TValue last_pair = kget_dummy3(K);
- TValue tail = obj;
-
- while(ttispair(tail) && !kis_marked(tail)) {
- TValue first = kcar(tail);
- if (!ttisenvironment(first)) {
- klispE_throw_simple(K, "not an environment in parent list");
- return KINERT;
- }
- TValue new_pair = kcons(K, first, KNIL);
- kmark(tail);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- }
-
- /* even if there was a cycle, the copy ends with nil */
- unmark_list(K, obj);
-
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
- }
- return kcutoff_dummy3(K);
-}
+/* GC: assume obj is rooted */
+TValue check_copy_env_list(klisp_State *K, TValue obj);
+
+/* The assimetry in error checking in the following functions
+ is a product of the contexts in which they are used, see the
+ .c for an enumeration of such contexts */
+/* list->? conversion functions, only type errors of elems checked */
+TValue list_to_string_h(klisp_State *K, TValue ls, int32_t length);
+TValue list_to_vector_h(klisp_State *K, TValue ls, int32_t length);
+TValue list_to_bytevector_h(klisp_State *K, TValue ls, int32_t length);
+
+/* ?->list conversion functions, type checked */
+TValue string_to_list_h(klisp_State *K, TValue obj, int32_t *length);
+TValue vector_to_list_h(klisp_State *K, TValue obj, int32_t *length);
+TValue bytevector_to_list_h(klisp_State *K, TValue obj, int32_t *length);
/*
** Generic function for type predicates
@@ -394,18 +408,23 @@ void ftyped_bpredp(klisp_State *K);
/* TODO unify them */
void ftyped_kbpredp(klisp_State *K);
-
-/*
-** Continuation that ignores the value received and instead returns
-** a previously computed value.
-*/
+/* Continuations that are used in more than one file */
+void do_seq(klisp_State *K);
+void do_pass_value(klisp_State *K);
void do_return_value(klisp_State *K);
+void do_bind(klisp_State *K);
+void do_access(klisp_State *K);
+void do_unbind(klisp_State *K);
+void do_set_pass(klisp_State *K);
+/* /Continuations that are used in more than one file */
-/* GC: assumes parent & obj are rooted */
-inline TValue make_return_value_cont(klisp_State *K, TValue parent, TValue obj)
-{
- return kmake_continuation(K, parent, do_return_value, 1, obj);
-}
+/* dynamic var */
+TValue make_bind_continuation(klisp_State *K, TValue key,
+ TValue old_flag, TValue old_value,
+ TValue new_flag, TValue new_value);
+
+TValue check_copy_guards(klisp_State *K, char *name, TValue obj);
+void guard_dynamic_extent(klisp_State *K);
/* Some helpers for working with fixints (signed 32 bits) */
inline int32_t kabs32(int32_t a) { return a < 0? -a : a; }
@@ -427,6 +446,61 @@ inline int32_t kcheck32(klisp_State *K, char *msg, int64_t i)
int64_t kgcd32_64(int32_t a, int32_t b);
int64_t klcm32_64(int32_t a, int32_t b);
+/*
+** Other
+*/
+
+/* memoize applicative (used in kstate & promises) */
+void memoize(klisp_State *K);
+/* list applicative (used in kstate and kgpairs_lists) */
+void list(klisp_State *K);
+
+/* Helper for list-tail, list-ref and list-set! */
+int32_t ksmallest_index(klisp_State *K, TValue obj, TValue tk);
+
+/* Helper for get-list-metrics, and list-tail, list-ref and list-set!
+ when receiving bigint indexes */
+void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
+ int32_t *a, int32_t *c);
+
+/* Helper for eq? and equal? */
+bool eq2p(klisp_State *K, TValue obj1, TValue obj2);
+
+/* Helper for equal?, assoc and member */
+/* compare two objects and check to see if they are "equal?". */
+bool equal2p(klisp_State *K, TValue obj1, TValue obj2);
+
+/* Helper (also used by $vau, $lambda, etc) */
+TValue copy_es_immutable_h(klisp_State *K, TValue ptree, bool mut_flag);
+
+/* ptree handling */
+void match(klisp_State *K, TValue env, TValue ptree, TValue obj);
+TValue check_copy_ptree(klisp_State *K, TValue ptree, TValue penv);
+
+/* map/$for-each */
+/* Helpers for map (also used by for-each) */
+
+/* Calculate the metrics for both the result list and the ptree
+ passed to the applicative */
+void map_for_each_get_metrics(
+ klisp_State *K, TValue lss, int32_t *app_apairs_out,
+ int32_t *app_cpairs_out, int32_t *res_apairs_out, int32_t *res_cpairs_out);
+
+/* Return two lists, isomorphic to lss: one list of cars and one list
+ of cdrs (replacing the value of lss) */
+/* GC: Assumes lss is rooted */
+TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
+ int32_t apairs, int32_t cpairs);
+
+/* Transpose lss so that the result is a list of lists, each one having
+ metrics (app_apairs, app_cpairs). The metrics of the returned list
+ should be (res_apairs, res_cpairs) */
+
+/* GC: Assumes lss is rooted */
+TValue map_for_each_transpose(klisp_State *K, TValue lss,
+ int32_t app_apairs, int32_t app_cpairs,
+ int32_t res_apairs, int32_t res_cpairs);
+
/*
** Macros for ground environment initialization
@@ -436,13 +510,13 @@ int64_t klcm32_64(int32_t a, int32_t b);
** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
** "value", both of type TValue. symbol will be bound to a symbol named by
** "n_" and can be referrenced in the var_args
-** GC: All of these should be called when GC is deactivated on startup
+** GC: All of these should be called when GC is deactivated
*/
/* TODO add si to the symbols */
#if KTRACK_SI
#define add_operative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_, KNIL); \
+ { symbol = ksymbol_new_b(K_, n_, KNIL); \
value = kmake_operative(K_, fn_, __VA_ARGS__); \
TValue str = kstring_new_b_imm(K_, __FILE__); \
TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
@@ -451,7 +525,7 @@ int64_t klcm32_64(int32_t a, int32_t b);
kadd_binding(K_, env_, symbol, value); }
#define add_applicative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_, KNIL); \
+ { symbol = ksymbol_new_b(K_, n_, KNIL); \
value = kmake_applicative(K_, fn_, __VA_ARGS__); \
TValue str = kstring_new_b_imm(K_, __FILE__); \
TValue si = kcons(K, str, kcons(K_, i2tv(__LINE__), \
@@ -461,19 +535,27 @@ int64_t klcm32_64(int32_t a, int32_t b);
kadd_binding(K_, env_, symbol, value); }
#else /* KTRACK_SI */
#define add_operative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_, KNIL); \
+ { symbol = ksymbol_new_b(K_, n_, KNIL); \
value = kmake_operative(K_, fn_, __VA_ARGS__); \
kadd_binding(K_, env_, symbol, value); }
#define add_applicative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_); \
+ { symbol = ksymbol_new_b(K_, n_, KNIL); \
value = kmake_applicative(K_, fn_, __VA_ARGS__); \
kadd_binding(K_, env_, symbol, value); }
#endif /* KTRACK_SI */
#define add_value(K_, env_, n_, v_) \
{ value = v_; \
- symbol = ksymbol_new(K_, n_, KNIL); \
+ symbol = ksymbol_new_b(K_, n_, KNIL); \
kadd_binding(K_, env_, symbol, v_); }
#endif
+
+/* for initiliazing continuation names */
+#define add_cont_name(K_, t_, c_, n_) \
+ { TValue str = kstring_new_b_imm(K_, n_); \
+ TValue *node = klispH_set(K_, t_, p2tv(c_)); \
+ *node = str; \
+ }
+
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -20,7 +20,6 @@
#include "kerror.h"
#include "kghelpers.h"
-#include "kgcontinuations.h" /* for do_pass_value / guards */
#include "kgkd_vars.h"
/*
@@ -30,172 +29,8 @@
*/
/* Helpers for make-keyed-dynamic-variable */
+/* in kghelpers */
-/* accesor returned */
-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
- */
- check_0p(K, ptree);
- UNUSED(denv);
- TValue key = xparams[0];
-
- if (kis_true(kcar(key))) {
- kapply_cc(K, kcdr(key));
- } else {
- klispE_throw_simple(K, "variable is unbound");
- return;
- }
-}
-
-/* continuation to set the key to the old value on normal return */
-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
- ** xparams[2]: old value
- */
-
- TValue key = xparams[0];
- TValue old_flag = xparams[1];
- TValue old_value = xparams[2];
-
- kset_car(key, old_flag);
- kset_cdr(key, old_value);
- /* pass along the value returned to this continuation */
- kapply_cc(K, obj);
-}
-
-/* operative for setting the key to the new/old flag/value */
-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
- ** xparams[2]: value
- */
- TValue key = xparams[0];
- TValue flag = xparams[1];
- TValue value = xparams[2];
- UNUSED(denv);
-
- kset_car(key, flag);
- kset_cdr(key, value);
-
- /* pass to next interceptor/ final destination */
- /* ptree is as for interceptors: (obj divert) */
- TValue obj = kcar(ptree);
- kapply_cc(K, obj);
-}
-
-/* create continuation to set the key on both normal return and
- abnormal passes */
-/* TODO: reuse the code for guards in kgcontinuations.c */
-
-/* GC: this assumes that key, old_value and new_value are rooted */
-inline TValue make_bind_continuation(klisp_State *K, TValue key,
- TValue old_flag, TValue old_value,
- TValue new_flag, TValue new_value)
-{
- TValue unbind_cont = kmake_continuation(K, kget_cc(K),
- do_unbind, 3, key, old_flag,
- old_value);
- krooted_tvs_push(K, unbind_cont);
- /* create the guards to guarantee that the values remain consistent on
- abnormal passes (in both directions) */
- TValue exit_int = kmake_operative(K, do_set_pass,
- 3, key, old_flag, old_value);
- krooted_tvs_push(K, exit_int);
- TValue exit_guard = kcons(K, K->root_cont, exit_int);
- krooted_tvs_pop(K); /* already rooted in guard */
- krooted_tvs_push(K, exit_guard);
- TValue exit_guards = kcons(K, exit_guard, KNIL);
- krooted_tvs_pop(K); /* already rooted in guards */
- krooted_tvs_push(K, exit_guards);
-
- TValue entry_int = kmake_operative(K, do_set_pass,
- 3, key, new_flag, new_value);
- krooted_tvs_push(K, entry_int);
- TValue entry_guard = kcons(K, K->root_cont, entry_int);
- krooted_tvs_pop(K); /* already rooted in guard */
- krooted_tvs_push(K, entry_guard);
- TValue entry_guards = kcons(K, entry_guard, KNIL);
- krooted_tvs_pop(K); /* already rooted in guards */
- krooted_tvs_push(K, entry_guards);
-
-
- /* NOTE: in the stack now we have the unbind cont & two guard lists */
- /* this is needed for interception code */
- TValue env = kmake_empty_environment(K);
- krooted_tvs_push(K, env);
- TValue outer_cont = kmake_continuation(K, unbind_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);
-
- /* unbind_cont & 2 guard_lists */
- krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
- /* env & outer_cont */
- krooted_tvs_pop(K); krooted_tvs_pop(K);
-
- return inner_cont;
-}
-
-/* binder returned */
-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
- */
- bind_2tp(K, ptree, "any", anytype, obj,
- "combiner", ttiscombiner, comb);
- UNUSED(denv); /* the combiner is called in an empty environment */
- TValue key = xparams[0];
- /* GC: root intermediate objs */
- TValue new_flag = KTRUE;
- TValue new_value = obj;
- TValue old_flag = kcar(key);
- TValue old_value = kcdr(key);
- /* set the var to the new object */
- kset_car(key, new_flag);
- kset_cdr(key, new_value);
- /* Old value must be protected from GC. It is no longer
- reachable through key and not yet reachable through
- continuation xparams. Boolean flag needn't be rooted,
- because is not heap-allocated. */
- krooted_tvs_push(K, old_value);
- /* create a continuation to set the var to the correct value/flag on both
- normal return and abnormal passes */
- TValue new_cont = make_bind_continuation(K, key, old_flag, old_value,
- new_flag, new_value);
- krooted_tvs_pop(K);
- kset_cc(K, new_cont); /* implicit rooting */
- TValue env = kmake_empty_environment(K);
- krooted_tvs_push(K, env);
- TValue expr = kcons(K, comb, KNIL);
- krooted_tvs_pop(K);
- ktail_eval(K, expr, env)
-}
/* 10.1.1 make-keyed-dynamic-variable */
void make_keyed_dynamic_variable(klisp_State *K)
diff --git a/src/kgkd_vars.h b/src/kgkd_vars.h
@@ -7,25 +7,7 @@
#ifndef kgkd_vars_h
#define kgkd_vars_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"
-
-/* This is also used by kgports.c */
-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);
-
-void do_unbind(klisp_State *K);
/* init ground */
void kinit_kgkd_vars_ground_env(klisp_State *K);
diff --git a/src/kgks_vars.h b/src/kgks_vars.h
@@ -7,19 +7,7 @@
#ifndef kgks_vars_h
#define kgks_vars_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"
-
-/* 11.1.1 make-static-dynamic-variable */
-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
@@ -11,9 +11,11 @@
#include <assert.h>
#include <stdio.h>
+#include <string.h>
#include <stdlib.h>
#include <stdbool.h>
#include <stdint.h>
+#include <inttypes.h> /* for string conversion */
#include "kstate.h"
#include "kobject.h"
@@ -28,42 +30,10 @@
#include "kghelpers.h"
#include "kgnumbers.h"
-#include "kgkd_vars.h" /* for strict arith flag */
/* 15.5.1? number?, finite?, integer? */
/* use ftypep & ftypep_predp */
-/* Helpers for typed predicates */
-bool knumberp(TValue obj) { return ttisnumber(obj); }
-/* TEMP used (as a type predicate) in all predicates that need a primary value
- (XXX it's not actually a type error, but it's close enough and otherwise
- should define new predp & bpredp for numeric predicates...) */
-bool knumber_wpvp(TValue obj)
-{
- return ttisnumber(obj) && !ttisrwnpv(obj) && !ttisundef(obj);
-}
-/* This is used in gcd & lcm */
-bool kimp_intp(TValue obj) { return ttisinteger(obj) || ttisinf(obj); }
-/* obj is known to be a number */
-bool kfinitep(TValue obj) { return !ttisinf(obj); }
-/* fixint, bigints & inexact integers */
-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
- primary value (XXX it's not actually a type error, but it's close enough
- and otherwise should define new predp & bpredp for numeric predicates...) */
-bool kreal_wpvp(TValue obj) { return ttisreal(obj) && !ttisrwnpv(obj); }
-
-bool kexactp(TValue obj) { return ttisexact(obj); }
-bool kinexactp(TValue obj) { return ttisinexact(obj); }
-bool kundefinedp(TValue obj) { return ttisundef(obj); }
-bool krobustp(TValue obj) { return ttisrobust(obj); }
-
/* 12.5.2 =? */
/* uses typed_bpredp */
@@ -907,9 +877,8 @@ void kplus(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
- int32_t cpairs;
- int32_t pairs = check_typed_list(K, "+", "number", knumberp,
- true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_typed_list(K, knumberp, true, ptree, &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue res;
@@ -978,9 +947,8 @@ void ktimes(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
- int32_t cpairs;
- int32_t pairs = check_typed_list(K, "*", "number", knumberp, true,
- ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_typed_list(K, knumberp, true, ptree, &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue res;
@@ -1060,7 +1028,7 @@ void kminus(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
- int32_t cpairs;
+ int32_t pairs, cpairs;
/* - in kernel (and unlike in scheme) requires at least 2 arguments */
if (!ttispair(ptree) || !ttispair(kcdr(ptree))) {
@@ -1071,8 +1039,7 @@ void kminus(klisp_State *K)
return;
}
TValue first_val = kcar(ptree);
- int32_t pairs = check_typed_list(K, "-", "number", knumberp, true,
- kcdr(ptree), &cpairs);
+ check_typed_list(K, knumberp, true, kcdr(ptree), &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue res;
@@ -1206,6 +1173,11 @@ int32_t kfixint_div0_mod0(int32_t n, int32_t d, int32_t *res_mod)
return div;
}
+/* Helper for div and mod */
+#define FDIV_DIV 1
+#define FDIV_MOD 2
+#define FDIV_ZERO 4
+
/* flags are FDIV_DIV, FDIV_MOD, FDIV_ZERO */
void kdiv_mod(klisp_State *K)
{
@@ -1374,48 +1346,7 @@ void kdiv_mod(klisp_State *K)
/* use ftyped_predp */
/* Helpers for positive?, negative?, odd? & even? */
-bool kpositivep(TValue n)
-{
- switch (ttype(n)) {
- case K_TFIXINT:
- case K_TEINF:
- case K_TIINF:
- return ivalue(n) > 0;
- case K_TBIGINT:
- return kbigint_positivep(n);
- case K_TBIGRAT:
- return kbigrat_positivep(n);
- case K_TDOUBLE:
- return dvalue(n) > 0.0;
- /* real with no prim value, complex and undefined should be captured by
- type predicate */
- default:
- klisp_assert(0);
- return false;
- }
-}
-
-bool knegativep(TValue n)
-{
- switch (ttype(n)) {
- case K_TFIXINT:
- case K_TEINF:
- case K_TIINF:
- return ivalue(n) < 0;
- case K_TBIGINT:
- return kbigint_negativep(n);
- case K_TBIGRAT:
- return kbigrat_negativep(n);
- case K_TDOUBLE:
- return dvalue(n) < 0.0;
- /* real with no prim value, complex and undefined should be captured by
- type predicate */
- default:
- klisp_assert(0);
- return false;
- }
-}
-
+/* positive and negative, in kghelpers */
/* n is finite, integer */
bool koddp(TValue n)
{
@@ -1467,6 +1398,9 @@ void kabs(klisp_State *K)
kapply_cc(K, res);
}
+#define FMIN (true)
+#define FMAX (false)
+
/* 12.5.13 min, max */
/* NOTE: this does two passes, one for error checking and one for doing
the actual work */
@@ -1482,21 +1416,15 @@ void kmin_max(klisp_State *K)
*/
UNUSED(denv);
- char *name = ksymbol_buf(xparams[0]);
bool minp = bvalue(xparams[1]);
/* cycles are allowed, loop counting pairs */
- int32_t dummy; /* don't care about count of cycle pairs */
- int32_t pairs = check_typed_list(K, name, "number", knumberp, true, ptree,
- &dummy);
+ int32_t pairs;
+ check_typed_list(K, knumberp, true, ptree, &pairs, NULL);
TValue res;
- if (minp) {
- res = KEPINF;
- } else {
- res = KEMINF;
- }
+ res = minp? KEPINF : KEMINF;
TValue tail = ptree;
bool (*cmp)(klisp_State *K, TValue, TValue) = minp? knum_ltp : knum_gtp;
@@ -1521,8 +1449,8 @@ void kgcd(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
/* cycles are allowed, loop counting pairs */
- int32_t pairs = check_typed_list(K, "gcd", "improper integer", kimp_intp,
- true, ptree, NULL);
+ int32_t pairs;
+ check_typed_list(K, kimp_intp, true, ptree, &pairs, NULL);
TValue res = i2tv(0);
krooted_vars_push(K, &res);
@@ -1559,8 +1487,8 @@ void klcm(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
/* cycles are allowed, loop counting pairs */
- int32_t pairs = check_typed_list(K, "lcm", "improper integer", kimp_intp,
- true, ptree, NULL);
+ int32_t pairs;
+ check_typed_list(K, kimp_intp, true, ptree, &pairs, NULL);
/* report: this will cover the case of (lcm) = 1 */
TValue res = i2tv(1);
@@ -1775,7 +1703,7 @@ void kdivided(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
- int32_t cpairs;
+ int32_t pairs, cpairs;
/* / in kernel (and unlike in scheme) requires at least 2 arguments */
if (!ttispair(ptree) || !ttispair(kcdr(ptree))) {
@@ -1786,8 +1714,7 @@ void kdivided(klisp_State *K)
return;
}
TValue first_val = kcar(ptree);
- int32_t pairs = check_typed_list(K, "/", "number", knumberp, true,
- kcdr(ptree), &cpairs);
+ check_typed_list(K, knumberp, true, kcdr(ptree), &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue res;
@@ -2343,6 +2270,232 @@ void kexpt(klisp_State *K)
arith_kapply_cc(K, res);
}
+/* Number<->String conversion */
+void number_to_string(klisp_State *K)
+{
+ /* MAYBE this code could be factored out and used in kwrite too,
+ but maybe it's too much allocation for kwrite in the simpler cases */
+ 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_al1tp(K, ptree, "number", knumberp, obj, maybe_radix);
+ int radix = 10;
+ if (get_opt_tpar(K, maybe_radix, "radix (2, 8, 10, or 16)", ttisradix))
+ radix = ivalue(maybe_radix);
+
+ char small_buf[64]; /* for fixints */
+ TValue buf_str = K->empty_string; /* for bigrats, bigints and doubles */
+ krooted_vars_push(K, &buf_str);
+ char *buf;
+
+ switch(ttype(obj)) {
+ case K_TFIXINT: {
+ /* can't use snprintf here... there's no support for binary,
+ so just do by hand */
+ uint32_t value;
+ /* convert to unsigned to write */
+ value = (uint32_t) ((ivalue(obj) < 0)?
+ -((int64_t) ivalue(obj)) :
+ ivalue(obj));
+ char *digits = "0123456789abcdef";
+ /* write backwards so we don't have to reverse the buffer */
+ buf = small_buf + sizeof(small_buf) - 1;
+ *buf-- = '\0';
+ do {
+ *buf-- = digits[value % radix];
+ value /= radix;
+ } while(value > 0); /* with the guard down it works for zero too */
+
+ /* only put the sign if negative,
+ then correct the pointer to the first char */
+ if (ivalue(obj) < 0)
+ *buf = '-';
+ else
+ ++buf;
+ break;
+ }
+ case K_TBIGINT: {
+ int32_t size = kbigint_print_size(obj, radix);
+ /* here we are using 1 byte extra, because size already includes
+ 1 for the terminator, but better be safe than sorry */
+ buf_str = kstring_new_s(K, size);
+ buf = kstring_buf(buf_str);
+ kbigint_print_string(K, obj, radix, buf, size);
+ /* the string will be copied and trimmed later,
+ because print_size may overestimate */
+ break;
+ }
+ case K_TBIGRAT: {
+ int32_t size = kbigrat_print_size(obj, radix);
+ /* here we are using 1 byte extra, because size already includes
+ 1 for the terminator, but better be safe than sorry */
+ buf_str = kstring_new_s(K, size);
+ buf = kstring_buf(buf_str);
+ kbigrat_print_string(K, obj, radix, buf, size);
+ /* the string will be copied and trimmed later,
+ because print_size may overestimate */
+ break;
+ }
+ case K_TEINF:
+ buf = tv_equal(obj, KEPINF)? "#e+infinity" : "#e-infinity";
+ break;
+ case K_TIINF:
+ buf = tv_equal(obj, KIPINF)? "#i+infinity" : "#i-infinity";
+ break;
+ case K_TDOUBLE: {
+ if (radix != 10) {
+ /* only radix 10 is supported for inexact numbers
+ see rationale in the report (technically they could be
+ printed without a decimal point, like fractions, but...*/
+ klispE_throw_simple_with_irritants(K, "radix != 10 with inexact "
+ "number", 2, obj,maybe_radix);
+ return;
+ }
+ /* radix is always 10 */
+ int32_t size = kdouble_print_size(obj);
+ /* here we are using 1 byte extra, because size already includes
+ 1 for the terminator, but better be safe than sorry */
+ buf_str = kstring_new_s(K, size);
+ buf = kstring_buf(buf_str);
+ kdouble_print_string(K, obj, buf, size);
+ /* the string will be copied and trimmed later,
+ because print_size may overestimate */
+ break;
+ }
+ case K_TRWNPV:
+ buf = "#real";
+ break;
+ case K_TUNDEFINED:
+ buf = "#undefined";
+ break;
+ default:
+ /* shouldn't happen */
+ klisp_assert(0);
+ }
+
+ TValue str = kstring_new_b(K, buf);
+ krooted_vars_pop(K);
+ kapply_cc(K, str);
+}
+
+struct kspecial_number {
+ const char *ext_rep; /* downcase external representation */
+ TValue obj;
+} kspecial_numbers[] = { { "#e+infinity", KEPINF_ },
+ { "#e-infinity", KEMINF_ },
+ { "#i+infinity", KIPINF_ },
+ { "#i-infinity", KIMINF_ },
+ { "#real", KRWNPV_ },
+ { "#undefined", KUNDEF_ }
+};
+
+/* N.B. If case insignificance is removed, check here too!
+ This will happily accept exactness and radix arguments in both cases
+ (but not the names of special numbers) */
+void string_to_number(klisp_State *K)
+{
+ /* MAYBE try to unify with ktoken */
+
+ 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_al1tp(K, ptree, "string", ttisstring, str, maybe_radix);
+ int radix = 10;
+ if (get_opt_tpar(K, maybe_radix, "radix (2, 8, 10, or 16)", ttisradix))
+ radix = ivalue(maybe_radix);
+
+ /* track length to throw better error msgs */
+ char *buf = kstring_buf(str);
+ int32_t len = kstring_size(str);
+
+ /* if at some point we reach the end of the string
+ the char will be '\0' and will fail all tests,
+ so there is no need to test the length explicitly */
+ bool has_exactp = false;
+ bool exactp = false; /* the default exactness will depend on the format */
+ bool has_radixp = false;
+
+ TValue res = KINERT;
+ size_t snum_size = sizeof(kspecial_numbers) /
+ sizeof(struct kspecial_number);
+ for (int i = 0; i < snum_size; i++) {
+ struct kspecial_number number = kspecial_numbers[i];
+ /* NOTE: must check type because buf may contain embedded '\0's */
+ if (len == strlen(number.ext_rep) &&
+ strcmp(number.ext_rep, buf) == 0) {
+ res = number.obj;
+ break;
+ }
+ }
+ if (ttisinert(res)) {
+ /* number wasn't a special number */
+ while (*buf == '#') {
+ switch(*++buf) {
+ case 'e': case 'E': case 'i': case 'I':
+ if (has_exactp) {
+ klispE_throw_simple_with_irritants(
+ K, "two exactness prefixes", 1, str);
+ return;
+ }
+ has_exactp = true;
+ exactp = (*buf == 'e');
+ ++buf;
+ break;
+ case 'b': case 'B': radix = 2; goto RADIX;
+ case 'o': case 'O': radix = 8; goto RADIX;
+ case 'd': case 'D': radix = 10; goto RADIX;
+ case 'x': case 'X': radix = 16; goto RADIX;
+ RADIX:
+ if (has_radixp) {
+ klispE_throw_simple_with_irritants(
+ K, "two radix prefixes", 1, str);
+ return;
+ }
+ has_radixp = true;
+ ++buf;
+ break;
+ default:
+ klispE_throw_simple_with_irritants(K, "unexpected char "
+ "after #", 1, str);
+ return;
+ }
+ }
+
+ if (radix == 10) {
+ /* only allow decimals with radix 10 */
+ bool decimalp = false;
+ if (!krational_read_decimal(K, buf, radix, &res, NULL, &decimalp)) {
+ klispE_throw_simple_with_irritants(K, "Bad format", 1, str);
+ return;
+ }
+ if (decimalp && !has_exactp) {
+ /* handle decimal format as an explicit #i */
+ has_exactp = true;
+ exactp = false;
+ }
+ } else {
+ if (!krational_read(K, buf, radix, &res, NULL)) {
+ klispE_throw_simple_with_irritants(K, "Bad format", 1, str);
+ return;
+ }
+ }
+
+ if (has_exactp && !exactp) {
+ krooted_tvs_push(K, res);
+ res = kexact_to_inexact(K, res);
+ krooted_tvs_pop(K);
+ }
+ }
+ kapply_cc(K, res);
+}
/* init ground */
void kinit_numbers_ground_env(klisp_State *K)
@@ -2358,6 +2511,9 @@ void kinit_numbers_ground_env(klisp_State *K)
p2tv(knumber_wpvp), p2tv(kfinitep));
add_applicative(K, ground_env, "integer?", ftypep, 2, symbol,
p2tv(kintegerp));
+ /* 12.5.? exact-integer? */
+ add_applicative(K, ground_env, "exact-integer?", ftypep, 2, symbol,
+ p2tv(keintegerp));
/* 12.5.2 =? */
add_applicative(K, ground_env, "=?", ftyped_kbpredp, 3,
symbol, p2tv(knumber_wpvp), p2tv(knum_eqp));
@@ -2479,5 +2635,7 @@ void kinit_numbers_ground_env(klisp_State *K)
/* 12.9.6 expt */
add_applicative(K, ground_env, "expt", kexpt, 0);
- /* TODO add some conversion like number->string, string->number */
+ /* 12.? string->number, number->string */
+ add_applicative(K, ground_env, "string->number", string_to_number, 0);
+ add_applicative(K, ground_env, "number->string", number_to_string, 0);
}
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -7,209 +7,7 @@
#ifndef kgnumbers_h
#define kgnumbers_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"
-
-/* 15.5.1 number?, finite?, integer? */
-/* use ftypep & ftypep_predp */
-
-/* Helpers for typed predicates */
-/* XXX: this should probably be in a file knumber.h but there is no real need for
- that file yet */
-bool knumberp(TValue obj);
-bool knumber_wpvp(TValue obj);
-bool kfinitep(TValue obj);
-bool kintegerp(TValue obj);
-bool keintegerp(TValue obj);
-bool krationalp(TValue obj);
-bool krealp(TValue obj);
-bool kreal_wpvp(TValue obj);
-bool kexactp(TValue obj);
-bool kinexactp(TValue obj);
-bool kundefinedp(TValue obj);
-bool krobustp(TValue obj);
-bool ku8p(TValue obj);
-
-
-/* 12.5.2 =? */
-/* uses typed_bpredp */
-
-/* 12.5.3 <?, <=?, >?, >=? */
-/* use typed_bpredp */
-
-/* Helpers for typed binary predicates */
-/* XXX: this should probably be in a file knumber.h but there is no real need for
- that file yet */
-bool knum_eqp(klisp_State *K, TValue n1, TValue n2);
-bool knum_ltp(klisp_State *K, TValue n1, TValue n2);
-bool knum_lep(klisp_State *K, TValue n1, TValue n2);
-bool knum_gtp(klisp_State *K, TValue n1, TValue n2);
-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);
-
-/* 12.5.5 * */
-/* TEMP: for now only accept two arguments */
-void ktimes(klisp_State *K);
-
-/* 12.5.6 - */
-/* TEMP: for now only accept two arguments */
-void kminus(klisp_State *K);
-
-/* 12.5.7 zero? */
-/* uses ftyped_predp */
-
-/* Helper for zero? */
-bool kzerop(TValue n);
-
-/* 12.5.8 div, mod, div-and-mod */
-/* TODO */
-
-/* 12.5.9 div0, mod0, div0-and-mod0 */
-/* TODO */
-
-/* 12.5.10 positive?, negative? */
-/* use ftyped_predp */
-
-/* 12.5.11 odd?, even? */
-/* use ftyped_predp */
-
-/* Helpers for positive?, negative?, odd? & even? */
-bool kpositivep(TValue n);
-bool knegativep(TValue n);
-bool koddp(TValue n);
-bool kevenp(TValue n);
-
-/* 12.5.8 div, mod, div-and-mod */
-/* use div_mod */
-
-/* 12.5.9 div0, mod0, div0-and-mod0 */
-/* use div_mod */
-
-/* Helper for div and mod */
-#define FDIV_DIV 1
-#define FDIV_MOD 2
-#define FDIV_ZERO 4
-
-void kdiv_mod(klisp_State *K);
-
-
-/* 12.5.12 abs */
-void kabs(klisp_State *K);
-
-/* 12.5.13 min, max */
-/* use kmin_max */
-
-/* Helper */
-#define FMIN (true)
-#define FMAX (false)
-void kmin_max(klisp_State *K);
-
-/* 12.5.14 gcm, lcm */
-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);
-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);
-void kget_real_exact_primary(klisp_State *K);
-
-/* 12.6.4 make-inexact */
-void kmake_inexact(klisp_State *K);
-
-/* 12.6.5 real->inexact, real->exact */
-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);
-
-void kget_strict_arithmeticp(klisp_State *K);
-
-/* 12.8.1 rational? */
-/* uses ftypep */
-
-/* 12.8.2 / */
-void kdivided(klisp_State *K);
-
-/* 12.8.3 numerator, denominator */
-void knumerator(klisp_State *K);
-void kdenominator(klisp_State *K);
-
-/* 12.8.4 floor, ceiling, truncate, round */
-void kreal_to_integer(klisp_State *K);
-
-/* 12.8.5 rationalize, simplest-rational */
-void krationalize(klisp_State *K);
-
-void ksimplest_rational(klisp_State *K);
-
-
-/* 12.9.1 real? */
-/* uses ftypep */
-
-/* 12.9.2 exp, log */
-void kexp(klisp_State *K);
-void klog(klisp_State *K);
-
-/* 12.9.3 sin, cos, tan */
-void ktrig(klisp_State *K);
-
-/* 12.9.4 asin, acos, atan */
-void katrig(klisp_State *K);
-void katan(klisp_State *K);
-
-/* 12.9.5 sqrt */
-void ksqrt(klisp_State *K);
-
-/* 12.9.6 expt */
-void kexpt(klisp_State *K);
-
-
-/* REFACTOR: These should be in a knumber.h header */
-
-/* Misc Helpers */
-/* TEMP: only reals (no complex numbers) */
-inline bool kfast_zerop(TValue n)
-{
- return (ttisfixint(n) && ivalue(n) == 0) ||
- (ttisdouble(n) && dvalue(n) == 0.0);
-}
-
-inline bool kfast_onep(TValue n)
-{
- return (ttisfixint(n) && ivalue(n) == 1) ||
- (ttisdouble(n) && dvalue(n) == 1.0);
-}
-
-inline TValue kneg_inf(TValue i)
-{
- if (ttiseinf(i))
- return tv_equal(i, KEPINF)? KEMINF : KEPINF;
- else /* ttisiinf(i) */
- return tv_equal(i, KIPINF)? KIMINF : KIPINF;
-}
-
-inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
-{
- return kpositivep(n1) == kpositivep(n2);
-}
/* init ground */
void kinit_numbers_ground_env(klisp_State *K);
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -19,8 +19,6 @@
#include "kghelpers.h"
#include "kgpair_mut.h"
-#include "kgeqp.h" /* eq? checking in memq and assq */
-#include "kgnumbers.h" /* for kpositivep and keintegerp */
/* 4.7.1 set-car!, set-cdr! */
void set_carB(klisp_State *K)
@@ -75,98 +73,16 @@ void copy_es(klisp_State *K)
** xparams[0]: copy-es-immutable symbol
** xparams[1]: boolean (#t: use mutable pairs, #f: use immutable pairs)
*/
- char *name = ksymbol_buf(xparams[0]);
bool mut_flag = bvalue(xparams[1]);
bind_1p(K, ptree, obj);
- TValue copy = copy_es_immutable_h(K, name, obj, mut_flag);
+ TValue copy = copy_es_immutable_h(K, obj, mut_flag);
kapply_cc(K, copy);
}
/* 4.7.2 copy-es-immutable */
/* uses copy_es */
-/*
-** This is in a helper method to use it from $lambda, $vau, etc
-**
-** We mark each seen mutable pair with the corresponding copied
-** immutable pair to construct a structure that is isomorphic to
-** the original.
-** All objects that aren't mutable pairs are retained without
-** copying
-** sstack is used to keep track of pairs and tbstack is used
-** to keep track of which of car or cdr we were copying,
-** 0 means just pushed, 1 means return from car, 2 means return from cdr
-**
-** This also copies source code info
-**
-*/
-
-/* GC: assumes obj is rooted */
-TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj,
- bool mut_flag)
-{
- TValue copy = obj;
- krooted_vars_push(K, ©);
-
- assert(ks_sisempty(K));
- assert(ks_tbisempty(K));
-
- ks_spush(K, obj);
- ks_tbpush(K, ST_PUSH);
-
- while(!ks_sisempty(K)) {
- char state = ks_tbpop(K);
- TValue top = ks_spop(K);
-
- if (state == ST_PUSH) {
- /* if the pair is immutable & we are constructing immutable
- pairs there is no need to copy */
- if (ttispair(top) && (mut_flag || kis_mutable(top))) {
- if (kis_marked(top)) {
- /* this pair was already seen, use the same */
- copy = kget_mark(top);
- } else {
- TValue new_pair = kcons_g(K, mut_flag, KINERT, KINERT);
- kset_mark(top, new_pair);
- /* save the source code info on the new pair */
- /* MAYBE: only do it if mutable */
- TValue si = ktry_get_si(K, top);
- if (!ttisnil(si))
- kset_source_info(K, new_pair, si);
- /* leave the pair in the stack, continue with the car */
- ks_spush(K, top);
- ks_tbpush(K, ST_CAR);
-
- ks_spush(K, kcar(top));
- ks_tbpush(K, ST_PUSH);
- }
- } else {
- copy = top;
- }
- } else { /* last action was a pop */
- TValue new_pair = kget_mark(top);
- if (state == ST_CAR) {
- /* new_pair may be immutable */
- kset_car_unsafe(K, new_pair, copy);
- /* leave the pair on the stack, continue with the cdr */
- ks_spush(K, top);
- ks_tbpush(K, ST_CDR);
-
- ks_spush(K, kcdr(top));
- ks_tbpush(K, ST_PUSH);
- } else {
- /* new_pair may be immutable */
- kset_cdr_unsafe(K, new_pair, copy);
- copy = new_pair;
- }
- }
- }
- unmark_tree(K, obj);
- krooted_vars_pop(K);
- return copy;
-}
-
/* 5.8.1 encycle! */
void encycleB(klisp_State *K)
{
@@ -264,9 +180,53 @@ void encycleB(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* Helpers for append! */
+/* 6.?? list-set! */
+void list_setB(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?
+ We foolow list-tail here and allow it */
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_3tp(K, ptree, "any", anytype, obj,
+ "exact integer", keintegerp, tk,
+ "any", anytype, val);
+ if (knegativep(tk)) {
+ klispE_throw_simple(K, "negative index");
+ return;
+ }
+ int32_t k = (ttisfixint(tk))? ivalue(tk)
+ : ksmallest_index(K, obj, tk);
+
+ while(k) {
+ if (!ttispair(obj)) {
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
+ }
+ obj = kcdr(obj);
+ --k;
+ }
+
+ if (!ttispair(obj)) {
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ } else if (kis_immutable(obj)) {
+ /* this could be checked before, but the error here seems better */
+ klispE_throw_simple(K, "immutable pair");
+ } else {
+ kset_car(obj, val);
+ kapply_cc(K, KINERT);
+ }
+}
+
+/* Helpers for append! */
inline void appendB_clear_last_pairs(klisp_State *K, TValue ls)
{
UNUSED(K);
@@ -282,11 +242,13 @@ inline void appendB_clear_last_pairs(klisp_State *K, TValue ls)
objects (1 based) should be set to the next object in the list (this will
encycle! the result if necessary) */
-/* GC: Assumes lss is rooted, uses dummy1 */
+/* GC: Assumes lss is rooted */
TValue appendB_get_lss_endpoints(klisp_State *K, TValue lss, int32_t apairs,
int32_t cpairs)
{
- TValue last_pair = kget_dummy1(K);
+ TValue elist = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &elist);
+ TValue last_pair = elist;
TValue tail = lss;
/* this is a list of last pairs using the marks to link the pairs) */
TValue last_pairs = KNIL;
@@ -413,7 +375,8 @@ TValue appendB_get_lss_endpoints(klisp_State *K, TValue lss, int32_t apairs,
/* discard the first element (there is always one) because it
isn't necessary, the list is used to set the last pairs of
the objects to the correspoding next first pair */
- return kcdr(kcutoff_dummy1(K));
+ krooted_vars_pop(K);
+ return kcdr(kcdr(elist));
}
/* 6.4.1 append! */
@@ -437,12 +400,11 @@ void appendB(klisp_State *K)
}
TValue lss = ptree;
TValue first_ls = kcar(lss);
- int32_t cpairs;
+ int32_t pairs, cpairs;
/* ASK John: if encycle! has only one argument, can't it be cyclic?
the report says no, but the wording is poor */
- int32_t pairs = check_list(K, "append!", false, first_ls, &cpairs);
-
- pairs = check_list(K, "append!", true, lss, &cpairs);
+ check_list(K, false, first_ls, NULL, NULL);
+ check_list(K, true, lss, &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue endpoints =
@@ -475,8 +437,8 @@ void assq(klisp_State *K)
bind_2p(K, ptree, obj, ls);
/* first pass, check structure */
- int32_t pairs = check_typed_list(K, "assq", "pair", kpairp,
- true, ls, NULL);
+ int32_t pairs;
+ check_typed_list(K, kpairp, true, ls, &pairs, NULL);
TValue tail = ls;
TValue res = KNIL;
while(pairs--) {
@@ -504,7 +466,8 @@ void memqp(klisp_State *K)
bind_2p(K, ptree, obj, ls);
/* first pass, check structure */
- int32_t pairs = check_list(K, "memq?", true, ls, NULL);
+ int32_t pairs;
+ check_list(K, true, ls, &pairs, NULL);
TValue tail = ls;
TValue res = KFALSE;
while(pairs--) {
@@ -536,6 +499,8 @@ void kinit_pair_mut_ground_env(klisp_State *K)
b2tv(false));
/* 5.8.1 encycle! */
add_applicative(K, ground_env, "encycle!", encycleB, 0);
+ /* 6.?? list-set! */
+ add_applicative(K, ground_env, "list-set!", list_setB, 0);
/* 6.4.1 append! */
add_applicative(K, ground_env, "append!", appendB, 0);
/* 6.4.2 copy-es */
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -7,50 +7,7 @@
#ifndef kgpairs_mut_h
#define kgpairs_mut_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"
-
-/* Helper (also used by $vau, $lambda, etc) */
-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);
-
-void set_cdrB(klisp_State *K);
-
-/* Helper for copy-es & copy-es-immutable */
-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);
-
-/* 6.4.1 append! */
-void appendB(klisp_State *K);
-
-/* 6.4.2 copy-es */
-/* uses copy_es helper */
-
-/* 6.4.3 assq */
-void assq(klisp_State *K);
-
-/* 6.4.3 memq? */
-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
@@ -20,10 +20,23 @@
#include "kerror.h"
#include "kghelpers.h"
-#include "kgequalp.h"
#include "kgpairs_lists.h"
-#include "kgnumbers.h"
-#include "kinteger.h"
+
+/* Continuations */
+void do_ret_cdr(klisp_State *K);
+
+void do_memberp(klisp_State *K);
+void do_assoc(klisp_State *K);
+
+void do_filter_encycle(klisp_State *K);
+void do_filter(klisp_State *K);
+void do_filter_cycle(klisp_State *K);
+
+void do_reduce(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);
/* 4.6.1 pair? */
/* uses typep */
@@ -46,20 +59,8 @@ void cons(klisp_State *K)
kapply_cc(K, new_pair);
}
-
/* 5.2.1 list */
-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);
- UNUSED(denv);
- kapply_cc(K, ptree);
-}
+/* defined in kghelpers.h (for use in kstate) */
/* 5.2.2 list* */
void listS(klisp_State *K)
@@ -81,7 +82,9 @@ void listS(klisp_State *K)
klispE_throw_simple(K, "empty argument list");
return;
}
- TValue last_pair = kget_dummy1(K);
+ TValue res_obj = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &res_obj);
+ TValue last_pair = res_obj;
TValue tail = ptree;
/* First copy the list, but remembering the next to last pair */
@@ -102,7 +105,8 @@ void listS(klisp_State *K)
we need at least one pair for this to work. */
TValue next_to_last_pair = kcdr(last_pair);
kset_cdr(next_to_last_pair, kcar(last_pair));
- kapply_cc(K, kcutoff_dummy1(K));
+ krooted_vars_pop(K);
+ kapply_cc(K, kcdr(res_obj));
} else if (ttispair(tail)) { /* cyclic argument list */
klispE_throw_simple(K, "cyclic argument list");
return;
@@ -112,9 +116,18 @@ void listS(klisp_State *K)
}
}
+/* Helper macros to construct xparams[1] for c[ad]{1,4}r */
+#define C_AD_R_PARAM(len_, br_) \
+ (i2tv((C_AD_R_LEN(len_) | (C_AD_R_BRANCH(br_)))))
+#define C_AD_R_LEN(len_) ((len_) << 4)
+#define C_AD_R_BRANCH(br_) \
+ ((br_ & 0x0001? 0x1 : 0) | \
+ (br_ & 0x0010? 0x2 : 0) | \
+ (br_ & 0x0100? 0x4 : 0) | \
+ (br_ & 0x1000? 0x8 : 0))
+
/* 5.4.1 car, cdr */
/* 5.4.2 caar, cadr, ... cddddr */
-
void c_ad_r(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -155,43 +168,86 @@ void c_ad_r(klisp_State *K)
kapply_cc(K, obj);
}
-/* also used in list-tail and list-ref when receiving
- bigint indexes */
-void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
- int32_t *a, int32_t *c)
+/* 5.4.? make-list */
+void make_list(klisp_State *K)
{
- TValue tail = obj;
- int32_t pairs = 0;
+ 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, fill);
+
+ if (!get_opt_tpar(K, fill, "any", anytype))
+ fill = KINERT;
+
+ if (knegativep(tv_s)) {
+ klispE_throw_simple(K, "negative list length");
+ return;
+ } else if (!ttisfixint(tv_s)) {
+ klispE_throw_simple(K, "list length is too big");
+ return;
+ }
+ TValue tail = KNIL;
+ int i = ivalue(tv_s);
+ krooted_vars_push(K, &tail);
+ while(i-- > 0) {
+ tail = kcons(K, fill, tail);
+ }
+ krooted_vars_pop(K);
+
+ kapply_cc(K, tail);
+}
+
+/* 5.4.? list-copy */
+void list_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_1p(K, ptree, ls);
+ TValue copy = check_copy_list(K, ls, true, NULL, NULL);
+ kapply_cc(K, copy);
+}
+
+/* 5.4.? reverse */
+void reverse(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, ls);
+ TValue tail = ls;
+ TValue res = KNIL;
+ krooted_vars_push(K, &res);
while(ttispair(tail) && !kis_marked(tail)) {
- /* record the pair number to simplify cycle pair counting */
- kset_mark(tail, i2tv(pairs));
- ++pairs;
+ kmark(tail);
+ res = kcons(K, kcar(tail), res);
tail = kcdr(tail);
}
- int32_t apairs, cpairs, nils;
- if (ttisnil(tail)) {
- /* simple (possibly empty) list */
- apairs = pairs;
- nils = 1;
- cpairs = 0;
- } else if (ttispair(tail)) {
- /* cyclic (maybe circular) list */
- apairs = ivalue(kget_mark(tail));
- cpairs = pairs - apairs;
- nils = 0;
+ unmark_list(K, ls);
+ krooted_vars_pop(K);
+
+ if (ttispair(tail)) {
+ klispE_throw_simple(K, "expected acyclic list");
+ } else if (!ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
} else {
- apairs = pairs;
- cpairs = 0;
- nils = 0;
+ kapply_cc(K, res);
}
-
- unmark_list(K, obj);
-
- if (p != NULL) *p = pairs;
- if (n != NULL) *n = nils;
- if (a != NULL) *a = apairs;
- if (c != NULL) *c = cpairs;
}
/* 5.7.1 get-list-metrics */
@@ -214,42 +270,6 @@ void get_list_metrics(klisp_State *K)
kapply_cc(K, res);
}
-/* Helper for list-tail and list-ref */
-
-/* Calculate the smallest i such that
- (eq? (list-tail obj i) (list-tail obj tk))
- tk is a bigint and all lists have fixint range number of pairs,
- so the list should cyclic and we should calculate an index that
- doesn't go through the complete cycle not even once */
-int32_t ksmallest_index(klisp_State *K, char *name, TValue obj,
- TValue tk)
-{
- int32_t apairs, cpairs;
- get_list_metrics_aux(K, obj, NULL, NULL, &apairs, &cpairs);
- if (cpairs == 0) {
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return 0;
- }
- TValue tv_apairs = i2tv(apairs);
- TValue tv_cpairs = i2tv(cpairs);
-
- /* all calculations will be done with bigints */
- kensure_bigint(tv_apairs);
- kensure_bigint(tv_cpairs);
-
- TValue idx = kbigint_minus(K, tk, tv_apairs);
- krooted_tvs_push(K, idx); /* root idx if it is a bigint */
- /* idx may have become a fixint */
- kensure_bigint(idx);
- UNUSED(kbigint_div_mod(K, idx, tv_cpairs, &idx));
- krooted_tvs_pop(K);
- /* now idx is less than cpairs so it fits in a fixint */
- assert(ttisfixint(idx));
- return ivalue(idx) + apairs;
-}
-
-
/* 5.7.2 list-tail */
void list_tail(klisp_State *K)
{
@@ -271,7 +291,7 @@ void list_tail(klisp_State *K)
}
int32_t k = (ttisfixint(tk))? ivalue(tk)
- : ksmallest_index(K, "list-tail", obj, tk);
+ : ksmallest_index(K, obj, tk);
while(k) {
if (!ttispair(obj)) {
@@ -332,7 +352,7 @@ void list_ref(klisp_State *K)
}
int32_t k = (ttisfixint(tk))? ivalue(tk)
- : ksmallest_index(K, "list-tail", obj, tk);
+ : ksmallest_index(K, obj, tk);
while(k) {
if (!ttispair(obj)) {
@@ -358,7 +378,7 @@ void list_ref(klisp_State *K)
(as the ret value) and the last_pair. If obj is nil, *last_pair remains
unmodified (this avoids having to check ttisnil before calling this) */
-/* GC: Assumes obj is rooted, uses dummy1 */
+/* GC: Assumes obj is rooted */
TValue append_check_copy_list(klisp_State *K, char *name, TValue obj,
TValue *last_pair_ptr)
{
@@ -366,7 +386,9 @@ TValue append_check_copy_list(klisp_State *K, char *name, TValue obj,
if (ttisnil(obj))
return obj;
- TValue last_pair = kget_dummy1(K);
+ TValue copy = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, ©);
+ TValue last_pair = copy;
TValue tail = obj;
while(ttispair(tail) && !kis_marked(tail)) {
@@ -386,7 +408,8 @@ TValue append_check_copy_list(klisp_State *K, char *name, TValue obj,
return KINERT;
}
*last_pair_ptr = last_pair;
- return kcutoff_dummy1(K);
+ krooted_vars_pop(K);
+ return (kcdr(copy));
}
/* 6.3.3 append */
@@ -399,12 +422,13 @@ void append(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
- int32_t cpairs;
- int32_t pairs = check_list(K, "append", true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ptree, &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
- /* use dummy2, append_check_copy uses dummy1 */
- TValue last_pair = kget_dummy2(K);
+ TValue res_list = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &res_list);
+ TValue last_pair = res_list;
TValue lss = ptree;
TValue last_apair;
@@ -452,7 +476,8 @@ void append(klisp_State *K)
kset_cdr(last_cpair, first_cpair); /* encycle! */
}
}
- kapply_cc(K, kcutoff_dummy2(K));
+ krooted_vars_pop(K);
+ kapply_cc(K, kcdr(res_list));
}
/* 6.3.4 list-neighbors */
@@ -467,12 +492,14 @@ void list_neighbors(klisp_State *K)
bind_1p(K, ptree, ls);
- int32_t cpairs;
- int32_t pairs = check_list(K, "list_neighbors", true, ls, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ls, &pairs, &cpairs);
TValue tail = ls;
int32_t count = cpairs? pairs - cpairs : pairs - 1;
- TValue last_pair = kget_dummy1(K);
+ TValue neighbors = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &neighbors);
+ TValue last_pair = neighbors;
TValue last_apair = last_pair; /* set after first loop */
bool doing_cycle = false;
@@ -502,7 +529,8 @@ void list_neighbors(klisp_State *K)
/* this will loop once more */
}
}
- kapply_cc(K, kcutoff_dummy1(K));
+ krooted_vars_pop(K);
+ kapply_cc(K, kcdr(neighbors));
}
/* Helpers for filter */
@@ -523,7 +551,7 @@ void do_ret_cdr(klisp_State *K)
/* XXX: the check isn't necessary really, but there is
no list_copy (and if there was it would take apairs and
cpairs, which we don't have here */
- TValue copy = check_copy_list(K, "filter", kcdr(xparams[0]), true);
+ TValue copy = check_copy_list(K, kcdr(xparams[0]), true, NULL, NULL);
kapply_cc(K, copy);
}
@@ -559,7 +587,7 @@ void do_filter_encycle(klisp_State *K)
/* XXX: the check isn't necessary really, but there is
no list_copy (and if there was it would take apairs and
cpairs, which we don't have here */
- TValue copy = check_copy_list(K, "filter", kcdr(xparams[0]), true);
+ TValue copy = check_copy_list(K, kcdr(xparams[0]), true, NULL, NULL);
kapply_cc(K, copy);
}
@@ -665,12 +693,12 @@ void filter(klisp_State *K)
/* ASK John: the semantics when this is mixed with continuations,
isn't all that great..., but what are the expectations considering
there is no prescribed order? */
- int32_t cpairs;
- int32_t pairs = check_list(K, "filter", true, ls, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ls, &pairs, &cpairs);
/* XXX: This was the paradigmatic use case of the force copy flag
in the old implementation, but it caused problems with continuations
Is there any other use case for force copy flag?? */
- ls = check_copy_list(K, "filter", ls, false);
+ ls = check_copy_list(K, ls, false, NULL, NULL);
/* This will be the list to be returned, but it will be copied
before to play a little nicer with continuations */
TValue dummy = kcons(K, KINERT, KNIL);
@@ -695,6 +723,48 @@ void filter(klisp_State *K)
}
/* 6.3.6 assoc */
+/* helper if third optional argument is used */
+void do_assoc(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]: pred
+ ** xparams[1]: obj to be compared
+ ** xparams[2]: last-pair + rem ls
+ ** xparams[3]: rem pairs
+ */
+
+ TValue pred = xparams[0];
+ TValue cmp_obj = xparams[1];
+ TValue ls = xparams[2];
+ int32_t pairs = ivalue(xparams[3]);
+
+ if (!ttisboolean(obj)) {
+ klispE_throw_simple_with_irritants(K, "expected boolean", 1, obj);
+ return;
+ } else if (kis_true(obj) || pairs == 0) {
+ TValue res = kis_true(obj)? kcar(ls) : KNIL;
+ kapply_cc(K, res);
+ } else {
+ /* object not YET found */
+ TValue cont = kmake_continuation(K, kget_cc(K), do_assoc, 4, pred,
+ cmp_obj, kcdr(ls), i2tv(pairs-1));
+ /* not necessary but may save a continuation in some cases */
+ kset_bool_check_cont(cont);
+ kset_cc(K, cont);
+ TValue exp = kcons(K, kcar(kcar(kcdr(ls))), KNIL);
+ krooted_vars_push(K, &exp);
+ exp = kcons(K, cmp_obj, exp);
+ exp = kcons(K, pred, exp);
+ /* TEMP for now use an empty environment for dynamic env */
+ TValue env = kmake_empty_environment(K);
+ krooted_vars_pop(K);
+ ktail_eval(K, exp, env);
+ }
+}
+
void assoc(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -704,25 +774,85 @@ void assoc(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
- bind_2p(K, ptree, obj, ls);
+ bind_al2p(K, ptree, obj, ls, maybe_pred);
+ bool predp = get_opt_tpar(K, maybe_pred, "applicative", ttisapplicative);
/* first pass, check structure */
- int32_t pairs = check_typed_list(K, "assoc", "pair", kpairp,
- true, ls, NULL);
- TValue tail = ls;
- TValue res = KNIL;
- while(pairs--) {
- TValue first = kcar(tail);
- if (equal2p(K, kcar(first), obj)) {
- res = first;
- break;
+ int32_t pairs;
+ check_typed_list(K, kpairp, true, ls, &pairs, NULL);
+
+ TValue res;
+ if (predp) {
+ /* we'll need use continuations, copy list first to
+ avoid troubles with mutation */
+ ls = check_copy_list(K, ls, false, NULL, NULL);
+ krooted_vars_push(K, &ls);
+ ls = kcons(K, KINERT, ls); /* add dummy obj to stand as last
+ compared obj */
+ TValue cont = kmake_continuation(K, kget_cc(K), do_assoc, 4,
+ maybe_pred, obj, ls, i2tv(pairs));
+ krooted_vars_pop(K);
+ kset_cc(K, cont);
+ /* pass false to have it keep looking (in the whole list) */
+ res = KFALSE;
+ } else {
+ /* use equal?, no continuation needed */
+ TValue tail = ls;
+ res = KNIL;
+ while(pairs--) {
+ TValue first = kcar(tail);
+ if (equal2p(K, kcar(first), obj)) {
+ res = first;
+ break;
+ }
+ tail = kcdr(tail);
}
- tail = kcdr(tail);
}
-
kapply_cc(K, res);
}
/* 6.3.7 member? */
+/* helper if third optional argument is used */
+void do_memberp(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]: pred
+ ** xparams[1]: obj to be compared
+ ** xparams[2]: rem ls
+ ** xparams[3]: rem pairs
+ */
+
+ TValue pred = xparams[0];
+ TValue cmp_obj = xparams[1];
+ TValue ls = xparams[2];
+ int32_t pairs = ivalue(xparams[3]);
+
+ if (!ttisboolean(obj)) {
+ klispE_throw_simple_with_irritants(K, "expected boolean", 1, obj);
+ return;
+ } else if (kis_true(obj) || pairs == 0) {
+ /* object found if obj is true and not found if obj is false */
+ kapply_cc(K, obj);
+ } else {
+ /* object not YET found */
+ TValue cont = kmake_continuation(K, kget_cc(K), do_memberp, 4, pred,
+ cmp_obj, kcdr(ls), i2tv(pairs-1));
+ /* not necessary but may save a continuation in some cases */
+ kset_bool_check_cont(cont);
+ kset_cc(K, cont);
+ TValue exp = kcons(K, kcar(ls), KNIL);
+ krooted_vars_push(K, &exp);
+ exp = kcons(K, cmp_obj, exp);
+ exp = kcons(K, pred, exp);
+ /* TEMP for now use an empty environment for dynamic env */
+ TValue env = kmake_empty_environment(K);
+ krooted_vars_pop(K);
+ ktail_eval(K, exp, env);
+ }
+}
+
void memberp(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -732,20 +862,41 @@ void memberp(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
- bind_2p(K, ptree, obj, ls);
+ bind_al2p(K, ptree, obj, ls, maybe_pred);
+ bool predp = get_opt_tpar(K, maybe_pred, "applicative", ttisapplicative);
+
/* first pass, check structure */
- int32_t pairs = check_list(K, "member?", true, ls, NULL);
- TValue tail = ls;
- TValue res = KFALSE;
- while(pairs--) {
- TValue first = kcar(tail);
- if (equal2p(K, first, obj)) {
- res = KTRUE;
- break;
- }
- tail = kcdr(tail);
+ int32_t pairs;
+ if (predp) { /* copy if a custom predicate is used */
+ ls = check_copy_list(K, ls, false, &pairs, NULL);
+ } else {
+ check_list(K, true, ls, &pairs, NULL);
}
+ TValue res;
+ if (predp) {
+ /* we'll need use continuations */
+ krooted_tvs_push(K, ls);
+ TValue cont = kmake_continuation(K, kget_cc(K), do_memberp, 4,
+ maybe_pred, obj, ls, i2tv(pairs));
+ krooted_tvs_pop(K);
+ kset_cc(K, cont);
+ /* pass false to have it keep looking (in the whole list) */
+ res = KFALSE;
+ } else {
+ /* if using equal? we need no continuation, we can
+ do it all here */
+ TValue tail = ls;
+ res = KFALSE;
+ while(pairs--) {
+ TValue first = kcar(tail);
+ if (equal2p(K, first, obj)) {
+ res = KTRUE;
+ break;
+ }
+ tail = kcdr(tail);
+ }
+ }
kapply_cc(K, res);
}
@@ -759,7 +910,8 @@ void finite_listp(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
- int32_t pairs = check_list(K, "finite-list?", true, ptree, NULL);
+ int32_t pairs;
+ check_list(K, true, ptree, &pairs, NULL);
TValue res = KTRUE;
TValue tail = ptree;
@@ -791,7 +943,8 @@ void countable_listp(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
- int32_t pairs = check_list(K, "countable-list?", true, ptree, NULL);
+ int32_t pairs;
+ check_list(K, true, ptree, &pairs, NULL);
TValue res = KTRUE;
TValue tail = ptree;
@@ -815,9 +968,6 @@ void countable_listp(klisp_State *K)
/* Helpers for reduce */
-/* NOTE: This is used from both do_reduce_cycle and reduce */
-void do_reduce(klisp_State *K);
-
void do_reduce_prec(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -1040,12 +1190,11 @@ void reduce(klisp_State *K)
}
/* TODO all of these in one procedure */
- int32_t cpairs;
- int32_t pairs = check_list(K, "reduce", true, ls, &cpairs);
- int32_t apairs = pairs - cpairs;
+ int32_t pairs, cpairs;
/* force copy to be able to do all precycles and replace
the corresponding objs in ls */
- ls = check_copy_list(K, "reduce", ls, true);
+ ls = check_copy_list(K, ls, true, &pairs, &cpairs);
+ int32_t apairs = pairs - cpairs;
TValue first_cycle_pair = ls;
int32_t dapairs = apairs;
/* REFACTOR: add an extra return value to check_copy_list to output
@@ -1166,6 +1315,12 @@ void kinit_pairs_lists_ground_env(klisp_State *K)
C_AD_R_PARAM(4, 0x1110));
add_applicative(K, ground_env, "cddddr", c_ad_r, 2, symbol,
C_AD_R_PARAM(4, 0x1111));
+ /* 5.?.? make-list */
+ add_applicative(K, ground_env, "make-list", make_list, 0);
+ /* 5.?.? list-copy */
+ add_applicative(K, ground_env, "list-copy", list_copy, 0);
+ /* 5.?.? reverse */
+ add_applicative(K, ground_env, "reverse", reverse, 0);
/* 5.7.1 get-list-metrics */
add_applicative(K, ground_env, "get-list-metrics", get_list_metrics, 0);
/* 5.7.2 list-tail */
@@ -1193,3 +1348,24 @@ void kinit_pairs_lists_ground_env(klisp_State *K)
/* TODO add make-list, list-copy and reverse (from r7rs) */
}
+
+/* init continuation names */
+void kinit_pairs_lists_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_ret_cdr, "return-cdr");
+
+ add_cont_name(K, t, do_memberp, "member?-search");
+ add_cont_name(K, t, do_assoc, "assoc-search");
+
+ add_cont_name(K, t, do_filter, "filter-acyclic-part");
+ add_cont_name(K, t, do_filter_encycle, "filter-encycle!");
+ add_cont_name(K, t, do_filter_cycle, "filter-cyclic-part");
+
+ add_cont_name(K, t, do_reduce, "reduce-acyclic-part");
+ add_cont_name(K, t, do_reduce_prec, "reduce-precycle");
+ add_cont_name(K, t, do_reduce_combine, "reduce-combine");
+ add_cont_name(K, t, do_reduce_postc, "reduce-postcycle");
+ add_cont_name(K, t, do_reduce_cycle, "reduce-cyclic-part");
+}
diff --git a/src/kgpairs_lists.h b/src/kgpairs_lists.h
@@ -7,94 +7,11 @@
#ifndef kgpairs_lists_h
#define kgpairs_lists_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"
-
-/* 4.6.1 pair? */
-/* uses typep */
-
-/* 4.6.2 null? */
-/* uses typep */
-/* 4.6.3 cons */
-void cons(klisp_State *K);
-
-/* 5.2.1 list */
-void list(klisp_State *K);
-
-/* 5.2.2 list* */
-void listS(klisp_State *K);
-
-/* 5.4.1 car, cdr */
-/* 5.4.2 caar, cadr, ... cddddr */
-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_) \
- (i2tv((C_AD_R_LEN(len_) | (C_AD_R_BRANCH(br_)))))
-#define C_AD_R_LEN(len_) ((len_) << 4)
-#define C_AD_R_BRANCH(br_) \
- ((br_ & 0x0001? 0x1 : 0) | \
- (br_ & 0x0010? 0x2 : 0) | \
- (br_ & 0x0100? 0x4 : 0) | \
- (br_ & 0x1000? 0x8 : 0))
-
-/* 5.7.1 get-list-metrics */
-void get_list_metrics(klisp_State *K);
-
-/* 5.7.2 list-tail */
-void list_tail(klisp_State *K);
-
-/* 6.3.1 length */
-void length(klisp_State *K);
-
-/* 6.3.2 list-ref */
-void list_ref(klisp_State *K);
-
-/* 6.3.3 append */
-void append(klisp_State *K);
-
-/* 6.3.4 list-neighbors */
-void list_neighbors(klisp_State *K);
-
-/* 6.3.5 filter */
-void filter(klisp_State *K);
-
-/* 6.3.6 assoc */
-void assoc(klisp_State *K);
-
-/* 6.3.7 member? */
-void memberp(klisp_State *K);
-
-/* 6.3.8 finite-list? */
-void finite_listp(klisp_State *K);
-
-/* 6.3.9 countable-list? */
-void countable_listp(klisp_State *K);
-
-/* 6.3.10 reduce */
-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);
+/* init continuation names */
+void kinit_pairs_lists_cont_names(klisp_State *K);
#endif
diff --git a/src/kgports.c b/src/kgports.c
@@ -4,16 +4,17 @@
** See Copyright Notice in klisp.h
*/
-#include <assert.h>
#include <stdio.h>
#include <stdlib.h>
#include <stdbool.h>
#include <stdint.h>
+#include <string.h>
#include "kstate.h"
#include "kobject.h"
#include "kport.h"
#include "kstring.h"
+#include "ktable.h"
#include "kbytevector.h"
#include "kenvironment.h"
#include "kapplicative.h"
@@ -27,13 +28,11 @@
#include "kwrite.h"
#include "kpair.h"
-#include "kscript.h"
-
#include "kghelpers.h"
#include "kgports.h"
-#include "kgcontinuations.h" /* for guards */
-#include "kgcontrol.h" /* for evaling in sequence */
-#include "kgkd_vars.h" /* for dynamic input/output port */
+
+/* Continuations */
+void do_close_file_ret(klisp_State *K);
/* 15.1.1 port? */
/* uses typep */
@@ -338,6 +337,38 @@ void gwrite(klisp_State *K)
kapply_cc(K, KINERT);
}
+/* 15.1.? write-simple */
+void gwrite_simple(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, 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_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;
+ }
+
+ kwrite_simple_to_port(K, port, obj);
+ kapply_cc(K, KINERT);
+}
+
/* 15.1.? eof-object? */
/* uses typep */
@@ -699,7 +730,9 @@ void load(klisp_State *K)
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);
+ TValue inert_cont = kmake_continuation(K, kget_cc(K), do_return_value, 1,
+ KINERT);
+
krooted_tvs_push(K, inert_cont);
TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
@@ -738,6 +771,197 @@ void load(klisp_State *K)
}
}
+/* Helpers for require */
+static bool readable(const char *filename) {
+ FILE *f = fopen(filename, "r"); /* try to open file */
+ if (f == NULL) return false; /* open failed */
+ fclose(f);
+ return true;
+}
+
+/* Path can't/shouldn't contain embedded zeros */
+static const char *get_next_template(klisp_State *K, const char *path,
+ TValue *next) {
+ const char *l;
+ while (*path == *KLISP_PATHSEP) path++; /* skip separators */
+ if (*path == '\0') return NULL; /* no more templates */
+ l = strchr(path, *KLISP_PATHSEP); /* find next separator */
+ if (l == NULL) l = path + strlen(path);
+ *next = kstring_new_bs(K, path, l-path); /* template */
+ return l; /* pointer to the end of the template */
+}
+
+/* no strings should contains embedded zeroes */
+static TValue str_sub(klisp_State *K, TValue s, TValue p, TValue r)
+{
+ const char *sp = kstring_buf(s);
+ const char *pp = kstring_buf(p);
+ const char *rp = kstring_buf(r);
+
+ uint32_t size = kstring_size(s);
+ uint32_t psize = kstring_size(p);
+ uint32_t rsize = kstring_size(r);
+ int32_t diff_size = rsize - psize;
+
+ const char *wild;
+
+ /* first calculate needed size */
+ while ((wild = strstr(sp, pp)) != NULL) {
+ size += diff_size;
+ sp = wild + psize;
+ }
+
+ /* now construct result buffer and fill it */
+ TValue res = kstring_new_s(K, size);
+ char *resp = kstring_buf(res);
+ sp = kstring_buf(s);
+ while ((wild = strstr(sp, pp)) != NULL) {
+ ptrdiff_t l = wild - sp;
+ memcpy(resp, sp, l);
+ resp += l;
+ memcpy(resp, rp, rsize);
+ resp += rsize;
+ sp = wild + psize;
+ }
+ strcpy(resp, sp); /* the size was calculated beforehand */
+ return res;
+}
+
+static TValue find_file (klisp_State *K, TValue name, TValue pname) {
+ /* not used in klisp */
+ /* name = luaL_gsub(L, name, ".", LUA_DIRSEP); */
+ /* lua_getfield(L, LUA_ENVIRONINDEX, pname); */
+ klisp_assert(ttisstring(name) && !kstring_emptyp(name));
+ const char *path = kstring_buf(pname);
+ TValue next = K->empty_string;
+ krooted_vars_push(K, &next);
+ TValue wild = kstring_new_b(K, KLISP_PATH_MARK);
+ krooted_tvs_push(K, wild);
+
+ while ((path = get_next_template(K, path, &next)) != NULL) {
+ next = str_sub(K, next, wild, name);
+ if (readable(kstring_buf(next))) { /* does file exist and is readable? */
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ return next; /* return that file name */
+ }
+ }
+
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+ return K->empty_string; /* return empty_string */
+}
+
+/* ?.? require */
+/*
+** require is like load except that:
+** - require first checks to see if the file was already required
+** and if so, doesnt' do anything
+** - require looks for the named file in a number of locations
+** configurable via env var KLISP_PATH
+** - When/if the file is found, evaluation happens in an initially
+** standard environment
+*/
+/* TODO check if file was required */
+void require(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, "string", ttisstring, name);
+
+ if (kstring_emptyp(name)) {
+ klispE_throw_simple(K, "Empty name");
+ return;
+ }
+ /* search for the named file in the table of already
+ required files.
+ N.B. this will be fooled if the same file is accessed
+ through different names */
+ TValue saved_name = kstring_immutablep(name)? name :
+ kstring_new_bs_imm(K, kstring_buf(name), kstring_size(name));
+
+ const TValue *node = klispH_getstr(tv2table(K->require_table),
+ tv2str(saved_name));
+ if (node != &kfree) {
+ /* was required already, nothing to be done */
+ kapply_cc(K, KINERT);
+ }
+
+ krooted_tvs_push(K, saved_name);
+ TValue filename = K->empty_string;
+ krooted_vars_push(K, &filename);
+ filename = find_file(K, name, K->require_path);
+
+ if (kstring_emptyp(filename)) {
+ klispE_throw_simple_with_irritants(K, "Not found", 1, name);
+ return;
+ }
+
+ /* the file was found, save it in the table */
+ /* MAYBE the name should be saved in the table only if no error
+ occured... but that could lead to loops if the file is
+ required recursively. A third option would be to record the
+ sate of the require in the table, so we could have: error, required,
+ requiring, etc */
+ *(klispH_setstr(K, tv2table(K->require_table), tv2str(saved_name))) =
+ KTRUE;
+ krooted_tvs_pop(K); /* saved_name no longer necessary */
+
+ /* 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_fport(K, filename, false, false);
+ krooted_tvs_push(K, port);
+ krooted_vars_pop(K); /* filename already rooted */
+
+ TValue inert_cont = kmake_continuation(K, kget_cc(K), do_return_value, 1,
+ KINERT);
+
+ krooted_tvs_push(K, inert_cont);
+
+ TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
+ /* this will be used later, but contruct it now to use the
+ current continuation as parent
+ GC: root this obj */
+ kset_cc(K, guarded_cont); /* implicit rooting */
+ /* 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 a
+ standard environment and #inert returned after all are done */
+ kset_cc(K, inert_cont); /* implicit rooting */
+ krooted_tvs_pop(K); /* already rooted */
+
+ if (ttisnil(ls)) {
+ krooted_tvs_pop(K); /* port */
+ kapply_cc(K, KINERT);
+ } else {
+ TValue tail = kcdr(ls);
+ /* std environments have hashtable for bindings */
+ TValue env = kmake_table_environment(K, K->ground_env);
+ if (ttispair(tail)) {
+ krooted_tvs_push(K, ls);
+ krooted_tvs_push(K, env);
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
+ do_seq, 2, tail, env);
+ kset_cc(K, new_cont);
+#if KTRACK_SI
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
+#endif
+ krooted_tvs_pop(K); /* env */
+ krooted_tvs_pop(K); /* ls */
+ }
+ krooted_tvs_pop(K); /* port */
+ ktail_eval(K, kcar(ls), env);
+ }
+}
+
/* 15.2.3 get-module */
void get_module(klisp_State *K)
{
@@ -762,7 +986,8 @@ void get_module(klisp_State *K)
kadd_binding(K, env, K->module_params_sym, maybe_env);
}
- TValue ret_env_cont = make_return_value_cont(K, kget_cc(K), env);
+ TValue ret_env_cont = kmake_continuation(K, kget_cc(K), do_return_value,
+ 1, env);
krooted_tvs_pop(K); /* env alread in cont */
krooted_tvs_push(K, ret_env_cont);
@@ -836,38 +1061,38 @@ void display(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* 15.1.? flush-output-port */
-void flush(klisp_State *K)
+void read_line(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_out_port_key); /* access directly */
+ port = kcdr(K->kd_in_port_key); /* access directly */
}
- if (!kport_is_output(port)) {
- klispE_throw_simple(K, "the port should be an output 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;
}
- kwrite_flush_port(K, port);
- kapply_cc(K, KINERT);
+ TValue obj = kread_line_from_port(K, port);
+ kapply_cc(K, obj);
}
-/* 15.1.? file-exists? */
-void file_existsp(klisp_State *K)
+/* 15.1.? flush-output-port */
+void flush(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -875,69 +1100,25 @@ void file_existsp(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
+
+ TValue port = ptree;
- bind_1tp(K, ptree, "string", ttisstring, filename);
-
- /* TEMP: this should probably be done in a operating system specific
- manner, but this will do for now */
- TValue res = KFALSE;
- FILE *file = fopen(kstring_buf(filename), "r");
- if (file) {
- res = KTRUE;
- UNUSED(fclose(file));
+ if (!get_opt_tpar(K, port, "port", ttisport)) {
+ port = kcdr(K->kd_out_port_key); /* access directly */
}
- kapply_cc(K, res);
-}
-
-/* 15.1.? delete-file */
-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);
- bind_1tp(K, ptree, "string", ttisstring, filename);
-
- /* TEMP: this should probably be done in a operating system specific
- manner, but this will do for now */
- /* XXX: this could fail if there's a dead (in the gc sense) port still
- open, should probably retry once after doing a complete GC */
- if (remove(kstring_buf(filename))) {
- klispE_throw_errno_with_irritants(K, "remove", 1, filename);
- return;
- } else {
- kapply_cc(K, KINERT);
+ if (!kport_is_output(port)) {
+ klispE_throw_simple(K, "the port should be an output port");
return;
- }
-}
-
-/* 15.1.? rename-file */
-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);
-
- bind_2tp(K, ptree, "string", ttisstring, old_filename,
- "string", ttisstring, new_filename);
+ }
- /* TEMP: this should probably be done in a operating system specific
- manner, but this will do for now */
- /* XXX: this could fail if there's a dead (in the gc sense) port still
- open, should probably retry once after doing a complete GC */
- if (rename(kstring_buf(old_filename), kstring_buf(new_filename))) {
- klispE_throw_errno_with_irritants(K, "rename", 2, old_filename, new_filename);
- return;
- } else {
- kapply_cc(K, KINERT);
+ if (kport_is_closed(port)) {
+ klispE_throw_simple(K, "the port is already closed");
return;
}
+
+ kwrite_flush_port(K, port);
+ kapply_cc(K, KINERT);
}
/* init ground */
@@ -1036,6 +1217,8 @@ void kinit_ports_ground_env(klisp_State *K)
add_applicative(K, ground_env, "read", gread, 0);
/* 15.1.8 write */
add_applicative(K, ground_env, "write", gwrite, 0);
+ /* 15.1.? write-simple */
+ add_applicative(K, ground_env, "write-simple", gwrite_simple, 0);
/* 15.1.? eof-object? */
add_applicative(K, ground_env, "eof-object?", typep, 2, symbol,
@@ -1077,27 +1260,18 @@ void kinit_ports_ground_env(klisp_State *K)
2, symbol, b2tv(true));
/* 15.2.2 load */
add_applicative(K, ground_env, "load", load, 0);
+ /* 15.2.? require */
+ add_applicative(K, ground_env, "require", require, 0);
/* 15.2.3 get-module */
add_applicative(K, ground_env, "get-module", get_module, 0);
/* 15.2.? display */
add_applicative(K, ground_env, "display", display, 0);
+ /* 15.1.? read-line */
+ add_applicative(K, ground_env, "read-line", read_line, 0);
/* 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);
-
- /* 15.1.? delete-file */
- add_applicative(K, ground_env, "delete-file", delete_file, 0);
-
- /* this isn't in r7rs but it's in ansi c and quite easy to implement */
-
- /* 15.1.? rename-file */
- add_applicative(K, ground_env, "rename-file", rename_file, 0);
-
/*
* That's all there is in the report combined with r5rs and r7rs scheme.
* TODO
@@ -1107,3 +1281,11 @@ void kinit_ports_ground_env(klisp_State *K)
* would be nice
*/
}
+
+/* init continuation names */
+void kinit_ports_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_close_file_ret, "close-file-and-ret");
+}
diff --git a/src/kgports.h b/src/kgports.h
@@ -7,114 +7,11 @@
#ifndef kgports_h
#define kgports_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"
-
-/* 15.1.1 port? */
-/* uses typep */
-
-/* 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);
-
-/* 15.1.4 get-current-input-port, get-current-output-port */
-/* 15.1.? get-current-error-port */
-void get_current_port(klisp_State *K);
-
-/* 15.1.5 open-input-file, open-output-file */
-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);
-
-/* 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 gread(klisp_State *K);
-
-/* 15.1.8 write */
-void gwrite(klisp_State *K);
-
-/* 15.1.? eof-object? */
-/* uses typep */
-
-/* 15.1.? newline */
-void newline(klisp_State *K);
-
-/* 15.1.? write-char */
-void write_char(klisp_State *K);
-
-/* Helper for read-char and peek-char */
-void read_peek_char(klisp_State *K);
-
-/* 15.1.? read-char */
-/* uses read_peek_char */
-
-/* 15.1.? peek-char */
-/* uses read_peek_char */
-
-/* 15.1.? char-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 char_readyp(klisp_State *K);
-
-/* 15.2.1 call-with-input-file, call-with-output-file */
-void call_with_file(klisp_State *K);
-
-/* 15.2.2 load */
-void load(klisp_State *K);
-
-/* 15.2.3 get-module */
-void get_module(klisp_State *K);
-
-/* 15.2.? display */
-void display(klisp_State *K);
-
-void do_close_file_ret(klisp_State *K);
-
-/* 15.1.? flush-output-port */
-void flush(klisp_State *K);
-
-/* 15.1.? file-exists? */
-void file_existsp(klisp_State *K);
-
-/* 15.1.? delete-file */
-void delete_file(klisp_State *K);
-
-/* 15.1.? rename-file */
-void rename_file(klisp_State *K);
/* init ground */
void kinit_ports_ground_env(klisp_State *K);
+/* init continuation names */
+void kinit_ports_cont_names(klisp_State *K);
#endif
diff --git a/src/kgpromises.c b/src/kgpromises.c
@@ -21,6 +21,10 @@
#include "kghelpers.h"
#include "kgpromises.h"
+/* Continuations */
+void do_handle_result(klisp_State *K);
+
+
/* SOURCE_NOTE: this is mostly an adaptation of the library derivation
in the report */
@@ -107,7 +111,10 @@ void Slazy(klisp_State *K)
}
/* 9.1.4 memoize */
-void memoize(klisp_State *K)
+/* in kghelpers.c */
+
+/* $delay it's actually a short hand for ($lazy (memoize ...)) */
+void Sdelay(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -117,7 +124,11 @@ void memoize(klisp_State *K)
UNUSED(denv);
bind_1p(K, ptree, exp);
- TValue new_prom = kmake_promise(K, exp, KNIL);
+ TValue promise_body = kcons(K, exp, KNIL);
+ krooted_vars_push(K, &promise_body);
+ promise_body = kcons(K, K->memoize_app, promise_body);
+ TValue new_prom = kmake_promise(K, promise_body, denv);
+ krooted_vars_pop(K);
kapply_cc(K, new_prom);
}
@@ -136,4 +147,14 @@ void kinit_promises_ground_env(klisp_State *K)
add_operative(K, ground_env, "$lazy", Slazy, 0);
/* 9.1.4 memoize */
add_applicative(K, ground_env, "memoize", memoize, 0);
+ /* 9.1.5? $delay */
+ add_applicative(K, ground_env, "$delay", Sdelay, 0);
+}
+
+/* init continuation names */
+void kinit_promises_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+
+ add_cont_name(K, t, do_handle_result, "promise-handle-result");
}
diff --git a/src/kgpromises.h b/src/kgpromises.h
@@ -7,32 +7,11 @@
#ifndef kgpromises_h
#define kgpromises_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"
-
-/* 9.1.1 promise? */
-/* uses typep */
-
-/* 9.1.2 force */
-void force(klisp_State *K);
-
-/* 9.1.3 $lazy */
-void Slazy(klisp_State *K);
-
-/* 9.1.4 memoize */
-void memoize(klisp_State *K);
-
-void do_handle_result(klisp_State *K);
/* init ground */
void kinit_promises_ground_env(klisp_State *K);
+/* init continuation names */
+void kinit_promises_cont_names(klisp_State *K);
#endif
diff --git a/src/kground.c b/src/kground.c
@@ -38,7 +38,7 @@
#include "kgbytevectors.h"
#include "kgvectors.h"
#include "kgsystem.h"
-#include "kgerror.h"
+#include "kgerrors.h"
#if KUSE_LIBFFI
# include "kgffi.h"
@@ -49,14 +49,6 @@
#include "kstring.h"
#include "keval.h"
#include "krepl.h"
-#include "kscript.h"
-
-/* for init_cont_names */
-#define add_cont_name(K_, t_, c_, n_) \
- { TValue str = kstring_new_b_imm(K_, n_); \
- TValue *node = klispH_set(K_, t_, p2tv(c_)); \
- *node = str; \
- }
/*
** This is called once to save the names of the types of continuations
@@ -65,55 +57,32 @@
*/
void kinit_cont_names(klisp_State *K)
{
+ /* TEMP root and error continuations are set here (they are in kstate) */
Table *t = tv2table(K->cont_name_table);
-
- /* REPL, root-continuation & error-continuation */
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");
+ /* TEMP this is also in kstate */
+ add_cont_name(K, t, do_interception, "do-interception");
- /* SCRIPT, root-continuation & error-continuation */
- add_cont_name(K, t, do_script_exit, "script-exit");
- add_cont_name(K, t, do_script_error, "script-report-error");
+ /* TEMP repl ones should be done in the interpreter, and not in
+ the init state */
+ kinit_repl_cont_names(K);
- /* GROUND ENV */
- add_cont_name(K, t, do_eval_ls, "eval-list");
- add_cont_name(K, t, do_combine, "eval-combine");
- add_cont_name(K, t, do_Sandp_Sorp, "eval-booleans");
- add_cont_name(K, t, do_seq, "eval-sequence");
- add_cont_name(K, t, do_map, "map-acyclic-part");
- add_cont_name(K, t, do_map_encycle, "map-encycle!");
- add_cont_name(K, t, do_map_ret, "map-ret");
- add_cont_name(K, t, do_map_cycle, "map-cyclic-part");
- add_cont_name(K, t, do_extended_cont, "extended-cont");
- add_cont_name(K, t, do_pass_value, "pass-value");
- add_cont_name(K, t, do_select_clause, "select-clause");
- add_cont_name(K, t, do_cond, "eval-cond-list");
- add_cont_name(K, t, do_for_each, "for-each");
- add_cont_name(K, t, do_let, "eval-let");
- add_cont_name(K, t, do_bindsp, "eval-$binds?-env");
- add_cont_name(K, t, do_let_redirect, "eval-let-redirect");
- add_cont_name(K, t, do_remote_eval, "eval-remote-eval-env");
- add_cont_name(K, t, do_b_to_env, "bindings-to-env");
- add_cont_name(K, t, do_match, "match-ptree");
- add_cont_name(K, t, do_set_eval_obj, "set-eval-obj");
- add_cont_name(K, t, do_import, "import-bindings");
- add_cont_name(K, t, do_return_value, "return-value");
- add_cont_name(K, t, do_unbind, "unbind-dynamic-var");
- add_cont_name(K, t, do_filter, "filter-acyclic-part");
- add_cont_name(K, t, do_filter_encycle, "filter-encycle!");
- add_cont_name(K, t, do_ret_cdr, "return-cdr");
- add_cont_name(K, t, do_filter_cycle, "filter-cyclic-part");
- add_cont_name(K, t, do_reduce_prec, "reduce-precycle");
- add_cont_name(K, t, do_reduce_combine, "reduce-combine");
- add_cont_name(K, t, do_reduce_postc, "reduce-postcycle");
- add_cont_name(K, t, do_reduce, "reduce-acyclic-part");
- add_cont_name(K, t, do_reduce_cycle, "reduce-cyclic-part");
- add_cont_name(K, t, do_close_file_ret, "close-file-and-ret");
- add_cont_name(K, t, do_handle_result, "handle-result");
- add_cont_name(K, t, do_interception, "do-interception");
+ kinit_eval_cont_names(K);
+ kinit_kghelpers_cont_names(K);
+
+ kinit_booleans_cont_names(K);
+ kinit_combiners_cont_names(K);
+ kinit_environments_cont_names(K);
+ kinit_env_mut_cont_names(K);
+ kinit_pairs_lists_cont_names(K);
+ kinit_continuations_cont_names(K);
+ kinit_control_cont_names(K);
+ kinit_promises_cont_names(K);
+ kinit_ports_cont_names(K);
+#if KUSE_LIBFFI
+ kinit_ffi_cont_names(K);
+#endif
}
/*
@@ -150,11 +119,4 @@ void kinit_ground_env(klisp_State *K)
#if KUSE_LIBFFI
kinit_ffi_ground_env(K);
#endif
-
- /*
- ** Initialize the names of the continuation used in
- ** the supported modules to aid in debugging/error msgs
- */
- /* MAYBE some/most/all of these could be done in each module */
- kinit_cont_names(K);
}
diff --git a/src/kground.h b/src/kground.h
@@ -10,5 +10,6 @@
#include "kstate.h"
void kinit_ground_env(klisp_State *K);
+void kinit_cont_names(klisp_State *K);
#endif
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -19,12 +19,13 @@
#include "kcontinuation.h"
#include "kerror.h"
#include "ksymbol.h"
+#include "kchar.h"
#include "kstring.h"
+#include "kvector.h"
+#include "kbytevector.h"
#include "kghelpers.h"
-#include "kgchars.h" /* for kcharp */
#include "kgstrings.h"
-#include "kgnumbers.h" /* for keintegerp & knegativep */
/* 13.1.1? string? */
/* uses typep */
@@ -105,7 +106,7 @@ void string_ref(klisp_State *K)
}
/* 13.1.5? string-set! */
-void string_setS(klisp_State *K)
+void string_setB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -137,33 +138,47 @@ void string_setS(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* Helper for string and list->string */
-/* GC: Assumes ls is rooted */
-inline TValue list_to_string_h(klisp_State *K, char *name, TValue ls)
+/* 13.2.1? string */
+void string(klisp_State *K)
{
- int32_t dummy;
+ 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 allow cycles */
- int32_t pairs = check_typed_list(K, name, "char", kcharp, false,
- ls, &dummy);
+ int32_t pairs;
+ check_typed_list(K, kcharp, false, ptree, &pairs, NULL);
+ TValue new_str = list_to_string_h(K, ptree, pairs);
+ kapply_cc(K, new_str);
+}
- TValue new_str;
- /* the if isn't strictly necessary but it's clearer this way */
- if (pairs == 0) {
- return K->empty_string;
- } else {
- new_str = kstring_new_s(K, pairs);
- char *buf = kstring_buf(new_str);
- TValue tail = ls;
- while(pairs--) {
- *buf++ = chvalue(kcar(tail));
- tail = kcdr(tail);
- }
- return new_str;
+/* 13.?? string-upcase, string-downcase, string-titlecase, string-foldcase */
+/* this will work for upcase, downcase and foldcase (in ASCII) */
+void kstring_change_case(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]: conversion fn
+ */
+ UNUSED(denv);
+ bind_1tp(K, ptree, "string", ttisstring, str);
+ char (*fn)(char) = pvalue(xparams[0]);
+ int32_t size = kstring_size(str);
+ TValue res = kstring_new_bs(K, kstring_buf(str), size);
+ char *buf = kstring_buf(res);
+ for(int32_t i = 0; i < size; ++i, buf++) {
+ *buf = fn(*buf);
}
+ kapply_cc(K, res);
}
-/* 13.2.1? string */
-void string(klisp_State *K)
+void kstring_title_case(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -171,9 +186,25 @@ void string(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
-
- TValue new_str = list_to_string_h(K, "string", ptree);
- kapply_cc(K, new_str);
+ bind_1tp(K, ptree, "string", ttisstring, str);
+ uint32_t size = kstring_size(str);
+ TValue res = kstring_new_bs(K, kstring_buf(str), size);
+ char *buf = kstring_buf(res);
+ bool first = true;
+ while(size-- > 0) {
+ char ch = *buf;
+ if (ch == ' ')
+ first = true;
+ else if (!first)
+ *buf = tolower(ch);
+ else if (isalpha(ch)) {
+ /* only count as first letter something that can be capitalized */
+ *buf = toupper(ch);
+ first = false;
+ }
+ ++buf;
+ }
+ kapply_cc(K, res);
}
/* 13.2.2? string=?, string-ci=? */
@@ -322,10 +353,9 @@ void string_append(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
- int32_t dummy;
/* don't allow cycles */
- int32_t pairs = check_typed_list(K, "string-append", "string", kstringp,
- false, ptree, &dummy);
+ int32_t pairs;
+ check_typed_list(K, kstringp, false, ptree, &pairs, NULL);
TValue new_str;
int64_t total_size = 0; /* use int64 to check for overflow */
@@ -376,21 +406,61 @@ void string_to_list(klisp_State *K)
UNUSED(denv);
bind_1tp(K, ptree, "string", ttisstring, str);
- int32_t pairs = kstring_size(str);
- char *buf = kstring_buf(str);
+ TValue res = string_to_list_h(K, str, NULL);
+ kapply_cc(K, res);
+}
- TValue tail = kget_dummy1(K);
+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);
+
+ /* check later */
+ bind_1p(K, ptree, ls);
+ /* don't allow cycles */
+ int32_t pairs;
+ check_typed_list(K, kcharp, false, ls, &pairs, NULL);
+ TValue new_str = list_to_string_h(K, ls, pairs);
+ kapply_cc(K, new_str);
+}
- while(pairs--) {
- TValue new_pair = kcons(K, ch2tv(*buf), KNIL);
- buf++;
- kset_cdr(tail, new_pair);
- tail = new_pair;
+/* 13.? string->vector, vector->string */
+void string_to_vector(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);
+ TValue res;
+
+ if (kstring_emptyp(str)) {
+ res = K->empty_vector;
+ } else {
+ uint32_t size = kstring_size(str);
+
+ /* MAYBE add vector constructor without fill */
+ /* no need to root this */
+ res = kvector_new_sf(K, size, KINERT);
+ char *src = kstring_buf(str);
+ TValue *dst = kvector_buf(res);
+ while(size--) {
+ char ch = *src++; /* not needed but just in case */
+ *dst++ = ch2tv(ch);
+ }
}
- kapply_cc(K, kcutoff_dummy1(K));
+ kapply_cc(K, res);
}
-void list_to_string(klisp_State *K)
+/* TEMP Only ASCII for now */
+void vector_to_string(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -399,11 +469,92 @@ void list_to_string(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
- /* check later in list_to_string_h */
- bind_1p(K, ptree, ls);
+ bind_1tp(K, ptree, "vector", ttisvector, vec);
+ TValue res;
- TValue new_str = list_to_string_h(K, "list->string", ls);
- kapply_cc(K, new_str);
+ if (kvector_emptyp(vec)) {
+ res = K->empty_string;
+ } else {
+ uint32_t size = kvector_size(vec);
+
+ res = kstring_new_s(K, size); /* no need to root this */
+ TValue *src = kvector_buf(vec);
+ char *dst = kstring_buf(res);
+ while(size--) {
+ TValue tv = *src++;
+ if (!ttischar(tv)) {
+ klispE_throw_simple_with_irritants(K, "Non char object found",
+ 1, tv);
+ return;
+ }
+ *dst++ = chvalue(tv);
+ }
+ }
+ kapply_cc(K, res);
+}
+
+/* 13.? string->bytevector, bytevector->string */
+void string_to_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, "string", ttisstring, str);
+ TValue res;
+
+ if (kstring_emptyp(str)) {
+ res = K->empty_bytevector;
+ } else {
+ uint32_t size = kstring_size(str);
+
+ /* MAYBE add bytevector constructor without fill */
+ /* no need to root this */
+ res = kbytevector_new_s(K, size);
+ char *src = kstring_buf(str);
+ uint8_t *dst = kbytevector_buf(res);
+
+ while(size--) {
+ *dst++ = (uint8_t)*src++;
+ }
+ }
+ kapply_cc(K, res);
+}
+
+/* TEMP Only ASCII for now */
+void bytevector_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, "bytevector", ttisbytevector, bb);
+ TValue res;
+
+ if (kbytevector_emptyp(bb)) {
+ res = K->empty_string;
+ } else {
+ uint32_t size = kbytevector_size(bb);
+ res = kstring_new_s(K, size); /* no need to root this */
+ uint8_t *src = kbytevector_buf(bb);
+ char *dst = kstring_buf(res);
+ while(size--) {
+ uint8_t u8 = *src++;
+ if (u8 >= 128) {
+ klispE_throw_simple_with_irritants(K, "Char out of range",
+ 1, i2tv(u8));
+ return;
+ }
+ *dst++ = (char) u8;
+ }
+ }
+ kapply_cc(K, res);
}
/* 13.2.8? string-copy */
@@ -449,7 +600,7 @@ void string_to_immutable_string(klisp_State *K)
}
/* 13.2.10? string-fill! */
-void string_fillS(klisp_State *K)
+void string_fillB(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -497,9 +648,18 @@ void kinit_strings_ground_env(klisp_State *K)
/* 13.1.4? string-ref */
add_applicative(K, ground_env, "string-ref", string_ref, 0);
/* 13.1.5? string-set! */
- add_applicative(K, ground_env, "string-set!", string_setS, 0);
+ add_applicative(K, ground_env, "string-set!", string_setB, 0);
/* 13.2.1? string */
add_applicative(K, ground_env, "string", string, 0);
+ /* 13.?? string-upcase, string-downcase, string-titlecase,
+ string-foldcase */
+ add_applicative(K, ground_env, "string-upcase", kstring_change_case, 1,
+ p2tv(toupper));
+ add_applicative(K, ground_env, "string-downcase", kstring_change_case, 1,
+ p2tv(tolower));
+ add_applicative(K, ground_env, "string-titlecase", kstring_title_case, 0);
+ add_applicative(K, ground_env, "string-foldcase", kstring_change_case, 1,
+ p2tv(tolower));
/* 13.2.2? string=?, string-ci=? */
add_applicative(K, ground_env, "string=?", ftyped_bpredp, 3,
symbol, p2tv(kstringp), p2tv(kstring_eqp));
@@ -530,14 +690,20 @@ void kinit_strings_ground_env(klisp_State *K)
/* 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.?? string->vector, vector->string */
+ add_applicative(K, ground_env, "string->vector", string_to_vector, 0);
+ add_applicative(K, ground_env, "vector->string", vector_to_string, 0);
+ /* 13.?? string->bytevector, bytevector->string */
+ add_applicative(K, ground_env, "string->bytevector",
+ string_to_bytevector, 0);
+ add_applicative(K, ground_env, "bytevector->string",
+ bytevector_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-upcase and string-downcase like in r7rs-draft */
-
/* 13.2.10? string-fill! */
- add_applicative(K, ground_env, "string-fill!", string_fillS, 0);
+ add_applicative(K, ground_env, "string-fill!", string_fillB, 0);
}
diff --git a/src/kgstrings.h b/src/kgstrings.h
@@ -7,84 +7,7 @@
#ifndef kgstrings_h
#define kgstrings_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"
-
-/* 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);
-
-/* 13.1.3? string-length */
-void string_length(klisp_State *K);
-
-/* 13.1.4? string-ref */
-void string_ref (klisp_State *K);
-
-/* 13.1.5? string-set! */
-void string_setS (klisp_State *K);
-
-/* 13.2.1? string */
-void string(klisp_State *K);
-
-/* 13.2.2? string=?, string-ci=? */
-/* use ftyped_bpredp */
-
-/* 13.2.3? string<?, string<=?, string>?, string>=? */
-/* use ftyped_bpredp */
-
-/* 13.2.4? string-ci<?, string-ci<=?, string-ci>?, string-ci>=? */
-/* use ftyped_bpredp */
-
-/* Helpers for binary predicates */
-/* XXX: this should probably be in file kstring.h */
-bool kstring_eqp(TValue str1, TValue str2);
-bool kstring_ci_eqp(TValue str1, TValue str2);
-
-bool kstring_ltp(TValue str1, TValue str2);
-bool kstring_lep(TValue str1, TValue str2);
-bool kstring_gtp(TValue str1, TValue str2);
-bool kstring_gep(TValue str1, TValue str2);
-
-bool kstring_ci_ltp(TValue str1, TValue str2);
-bool kstring_ci_lep(TValue str1, TValue str2);
-bool kstring_ci_gtp(TValue str1, TValue str2);
-bool kstring_ci_gep(TValue str1, TValue str2);
-
-
-/* 13.2.5? substring */
-void substring(klisp_State *K);
-
-/* 13.2.6? string-append */
-void string_append(klisp_State *K);
-
-/* 13.2.7? string->list, list->string */
-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);
-
-/* 13.2.9? string->immutable-string */
-void string_to_immutable_string(klisp_State *K);
-
-/* 13.2.10? string-fill! */
-void string_fillS(klisp_State *K);
-
-/* Helpers */
-bool kstringp(TValue obj);
/* init ground */
void kinit_strings_ground_env(klisp_State *K);
diff --git a/src/kgsymbols.c b/src/kgsymbols.c
@@ -61,7 +61,7 @@ void string_to_symbol(klisp_State *K)
UNUSED(denv);
bind_1tp(K, ptree, "string", ttisstring, str);
/* TODO si */
- TValue new_sym = ksymbol_new_check_i(K, str, KNIL);
+ TValue new_sym = ksymbol_new_str(K, str, KNIL);
kapply_cc(K, new_sym);
}
diff --git a/src/kgsymbols.h b/src/kgsymbols.h
@@ -7,34 +7,7 @@
#ifndef kgsymbols_h
#define kgsymbols_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"
-
-/* 4.4.1 symbol? */
-/* uses typep */
-
-/* ?.?.1? symbol->string */
-void symbol_to_string(klisp_State *K);
-
-/* ?.?.2? string->symbol */
-/* TEMP: for now this can create symbols with no external representation
- this includes all symbols with non identifiers characters.
-*/
-/* NOTE:
- Symbols with uppercase alphabetic characters will write as lowercase and
- so, when read again will not compare as either eq? or equal?. This is ok
- 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);
/* init ground */
void kinit_symbols_ground_env(klisp_State *K);
diff --git a/src/kgsystem.c b/src/kgsystem.c
@@ -4,9 +4,10 @@
** See Copyright Notice in klisp.h
*/
-#include <assert.h>
+#include <string.h>
#include <stdlib.h>
#include <stdbool.h>
+#include <stdio.h>
#include <stdint.h>
#include <time.h>
@@ -14,6 +15,8 @@
#include "kobject.h"
#include "kpair.h"
#include "kerror.h"
+#include "ksystem.h"
+#include "kinteger.h"
#include "kghelpers.h"
#include "kgsystem.h"
@@ -23,6 +26,9 @@
*/
/* ??.?.? current-second */
+/* XXX current revision of the r7rs draft asks for tai seconds,
+ I am sticking with UTC seconds for now, at least till the report is
+ ratified */
void current_second(klisp_State *K)
{
TValue *xparams = K->next_xparams;
@@ -38,20 +44,30 @@ void current_second(klisp_State *K)
klispE_throw_simple(K, "couldn't get time");
return;
} else {
- if (now > INT32_MAX) {
- /* XXX/TODO create bigint */
- klispE_throw_simple(K, "integer too big");
- return;
- } else {
- kapply_cc(K, i2tv((int32_t) now));
- return;
- }
+ TValue res = kinteger_new_uint64(K, (uint64_t) now);
+ kapply_cc(K, res);
}
}
/* ??.?.? current-jiffy */
void current_jiffy(klisp_State *K)
{
+ TValue ptree = K->next_value;
+ check_0p(K, ptree);
+ kapply_cc(K, ksystem_current_jiffy(K));
+}
+
+/* ??.?.? jiffies-per-second */
+void jiffies_per_second(klisp_State *K)
+{
+ TValue ptree = K->next_value;
+ check_0p(K, ptree);
+ kapply_cc(K, ksystem_jiffies_per_second(K));
+}
+
+/* 15.1.? file-exists? */
+void file_existsp(klisp_State *K)
+{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
TValue denv = K->next_env;
@@ -59,28 +75,46 @@ void current_jiffy(klisp_State *K)
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 */
- clock_t now = clock();
- if (now == -1) {
- klispE_throw_simple(K, "couldn't get time");
- return;
+ bind_1tp(K, ptree, "string", ttisstring, filename);
+
+ /* TEMP: this should probably be done in a operating system specific
+ manner, but this will do for now */
+ TValue res = KFALSE;
+ FILE *file = fopen(kstring_buf(filename), "r");
+ if (file) {
+ res = KTRUE;
+ UNUSED(fclose(file));
+ }
+ kapply_cc(K, res);
+}
+
+/* 15.1.? delete-file */
+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);
+
+ bind_1tp(K, ptree, "string", ttisstring, filename);
+
+ /* TEMP: this should probably be done in a operating system specific
+ manner, but this will do for now */
+ /* XXX: this could fail if there's a dead (in the gc sense) port still
+ open, should probably retry once after doing a complete GC */
+ if (remove(kstring_buf(filename))) {
+ klispE_throw_errno_with_irritants(K, "remove", 1, filename);
+ return;
} else {
- if (now > INT32_MAX) {
- /* XXX/TODO create bigint */
- klispE_throw_simple(K, "integer too big");
- return;
- } else {
- kapply_cc(K, i2tv((int32_t) now));
- return;
- }
+ kapply_cc(K, KINERT);
+ return;
}
}
-/* ??.?.? jiffies-per-second */
-void jiffies_per_second(klisp_State *K)
+/* 15.1.? rename-file */
+void rename_file(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -89,17 +123,113 @@ void jiffies_per_second(klisp_State *K)
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");
- return;
+ bind_2tp(K, ptree, "string", ttisstring, old_filename,
+ "string", ttisstring, new_filename);
+
+ /* TEMP: this should probably be done in a operating system specific
+ manner, but this will do for now */
+ /* XXX: this could fail if there's a dead (in the gc sense) port still
+ open, should probably retry once after doing a complete GC */
+ if (rename(kstring_buf(old_filename), kstring_buf(new_filename))) {
+ klispE_throw_errno_with_irritants(K, "rename", 2, old_filename, new_filename);
+ return;
} else {
- kapply_cc(K, i2tv((int32_t) CLOCKS_PER_SEC));
+ kapply_cc(K, KINERT);
return;
}
}
+/* ?.? get-script-arguments, get-interpreter-arguments */
+void get_arguments(klisp_State *K)
+{
+ /*
+ ** xparams[0]: immutable argument list
+ */
+ TValue ptree = K->next_value;
+ TValue *xparams = K->next_xparams;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(denv);
+
+ check_0p(K, ptree);
+ TValue res = xparams[0];
+ kapply_cc(K, res);
+}
+
+/* ?.? get-environment-variable, get-environment-variables */
+void get_environment_variable(klisp_State *K)
+{
+ TValue ptree = K->next_value;
+ TValue *xparams = K->next_xparams;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1tp(K, ptree, "string", ttisstring, name);
+ char *str = getenv(kstring_buf(name));
+ /* I follow r7rs here, but should probably throw error */
+ TValue res;
+ if (str == NULL) {
+ res = KFALSE;
+ } else {
+ res = kstring_new_b_imm(K, str);
+ }
+ kapply_cc(K, res);
+}
+
+void get_environment_variables(klisp_State *K)
+{
+ /*
+ ** xparams[0]: immutable variable list
+ */
+ TValue ptree = K->next_value;
+ TValue *xparams = K->next_xparams;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(denv);
+
+ check_0p(K, ptree);
+ kapply_cc(K, xparams[0]);
+}
+
+/* This should work in mingw as well as gcc */
+/* TODO test, if that doesn't work, try to find a way
+ avoiding taking extra params in main */
+/* I think it's defined in unistd, but it needs to have __USE_GNU
+ defined. The correct way to do that would be to define _GNU_SOURCE
+ before including any system files... That's not so good for an
+ embeddable interpreter, but it could be done in the makefile I guess */
+extern
+#ifdef _WIN32
+ __declspec(dllimport)
+#endif
+ char **environ;
+
+/* Helper for get-environment-variables */
+TValue create_env_var_list(klisp_State *K)
+{
+ /* no need for gc guarding in this context */
+ TValue var_name, var_value;
+ TValue tail = KNIL;
+
+ /* This should work in mingw as well as gcc */
+ /* TODO test, if that doesn't work, try to find a way
+ avoiding taking extra params in main */
+ for(char **env = environ; *env != NULL; ++env) {
+ /* *env is of the form: "<name>=<value>", presumably, name can't have
+ an equal sign! */
+ char *eq = strchr(*env, '=');
+ int name_len = eq - *env;
+ klisp_assert(eq != NULL); /* shouldn't happen */
+ var_name = kstring_new_bs_imm(K, *env, name_len);
+ var_value = kstring_new_b_imm(K, *env + name_len + 1);
+ TValue new_entry = kimm_cons(K, var_name, var_value);
+ tail = kimm_cons(K, new_entry, tail);
+ }
+ return tail;
+}
+
/* init ground */
void kinit_system_ground_env(klisp_State *K)
{
@@ -113,4 +243,22 @@ void kinit_system_ground_env(klisp_State *K)
/* ??.?.? jiffies-per-second */
add_applicative(K, ground_env, "jiffies-per-second", jiffies_per_second,
0);
+ /* ?.? file-exists? */
+ add_applicative(K, ground_env, "file-exists?", file_existsp, 0);
+ /* ?.? delete-file */
+ add_applicative(K, ground_env, "delete-file", delete_file, 0);
+ /* this isn't in r7rs but it's in ansi c and quite easy to implement */
+ /* ?.? rename-file */
+ add_applicative(K, ground_env, "rename-file", rename_file, 0);
+ /* The value for these two will get set later by the interpreter */
+ /* ?.? get-script-arguments, get-interpreter-arguments */
+ add_applicative(K, ground_env, "get-script-arguments", get_arguments,
+ 1, KNIL);
+ add_applicative(K, ground_env, "get-interpreter-arguments", get_arguments,
+ 1, KNIL);
+ /* ?.? get-environment-variable, get-environment-variables */
+ add_applicative(K, ground_env, "get-environment-variable",
+ get_environment_variable, 0);
+ add_applicative(K, ground_env, "get-environment-variables",
+ get_environment_variables, 1, create_env_var_list(K));
}
diff --git a/src/kgsystem.h b/src/kgsystem.h
@@ -7,21 +7,7 @@
#ifndef kgsystem_h
#define kgsystem_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"
-
-/* ??.?.? current-second */
-void current_second(klisp_State *K);
-/* ??.?.? current-jiffy */
-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
@@ -19,10 +19,10 @@
#include "kerror.h"
#include "kvector.h"
#include "kpair.h"
+#include "kbytevector.h"
#include "kghelpers.h"
#include "kgvectors.h"
-#include "kgnumbers.h" /* for keintegerp & knegativep */
/* (R7RS 3rd draft 6.3.6) vector? */
/* uses typep */
@@ -47,8 +47,8 @@ void make_vector(klisp_State *K)
klispE_throw_simple(K, "vector length is too big");
return;
}
- TValue new_vector = (ivalue(tv_s) == 0)
- ? K->empty_vector
+ TValue new_vector = (ivalue(tv_s) == 0)?
+ K->empty_vector
: kvector_new_sf(K, ivalue(tv_s), fill);
kapply_cc(K, new_vector);
}
@@ -61,7 +61,7 @@ void vector_length(klisp_State *K)
bind_1tp(K, ptree, "vector", ttisvector, vector);
- TValue res = i2tv(kvector_length(vector));
+ TValue res = i2tv(kvector_size(vector));
kapply_cc(K, res);
}
@@ -80,16 +80,16 @@ void vector_ref(klisp_State *K)
return;
}
int32_t i = ivalue(tv_i);
- if (i < 0 || i >= kvector_length(vector)) {
+ if (i < 0 || i >= kvector_size(vector)) {
klispE_throw_simple_with_irritants(K, "vector index out of bounds",
1, tv_i);
return;
}
- kapply_cc(K, kvector_array(vector)[i]);
+ kapply_cc(K, kvector_buf(vector)[i]);
}
/* (R7RS 3rd draft 6.3.6) vector-set! */
-void vector_setS(klisp_State *K)
+void vector_setB(klisp_State *K)
{
klisp_assert(ttisenvironment(K->next_env));
@@ -101,19 +101,19 @@ void vector_setS(klisp_State *K)
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)) {
+ if (i < 0 || i >= kvector_size(vector)) {
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;
}
- kvector_array(vector)[i] = tv_new_value;
+ kvector_buf(vector)[i] = tv_new_value;
kapply_cc(K, KINERT);
}
@@ -128,34 +128,21 @@ void vector_copy(klisp_State *K)
TValue new_vector = kvector_emptyp(v)?
v
- : kvector_new_bs_g(K, true, kvector_array(v), kvector_length(v));
+ : kvector_new_bs_g(K, true, kvector_buf(v), kvector_size(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));
+ /* don't allow cycles */
+ int32_t pairs;
+ check_list(K, false, ptree, &pairs, NULL);
+ TValue res = list_to_vector_h(K, ptree, pairs);
+ kapply_cc(K, res);
}
/* (R7RS 3rd draft 6.3.6) list->vector */
@@ -165,7 +152,11 @@ void list_to_vector(klisp_State *K)
TValue ptree = K->next_value;
bind_1p(K, ptree, ls);
- kapply_cc(K, list_to_vector_h(K, "list->vector", ls));
+ /* don't allow cycles */
+ int32_t pairs;
+ check_list(K, false, ls, &pairs, NULL);
+ TValue res = list_to_vector_h(K, ls, pairs);
+ kapply_cc(K, res);
}
/* (R7RS 3rd draft 6.3.6) vector->list */
@@ -176,13 +167,248 @@ void vector_to_list(klisp_State *K)
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);
+ TValue res = vector_to_list_h(K, v, NULL);
+ kapply_cc(K, res);
+}
+
+/* 13.? bytevector->vector, vector->bytevector */
+void bytevector_to_vector(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, str);
+ TValue res;
+
+ if (kbytevector_emptyp(str)) {
+ res = K->empty_vector;
+ } else {
+ uint32_t size = kbytevector_size(str);
+
+ /* MAYBE add vector constructor without fill */
+ /* no need to root this */
+ res = kvector_new_sf(K, size, KINERT);
+ uint8_t *src = kbytevector_buf(str);
+ TValue *dst = kvector_buf(res);
+ while(size--) {
+ uint8_t u8 = *src++; /* not needed but just in case */
+ *dst++ = i2tv(u8);
+ }
+ }
+ kapply_cc(K, res);
+}
+
+/* TEMP Only ASCII for now */
+void vector_to_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, "vector", ttisvector, vec);
+ TValue res;
+
+ if (kvector_emptyp(vec)) {
+ res = K->empty_bytevector;
+ } else {
+ uint32_t size = kvector_size(vec);
+
+ res = kbytevector_new_s(K, size); /* no need to root this */
+ TValue *src = kvector_buf(vec);
+ uint8_t *dst = kbytevector_buf(res);
+ while(size--) {
+ TValue tv = *src++;
+ if (!ttisu8(tv)) {
+ klispE_throw_simple_with_irritants(K, "Non u8 object found",
+ 1, tv);
+ return;
+ }
+ *dst++ = (uint8_t) ivalue(tv);
+ }
+ }
+ kapply_cc(K, res);
+}
+
+/* 13.2.9? vector-copy! */
+void vector_copyB(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, "vector", ttisvector, vector1,
+ "vector", ttisvector, vector2);
+
+ if (kvector_immutablep(vector2)) {
+ klispE_throw_simple(K, "immutable destination vector");
+ return;
+ } else if (kvector_size(vector1) > kvector_size(vector2)) {
+ klispE_throw_simple(K, "destination vector is too small");
+ return;
+ }
+
+ if (!tv_equal(vector1, vector2) &&
+ !tv_equal(vector1, K->empty_vector)) {
+ memcpy(kvector_buf(vector2),
+ kvector_buf(vector1),
+ kvector_size(vector1) * sizeof(TValue));
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* ?.? vector-copy-partial */
+/* TEMP: at least for now this always returns mutable vectors */
+void vector_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, "vector", ttisvector, vector,
+ "exact integer", keintegerp, tv_start,
+ "exact integer", keintegerp, tv_end);
+
+ if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
+ ivalue(tv_start) > kvector_size(vector)) {
+ /* 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) > kvector_size(vector)) {
+ 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_vector;
+ /* the if isn't strictly necessary but it's clearer this way */
+ if (size == 0) {
+ new_vector = K->empty_vector;
+ } else {
+ new_vector = kvector_new_bs_g(K, true, kvector_buf(vector)
+ + start, size);
+ }
+ kapply_cc(K, new_vector);
+}
+
+/* ?.? vector-copy-partial! */
+void vector_copy_partialB(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, "vector", ttisvector, vector1,
+ "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,
+ "vector", ttisvector, vector2,
+ "exact integer", keintegerp, tv_start2);
+
+ if (!ttisfixint(tv_start) || ivalue(tv_start) < 0 ||
+ ivalue(tv_start) > kvector_size(vector1)) {
+ /* 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) > kvector_size(vector1)) {
+ 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 (kvector_immutablep(vector2)) {
+ klispE_throw_simple(K, "immutable destination vector");
+ return;
+ }
+
+ if (!ttisfixint(tv_start2) || ivalue(tv_start2) < 0 ||
+ ivalue(tv_start2) > kvector_size(vector2)) {
+ 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) > kvector_size(vector2))) {
+ klispE_throw_simple(K, "not enough space in destination");
+ return;
+ }
+
+ if (size > 0) {
+ memcpy(kvector_buf(vector2) + start2,
+ kvector_buf(vector1) + start,
+ size * sizeof(TValue));
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* ?.? vector-fill! */
+void vector_fillB(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, "vector", ttisvector, vector,
+ "any", anytype, fill);
+
+ if (kvector_immutablep(vector)) {
+ klispE_throw_simple(K, "immutable vector");
+ return;
+ }
+
+ uint32_t size = kvector_size(vector);
+ TValue *buf = kvector_buf(vector);
+ while(size-- > 0) {
+ *buf++ = fill;
+ }
+ kapply_cc(K, KINERT);
}
/* ??.?.? vector->immutable-vector */
@@ -195,7 +421,7 @@ void vector_to_immutable_vector(klisp_State *K)
TValue res = kvector_immutablep(v)?
v
- : kvector_new_bs_g(K, false, kvector_array(v), kvector_length(v));
+ : kvector_new_bs_g(K, false, kvector_buf(v), kvector_size(v));
kapply_cc(K, res);
}
@@ -226,20 +452,39 @@ void kinit_vectors_ground_env(klisp_State *K)
/* (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);
+ add_applicative(K, ground_env, "vector-set!", vector_setB, 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 */
+ /* ?.? 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! */
+ /* ?.? vector->bytevector, bytevector->vector */
+ add_applicative(K, ground_env, "vector->bytevector",
+ vector_to_bytevector, 0);
+ add_applicative(K, ground_env, "bytevector->vector",
+ bytevector_to_vector, 0);
+
+ /* ?.? vector->string, string->vector */
+ /* in kgstrings.c */
+
+ /* ?.? vector-copy! */
+ add_applicative(K, ground_env, "vector-copy!", vector_copyB, 0);
+
+ /* ?.? vector-copy-partial */
+ add_applicative(K, ground_env, "vector-copy-partial",
+ vector_copy_partial, 0);
+ /* ?.? vector-copy-partial! */
+ add_applicative(K, ground_env, "vector-copy-partial!",
+ vector_copy_partialB, 0);
+
+ /* ?.? vector-fill! */
+ add_applicative(K, ground_env, "vector-fill!", vector_fillB, 0);
- /* ??.1.?? vector->immutable-vector */
+ /* ?.? vector->immutable-vector */
add_applicative(K, ground_env, "vector->immutable-vector",
vector_to_immutable_vector, 0);
}
diff --git a/src/kinteger.c b/src/kinteger.c
@@ -68,6 +68,7 @@ bool kinteger_read(klisp_State *K, char *buf, int32_t base, TValue *out,
print the number */
int32_t kbigint_print_size(TValue tv_bigint, int32_t base)
{
+ klisp_assert(ttisbigint(tv_bigint));
return mp_int_string_len(tv2bigint(tv_bigint), base);
}
@@ -75,6 +76,7 @@ int32_t kbigint_print_size(TValue tv_bigint, int32_t base)
void kbigint_print_string(klisp_State *K, TValue tv_bigint, int32_t base,
char *buf, int32_t limit)
{
+ klisp_assert(ttisbigint(tv_bigint));
mp_result res = mp_int_to_string(K, tv2bigint(tv_bigint), base, buf,
limit);
/* only possible error is truncation */
@@ -293,3 +295,23 @@ TValue kbigint_lcm(klisp_State *K, TValue n1, TValue n2)
krooted_tvs_pop(K);
return kbigint_try_fixint(K, tv_res);
}
+
+TValue kinteger_new_uint64(klisp_State *K, uint64_t x)
+{
+ if (x <= INT32_MAX) {
+ return i2tv((int32_t) x);
+ } else {
+ TValue res = kbigint_make_simple(K);
+ krooted_tvs_push(K, res);
+
+ uint8_t d[8];
+ for (int i = 7; i >= 0; i--) {
+ d[i] = (x & 0xFF);
+ x >>= 8;
+ }
+
+ mp_int_read_unsigned(K, tv2bigint(res), d, 8);
+ krooted_tvs_pop(K);
+ return res;
+ }
+}
diff --git a/src/kinteger.h b/src/kinteger.h
@@ -94,6 +94,7 @@ void kbigint_invert_sign(klisp_State *K, TValue tv_bigint);
/* read/write interface */
/* this works for bigints & fixints, returns true if ok */
+/* only positive numbers? */
bool kinteger_read(klisp_State *K, char *buf, int32_t base, TValue *out,
char **end);
@@ -132,4 +133,7 @@ TValue kbigint_abs(klisp_State *K, TValue tv_bigint);
TValue kbigint_gcd(klisp_State *K, TValue n1, TValue n2);
TValue kbigint_lcm(klisp_State *K, TValue n1, TValue n2);
+/* conversion from uint64_t */
+TValue kinteger_new_uint64(klisp_State *K, uint64_t x);
+
#endif
diff --git a/src/klimits.h b/src/klimits.h
@@ -63,6 +63,11 @@
#define MINCONTNAMETABSIZE 32
#endif
+/* minimum size for the require table (must be power of 2) */
+#ifndef MINREQUIRETABSIZE
+#define MINREQUIRETABSIZE 32
+#endif
+
/* starting size for ground environment hashtable */
/* at last count, there were about 200 bindings in ground env */
#define ENVTABSIZE 512
@@ -77,4 +82,9 @@
#define MINBYTEVECTORPORTBUFFER 256
#endif
+/* starting size for readline buffer */
+#ifndef MINREADLINEBUFFER
+#define MINREADLINEBUFFER 80
+#endif
+
#endif
diff --git a/src/klisp.c b/src/klisp.c
@@ -7,6 +7,14 @@
/*
** TODO This needs a serious clean up, I hacked it together during
** an all nighter...
+**
+** For starters:
+** - Split dofile in dofile & dostdin
+** - Merge dofile and dorfile with a boolean flat (load/require)
+** (use dorfile as a model)
+** - Add string-eval to the ground environment and use that
+** in dostring (use dorfile as a model)
+** - Add get_ground_binding somewhere (probably kstate) and use it.
*/
#include <stdio.h>
@@ -25,27 +33,37 @@
#include "kstring.h"
#include "kcontinuation.h"
#include "koperative.h"
+#include "kapplicative.h"
+#include "ksymbol.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"
-
-/* TODO update dependencies in makefile */
+#include "ksystem.h"
+#include "kghelpers.h" /* for do_pass_value and do_seq */
static const char *progname = KLISP_PROGNAME;
+/*
+** Three possible status after an evaluation:
+** error: the error continuation was passed a value -> EXIT_FAILURE
+** root: the root continuation was passed a value -> status depends on value
+** continue: normally completed evaluation, continue with next argument
+*/
+#define STATUS_ERROR -1
+#define STATUS_CONTINUE 0
+#define STATUS_ROOT 1
+
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"
+ " -l name load file " KLISP_QL("name") "\n"
+ " -r name require file " KLISP_QL("name") "\n"
" -i enter interactive mode after executing "
KLISP_QL("script") "\n"
" -v show version information\n"
@@ -139,7 +157,7 @@ static void show_error(klisp_State *K, TValue obj) {
static int report (klisp_State *K, int status)
{
- if (status != 0) {
+ if (status == STATUS_ERROR) {
const char *msg = "Error!";
k_message(progname, msg);
show_error(K, K->next_value);
@@ -149,7 +167,7 @@ static int report (klisp_State *K, int status)
static void print_version(void)
{
- k_message(NULL, KLISP_RELEASE " " KLISP_COPYRIGHT);
+ printf("%s\n", KLISP_RELEASE " " KLISP_COPYRIGHT);
}
/* REFACTOR maybe these should be moved to a general place to be used
@@ -213,9 +231,25 @@ void do_int_mark_error(klisp_State *K)
kapply_cc(K, error_obj);
}
+void do_int_mark_root(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]: rootp pointer
+ */
+ UNUSED(obj); /* ignore obj */
+ bool *rootp = (bool *) pvalue(xparams[0]);
+ *rootp = false; /* mark that we didn't explicitly call the root cont */
+ /* pass #INERT to the root continuation */
+ kapply_cc(K, KINERT);
+}
+
static int dostring (klisp_State *K, const char *s, const char *name)
{
bool errorp = false; /* may be set to true in error handler */
+ bool rootp = true; /* may be set to false in continuation */
UNUSED(name); /* could use as filename?? */
/* create a string input port */
@@ -253,12 +287,22 @@ static int dostring (klisp_State *K, const char *s, const char *name)
/* only port remains in the root stack */
krooted_tvs_push(K, inner_cont);
+ /* This continuation will discard the result of the evaluation
+ and return #inert instead, it will also signal via rootp = false
+ that the evaluation didn't explicitly invoke the root continuation
+ */
+ TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
+ 1, p2tv(&rootp));
+
+ krooted_tvs_pop(K); /* pop inner cont */
+ krooted_tvs_push(K, discard_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,
+ TValue eval_cont = kmake_continuation(K, discard_cont, do_str_eval,
1, env);
- krooted_tvs_pop(K); /* pop inner cont */
+ krooted_tvs_pop(K); /* pop discard cont */
krooted_tvs_push(K, eval_cont);
TValue read_cont = kmake_continuation(K, eval_cont, do_str_read,
1, port);
@@ -269,8 +313,8 @@ static int dostring (klisp_State *K, const char *s, const char *name)
klispS_run(K);
- int status = errorp? 1 : 0;
-
+ int status = errorp? STATUS_ERROR :
+ (rootp? STATUS_ROOT : STATUS_CONTINUE);
/* get the standard environment again in K->next_env */
K->next_env = env;
return report(K, status);
@@ -311,6 +355,7 @@ void do_file_read(klisp_State *K)
static int dofile(klisp_State *K, const char *name)
{
bool errorp = false; /* may be set to true in error handler */
+ bool rootp = true; /* may be set to false in continuation */
/* create a file input port (unless it's stdin, then just use) */
TValue port;
@@ -330,7 +375,7 @@ static int dofile(klisp_State *K, const char *name)
krooted_tvs_pop(K);
krooted_tvs_pop(K);
K->next_value = error_obj;
- return report(K, 1);
+ return report(K, STATUS_ERROR);
}
TValue name_str = kstring_new_b(K, name);
@@ -369,12 +414,23 @@ static int dofile(klisp_State *K, const char *name)
/* only port remains in the root stack */
krooted_tvs_push(K, inner_cont);
+
+ /* This continuation will discard the result of the evaluation
+ and return #inert instead, it will also signal via rootp = false
+ that the evaluation didn't explicitly invoke the root continuation
+ */
+ TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
+ 1, p2tv(&rootp));
+
+ krooted_tvs_pop(K); /* pop inner cont */
+ krooted_tvs_push(K, discard_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,
+ TValue eval_cont = kmake_continuation(K, discard_cont, do_file_eval,
1, env);
- krooted_tvs_pop(K); /* pop inner cont */
+ krooted_tvs_pop(K); /* pop discard cont */
krooted_tvs_push(K, eval_cont);
TValue read_cont = kmake_continuation(K, eval_cont, do_file_read,
1, port);
@@ -385,7 +441,8 @@ static int dofile(klisp_State *K, const char *name)
klispS_run(K);
- int status = errorp? 1 : 0;
+ int status = errorp? STATUS_ERROR :
+ (rootp? STATUS_ROOT : STATUS_CONTINUE);
/* get the standard environment again in K->next_env */
K->next_env = env;
@@ -401,6 +458,82 @@ static void dotty(klisp_State *K)
K->next_env = env;
}
+/* name != NULL */
+static int dorfile(klisp_State *K, const char *name)
+{
+ bool errorp = false; /* may be set to true in error handler */
+ bool rootp = true; /* may be set to false in continuation */
+
+ klisp_assert(name != NULL);
+
+ TValue name_str = kstring_new_b(K, name);
+ krooted_tvs_push(K, name_str);
+ /* 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 name remains in the root stack */
+ krooted_tvs_push(K, inner_cont);
+
+
+ /* This continuation will discard the result of the evaluation
+ and return #inert instead, it will also signal via rootp = false
+ that the evaluation didn't explicitly invoke the root continuation
+ */
+ TValue discard_cont = kmake_continuation(K, inner_cont, do_int_mark_root,
+ 1, p2tv(&rootp));
+
+ krooted_tvs_pop(K); /* pop inner cont */
+
+ /* set the cont & call require */
+ kset_cc(K, discard_cont);
+
+ /* prepare params (str still in the gc stack) */
+ env = K->next_env; /* this will be ignored anyways */
+ TValue ptree = kcons(K, name_str, KNIL);
+ krooted_tvs_pop(K);
+ krooted_tvs_push(K, ptree);
+ /* TODO factor this out into a get_ground_binding(K, char *) */
+ TValue req = ksymbol_new_b(K, "require", KNIL);
+ krooted_vars_push(K, &req);
+ klisp_assert(kbinds(K, K->ground_env, req));
+ req = kunwrap(kget_binding(K, K->ground_env, req));
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
+
+ klispS_tail_call_si(K, req, ptree, env, KNIL);
+ klispS_run(K);
+
+ int status = errorp? STATUS_ERROR :
+ (rootp? STATUS_ROOT : STATUS_CONTINUE);
+
+ /* get the standard environment again in K->next_env */
+ K->next_env = env;
+ return report(K, status);
+}
+
static int handle_script(klisp_State *K, char **argv, int n)
{
const char *fname;
@@ -417,7 +550,7 @@ static int handle_script(klisp_State *K, char **argv, int n)
/* 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)
+static int collectargs (char **argv, bool *pi, bool *pv, bool *pe, bool *pl)
{
int i;
for (i = 1; argv[i] != NULL; i++) {
@@ -437,8 +570,13 @@ static int collectargs (char **argv, bool *pi, bool *pv, bool *pe)
*pv = true;
break;
case 'e':
- *pe = true; /* go through */
-// case 'l': /* No library for now */
+ *pe = true;
+ goto select_arg;
+ case 'l':
+ *pl = true;
+ goto select_arg;
+ case 'r':
+ select_arg:
if (argv[i][2] == '\0') {
i++;
if (argv[i] == NULL)
@@ -459,6 +597,8 @@ static int runargs (klisp_State *K, char **argv, int n)
TValue env = K->next_env;
UNUSED(env);
+ /* TEMP All passes to root cont and all resulting values will be ignored,
+ the only way to interrupt the running of arguments is to throw an error */
for (int i = 1; i < n; i++) {
if (argv[i] == NULL)
continue;
@@ -466,46 +606,106 @@ static int runargs (klisp_State *K, char **argv, int n)
klisp_assert(argv[i][0] == '-');
switch (argv[i][1]) { /* option */
- case 'e': {
+ case 'e': { /* eval expr */
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;
+ int res = dostring(K, chunk, "=(command line)");
+ if (res != STATUS_CONTINUE)
+ return res; /* stop if eval fails/exit */
+ break;
+ }
+ case 'l': { /* load file */
+ const char *filename = argv[i] + 2;
+ if (*filename == '\0') filename = argv[++i];
+ klisp_assert(filename != NULL);
+
+ int res = dofile(K, filename);
+ if (res != STATUS_CONTINUE)
+ return res; /* stop if file fails/exit */
+ break;
+ }
+ case 'r': { /* require file */
+ const char *filename = argv[i] + 2;
+ if (*filename == '\0') filename = argv[++i];
+ klisp_assert(filename != NULL);
+
+ int res = dorfile(K, filename);
+ if (res != STATUS_CONTINUE)
+ return res; /* stop if file fails/exit */
break;
}
-// case 'l': /* no libraries for now */
default:
break;
}
}
- return 0;
+ return STATUS_CONTINUE;
+}
+
+static void populate_argument_lists(klisp_State *K, char **argv, int argc,
+ int script)
+{
+ /* first create the script list */
+ TValue tail = KNIL;
+ TValue obj = KINERT;
+ krooted_vars_push(K, &tail);
+ krooted_vars_push(K, &obj);
+ while(argc > script) {
+ char *arg = argv[--argc];
+ obj = kstring_new_b_imm(K, arg);
+ tail = kimm_cons(K, obj, tail);
+ }
+ /* Store the script argument list */
+ obj = ksymbol_new_b(K, "get-script-arguments", KNIL);
+ klisp_assert(kbinds(K, K->ground_env, obj));
+ obj = kunwrap(kget_binding(K, K->ground_env, obj));
+ tv2op(obj)->extra[0] = tail;
+
+ while(argc > 0) {
+ char *arg = argv[--argc];
+ obj = kstring_new_b_imm(K, arg);
+ tail = kimm_cons(K, obj, tail);
+ }
+ /* Store the interpreter argument list */
+ obj = ksymbol_new_b(K, "get-interpreter-arguments", KNIL);
+ klisp_assert(kbinds(K, K->ground_env, obj));
+ obj = kunwrap(kget_binding(K, K->ground_env, obj));
+ tv2op(obj)->extra[0] = tail;
+
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
}
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);
+ const char *init = getenv(KLISP_INIT);
+ int res;
+ if (init == NULL)
+ res = STATUS_CONTINUE;
+ else
+ res = dostring(K, init, "=" KLISP_INIT);
+
+ return res;
}
/* This is weird but was done to follow lua scheme */
struct Smain {
int argc;
char **argv;
- int status;
+ int status; /* STATUS_ROOT, STATUS_ERROR, STATUS_CONTINUE */
};
-static int pmain(klisp_State *K)
+static void 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;
+ s->status = STATUS_CONTINUE;
+ /* this is needed in case there are no arguments and no init */
+ K->next_value = KINERT;
+
/* There is a standard env in K->next_env, a common one is used for all
evaluations (init, expression args, script/repl) */
@@ -524,50 +724,51 @@ static int pmain(klisp_State *K)
/* init (eval KLISP_INIT env variable contents) */
s->status = handle_klispinit(K);
- if (s->status != 0)
- return 0;
+ if (s->status != STATUS_CONTINUE)
+ return;
- bool has_i = false, has_v = false, has_e = false;
- int script = collectargs(argv, &has_i, &has_v, &has_e);
+ bool has_i = false, has_v = false, has_e = false, has_l = false;
+ int script = collectargs(argv, &has_i, &has_v, &has_e, &has_l);
if (script < 0) { /* invalid args? */
print_usage();
- s->status = 1;
- return 0;
+ s->status = STATUS_ERROR;
+ return;
}
if (has_v)
print_version();
+ /* TEMP this could be either set before or after running the arguments,
+ we'll do it before for now */
+ populate_argument_lists(K, argv, s->argc, (script > 0) ? script : s->argc);
+
s->status = runargs(K, argv, (script > 0) ? script : s->argc);
- if (s->status != 0)
- return 0;
+ if (s->status != STATUS_CONTINUE)
+ return;
if (script > 0) {
s->status = handle_script(K, argv, script);
}
- if (s->status != 0)
- return 0;
+ if (s->status != STATUS_CONTINUE)
+ return;
if (has_i) {
dotty(K);
- } else if (script == 0 && !has_e && !has_v) {
- if (true) {
+ } else if (script == 0 && !has_e && !has_l && !has_v) {
+ if (ksystem_isatty(K, kcurr_input_port(K))) {
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();
@@ -580,9 +781,27 @@ int main(int argc, char *argv[])
s.argc = argc;
s.argv = argv;
K->next_value = p2tv(&s);
- status = pmain(K);
+
+ pmain(K);
+
+ /* convert s.status to either EXIT_SUCCESS or EXIT_FAILURE */
+ if (s.status == STATUS_CONTINUE || s.status == STATUS_ROOT) {
+ /* must check value passed to the root continuation to
+ return proper exit status */
+ if (ttisinert(K->next_value)) {
+ s.status = EXIT_SUCCESS;
+ } else if (ttisboolean(K->next_value)) {
+ s.status = kis_true(K->next_value)? EXIT_SUCCESS : EXIT_FAILURE;
+ } else if (ttisfixint(K->next_value)) {
+ s.status = ivalue(K->next_value);
+ } else {
+ s.status = EXIT_FAILURE;
+ }
+ } else { /* s.status == STATUS_ERROR */
+ s.status = EXIT_FAILURE;
+ }
klisp_close(K);
- return (status || s.status)? EXIT_FAILURE : EXIT_SUCCESS;
+ return s.status;
}
diff --git a/src/klispconf.h b/src/klispconf.h
@@ -25,6 +25,7 @@
** non-ansi feature or library.
*/
#if defined(__STRICT_ANSI__)
+/* XXX currently unused */
#define KLISP_ANSI
#endif
@@ -36,11 +37,13 @@
#if defined(KLISP_USE_LINUX)
#define KLISP_USE_POSIX
#define KLISP_USE_DLOPEN /* needs an extra library: -ldl */
+/* XXX currently unused */
#define KLISP_USE_READLINE /* needs some extra libraries */
#endif
#if defined(KLISP_USE_MACOSX)
#define KLISP_USE_POSIX
+/* XXX currently unused */
#define KLISP_DL_DYLD /* does not need extra library */
#endif
@@ -57,7 +60,6 @@
*/
#define KLISP_QL(x) "'" x "'"
#define KLISP_QS KLISP_QL("%s")
-/* /TODO */
/*
@@ KLISP_USE_POSIX includes all functionallity listed as X/Open System
@@ -72,16 +74,87 @@
#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
+@@ KLISP_PATH and KLISP_CPATH are the names of the environment variables that
+@* Klisp 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_PATH "KLISP_PATH"
+#define KLISP_CPATH "KLISP_CPATH"
#define KLISP_INIT "KLISP_INIT"
+
+/*
+@@ KLISP_PATH_DEFAULT is the default path that Klisp uses to look for
+@* Klisp libraries.
+@@ KLISP_CPATH_DEFAULT is the default path that Klisp uses to look for
+@* C libraries.
+** CHANGE them if your machine has a non-conventional directory
+** hierarchy or if you want to install your libraries in
+** non-conventional directories.
+*/
+#if defined(_WIN32)
+/*
+** In Windows, any exclamation mark ('!') in the path is replaced by the
+** path of the directory of the executable file of the current process.
+*/
+#define KLISP_LDIR "!\\klisp\\"
+#define KLISP_CDIR "!\\"
+#define KLISP_PATH_DEFAULT \
+ ".\\?.k;" ".\\?" \
+ KLISP_LDIR"?.k;" KLISP_LDIR"?;" \
+ KLISP_CDIR"?.k;" KLISP_CDIR"?;"
+/* XXX Not used for now */
+#define KLISP_CPATH_DEFAULT \
+ ".\\?.dll;" KLISP_CDIR"?.dll;" KLISP_CDIR"loadall.dll"
+
+#else
+#define KLISP_ROOT "/usr/local/"
+#define KLISP_LDIR KLISP_ROOT "share/klisp/0.3/"
+#define KLISP_CDIR KLISP_ROOT "lib/klisp/0.3/"
+#define KLISP_PATH_DEFAULT \
+ "./?.k;./?;" \
+ KLISP_LDIR"?.k;" KLISP_LDIR"?;" \
+ KLISP_CDIR"?;" KLISP_CDIR"?.k"
+/* XXX Not used for now */
+#define KLISP_CPATH_DEFAULT \
+ "./?.so;" KLISP_CDIR"?.so;" KLISP_CDIR"loadall.so"
+#endif
+
+
+/*
+@@ KLISP_DIRSEP is the directory separator (for submodules).
+** XXX KLISP_DIRSEP is not currently used
+** This allows naturally looking paths in windows while still using
+** CHANGE it if your machine does not use "/" as the directory separator
+** and is not Windows. (On Windows Klisp automatically uses "\".)
+*/
+#if defined(_WIN32)
+#define KLISP_DIRSEP "\\"
+#else
+#define KLISP_DIRSEP "/"
+#endif
+
+
+/*
+@@ KLISP_PATHSEP is the character that separates templates in a path.
+@@ KLISP_PATH_MARK is the string that marks the substitution points in a
+@* template.
+@@ KLISP_EXECDIR in a Windows path is replaced by the executable's
+@* directory.
+@@ XXX KLISP_IGMARK is not currently used in klisp.
+@@ KLISP_IGMARK is a mark to ignore all before it when bulding the
+@* klispopen_ function name.
+** CHANGE them if for some reason your system cannot use those
+** characters. (E.g., if one of those characters is a common character
+** in file/directory names.) Probably you do not need to change them.
+*/
+#define KLISP_PATHSEP ";"
+#define KLISP_PATH_MARK "?"
+#define KLISP_EXECDIR "!"
+#define KLISP_IGMARK "-"
+
/*
@@ klisp_stdin_is_tty detects whether the standard input is a 'tty' (that
@* is, whether we're running klisp interactively).
@@ -117,7 +190,7 @@
#define KTRACK_MARKS true
*/
-/* TODO use this defines */
+/* TODO use this defines everywhere */
#define KTRACK_NAMES true
#define KTRACK_SI true
diff --git a/src/kobject.c b/src/kobject.c
@@ -1,5 +1,5 @@
/*
-** kobject.h
+** kobject.c
** Type definitions for Kernel Objects
** See Copyright Notice in klisp.h
*/
@@ -24,10 +24,20 @@ const TValue kipinf = KIPINF_;
const TValue kiminf = KIMINF_;
const TValue krwnpv = KRWNPV_;
const TValue kundef = KUNDEF_;
-const TValue kspace = KSPACE_;
-const TValue knewline = KNEWLINE_;
const TValue kfree = KFREE_;
+const TValue knull = KNULL_;
+const TValue kalarm = KALARM_;
+const TValue kbackspace = KBACKSPACE_;
+const TValue ktab = KTAB_;
+const TValue knewline = KNEWLINE_;
+const TValue kreturn = KRETURN_;
+const TValue kescape = KESCAPE_;
+const TValue kspace = KSPACE_;
+const TValue kdelete = KDELETE_;
+const TValue kvtab = KVTAB_;
+const TValue kformfeed = KFORMFEED_;
+
/*
** The name strings for all TValue types
** This should be updated if types are modified in kobject.h
diff --git a/src/kobject.h b/src/kobject.h
@@ -244,9 +244,20 @@ 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;})
+/* for items in bytevectors */
#define ttisu8(o) ({ \
TValue o__ = (o); \
(ttisfixint(o__) && ivalue(o__) >= 0 && ivalue(o__) < 256); })
+/* for radixes in string<->number */
+#define ttisradix(o) ({ \
+ TValue o__ = (o); \
+ (ttisfixint(o__) && \
+ (ivalue(o__) == 2 || ivalue(o__) == 8 || \
+ ivalue(o__) == 10 || ivalue(o__) == 16)); })
+/* for bases in char->digit and related functions */
+#define ttisbase(o) ({ \
+ TValue o__ = (o); \
+ (ttisfixint(o__) && ivalue(o__) >= 2 && ivalue(o__) <= 36); })
#define ttisinteger(o) ({ TValue o__ = (o); \
(ttiseinteger(o__) || \
(ttisdouble(o__) && (floor(dvalue(o__)) == dvalue(o__))));})
@@ -605,10 +616,20 @@ union GCObject {
#define KIMINF_ {.tv = {.t = K_TAG_IINF, .v = { .i = -1 }}}
#define KRWNPV_ {.tv = {.t = K_TAG_RWNPV, .v = { .i = 0 }}}
#define KUNDEF_ {.tv = {.t = K_TAG_UNDEFINED, .v = { .i = 0 }}}
-#define KSPACE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = ' ' }}}
-#define KNEWLINE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\n' }}}
#define KFREE_ {.tv = {.t = K_TAG_FREE, .v = { .i = 0 }}}
-
+/* named character */
+/* N.B. don't confuse with KNULL_ with KNIL!!! */
+#define KNULL_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\0' }}}
+#define KALARM_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\a' }}}
+#define KBACKSPACE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\b' }}}
+#define KTAB_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\t' }}}
+#define KNEWLINE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\n' }}}
+#define KRETURN_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\r' }}}
+#define KESCAPE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\x1b' }}}
+#define KSPACE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = ' ' }}}
+#define KDELETE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\x7f' }}}
+#define KVTAB_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\v' }}}
+#define KFORMFEED_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\f' }}}
/* RATIONALE: the ones above can be used in initializers */
#define KNIL ((TValue) KNIL_)
@@ -807,27 +828,27 @@ int32_t kmark_count;
#define kis_mutable(o_) ((tv_get_kflags(o_) & K_FLAG_IMMUTABLE) == 0)
#define kis_immutable(o_) (!kis_mutable(o_))
-/* KFlags for symbols */
-/* has external representation (identifiers) */
-#define K_FLAG_EXT_REP 0x01
-#define khas_ext_rep(s_) ((tv_get_kflags(s_) & K_FLAG_EXT_REP) != 0)
-
/* KFlags for marking continuations */
#define K_FLAG_OUTER 0x01
#define K_FLAG_INNER 0x02
#define K_FLAG_DYNAMIC 0x04
#define K_FLAG_BOOL_CHECK 0x08
+/* this is the same as immutable, but there is no problem
+ with continuations */
+#define K_FLAG_INERT_RET 0x10
/* evaluate c_ more than once */
#define kset_inner_cont(c_) (tv_get_kflags(c_) |= K_FLAG_INNER)
#define kset_outer_cont(c_) (tv_get_kflags(c_) |= K_FLAG_OUTER)
#define kset_dyn_cont(c_) (tv_get_kflags(c_) |= K_FLAG_DYNAMIC)
#define kset_bool_check_cont(c_) (tv_get_kflags(c_) |= K_FLAG_BOOL_CHECK)
+#define kset_inert_ret_cont(c_) (tv_get_kflags(c_) |= K_FLAG_INERT_RET)
#define kis_inner_cont(c_) ((tv_get_kflags(c_) & K_FLAG_INNER) != 0)
#define kis_outer_cont(c_) ((tv_get_kflags(c_) & K_FLAG_OUTER) != 0)
#define kis_dyn_cont(c_) ((tv_get_kflags(c_) & K_FLAG_DYNAMIC) != 0)
#define kis_bool_check_cont(c_) ((tv_get_kflags(c_) & K_FLAG_BOOL_CHECK) != 0)
+#define kis_inert_ret_cont(c_) ((tv_get_kflags(c_) & K_FLAG_INERT_RET) != 0)
#define K_FLAG_OUTPUT_PORT 0x01
#define K_FLAG_INPUT_PORT 0x02
diff --git a/src/kpair.c b/src/kpair.c
@@ -37,8 +37,6 @@ TValue klist_g(klisp_State *K, bool m, int32_t n, ...)
klisp_assert(n < MAX_LIST_N);
- /* don't use any of the klisp dummys, because this is
- called from many places */
TValue dummy = kcons_g(K, m, KINERT, KNIL);
krooted_tvs_push(K, dummy);
TValue tail = dummy;
diff --git a/src/kpair.h b/src/kpair.h
@@ -61,7 +61,6 @@ inline TValue kcdr(TValue p)
#define kcdddar(p_) (kcdr(kcdr(kcdr(kcar(p_)))))
#define kcddddr(p_) (kcdr(kcdr(kcdr(kcdr(p_)))))
-/* these will also work with immutable pairs */
inline void kset_car(TValue p, TValue v)
{
klisp_assert(kmutable_pairp(p));
@@ -103,64 +102,4 @@ TValue klist_g(klisp_State *K, bool m, int32_t n, ...);
#define klist(K_, n_, ...) (klist_g(K_, true, n_, __VA_ARGS__))
#define kimm_list(K_, n_, ...) (klist_g(K_, false, n_, __VA_ARGS__))
-inline TValue kget_dummy1(klisp_State *K)
-{
- klisp_assert(ttispair(K->dummy_pair1) && ttisnil(kcdr(K->dummy_pair1)));
- return K->dummy_pair1;
-}
-
-inline TValue kget_dummy1_tail(klisp_State *K)
-{
- klisp_assert(ttispair(K->dummy_pair1));
- return kcdr(K->dummy_pair1);
-}
-
-inline TValue kcutoff_dummy1(klisp_State *K)
-{
- klisp_assert(ttispair(K->dummy_pair1));
- TValue res = kcdr(K->dummy_pair1);
- kset_cdr(K->dummy_pair1, KNIL);
- return res;
-}
-
-inline TValue kget_dummy2(klisp_State *K)
-{
- klisp_assert(ttispair(K->dummy_pair2) && ttisnil(kcdr(K->dummy_pair2)));
- return K->dummy_pair2;
-}
-
-inline TValue kget_dummy2_tail(klisp_State *K)
-{
- klisp_assert(ttispair(K->dummy_pair2));
- return kcdr(K->dummy_pair2);
-}
-
-inline TValue kcutoff_dummy2(klisp_State *K)
-{
- klisp_assert(ttispair(K->dummy_pair2));
- TValue res = kcdr(K->dummy_pair2);
- kset_cdr(K->dummy_pair2, KNIL);
- return res;
-}
-
-inline TValue kget_dummy3(klisp_State *K)
-{
- klisp_assert(ttispair(K->dummy_pair3) && ttisnil(kcdr(K->dummy_pair3)));
- return K->dummy_pair3;
-}
-
-inline TValue kget_dummy3_tail(klisp_State *K)
-{
- klisp_assert(ttispair(K->dummy_pair3));
- return kcdr(K->dummy_pair3);
-}
-
-inline TValue kcutoff_dummy3(klisp_State *K)
-{
- klisp_assert(ttispair(K->dummy_pair3));
- TValue res = kcdr(K->dummy_pair3);
- kset_cdr(K->dummy_pair3, KNIL);
- return res;
-}
-
#endif
diff --git a/src/krational.c b/src/krational.c
@@ -190,15 +190,17 @@ bool krational_read_decimal(klisp_State *K, char *buf, int32_t base, TValue *out
/* this is used by write to estimate the number of chars necessary to
print the number */
-int32_t kbigrat_print_size(TValue tv_bigint, int32_t base)
+int32_t kbigrat_print_size(TValue tv_bigrat, int32_t base)
{
- return mp_rat_string_len(tv2bigrat(tv_bigint), base);
+ klisp_assert(ttisbigrat(tv_bigrat));
+ return mp_rat_string_len(tv2bigrat(tv_bigrat), base);
}
/* this is used by write */
void kbigrat_print_string(klisp_State *K, TValue tv_bigrat, int32_t base,
char *buf, int32_t limit)
{
+ klisp_assert(ttisbigrat(tv_bigrat));
mp_result res = mp_rat_to_string(K, tv2bigrat(tv_bigrat), base, buf,
limit);
/* only possible error is truncation */
diff --git a/src/kread.c b/src/kread.c
@@ -5,6 +5,7 @@
*/
#include <stdio.h>
+#include <string.h>
#include <stdlib.h>
#include "kread.h"
@@ -15,6 +16,7 @@
#include "kerror.h"
#include "ktable.h"
#include "kport.h"
+#include "kstring.h"
/*
@@ -537,7 +539,7 @@ TValue kread_fsm(klisp_State *K, bool listp)
read_next_token = false;
}
}
- } else { /* if(read_next_token) */
+ } else { /* read_next_token == false */
/* process the object just read */
switch(get_state(K)) {
case ST_FIRST_EOF_LIST:
@@ -674,24 +676,20 @@ TValue kread_fsm(klisp_State *K, bool listp)
*/
TValue kread(klisp_State *K, bool listp)
{
- TValue obj;
-
klisp_assert(ttisnil(K->shared_dict));
- /* WORKAROUND: for repl problem with eofs */
- K->ktok_seen_eof = false;
-
- obj = kread_fsm(K, listp);
-
- /* NOTE: clear after function to allow earlier gc */
- clear_shared_dict(K);
+ TValue obj = kread_fsm(K, listp);
+ clear_shared_dict(K); /* clear after function to allow earlier gc */
return obj;
}
/* 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;
+ if (!tv_equal(port, K->curr_port)) {
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
+ }
K->read_mconsp = mut;
ktok_set_source_info(K, kport_filename(port),
@@ -704,23 +702,39 @@ TValue kread_from_port_g(klisp_State *K, TValue port, bool mut, bool listp)
return obj;
}
+/*
+** Reader Interface
+*/
+
TValue kread_from_port(klisp_State *K, TValue port, bool mut)
{
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_input(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_textual(port));
return kread_from_port_g(K, port, mut, false);
}
TValue kread_list_from_port(klisp_State *K, TValue port, bool mut)
{
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_input(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_textual(port));
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,
- by operations on all ports. */
- K->ktok_seen_eof = false;
-
- K->curr_port = port;
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_input(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_textual(port));
+
+ if (!tv_equal(port, K->curr_port)) {
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
+ }
int ch;
if (peek) {
ch = ktok_peekc(K);
@@ -736,10 +750,15 @@ 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)
{
- /* 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;
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_input(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_binary(port));
+
+ if (!tv_equal(port, K->curr_port)) {
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
+ }
int32_t u8;
if (peek) {
u8 = ktok_peekc(K);
@@ -753,14 +772,67 @@ TValue kread_peek_u8_from_port(klisp_State *K, TValue port, bool peek)
return u8 == EOF? KEOF : i2tv(u8 & 0xff);
}
+TValue kread_line_from_port(klisp_State *K, TValue port)
+{
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_input(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_textual(port));
+
+ if (!tv_equal(port, K->curr_port)) {
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
+ }
+
+ uint32_t size = MINREADLINEBUFFER;
+ uint32_t i = 0;
+ int ch;
+ TValue new_str = kstring_new_s(K, size);
+ krooted_vars_push(K, &new_str);
+
+ char *buf = kstring_buf(new_str);
+ ktok_set_source_info(K, kport_filename(port),
+ kport_line(port), kport_col(port));
+ bool found_newline = false;
+ while(true) {
+ ch = ktok_getc(K);
+ if (ch == EOF) {
+ break;
+ } else if (ch == '\n') {
+ /* adjust string to the right size if necessary */
+ if (i < size) {
+ new_str = kstring_new_bs(K, kstring_buf(new_str), i);
+ }
+ found_newline = true;
+ break;
+ } else {
+ if (i == size) {
+ size *= 2;
+ char *old_buf = kstring_buf(new_str);
+ new_str = kstring_new_s(K, size);
+ buf = kstring_buf(new_str);
+ /* copy the data we have */
+ memcpy(buf, old_buf, i);
+ buf += i;
+ }
+ *buf++ = (char) ch;
+ ++i;
+ }
+ }
+ kport_update_source_info(port, K->ktok_source_info.line,
+ K->ktok_source_info.col);
+ krooted_vars_pop(K);
+ return found_newline? new_str : KEOF;
+}
+
/* 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)
+ that could affect the (freshly reset) source info */
+void kread_clear_leading_whitespace_from_port(klisp_State *K, TValue port)
{
- K->curr_port = port;
+ if (!tv_equal(port, K->curr_port)) {
+ K->ktok_seen_eof = false; /* WORKAROUND: for repl problem with eofs */
+ K->curr_port = port;
+ }
/* source code info isn't important because it will be reset later */
- ktok_ignore_whitespace_and_comments(K);
+ ktok_ignore_whitespace(K);
}
diff --git a/src/kread.h b/src/kread.h
@@ -17,9 +17,8 @@ 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);
+TValue kread_line_from_port(klisp_State *K, TValue port);
+void kread_clear_leading_whitespace_from_port(klisp_State *K, TValue port);
#endif
diff --git a/src/kreal.c b/src/kreal.c
@@ -562,6 +562,7 @@ bool dtoa(klisp_State *K, double d, char *buf, int32_t upoint, int32_t *out_h,
number */
int32_t kdouble_print_size(TValue tv_double)
{
+ klisp_assert(ttisdouble(tv_double));
UNUSED(tv_double);
return 1024;
}
@@ -569,6 +570,7 @@ int32_t kdouble_print_size(TValue tv_double)
void kdouble_print_string(klisp_State *K, TValue tv_double,
char *buf, int32_t limit)
{
+ klisp_assert(ttisdouble(tv_double));
/* TODO: add exponent to values too large or too small */
/* TEMP */
int32_t h = 0;
diff --git a/src/krepl.c b/src/krepl.c
@@ -19,11 +19,15 @@
#include "ksymbol.h"
#include "kport.h"
#include "kpair.h"
-#include "kgerror.h"
-/* for names */
-#include "ktable.h"
-/* for do_pass_value */
-#include "kgcontinuations.h"
+#include "ktable.h" /* for names */
+#include "kghelpers.h" /* for do_pass_value */
+
+/* Continuations */
+void do_repl_read(klisp_State *K);
+void do_repl_eval(klisp_State *K);
+void do_repl_loop(klisp_State *K);
+void do_repl_int_error(klisp_State *K);
+
/* TODO add names & source info to the repl continuations */
@@ -41,13 +45,10 @@ void do_repl_read(klisp_State *K)
TValue port = kcdr(K->kd_in_port_key);
klisp_assert(kfport_file(port) == stdin);
-#if 0 /* Let's disable this for now */
- /* workaround to the problem of the dangling '\n' in repl
+ /* Workaround to the problem of the dangling '\n' in repl
(from previous line) */
- kread_ignore_whitespace_and_comments_from_port(K, port);
-
- kport_reset_source_info(port);
-#endif
+ kread_clear_leading_whitespace_from_port(K, port);
+ kport_reset_source_info(port); /* always start with a clean source info */
obj = kread_from_port(K, port, true); /* read mutable pairs */
kapply_cc(K, obj);
}
@@ -82,17 +83,14 @@ void do_repl_eval(klisp_State *K)
}
}
-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 */
+/* this is called from both do_repl_loop and do_repl_int_error */
/* GC: assumes denv is NOT rooted */
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);
+ TValue error_int = kmake_operative(K, do_repl_int_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);
@@ -154,7 +152,7 @@ void do_repl_loop(klisp_State *K)
}
/* the underlying function of the error cont */
-void do_int_repl_error(klisp_State *K)
+void do_repl_int_error(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -237,7 +235,7 @@ void do_int_repl_error(klisp_State *K)
krooted_tvs_pop(K);
} else {
fprintf(stderr, "\n*ERROR*: not an error object passed to "
- "error continuation");
+ "error continuation\n\n");
}
UNUSED(divert);
@@ -262,3 +260,13 @@ void kinit_repl(klisp_State *K)
/* GC: create_loop will root std_env */
create_loop(K, std_env);
}
+
+/* init continuation names */
+void kinit_repl_cont_names(klisp_State *K)
+{
+ Table *t = tv2table(K->cont_name_table);
+ 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-print-loop");
+ add_cont_name(K, t, do_repl_int_error, "repl-int-error");
+}
diff --git a/src/krepl.h b/src/krepl.h
@@ -12,12 +12,7 @@
#include "kobject.h"
void kinit_repl(klisp_State *K);
-
-/* continuation functions */
-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);
+/* init continuation names */
+void kinit_repl_cont_names(klisp_State *K);
#endif
diff --git a/src/kscript.c b/src/kscript.c
@@ -1,254 +0,0 @@
-/*
-** kscript.c
-** klisp noninteractive script execution
-** See Copyright Notice in klisp.h
-*/
-#include <stdio.h>
-#include <setjmp.h>
-
-#include "klisp.h"
-#include "kstate.h"
-#include "kobject.h"
-#include "kcontinuation.h"
-#include "kenvironment.h"
-#include "kerror.h"
-#include "kread.h"
-#include "kwrite.h"
-#include "kstring.h"
-#include "krepl.h"
-#include "kscript.h"
-#include "ksymbol.h"
-#include "kport.h"
-#include "kpair.h"
-#include "kgcontrol.h"
-#include "kgerror.h"
-/* for names */
-#include "ktable.h"
-
-/* Push (v) in GC roots and return (v). */
-static inline TValue krooted_tvs_pass(klisp_State *K, TValue v)
-{
- krooted_tvs_push(K, v);
- return v;
-}
-
-#if KTRACK_SI
-static inline TValue krooted_tvs_pass_si(klisp_State *K, TValue v, TValue si)
-{
- krooted_tvs_push(K, v);
- kset_source_info(K, v, si);
- return v;
-}
-#endif
-
-/* the exit continuation, it exits the loop */
-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 */
-
- switch(ttype(obj)) {
- case K_TINERT:
- K->script_exit_code = 0;
- break;
- case K_TFIXINT:
- K->script_exit_code = (int) ivalue(obj);
- break;
- default:
- K->script_exit_code = KSCRIPT_DEFAULT_ERROR_EXIT_CODE;
- /* TODO: print error message here ? */
- break;
- }
-
- /* force the loop to terminate */
- K->next_func = NULL;
- return;
-}
-
-
-/* the underlying function of the error cont */
-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(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");
- }
-
- /* Save the exit code to be returned from interpreter
- main(). Terminate the interpreter loop. */
-
- K->script_exit_code = KSCRIPT_DEFAULT_ERROR_EXIT_CODE;
- K->next_func = NULL;
-}
-
-/* convert C style argc-argv pair to list of strings */
-static TValue argv2value(klisp_State *K, int argc, char *argv[])
-{
- TValue dummy = kcons_g(K, false, KINERT, KNIL);
- krooted_tvs_push(K, dummy);
- TValue tail = dummy;
- for (int i = 0; i < argc; i++) {
- TValue next_car = kstring_new_b_imm(K, argv[i]);
- krooted_tvs_push(K, next_car);
- TValue np = kcons_g(K, false, next_car, KNIL);
- krooted_tvs_pop(K);
- kset_cdr_unsafe(K, tail, np);
- tail = np;
- }
- krooted_tvs_pop(K);
- return kcdr(dummy);
-}
-
-/* loader_body(K, ARGV, DENV) returns the value
- *
- * ((load (car ARGV))
- * ($if ($binds? DENV main) (main ARGV) #inert)
- *
- */
-static TValue loader_body(klisp_State *K, TValue argv, TValue denv)
-{
- int32_t rooted_tvs_mark = K->rooted_tvs_top;
-# define S(z) (krooted_tvs_pass(K, ksymbol_new(K, (z), KNIL)))
-# define C(car, cdr) (krooted_tvs_pass(K, kcons_g(K, false, (car), (cdr))))
-# define L(n, ...) (krooted_tvs_pass(K, klist_g(K, false, (n), __VA_ARGS__)))
- TValue main_sym = S("main");
- TValue script_name = krooted_tvs_pass(K, kcar(argv));
- TValue body =
- L(2, L(2, S("load"), script_name),
- L(4, S("$if"), L(3, S("$binds?"), denv, main_sym),
- L(2, main_sym, C(S("list"), argv)),
- KINERT));
-# undef S
-# undef L
- K->rooted_tvs_top = rooted_tvs_mark;
- return body;
-}
-
-/* call this to init the noninteractive mode */
-
-void kinit_script(klisp_State *K, int argc, char *argv[])
-{
-# define R(z) (krooted_tvs_pass(K, (z)))
-# define G(z, sym) \
- do { TValue symbol = ksymbol_new(K, (sym), KNIL); \
- krooted_tvs_push(K, symbol); \
- kadd_binding(K, K->ground_env, symbol, (z)); \
- krooted_tvs_pop(K); \
- } while (0)
-
-#if KTRACK_SI
- TValue str = R(kstring_new_b_imm(K, __FILE__));
- TValue tail = R(kcons(K, i2tv(__LINE__), i2tv(0)));
- TValue si = kcons(K, str, tail);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_push(K, si);
-# define RSI(z) (krooted_tvs_pass_si(K, (z), si))
-#else
-# define RSI(z) R(z)
-#endif
-
- TValue std_env = RSI(kmake_environment(K, K->ground_env));
- TValue root_cont = RSI(kmake_continuation(K, KNIL, do_script_exit, 0));
- TValue error_cont = RSI(kmake_continuation(K, root_cont, do_script_error, 1, std_env));
- G(root_cont, "root-continuation");
- G(error_cont, "error-continuation");
- K->root_cont = root_cont;
- K->error_cont = error_cont;
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
-
- /* Create error continuation hierarchy. */
- kinit_error_hierarchy(K);
-
- TValue argv_value = RSI(argv2value(K, argc, argv));
- TValue loader = RSI(loader_body(K, argv_value, std_env));
- TValue loader_cont = RSI(kmake_continuation(K, root_cont, do_seq, 2, loader, std_env));
- kset_cc(K, loader_cont);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
-#if KTRACK_SI
- krooted_tvs_pop(K);
-#endif
- kapply_cc(K, KINERT);
-
-#undef R
-#undef RSI
-#undef G
-}
diff --git a/src/kscript.h b/src/kscript.h
@@ -1,25 +0,0 @@
-/*
-** krepl.h
-** klisp noninteractive script execution
-** See Copyright Notice in klisp.h
-*/
-
-#ifndef kscript_h
-#define kscript_h
-
-#include <stdio.h>
-#include "klisp.h"
-#include "kstate.h"
-#include "kobject.h"
-
-void kinit_script(klisp_State *K, int argc, char *argv[]);
-
-/* continuation functions */
-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 */
-
-#define KSCRIPT_DEFAULT_ERROR_EXIT_CODE 70
-
-#endif
diff --git a/src/kstate.c b/src/kstate.c
@@ -13,14 +13,15 @@
** problem. ASK John.
*/
+#include <stdlib.h>
#include <stddef.h>
#include <setjmp.h>
+#include <string.h>
#include "klisp.h"
#include "klimits.h"
#include "kstate.h"
#include "kobject.h"
-#include "kstring.h"
#include "kpair.h"
#include "kmem.h"
#include "keval.h"
@@ -30,7 +31,6 @@
#include "kenvironment.h"
#include "kground.h"
#include "krepl.h"
-#include "kscript.h"
#include "ksymbol.h"
#include "kstring.h"
#include "kport.h"
@@ -38,8 +38,8 @@
#include "kbytevector.h"
#include "kvector.h"
-#include "kgpairs_lists.h" /* for creating list_app */
-#include "kgerror.h" /* for creating error hierarchy */
+#include "kghelpers.h" /* for creating list_app & memoize_app */
+#include "kgerrors.h" /* for creating error hierarchy */
#include "kgc.h" /* for memory freeing & gc init */
@@ -128,10 +128,6 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->rooted_tvs_top = 0;
K->rooted_vars_top = 0;
- K->dummy_pair1 = kcons(K, KINERT, KNIL);
- K->dummy_pair2 = kcons(K, KINERT, KNIL);
- K->dummy_pair3 = kcons(K, KINERT, KNIL);
-
/* initialize strings */
/* initial size of string/symbol table */
@@ -196,8 +192,20 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* initialize writer */
K->write_displayp = false; /* set on each call to write */
- /* initialize script */
- K->script_exit_code = KSCRIPT_DEFAULT_ERROR_EXIT_CODE;
+ /* initialize require facilities */
+ {
+ char *str = getenv(KLISP_PATH);
+ if (str == NULL)
+ str = KLISP_PATH_DEFAULT;
+
+ K->require_path = kstring_new_b_imm(K, str);
+ /* replace dirsep with forward slashes,
+ windows will happily accept forward slashes */
+ str = kstring_buf(K->require_path);
+ while ((str = strchr(str, *KLISP_DIRSEP)) != NULL)
+ *str++ = '/';
+ }
+ K->require_table = klispH_new(K, 0, MINREQUIRETABSIZE, 0);
/* initialize temp stack */
K->ssize = KS_ISSIZE;
@@ -222,27 +230,37 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
int32_t line_number;
TValue si;
K->eval_op = kmake_operative(K, keval_ofn, 0), line_number = __LINE__;
+#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
kcons(K, i2tv(line_number), i2tv(0)));
kset_source_info(K, K->eval_op, si);
-
+#endif
/* TODO: si */
- TValue eval_name = ksymbol_new(K, "eval", KNIL);
+ TValue eval_name = ksymbol_new_b(K, "eval", KNIL);
ktry_set_name(K, K->eval_op, eval_name);
K->list_app = kmake_applicative(K, list, 0), line_number = __LINE__;
+#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
kcons(K, i2tv(__LINE__), i2tv(0)));
kset_source_info(K, K->list_app, si);
kset_source_info(K, kunwrap(K->list_app), si);
+#endif
+ K->memoize_app = kmake_applicative(K, memoize, 0), line_number = __LINE__;
+#if KTRACK_SI
+ si = kcons(K, kstring_new_b_imm(K, __FILE__),
+ kcons(K, i2tv(__LINE__), i2tv(0)));
+ kset_source_info(K, K->memoize_app, si);
+ kset_source_info(K, kunwrap(K->memoize_app), si);
+#endif
/* ground environment has a hashtable for bindings */
K->ground_env = kmake_table_environment(K, KNIL);
// K->ground_env = kmake_empty_environment(K);
/* MAYBE: fix it so we can remove module_params_sym from roots */
/* TODO si */
- K->module_params_sym = ksymbol_new(K, "module-parameters", KNIL);
+ K->module_params_sym = ksymbol_new_b(K, "module-parameters", KNIL);
/* Create the root and error continuation (will be added to the
environment in kinit_ground_env) */
@@ -267,8 +285,8 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* this must be done before calling kinit_ground_env */
kinit_error_hierarchy(K);
-
kinit_ground_env(K);
+ kinit_cont_names(K);
/* create a std environment and leave it in K->next_env */
K->next_env = kmake_table_environment(K, K->ground_env);
@@ -429,12 +447,14 @@ TValue select_interceptor(TValue guard_ls)
** (interceptor-op outer_cont . denv)
*/
-/* GC: assume src_cont & dst_cont are rooted, uses dummy1 */
+/* GC: assume src_cont & dst_cont are rooted */
inline TValue create_interception_list(klisp_State *K, TValue src_cont,
TValue dst_cont)
{
mark_iancestors(dst_cont);
- TValue tail = kget_dummy1(K);
+ TValue ilist = kcons(K, KNIL, KNIL);
+ krooted_vars_push(K, &ilist);
+ TValue tail = ilist;
TValue cont = src_cont;
/* exit guards are from the inside to the outside, and
@@ -505,7 +525,8 @@ inline TValue create_interception_list(klisp_State *K, TValue src_cont,
/* all interceptions collected, append the two lists and return */
kset_cdr(tail, entry_int);
krooted_vars_pop(K);
- return kcutoff_dummy1(K);
+ krooted_vars_pop(K);
+ return kcdr(ilist);
}
/* this passes the operand tree to the continuation */
diff --git a/src/kstate.h b/src/kstate.h
@@ -50,12 +50,14 @@ typedef struct stringtable {
/* NOTE: when adding TValues here, remember to add them to
markroot in kgc.c!! */
+/* TODO split this struct in substructs (e.g. run_context, tokenizer,
+ gc, etc) */
struct klisp_State {
stringtable strt; /* hash table for immutable strings & symbols */
TValue name_table; /* hash tables for naming objects */
TValue cont_name_table; /* hash tables for naming continuation functions*/
- TValue curr_cont;
+ TValue curr_cont;
/*
** If next_env is NIL, then the next_func from a continuation
** and otherwise next_func is from an operative
@@ -72,6 +74,7 @@ struct klisp_State {
TValue eval_op; /* the operative for evaluation */
TValue list_app; /* the applicative for list evaluation */
+ TValue memoize_app; /* the applicative for promise memoize */
TValue ground_env; /* the environment with all the ground definitions */
/* standard environments are environments with no bindings and ground_env
as parent */
@@ -134,9 +137,10 @@ struct klisp_State {
TValue ktok_sexp_comment;
/* WORKAROUND for repl */
- bool ktok_seen_eof;
+ bool ktok_seen_eof; /* to keep track of eofs that later dissapear */
+ /* source info tracking */
ksource_info_t ktok_source_info;
- /* tokenizer buffer */
+ /* tokenizer buffer (XXX this could be done with a string) */
int32_t ktok_buffer_size;
int32_t ktok_buffer_idx;
char *ktok_buffer;
@@ -151,15 +155,17 @@ struct klisp_State {
/* writer */
bool write_displayp;
- /* script */
- /* REFACTOR rename to exit_code */
- int script_exit_code;
+ /* require */
+ TValue require_path;
+ TValue require_table;
- /* auxiliary stack */
+ /* auxiliary stack (XXX this could be a vector) */
int32_t ssize; /* total size of array */
int32_t stop; /* top of the stack (all elements are below this index) */
TValue *sbuf;
+ /* These could be eliminated if a stack was adopted for the c interface */
+ /* (like in lua) */
/* TValue stack to protect values from gc, must not grow, otherwise
it may call the gc */
int32_t rooted_tvs_top;
@@ -169,14 +175,6 @@ struct klisp_State {
object pointed to by a variable may change */
int32_t rooted_vars_top;
TValue *rooted_vars_buf[GC_PROTECT_SIZE];
-
- /* These three are useful for constructing lists by means of set-car &
- set-cdr. The idea is that these dummy pairs start as the head of
- the list (protecting the entire chain from GC) and at the end of the
- construction, the list is cut off from the cdr of the dummy */
- TValue dummy_pair1;
- TValue dummy_pair2;
- TValue dummy_pair3;
};
/* some size related macros */
@@ -355,15 +353,6 @@ inline void krooted_vars_pop(klisp_State *K)
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 */
-
-/* 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)
-#define kstate_cdr(p_) (tv2pair(p_)->cdr)
-
-
/*
** Source code tracking
** MAYBE: add source code tracking to symbols
@@ -416,12 +405,6 @@ inline void klispS_apply_cc(klisp_State *K, TValue val)
/* TODO add marks assertions */
klisp_assert(K->rooted_tvs_top == 0);
klisp_assert(K->rooted_vars_top == 0);
- klisp_assert(ttispair(K->dummy_pair1) &&
- ttisnil(kstate_cdr(K->dummy_pair1)));
- klisp_assert(ttispair(K->dummy_pair2) &&
- ttisnil(kstate_cdr(K->dummy_pair2)));
- klisp_assert(ttispair(K->dummy_pair3) &&
- ttisnil(kstate_cdr(K->dummy_pair3)));
K->next_obj = K->curr_cont; /* save it from GC */
Continuation *cont = tv2cont(K->curr_cont);
@@ -458,12 +441,6 @@ inline void klispS_tail_call_si(klisp_State *K, TValue top, TValue ptree,
/* various assert to check the freeing of gc protection methods */
klisp_assert(K->rooted_tvs_top == 0);
klisp_assert(K->rooted_vars_top == 0);
- klisp_assert(ttispair(K->dummy_pair1) &&
- ttisnil(kstate_cdr(K->dummy_pair1)));
- klisp_assert(ttispair(K->dummy_pair2) &&
- ttisnil(kstate_cdr(K->dummy_pair2)));
- klisp_assert(ttispair(K->dummy_pair3) &&
- ttisnil(kstate_cdr(K->dummy_pair3)));
K->next_obj = top;
Operative *op = tv2op(top);
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -8,8 +8,6 @@
#include "ksymbol.h"
#include "kobject.h"
-/* for identifier checking */
-#include "ktoken.h"
#include "kstate.h"
#include "kmem.h"
#include "kgc.h"
@@ -19,10 +17,13 @@
/* NOTE: symbols can have source info, they should be compared with
tv_sym_equal, NOT tv_equal */
-/* TEMP: for now only interned symbols are the ones that don't
- have source info (like those created with string->symbol) */
-TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
- TValue si, bool identifierp)
+/* No case folding is performed by these constructors */
+
+/*
+** Interned symbols are only the ones that don't have source info
+** (like those created with string->symbol)
+*/
+TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size, TValue si)
{
/* First calculate the hash */
uint32_t h = size; /* seed */
@@ -71,7 +72,7 @@ TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
differently */
new_sym->gct = klispC_white(K);
new_sym->tt = K_TSYMBOL;
- new_sym->kflags = identifierp? K_FLAG_EXT_REP : 0;
+ new_sym->kflags = 0;
new_sym->si = NULL;
/* symbol specific fields */
@@ -93,8 +94,7 @@ TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
} else { /* non nil source info */
/* link it with regular objects and save source info */
/* header + gc_fields */
- klispC_link(K, (GCObject *) new_sym, K_TSYMBOL,
- identifierp? K_FLAG_EXT_REP : 0);
+ klispC_link(K, (GCObject *) new_sym, K_TSYMBOL, 0);
/* symbol specific fields */
new_sym->str = new_str;
@@ -107,59 +107,18 @@ TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
return ret_tv;
}
-/* for indentifiers */
-TValue ksymbol_new_i(klisp_State *K, const char *buf, int32_t size, TValue si)
-{
- return ksymbol_new_g(K, buf, size, si, true);
-}
-
-/* for indentifiers with no size */
-TValue ksymbol_new(klisp_State *K, const char *buf, TValue si)
+/* for c strings with unknown size */
+TValue ksymbol_new_b(klisp_State *K, const char *buf, TValue si)
{
int32_t size = (int32_t) strlen(buf);
- return ksymbol_new_g(K, buf, size, si, true);
+ return ksymbol_new_bs(K, buf, size, si);
}
/* for string->symbol */
/* GC: assumes str is rooted */
-TValue ksymbol_new_check_i(klisp_State *K, TValue str, TValue si)
+TValue ksymbol_new_str(klisp_State *K, TValue str, TValue si)
{
- int32_t size = kstring_size(str);
- char *buf = kstring_buf(str);
- bool identifierp;
-
- /* this is necessary because the empty symbol isn't an identifier */
- /* MAYBE it should throw an error if the string is empty */
- /* XXX: The exact syntax for identifiers isn't there in the report
- yet, here we use something like scheme, and the same as in ktoken.h
- (details, leading numbers '.', '+' and '-' are a no go, but '+' and
- '-' are an exception.
- */
- identifierp = (size > 0);
- if (identifierp) {
- char first = *buf;
- buf++;
- size--;
- if (first == '+' || first == '-')
- identifierp = (size == 0);
- else if (first == '.' || ktok_is_numeric(first))
- identifierp = false;
- else
- identifierp = ktok_is_subsequent(first);
-
- while(identifierp && size--) {
- if (!ktok_is_subsequent(*buf))
- identifierp = false;
- else
- buf++;
- }
- }
- /* recover size & buf*/
- size = kstring_size(str);
- buf = kstring_buf(str);
-
- TValue new_sym = ksymbol_new_g(K, buf, size, si, identifierp);
- return new_sym;
+ return ksymbol_new_bs(K, kstring_buf(str), kstring_size(str), si);
}
bool ksymbolp(TValue obj) { return ttissymbol(obj); }
diff --git a/src/ksymbol.h b/src/ksymbol.h
@@ -17,13 +17,15 @@
/* NOTE: symbols can have source info, they should be compared with
tv_sym_equal, NOT tv_equal */
-/* For identifiers */
-TValue ksymbol_new_i(klisp_State *K, const char *buf, int32_t size,
+/* No case folding is performed by these constructors */
+
+/* buffer + size, may contain nulls */
+TValue ksymbol_new_bs(klisp_State *K, const char *buf, int32_t size,
TValue si);
-/* For identifiers, simplified for unknown size */
-TValue ksymbol_new(klisp_State *K, const char *buf, TValue si);
-/* For general strings, copies str if not immutable */
-TValue ksymbol_new_check_i(klisp_State *K, TValue str, TValue si);
+/* null terminated buffer */
+TValue ksymbol_new_b(klisp_State *K, const char *buf, TValue si);
+/* copies str if not immutable */
+TValue ksymbol_new_str(klisp_State *K, TValue str, TValue si);
#define ksymbol_str(tv_) (tv2sym(tv_)->str)
#define ksymbol_buf(tv_) (kstring_buf(tv2sym(tv_)->str))
diff --git a/src/ksystem.c b/src/ksystem.c
@@ -0,0 +1,68 @@
+/*
+** ksystem.c
+** Platform dependent functionality.
+** See Copyright Notice in klisp.h
+*/
+
+#include "kobject.h"
+#include "kstate.h"
+#include "kerror.h"
+#include "kinteger.h"
+#include "ksystem.h"
+
+/* detect platform
+ * TODO: sync with klispconf.h and kgffi.c */
+
+#if defined(KLISP_USE_POSIX)
+# define KLISP_PLATFORM_POSIX
+#elif defined(_WIN32)
+# define KLISP_PLATFORM_WIN32
+#endif
+
+/* Include platform-dependent versions. The platform-dependent
+ * code #defines macro HAVE_PLATFORM_<functionality>, if it
+ * actually implements <functionality>.
+ */
+
+#if defined(KLISP_PLATFORM_POSIX)
+# include "ksystem.posix.c"
+#elif defined(KLISP_PLATFORM_WIN32)
+# include "ksystem.win32.c"
+#endif
+
+/* Fall back to platform-independent versions if necessaty. */
+
+#ifndef HAVE_PLATFORM_JIFFIES
+
+#include <time.h>
+
+/* TEMP for now the best we can do is return the current second */
+TValue ksystem_current_jiffy(klisp_State *K)
+{
+ time_t now = time(NULL);
+
+ if (now == -1) {
+ klispE_throw_simple(K, "couldn't get time");
+ return KFALSE;
+ } else {
+ return kinteger_new_uint64(K, (uint64_t) now);
+ }
+}
+
+TValue ksystem_jiffies_per_second(klisp_State *K)
+{
+ return i2tv(1);
+}
+
+#endif /* HAVE_PLATFORM_JIFFIES */
+
+#ifndef HAVE_PLATFORM_ISATTY
+
+bool ksystem_isatty(klisp_State *K, TValue port)
+{
+ UNUSED(K);
+ UNUSED(port);
+ return false;
+}
+
+#endif /* HAVE_PLATFORM_ISATTY */
diff --git a/src/ksystem.h b/src/ksystem.h
@@ -0,0 +1,17 @@
+/*
+** ksystem.h
+** Platform dependent functionality.
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef ksystem_h
+#define ksystem_h
+
+#include "kobject.h"
+
+TValue ksystem_current_jiffy(klisp_State *K);
+TValue ksystem_jiffies_per_second(klisp_State *K);
+bool ksystem_isatty(klisp_State *K, TValue port);
+
+#endif
+
diff --git a/src/ksystem.posix.c b/src/ksystem.posix.c
@@ -0,0 +1,53 @@
+/*
+** ksystem.posix.c
+** Platform dependent functionality - version for POSIX systems.
+** See Copyright Notice in klisp.h
+*/
+
+#include <stdio.h>
+#include <sys/time.h>
+#include "kobject.h"
+#include "kstate.h"
+#include "kinteger.h"
+#include "kport.h"
+#include "ksystem.h"
+
+/* declare implemented functionality */
+
+#define HAVE_PLATFORM_JIFFIES
+#define HAVE_PLATFORM_ISATTY
+
+/* jiffies */
+
+TValue ksystem_current_jiffy(klisp_State *K)
+{
+ /* TEMP: use gettimeofday(). clock_gettime(CLOCK_MONOTONIC,...)
+ * might be more apropriate, but it is reportedly not
+ * supported on MacOS X. */
+
+ struct timeval tv;
+ gettimeofday(&tv, NULL);
+
+ TValue res = kbigint_make_simple(K);
+ krooted_vars_push(K, &res);
+ mp_int_set_value(K, tv2bigint(res), tv.tv_sec);
+ mp_int_mul_value(K, tv2bigint(res), 1000000, tv2bigint(res));
+ mp_int_add_value(K, tv2bigint(res), tv.tv_usec, tv2bigint(res));
+ krooted_vars_pop(K);
+
+ return kbigint_try_fixint(K, res);
+}
+
+TValue ksystem_jiffies_per_second(klisp_State *K)
+{
+ UNUSED(K);
+ return i2tv(1000000);
+}
+
+/* isatty */
+
+bool ksystem_isatty(klisp_State *K, TValue port)
+{
+ return ttisfport(port) && kport_is_open(port)
+ && isatty(fileno(kfport_file(port)));
+}
diff --git a/src/ksystem.win32.c b/src/ksystem.win32.c
@@ -0,0 +1,73 @@
+/*
+** ksystem.win32.c
+** Platform dependent functionality - version for Windows.
+** See Copyright Notice in klisp.h
+*/
+
+#include <windows.h>
+#include <stdio.h>
+#include "kobject.h"
+#include "kstate.h"
+#include "kinteger.h"
+#include "kport.h"
+#include "ksystem.h"
+
+/* declare implemented functionality */
+
+#define HAVE_PLATFORM_JIFFIES
+#define HAVE_PLATFORM_ISATTY
+
+/* jiffies */
+
+TValue ksystem_current_jiffy(klisp_State *K)
+{
+ LARGE_INTEGER li;
+ QueryPerformanceCounter(&li);
+ return kinteger_new_uint64(K, li.QuadPart);
+}
+
+TValue ksystem_jiffies_per_second(klisp_State *K)
+{
+ LARGE_INTEGER li;
+ QueryPerformanceFrequency(&li);
+ return kinteger_new_uint64(K, li.QuadPart);
+}
+
+bool ksystem_isatty(klisp_State *K, TValue port)
+{
+ if (!ttisfport(port) || kport_is_closed(port))
+ return false;
+
+ /* get the underlying Windows File HANDLE */
+
+ int fd = _fileno(kfport_file(port));
+ if (fd == -1 || fd == -2)
+ return false;
+
+ HANDLE h = (HANDLE) _get_osfhandle(fd);
+ if (h == INVALID_HANDLE_VALUE)
+ return false;
+
+ /* Googling gives two unreliable ways to emulate isatty():
+ *
+ * 1) test if GetFileType() returns FILE_TYPE_CHAR
+ * - reports NUL special file as a terminal
+ *
+ * 2) test if GetConsoleMode() succeeds
+ * - does not work on output handles
+ * - does not work in plain wine (works in wineconsole)
+ * - probably won't work if Windows Console is replaced
+ * a terminal emulator
+ *
+ * TEMP: use GetConsoleMode()
+ */
+/*
+** Lua uses _isatty in Windows, shouldn't that work?
+** e.g. _isatty(_fileno(kport_file(port)))
+** I'll try to test it when I have access to a Windows box
+** Andres Navarro
+*/
+
+ DWORD mode;
+ return GetConsoleMode(h, &mode);
+}
diff --git a/src/ktable.c b/src/ktable.c
@@ -36,7 +36,7 @@
#include "kstate.h"
#include "ktable.h"
#include "kapplicative.h"
-#include "kgeqp.h"
+#include "kghelpers.h" /* for eq2p */
#include "kstring.h"
/*
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -5,23 +5,10 @@
*/
/*
-** Symbols should be converted to some standard case before interning
-** (in this case downcase)
-*/
-
-/*
** TODO:
**
-** From the Report:
-**
-** - Support for complete number syntax (complex)
-**
-** NOT from the Report:
+** - Support for complete number syntax (complex) (report)
** - Support for unicode (strings, char and symbols).
-** - srfi-30 stype #| ... |# nested comments and srfi-62 style #;
-** sexp comments.
-** - more named chars (like #\tab and in strings "\t")
-** - numeric escaped chars (like #\u0020)
**
*/
#include <stdio.h>
@@ -86,7 +73,8 @@ void kcharset_union(kcharset chs, kcharset chs2)
** Character sets for classification
*/
kcharset ktok_alphabetic, ktok_numeric, ktok_whitespace;
-kcharset ktok_delimiter, ktok_extended, ktok_subsequent;
+kcharset ktok_delimiter, ktok_extended;
+kcharset ktok_initial, ktok_subsequent;
/*
** Special Tokens
@@ -101,7 +89,9 @@ kcharset ktok_delimiter, ktok_extended, ktok_subsequent;
** char in the car and nil in the cdr.
** srfi-38 tokens are also represented with a char in the car indicating if
** it's a defining token ('=') or a referring token ('#') and the number in
-** the cdr. This way a special token can be easily tested for (with ttispair)
+** the cdr.
+** The sexp comment token with a ';' in the car.
+** This way a special token can be easily tested for (with ttispair)
** and easily classified (with switch(chvalue(kcar(tok)))).
**
*/
@@ -112,15 +102,24 @@ void ktok_init(klisp_State *K)
kcharset_fill(ktok_alphabetic, "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"abcdefghijklmnopqrstuvwxyz");
kcharset_fill(ktok_numeric, "0123456789");
+ /* keep synchronized with cases in main tokenizer switch */
kcharset_fill(ktok_whitespace, " \t\v\r\n\f");
kcharset_fill(ktok_delimiter, "()\";");
kcharset_union(ktok_delimiter, ktok_whitespace);
- kcharset_fill(ktok_extended, "!$%&*+-./:<=>?@^_~");
+ kcharset_fill(ktok_initial, "!$%&*./:<=>?@^_~");
+ kcharset_union(ktok_initial, ktok_alphabetic);
+
+ /* N.B. Unlike in scheme, kernel admits both '.' and
+ '@' as initial chars in identifiers, but doesn't allow
+ '+' or '-'. There are 3 exceptions:
+ both '+' and '-' alone are identifiers and '.' alone is
+ not an identifier */
+ kcharset_fill(ktok_extended, "+-");
kcharset_empty(ktok_subsequent);
- kcharset_union(ktok_subsequent, ktok_alphabetic);
+ kcharset_union(ktok_subsequent, ktok_initial);
kcharset_union(ktok_subsequent, ktok_numeric);
kcharset_union(ktok_subsequent, ktok_extended);
}
@@ -313,13 +312,15 @@ 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);
+char ktok_read_hex_escape(klisp_State *K);
TValue ktok_read_string(klisp_State *K);
TValue ktok_read_special(klisp_State *K);
TValue ktok_read_number(klisp_State *K, char *buf, int32_t len,
bool has_exactp, bool exactp, bool has_radixp,
int32_t radix);
TValue ktok_read_maybe_signed_numeric(klisp_State *K);
-TValue ktok_read_identifier(klisp_State *K);
+TValue ktok_read_identifier_or_dot(klisp_State *K);
+TValue ktok_read_bar_identifier(klisp_State *K);
int ktok_read_until_delimiter(klisp_State *K);
/*
@@ -330,8 +331,6 @@ TValue ktok_read_token(klisp_State *K)
klisp_assert(ks_tbisempty(K));
while(true) {
- ktok_ignore_whitespace(K);
-
/* save the source info in case a token starts here */
ktok_save_source_info(K);
@@ -341,6 +340,14 @@ TValue ktok_read_token(klisp_State *K)
case EOF:
ktok_getc(K);
return KEOF;
+ case ' ':
+ case '\n':
+ case '\r':
+ case '\t':
+ case '\v':
+ case '\f': /* Keep synchronized with whitespace chars */
+ ktok_ignore_whitespace(K);
+ continue;
case ';':
ktok_ignore_single_line_comment(K);
continue;
@@ -350,22 +357,14 @@ TValue ktok_read_token(klisp_State *K)
case ')':
ktok_getc(K);
return K->ktok_rparen;
- case '.':
- ktok_getc(K);
- if (ktok_check_delimiter(K))
- return K->ktok_dot;
- else {
- ktok_error(K, "no delimiter found after dot");
- /* avoid warning */
- return KINERT;
- }
case '"':
return ktok_read_string(K);
+ case '|':
+ return ktok_read_bar_identifier(K);
/* TODO use read_until_delimiter in all these cases */
case '#': {
ktok_getc(K);
chi = ktok_peekc(K);
-
switch(chi) {
case EOF:
ktok_error(K, "# constant is too short");
@@ -399,6 +398,8 @@ TValue ktok_read_token(klisp_State *K)
case '+': case '-':
/* signed number, no exactness or radix indicator */
return ktok_read_maybe_signed_numeric(K);
+ case '\\': /* this is a symbol that starts with an hex escape */
+ /* These should be kept synchronized with initial */
case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G':
case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N':
case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U':
@@ -410,28 +411,16 @@ TValue ktok_read_token(klisp_State *K)
case '!': case '$': case '%': case '&': case '*': case '/': case ':':
case '<': case '=': case '>': case '?': case '@': case '^': case '_':
case '~':
+ case '.': /* this is either a symbol or a dot token */
/*
- ** NOTE: the cases for '+', '-', '.' and numbers were already
- ** considered so identifier-subsequent is used instead of
- ** identifier-first-char (in the cases above)
+ ** N.B.: the cases for '+', and '-', were already
+ ** considered
*/
- return ktok_read_identifier(K);
- case '|':
- ktok_getc(K);
- chi = ktok_peekc(K);
- if (chi == EOF || chi != '#') {
- chi = '|';
- goto unrecognized_error;
- }
- ktok_getc(K);
- ktok_error(K, "unmatched multiline comment close (\"|#\")");
- /* avoid warning */
- return KINERT;
+ return ktok_read_identifier_or_dot(K);
default:
chi = ktok_getc(K);
- /* TODO add char to error */
- unrecognized_error:
- ktok_error_extra(K, "unrecognized token starting char", ch2tv((char) chi));
+ ktok_error_extra(K, "unrecognized token starting char",
+ ch2tv((char) chi));
/* avoid warning */
return KINERT;
}
@@ -525,29 +514,6 @@ void ktok_ignore_whitespace(klisp_State *K)
}
}
-/* XXX temp for repl */
-void ktok_ignore_whitespace_and_comments(klisp_State *K)
-{
- /* NOTE: if it's not whitespace do nothing (even on eof) */
- while(true) {
- int chi = ktok_peekc(K);
-
- if (chi == EOF) {
- return;
- } else {
- char ch = (char) chi;
- if (ktok_is_whitespace(ch)) {
- ktok_getc(K);
- } else if (ch == ';') {
- ktok_ignore_single_line_comment(K);
- } else {
- return;
- }
- }
- }
-}
-
-
/*
** Delimiter checking
*/
@@ -626,7 +592,7 @@ TValue ktok_read_maybe_signed_numeric(klisp_State *K)
/* save the source info in the symbol */
TValue si = ktok_get_source_info(K);
krooted_tvs_push(K, si); /* will be popped by throw */
- TValue new_sym = ksymbol_new_i(K, ks_tbget_buffer(K), 1, si);
+ TValue new_sym = ksymbol_new_bs(K, ks_tbget_buffer(K), 1, si);
krooted_tvs_pop(K); /* already in symbol */
krooted_tvs_push(K, new_sym);
ks_tbclear(K); /* this shouldn't cause gc, but just in case */
@@ -642,6 +608,62 @@ TValue ktok_read_maybe_signed_numeric(klisp_State *K)
}
/*
+** Hex escapes for strings and symbols
+** "#\xXXXXXX;"
+** "#\x" already read
+*/
+
+char ktok_read_hex_escape(klisp_State *K)
+{
+ /* enough space for any unicode char + 2 */
+ int ch;
+ char buf[10];
+ int c = 0;
+ bool at_least_onep = false;
+ for(ch = ktok_getc(K); ch != EOF && ch != ';';
+ ch = ktok_getc(K)) {
+ if (!ktok_is_digit(ch, 16)) {
+ ktok_error_extra(K, "Invalid char found in hex escape",
+ ch2tv(ch));
+ return '\0'; /* avoid warning */
+ }
+ /*
+ ** This will allow one space for '\0' and one extra
+ ** char in case the value is too big, and so will
+ ** naturally result in a value outside the unicode
+ ** range without the need to record any extra
+ ** characters other than the first 8 (without
+ ** leading zeroes).
+ */
+ at_least_onep = true;
+ if (c < sizeof(buf) - 1 && (c > 0 || ch != '0'))
+ buf[c++] = ch;
+ }
+ if (ch == EOF) {
+ ktok_error(K, "EOF found while reading hex escape");
+ return '\0'; /* avoid warning */
+ } else if (!at_least_onep) {
+ ktok_error(K, "Empty hex escape found");
+ return '\0'; /* avoid warning */
+ } else if (c == 0) { /* this is the case of a NULL char */
+ buf[c++] = '0';
+ }
+ buf[c++] = '\0';
+ /* buf now contains the hex value of the char */
+ TValue n;
+ int res = kinteger_read(K, buf, 16, &n, NULL);
+ /* can't fail, all digits were checked already */
+ klisp_assert(res == true);
+ if (!ttisfixint(n) || ivalue(n) > 127) {
+ krooted_tvs_push(K, n);
+ ktok_error_extra(K, "hex escaped char out of ASCII range", n);
+ return '\0'; /* avoid warning */
+ }
+ /* all ok, we pass the char */
+ return (char) ivalue(n);
+}
+
+/*
** Strings
*/
TValue ktok_read_string(klisp_State *K)
@@ -653,42 +675,105 @@ TValue ktok_read_string(klisp_State *K)
int i = 0;
while(!done) {
- int chi = ktok_getc(K);
- char ch = (char) chi;
-
- if (chi == EOF) {
+ int ch = ktok_getc(K);
+ just_read: /* this comes from escaped newline */
+ if (ch == EOF) {
ktok_error(K, "EOF found while reading a string");
- /* avoid warning */
- return KINERT;
- }
- if (ch < 0 || ch > 127) {
+ return KINERT; /* avoid warning */
+ } else if (ch < 0 || ch > 127) {
ktok_error(K, "Non ASCII char found while reading a string");
- /* avoid warning */
- return KINERT;
- } else if (ch == '"') {
+ return KINERT; /* avoid warning */
+ }
+
+
+ if (ch == '"') {
ks_tbadd(K, '\0');
done = true;
- } else {
- if (ch == '\\') {
- chi = ktok_getc(K);
+ } else if (ch == '\\') {
+ ch = ktok_getc(K);
- if (chi == EOF) {
+ if (ch == EOF) {
+ ktok_error(K, "EOF found while reading a string");
+ return KINERT; /* avoid warning */
+ }
+
+ switch(ch) {
+ /* These two will self insert */
+ case '"':
+ case '\\':
+ break;
+ /* These are naming chars (like in c, mostly) */
+ case '0':
+ ch = '\0';
+ break;
+ case 'a':
+ ch = '\a';
+ break;
+ case 'b':
+ ch = '\b';
+ break;
+ case 't':
+ ch = '\t';
+ break;
+ case 'n':
+ ch = '\n';
+ break;
+ case 'r':
+ ch = '\r';
+ break;
+ case 'v':
+ ch = '\v';
+ break;
+ case 'f':
+ ch = '\f';
+ break;
+ /*
+ ** These signal an escaped newline (not included in string)
+ */
+ case ' ':
+ case '\t':
+ /* eat up all intraline spacing */
+ while((ch = ktok_getc(K)) != EOF &&
+ (ch == ' ' || ch == '\t'))
+ ;
+ if (ch == EOF) {
ktok_error(K, "EOF found while reading a string");
- /* avoid warning */
- return KINERT;
+ return KINERT; /* avoid warning */
+ } else if (ch != '\n' && ch != '\r') {
+ ktok_error(K, "Invalid char found after \\ while "
+ "reading a string");
+ return KINERT; /* avoid warning */
}
-
- ch = (char) chi;
-
- if (ch != '\\' && ch != '"') {
- ktok_error(K, "Invalid char after '\\' "
- "while reading a string");
- /* avoid warning */
- return KINERT;
+ /* fall through */
+ case '\n':
+ case '\r':
+ /* use the r6rs definition for line end */
+ if (ch == 'r') {
+ ch = ktok_peekc(K);
+ if (ch != EOF && ch == '\n')
+ ktok_getc(K);
}
- }
+ /* eat up all intraline spacing */
+ while((ch = ktok_getc(K)) != EOF &&
+ (ch == ' ' || ch == '\t'))
+ ;
+ /* this will check for EOF and continue reading the
+ string at the top of the loop */
+ goto just_read;
+ /* This is an hex escaped char */
+ case 'x':
+ ch = ktok_read_hex_escape(K);
+ break;
+ default:
+ ktok_error_extra(K, "Invalid char after '\\' "
+ "while reading a string", ch2tv(ch));
+ return KINERT; /* avoid warning */
+ }
+ ks_tbadd(K, ch);
+ ++i;
+ } else {
ks_tbadd(K, ch);
- i++;
+ ++i;
}
}
/* TEMP: for now strings "read" are mutable but strings "loaded" are
@@ -720,11 +805,24 @@ struct kspecial_token {
{ "#i-infinity", KIMINF_ },
{ "#real", KRWNPV_ },
{ "#undefined", KUNDEF_ },
- { "#\\space", KSPACE_ },
- { "#\\newline", KNEWLINE_ }
+ /*
+ ** Character names
+ ** (r7rs + vtab from r6rs)
+ */
+ { "#\\null", KNULL_ },
+ { "#\\alarm", KALARM_ },
+ { "#\\backspace", KBACKSPACE_ },
+ { "#\\tab", KTAB_ },
+ { "#\\newline", KNEWLINE_ }, /* kernel */
+ { "#\\return", KRETURN_ },
+ { "#\\escape", KESCAPE_ },
+ { "#\\space", KSPACE_ }, /* kernel */
+ { "#\\delete", KDELETE_ },
+ { "#\\vtab", KVTAB_ }, /* r6rs, only */
+ { "#\\formfeed", KFORMFEED_ } /* r6rs in strings */
};
-#define MAX_EXT_REP_SIZE 64 /* all special tokens have much than 64 chars */
+#define MAX_EXT_REP_SIZE 64 /* all special tokens have less than 64 chars */
TValue ktok_read_special(klisp_State *K)
{
@@ -750,7 +848,8 @@ TValue ktok_read_special(klisp_State *K)
}
/* Then check for simple chars, this is the only thing
- that is case dependant, so after this we downcase buf */
+ that is case dependant, so after this we downcase buf
+ (except that an escaped char needs a small 'x' */
/* REFACTOR: move this to a new function */
/* char constant, needs at least 3 chars unless it's a delimiter
* char! */
@@ -759,8 +858,7 @@ TValue ktok_read_special(klisp_State *K)
int ch_i = ktok_getc(K);
if (ch_i == EOF) {
ktok_error(K, "EOF found while reading character name");
- /* avoid warning */
- return KINERT;
+ return KINERT; /* avoid warning */
}
ks_tbclear(K);
return ch2tv((char)ch_i);
@@ -773,7 +871,7 @@ TValue ktok_read_special(klisp_State *K)
** Kernel report (R-1RK))
** For now we follow the scheme report
*/
- char ch = buf[2];
+ char ch = buf[2]; /* we know buf_len > 2 */
if (ch < 0 || ch > 127) {
ktok_error(K, "Non ASCII char found as character constant");
@@ -791,15 +889,20 @@ TValue ktok_read_special(klisp_State *K)
/* fall through */
}
- /* we ignore case in all remaining comparisons */
- for(char *str2 = buf; *str2 != '\0'; str2++)
+ /* first save the third char, in case it's an hex escaped char
+ (that should be a lowercase x) */
+ char saved_third = buf[2]; /* there's at least 2 chars, so in the worst
+ case buf[2] is just '\0' */
+
+ /* now, we ignore case in all remaining comparisons */
+ size_t i = 0;
+ for(char *str2 = buf; i < buf_len; ++str2, ++i)
*str2 = tolower(*str2);
/* REFACTOR: move this to a new function */
- /* then check the known constants */
+ /* then check the known constants (including named characters) */
size_t stok_size = sizeof(kspecial_tokens) /
sizeof(struct kspecial_token);
- size_t i;
for (i = 0; i < stok_size; i++) {
struct kspecial_token token = kspecial_tokens[i];
/* NOTE: must check type because buf may contain embedded '\0's */
@@ -810,15 +913,42 @@ TValue ktok_read_special(klisp_State *K)
}
}
+ /* It wasn't a special token or named char, but it can still be a srfi-38
+ token or a character escape */
+
if (buf[1] == '\\') { /* this is to have a meaningful error msg */
- ktok_error(K, "Unrecognized character name");
- /* avoid warning */
- return KINERT;
+ if (saved_third != 'x') { /* case is significant here, so
+ we use the saved char */
+ ktok_error(K, "Unrecognized character name");
+ return KINERT;
+ }
+ /* We already checked that length != 3 (x is alphabetic),
+ so there's at least on more char */
+ TValue n;
+ char *end;
+
+ /* test for - and + explicitly, becayse kinteger read would parse them
+ without complaining (it will also parse spaces, but we read until
+ delimiter so... */
+ if (buf[3] == '-' || buf[3] == '+' ||
+ !kinteger_read(K, buf+3, 16, &n, &end) ||
+ end - buf != buf_len) {
+ ktok_error(K, "Bad char in hex escaped character constant");
+ return KINERT;
+ } else if (!ttisfixint(n) || ivalue(n) > 127) {
+ ktok_error(K, "Non ASCII char found in hex escaped character constant");
+ /* avoid warning */
+ return KINERT;
+ } else {
+ /* all ok, we just clean up and return the char */
+ ks_tbclear(K);
+ return ch2tv(ivalue(n));
+ }
}
/* REFACTOR: move this to a new function */
/* It was not a special token so it must be either a srfi-38 style
- token, or a char constant or a number. srfi-38 tokens are a '#' a
+ token, or a number. srfi-38 tokens are a '#' a
decimal number and end with a '=' or a '#' */
if (buf_len > 2 && ktok_is_numeric(buf[1])) {
/* NOTE: it's important to check is_numeric to avoid problems with
@@ -837,6 +967,7 @@ TValue ktok_read_special(klisp_State *K)
char *end;
/* 10 is the radix for srfi-38 tokens, buf+1 to jump over the '#',
end+1 to count the last char */
+ /* N.B. buf+1 can't be + or -, we already tested numeric before */
if (!kinteger_read(K, buf+1, 10, &n, &end) || end+1 - buf != buf_len) {
ktok_error(K, "Bad char in srfi-38 token");
return KINERT;
@@ -924,26 +1055,50 @@ TValue ktok_read_special(klisp_State *K)
}
/*
-** Identifiers
+** Identifiers (and dot token)
*/
-TValue ktok_read_identifier(klisp_State *K)
+TValue ktok_read_identifier_or_dot(klisp_State *K)
{
- int32_t i = 1;
+ bool seen_dot = false;
+ int32_t i = 0;
while (!ktok_check_delimiter(K)) {
/* NOTE: can't be eof, because eof is a delimiter */
char ch = (char) ktok_getc(K);
-
+ /* this is needed to differentiate a dot from an equivalent escape */
+ seen_dot |= ch == '.';
/* NOTE: is_subsequent of '\0' is false, so no embedded '\0' */
if (ktok_is_subsequent(ch)) {
+ /* downcase all non-escaped chars */
+ ks_tbadd(K, tolower(ch));
+ ++i;
+ } else if (ch == '\\') {
+ /* should be inline hex escape */
+ ch = ktok_getc(K);
+ if (ch == EOF) {
+ ktok_error(K, "EOF found while reading character name");
+ } else if (ch != 'x') {
+ ktok_error_extra(K, "Invalid char in identifier after \\",
+ ch2tv((char)ch));
+ }
+ ch = ktok_read_hex_escape(K);
+ /* don't downcase escaped chars */
ks_tbadd(K, ch);
- i++;
- } else
- ktok_error(K, "Invalid char in identifier");
+ ++i;
+ } else {
+ ktok_error_extra(K, "Invalid char in identifier",
+ ch2tv((char)ch));
+ }
}
+
+ if (i == 1 && seen_dot) {
+ ks_tbclear(K);
+ return K->ktok_dot;
+ }
+
ks_tbadd(K, '\0');
TValue si = ktok_get_source_info(K);
krooted_tvs_push(K, si); /* will be popped by throw */
- TValue new_sym = ksymbol_new_i(K, ks_tbget_buffer(K), i-1, si);
+ TValue new_sym = ksymbol_new_bs(K, ks_tbget_buffer(K), i, si);
krooted_tvs_pop(K); /* already in symbol */
krooted_tvs_push(K, new_sym);
ks_tbclear(K); /* this shouldn't cause gc, but just in case */
@@ -951,4 +1106,63 @@ TValue ktok_read_identifier(klisp_State *K)
return new_sym;
}
+TValue ktok_read_bar_identifier(klisp_State *K)
+{
+ /* discard opening bar */
+ ktok_getc(K);
+
+ bool done = false;
+ int i = 0;
+
+ /* Never downcase chars in |...| escaped symbols */
+ while(!done) {
+ int ch = ktok_getc(K);
+ if (ch == EOF) {
+ ktok_error(K, "EOF found while reading an |identifier|");
+ return KINERT; /* avoid warning */
+ } else if (ch < 0 || ch > 127) {
+ ktok_error(K, "Non ASCII char found while reading an identifier");
+ return KINERT; /* avoid warning */
+ }
+
+ if (ch == '|') {
+ ks_tbadd(K, '\0');
+ done = true;
+ } else if (ch == '\\') {
+ ch = ktok_getc(K);
+
+ if (ch == EOF) {
+ ktok_error(K, "EOF found while reading an |identifier|");
+ return KINERT; /* avoid warning */
+ }
+
+ switch(ch) {
+ /* These two will self insert */
+ case '|':
+ case '\\':
+ break;
+ case 'x':
+ ch = ktok_read_hex_escape(K);
+ break;
+ default:
+ ktok_error_extra(K, "Invalid char after '\\' "
+ "while reading a symbol", ch2tv(ch));
+ return KINERT; /* avoid warning */
+ }
+ ks_tbadd(K, ch);
+ ++i;
+ } else {
+ ks_tbadd(K, ch);
+ ++i;
+ }
+ }
+ TValue si = ktok_get_source_info(K);
+ krooted_tvs_push(K, si); /* will be popped by throw */
+ TValue new_sym = ksymbol_new_bs(K, ks_tbget_buffer(K), i, si);
+ krooted_tvs_pop(K); /* already in symbol */
+ krooted_tvs_push(K, new_sym);
+ ks_tbclear(K); /* this shouldn't cause gc, but just in case */
+ krooted_tvs_pop(K);
+ return new_sym;
+}
diff --git a/src/ktoken.h b/src/ktoken.h
@@ -7,11 +7,12 @@
#ifndef ktoken_h
#define ktoken_h
+#include <stdio.h>
+#include <ctype.h>
+
#include "kobject.h"
#include "kstate.h"
-#include <stdio.h>
-
/*
** Tokenizer interface
*/
@@ -32,12 +33,11 @@ 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);
+void ktok_ignore_whitespace(klisp_State *K);
-/* This is needed for string->symbol to check if a symbol has external
+/* This is needed for kwrite to check if a symbol has external
representation as an identifier */
/* REFACTOR: think out a better interface to all this */
-
/*
** Char set contains macro interface
*/
@@ -48,7 +48,8 @@ void ktok_ignore_whitespace_and_comments(klisp_State *K);
typedef uint32_t kcharset[8];
extern kcharset ktok_alphabetic, ktok_numeric, ktok_whitespace;
-extern kcharset ktok_delimiter, ktok_extended, ktok_subsequent;
+extern kcharset ktok_delimiter, ktok_extended;
+extern kcharset ktok_subsequent, ktok_initial;
#define ktok_is_alphabetic(chi_) kcharset_contains(ktok_alphabetic, chi_)
#define ktok_is_numeric(chi_) kcharset_contains(ktok_numeric, chi_)
@@ -56,6 +57,7 @@ extern kcharset ktok_delimiter, ktok_extended, ktok_subsequent;
#define ktok_is_whitespace(chi_) kcharset_contains(ktok_whitespace, chi_)
#define ktok_is_delimiter(chi_) ((chi_) == EOF || \
kcharset_contains(ktok_delimiter, chi_))
+#define ktok_is_initial(chi_) kcharset_contains(ktok_initial, chi_)
#define ktok_is_subsequent(chi_) kcharset_contains(ktok_subsequent, chi_)
#define kcharset_contains(kch_, ch_) \
@@ -63,25 +65,17 @@ extern kcharset ktok_delimiter, ktok_extended, ktok_subsequent;
kch_[KCHS_OCTANT(ch__)] & KCHS_BIT(ch__); })
-/* NOTE: only lowercase chars for hexa */
inline bool ktok_is_digit(char ch, int32_t radix)
{
+ ch = tolower(ch);
return (ktok_is_numeric(ch) && (ch - '0') < radix) ||
(ktok_is_alphabetic(ch) && (10 + (ch - 'a')) < radix);
}
inline int32_t ktok_digit_value(char ch)
{
+ ch = tolower(ch);
return (ch <= '9')? ch - '0' : 10 + (ch - 'a');
}
-/* This takes the args in sign magnitude form (sign & res),
- but must work for any representation of negative numbers */
-inline bool can_add_digit(uint32_t res, bool sign, uint32_t new_digit,
- int32_t radix)
-{
- return (sign)? res <= -(INT32_MIN + new_digit) / radix :
- res <= (INT32_MAX - new_digit) / radix;
-}
-
#endif
diff --git a/src/kvector.c b/src/kvector.c
@@ -14,6 +14,8 @@
/* helper function allocating vectors */
+/* XXX I'm not too convinced this is the best way to handle the empty
+ vector... Try to find a better way */
static Vector *kvector_alloc(klisp_State *K, bool m, uint32_t length)
{
Vector *new_vector;
diff --git a/src/kvector.h b/src/kvector.h
@@ -24,10 +24,10 @@ 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_buf(tv_) (tv2vector(tv_)->array)
+#define kvector_size(tv_) (tv2vector(tv_)->sizearray)
-#define kvector_emptyp(tv_) (kvector_length(tv_) == 0)
+#define kvector_emptyp(tv_) (kvector_size(tv_) == 0)
#define kvector_mutablep(tv_) (kis_mutable(tv_))
#define kvector_immutablep(tv_) (kis_immutable(tv_))
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -10,6 +10,7 @@
#include <assert.h>
#include <inttypes.h>
#include <string.h>
+#include <ctype.h>
#include "kwrite.h"
#include "kobject.h"
@@ -26,6 +27,7 @@
#include "kenvironment.h"
#include "kbytevector.h"
#include "kvector.h"
+#include "ktoken.h" /* for identifier checking */
/*
** Stack for the write FSM
@@ -156,9 +158,12 @@ void kw_print_double(klisp_State *K, TValue tv_double)
}
/*
-** Helper for printing strings (correcly escapes backslashes and
-** double quotes & prints embedded '\0's). It includes the surrounding
-** double quotes.
+** Helper for printing strings.
+** If !displayp it prints the surrounding double quotes
+** and escapes backslashes, double quotes,
+** and non printable chars (including NULL).
+** if displayp it doesn't include surrounding quotes and just
+** converts non-printable characters to spaces
*/
void kw_print_string(klisp_State *K, TValue str)
{
@@ -175,6 +180,7 @@ void kw_print_string(klisp_State *K, TValue str)
for every char */
for (ptr = buf;
i < size && *ptr != '\0' &&
+ (*ptr >= 32 && *ptr < 127) &&
(K->write_displayp || (*ptr != '\\' && *ptr != '"'));
i++, ptr++)
;
@@ -186,15 +192,42 @@ void kw_print_string(klisp_State *K, TValue str)
kw_printf(K, "%s", buf);
*ptr = ch;
- while(i < size && (*ptr == '\0' ||
- (!K->write_displayp && (*ptr == '\\' || *ptr == '"')))) {
- if (*ptr == '\0') {
- kw_printf(K, "%c", '\0'); /* this may not show in the terminal */
+ for(; i < size && (*ptr == '\0' || (*ptr < 32 || *ptr >= 127) ||
+ (!K->write_displayp &&
+ (*ptr == '\\' || *ptr == '"')));
+ ++i, ptr++) {
+ /* This are all ASCII printable characters (including space,
+ and exceptuating '\' and '"' if !displayp) */
+ char *fmt;
+ /* must be uint32_t to support all unicode chars
+ in the future */
+ uint32_t arg;
+ ch = *ptr;
+ if (K->write_displayp) {
+ fmt = "%c";
+ /* in display only show tabs and newlines,
+ all other non printables are shown as spaces */
+ arg = (uint32_t) ((ch == '\r' || ch == '\n' || ch == '\t')?
+ ch : ' ');
} else {
- kw_printf(K, "\\%c", *ptr);
+ switch(*ptr) {
+ /* regular \ escapes */
+ case '\"': fmt = "\\%c"; arg = (uint32_t) '"'; break;
+ case '\\': fmt = "\\%c"; arg = (uint32_t) '\\'; break;
+ case '\0': fmt = "\\%c"; arg = (uint32_t) '0'; break;
+ case '\a': fmt = "\\%c"; arg = (uint32_t) 'a'; break;
+ case '\b': fmt = "\\%c"; arg = (uint32_t) 'b'; break;
+ case '\t': fmt = "\\%c"; arg = (uint32_t) 't'; break;
+ case '\n': fmt = "\\%c"; arg = (uint32_t) 'n'; break;
+ case '\r': fmt = "\\%c"; arg = (uint32_t) 'r'; break;
+ case '\v': fmt = "\\%c"; arg = (uint32_t) 'v'; break;
+ case '\f': fmt = "\\%c"; arg = (uint32_t) 'f'; break;
+ /* for the rest of the non printable chars,
+ use hex escape */
+ default: fmt = "\\x%x;"; arg = (uint32_t) ch; break;
+ }
}
- i++;
- ptr++;
+ kw_printf(K, fmt, arg);
}
buf = ptr;
}
@@ -204,6 +237,95 @@ void kw_print_string(klisp_State *K, TValue str)
}
/*
+** Helper for printing symbols.
+** If symbol is not a regular identifier it
+** uses the "|...|" syntax, escaping '|', '\' and
+** non printing characters.
+*/
+void kw_print_symbol(klisp_State *K, TValue sym)
+{
+ uint32_t size = ksymbol_size(sym);
+ char *buf = ksymbol_buf(sym);
+
+ /* first determine if it's a simple identifier */
+ bool identifierp;
+ if (size == 0)
+ identifierp = false;
+ else if (size == 1 && *buf == '.')
+ identifierp = false;
+ else if (size == 1 && (*buf == '+' || *buf == '-'))
+ identifierp = true;
+ else if (*buf == tolower(*buf) && ktok_is_initial(*buf)) {
+ char *ptr = buf;
+ uint32_t i = 0;
+ identifierp = true;
+ while (identifierp && i < size) {
+ char ch = *ptr++;
+ ++i;
+ if (tolower(ch) != ch || !ktok_is_subsequent(ch))
+ identifierp = false;
+ }
+ } else
+ identifierp = false;
+
+ if (identifierp) {
+ /* no problem, just a simple string */
+ kw_printf(K, "%s", buf);
+ return;
+ }
+
+ /*
+ ** In case we get here, we'll have to use the "|...|" syntax
+ */
+ char *ptr = buf;
+ int i = 0;
+
+ kw_printf(K, "|");
+
+ while (i < size) {
+ /* find the longest printf-able substring to avoid calling printf
+ for every char */
+ for (ptr = buf;
+ i < size && *ptr != '\0' &&
+ (*ptr >= 32 && *ptr < 127) &&
+ (*ptr != '\\' && *ptr != '|');
+ i++, ptr++)
+ ;
+
+ /* NOTE: this work even if ptr == buf (which can only happen the
+ first or last time) */
+ char ch = *ptr;
+ *ptr = '\0';
+ kw_printf(K, "%s", buf);
+ *ptr = ch;
+
+ for(; i < size && (*ptr == '\0' || (*ptr < 32 || *ptr >= 127) ||
+ (*ptr == '\\' || *ptr == '|'));
+ ++i, ptr++) {
+ /* This are all ASCII printable characters (including space,
+ and exceptuating '\' and '|') */
+ char *fmt;
+ /* must be uint32_t to support all unicode chars
+ in the future */
+ uint32_t arg;
+ ch = *ptr;
+ switch(*ptr) {
+ /* regular \ escapes */
+ case '|': fmt = "\\%c"; arg = (uint32_t) '|'; break;
+ case '\\': fmt = "\\%c"; arg = (uint32_t) '\\'; break;
+ /* for the rest of the non printable chars,
+ use hex escape */
+ default: fmt = "\\x%x;"; arg = (uint32_t) ch; break;
+ }
+ kw_printf(K, fmt, arg);
+ }
+ buf = ptr;
+ }
+
+ kw_printf(K, "|");
+}
+
+/*
** Mark initialization and clearing
*/
/* GC: root is rooted */
@@ -274,7 +396,8 @@ void kw_set_initial_marks(klisp_State *K, TValue root)
#if KTRACK_NAMES
void kw_print_name(klisp_State *K, TValue obj)
{
- kw_printf(K, ": %s", ksymbol_buf(kget_name(K, obj)));
+ kw_printf(K, ": ");
+ kw_print_symbol(K, kget_name(K, obj));
}
#endif /* KTRACK_NAMES */
@@ -327,13 +450,12 @@ void kw_print_cont_type(klisp_State *K, TValue obj)
/*
** Writes all values except strings and pairs
*/
-
-void kwrite_simple(klisp_State *K, TValue obj)
+void kwrite_scalar(klisp_State *K, TValue obj)
{
switch(ttype(obj)) {
case K_TSTRING:
/* shouldn't happen */
- kwrite_error(K, "string type found in kwrite-simple");
+ klisp_assert(0);
/* avoid warning */
return;
case K_TFIXINT:
@@ -369,19 +491,70 @@ void kwrite_simple(klisp_State *K, TValue obj)
if (K->write_displayp) {
kw_printf(K, "%c", chvalue(obj));
} else {
- char ch_buf[4];
+ char ch_buf[16]; /* should be able to contain hex escapes */
char ch = chvalue(obj);
char *ch_ptr;
- if (ch == '\n') {
+ switch (ch) {
+ case '\0':
+ ch_ptr = "null";
+ break;
+ case '\a':
+ ch_ptr = "alarm";
+ break;
+ case '\b':
+ ch_ptr = "backspace";
+ break;
+ case '\t':
+ ch_ptr = "tab";
+ break;
+ case '\n':
ch_ptr = "newline";
- } else if (ch == ' ') {
+ break;
+ case '\r':
+ ch_ptr = "return";
+ break;
+ case '\x1b':
+ ch_ptr = "escape";
+ break;
+ case ' ':
ch_ptr = "space";
- } else {
- ch_buf[0] = ch;
- ch_buf[1] = '\0';
+ break;
+ case '\x7f':
+ ch_ptr = "delete";
+ break;
+ case '\v':
+ ch_ptr = "vtab";
+ break;
+ default: {
+ int i = 0;
+ if (ch >= 32 && ch < 127) {
+ /* printable ASCII range */
+ /* (del(127) and space(32) were already considered,
+ but it's clearer this way) */
+ ch_buf[i++] = ch;
+ } else {
+ /* use an hex escape for non printing, unnamed chars */
+ ch_buf[i++] = 'x';
+ int res = snprintf(ch_buf+i, sizeof(ch_buf) - i,
+ "%x", ch);
+ if (res < 0) {
+ /* shouldn't happen, but for the sake of
+ completeness... */
+ TValue port = K->curr_port;
+ if (ttisfport(port)) {
+ FILE *file = kfport_file(port);
+ clearerr(file); /* clear error for next time */
+ }
+ kwrite_error(K, "error writing");
+ return;
+ }
+ i += res; /* res doesn't include the '\0' */
+ }
+ ch_buf[i++] = '\0';
ch_ptr = ch_buf;
}
+ }
kw_printf(K, "#\\%s", ch_ptr);
}
break;
@@ -390,12 +563,7 @@ void kwrite_simple(klisp_State *K, TValue obj)
kw_printf(K, "#%c", bvalue(obj)? 't' : 'f');
break;
case K_TSYMBOL:
- if (khas_ext_rep(obj)) {
- /* TEMP: access symbol structure directly */
- kw_printf(K, "%s", ksymbol_buf(obj));
- } else {
- kw_printf(K, "#[symbol]");
- }
+ kw_print_symbol(K, obj);
break;
case K_TINERT:
kw_printf(K, "#inert");
@@ -607,7 +775,7 @@ void kwrite_fsm(klisp_State *K, TValue obj)
break;
}
default:
- kwrite_simple(K, obj);
+ kwrite_scalar(K, obj);
middle_list = true;
}
}
@@ -633,18 +801,52 @@ void kwrite(klisp_State *K, TValue obj)
}
/*
-** Interface
+** This is the same as above but will not display
+** shared tags (and will hang if there are cycles)
+*/
+void kwrite_simple(klisp_State *K, TValue obj)
+{
+ /* GC: root obj */
+ krooted_tvs_push(K, obj);
+ kwrite_fsm(K, obj);
+ kw_flush(K);
+ krooted_tvs_pop(K);
+}
+
+/*
+** Writer Interface
*/
void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
bool displayp)
{
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_output(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_textual(port));
+
K->curr_port = port;
K->write_displayp = displayp;
kwrite(K, obj);
}
+void kwrite_simple_to_port(klisp_State *K, TValue port, TValue obj)
+{
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_output(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_textual(port));
+
+ K->curr_port = port;
+ K->write_displayp = false;
+ kwrite_simple(K, obj);
+}
+
void kwrite_newline_to_port(klisp_State *K, TValue port)
{
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_output(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_textual(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'));
@@ -652,6 +854,10 @@ void kwrite_newline_to_port(klisp_State *K, TValue port)
void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch)
{
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_output(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_textual(port));
K->curr_port = port; /* this isn't needed but all other
i/o functions set it */
@@ -687,6 +893,10 @@ void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch)
void kwrite_u8_to_port(klisp_State *K, TValue port, TValue u8)
{
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_output(port));
+ klisp_assert(kport_is_open(port));
+ klisp_assert(kport_is_binary(port));
K->curr_port = port; /* this isn't needed but all other
i/o functions set it */
if (ttisfport(port)) {
@@ -723,6 +933,9 @@ void kwrite_u8_to_port(klisp_State *K, TValue port, TValue u8)
void kwrite_flush_port(klisp_State *K, TValue port)
{
+ klisp_assert(ttisport(port));
+ klisp_assert(kport_is_output(port));
+ klisp_assert(kport_is_open(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 */
diff --git a/src/kwrite.h b/src/kwrite.h
@@ -15,6 +15,7 @@
*/
void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj,
bool displayp);
+void kwrite_simple_to_port(klisp_State *K, TValue port, TValue obj);
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);
diff --git a/src/rep_op_c.sed b/src/rep_op_c.sed
@@ -1,78 +0,0 @@
-# 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
@@ -1,31 +0,0 @@
-# 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/booleans.k b/src/tests/booleans.k
@@ -74,7 +74,6 @@
($check-not-predicate (or? #f #f #f))
;; $and? & $or?
-;; TODO check tail call
($check-predicate (operative? $and?))
($check-predicate ($and?))
($check-predicate ($and? #t))
@@ -85,6 +84,15 @@
($check-not-predicate ($and? #t #t #f))
($check-not-predicate ($and? #f (/ 1 0))) ;; test conditional evaluation
+;; check tail recursiveness
+($let ((p (cons 1 2)))
+ ($check-predicate ($sequence ($and? ($let/cc cont1
+ (set-car! p cont1)
+ ($and? ($let/cc cont2
+ (set-cdr! p cont2)
+ #t))))
+ (eq? (car p) (cdr p)))))
+
($check-predicate (operative? $or?))
($check-predicate ($or? #t))
($check-predicate ($or? #f (eq? #t #t) #t)) ;; test some evaluation too!
@@ -94,6 +102,29 @@
($check-not-predicate ($or? #f))
($check-not-predicate ($or?))
+($let ((p (cons 1 2)))
+ ($check-predicate ($sequence ($or? ($let/cc cont1
+ (set-car! p cont1)
+ ($or? ($let/cc cont2
+ (set-cdr! p cont2)
+ #t))))
+ (eq? (car p) (cdr p)))))
+
+($let ((p (cons 1 2)))
+ ($check-predicate ($sequence ($and? ($let/cc cont1
+ (set-car! p cont1)
+ ($or? ($let/cc cont2
+ (set-cdr! p cont2)
+ #t))))
+ (eq? (car p) (cdr p)))))
+
+($let ((p (cons 1 2)))
+ ($check-predicate ($sequence ($or? ($let/cc cont1
+ (set-car! p cont1)
+ ($and? ($let/cc cont2
+ (set-cdr! p cont2)
+ #t))))
+ (eq? (car p) (cdr p)))))
;;;
;;; Error Checking and Robustness
diff --git a/src/tests/bytevectors.k b/src/tests/bytevectors.k
@@ -5,9 +5,6 @@
;; 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
;;
@@ -19,23 +16,8 @@
;; 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)))
+
+($define! u8 bytevector)
;; TODO: endianess
($define! u16
@@ -73,6 +55,27 @@
($check-predicate (mutable-bytevector?))
($check-predicate (mutable-bytevector? (make-bytevector 1)))
+;; XXX bytevector
+($check-predicate (bytevector? (bytevector 1 2 3)))
+($check-predicate (mutable-bytevector? (bytevector 1 2 3)))
+($check equal? (bytevector 1 2 3) (list->bytevector (list 1 2 3)))
+
+;; XXX list->bytevector
+($check equal? (make-bytevector 0) (list->bytevector ()))
+($check equal? (make-bytevector 3 1) (list->bytevector (list 1 1 1)))
+($check equal? (list->bytevector (list 1 2 3 4)) (u8 1 2 3 4))
+($check-predicate (mutable-bytevector? (list->bytevector (list 1 2 3))))
+($check-predicate (mutable-bytevector? (list->bytevector
+ (copy-es-immutable (list 1 2 3)))))
+
+;; XXX bytevector->list
+($check-predicate (null? (bytevector->list (u8))))
+($check equal? (bytevector->list (u8 1 2 3 4)) (list 1 2 3 4))
+($check-predicate (mutable-pair? (bytevector->list (u8 1 2))))
+($check-predicate (mutable-pair? (bytevector->list
+ (bytevector->immutable-bytevector
+ (u8 1 2)))))
+
;; (R7RS 3rd draft, section 6.3.7) make-bytevector bytevector-length
($check equal? (bytevector-length (make-bytevector 0)) 0)
@@ -162,6 +165,13 @@
($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-u8-fill!
+($check-predicate (inert? (bytevector-u8-fill! (u8 1 2) 0)))
+($check equal? ($let ((b (u8 1 2 3)))
+ (bytevector-u8-fill! b 0)
+ b)
+ (u8 0 0 0))
+
;; XXX bytevector->immutable-bytevector
($check-predicate
diff --git a/src/tests/characters.k b/src/tests/characters.k
@@ -73,8 +73,7 @@
($check-predicate (char-lower-case? #\a #\b #\j #\y #\z))
($check-predicate ($false-for-all? char-lower-case? #\0 #\A #\Z #\' #\@ #\{ #\[ #\~))
-;; XXX char-upcase char-downcase
-
+;; XXX char-upcase char-downcase char-titlecase char-foldcase
($check equal? (char-upcase #\a) #\A)
($check equal? (char-upcase #\z) #\Z)
($check equal? (char-upcase #\R) #\R)
@@ -85,6 +84,16 @@
($check equal? (char-downcase #\r) #\r)
($check equal? (char-downcase #\9) #\9)
+($check equal? (char-titlecase #\a) #\A)
+($check equal? (char-titlecase #\z) #\Z)
+($check equal? (char-titlecase #\R) #\R)
+($check equal? (char-titlecase #\2) #\2)
+
+($check equal? (char-foldcase #\A) #\a)
+($check equal? (char-foldcase #\Z) #\z)
+($check equal? (char-foldcase #\r) #\r)
+($check equal? (char-foldcase #\9) #\9)
+
;; XXX char->integer integer->char
($check equal? (char->integer #\space) #x20)
@@ -96,3 +105,59 @@
($check equal? (integer->char #x30) #\0)
($check equal? (integer->char #x41) #\A)
($check equal? (integer->char #x61) #\a)
+
+;; XXX char-digit?
+($check-predicate (char-digit? #\0))
+($check-predicate (char-digit? #\9))
+($check-not-predicate (char-digit? #\a))
+($check-not-predicate (char-digit? #\2 2))
+($check-predicate (char-digit? #\f 16))
+($check-predicate (char-digit? #\F 16))
+($check-not-predicate (char-digit? #\!))
+
+;; errors
+
+($check-error (char-digit?))
+($check-error (char-digit? 12))
+($check-error (char-digit? #\9 10 #\a))
+($check-error (char-digit? #\9 10 10))
+($check-error (char-digit? #\0 1))
+($check-error (char-digit? #\0 0))
+($check-error (char-digit? #\0 -1))
+($check-error (char-digit? #\0 37))
+
+;; XXX char->digit
+($check =? (char->digit #\0) 0)
+($check =? (char->digit #\9) 9)
+($check =? (char->digit #\f 16) 15)
+($check =? (char->digit #\F 16) 15)
+($check =? (char->digit #\z 36) 35)
+($check =? (char->digit #\Z 36) 35)
+
+;; errors
+($check-error (char->digit))
+($check-error (char->digit 0))
+($check-error (char->digit #\0 10 10))
+($check-error (char->digit #\0 1))
+($check-error (char->digit #\0 37))
+($check-error (char->digit #\0 0))
+($check-error (char->digit #\0 -1))
+($check-error (char->digit #\a 10))
+($check-error (char->digit #\2 2))
+
+;; XXX digit->char
+($check char=? (digit->char 0) #\0)
+($check char=? (digit->char 9) #\9)
+($check char=? (char-downcase (digit->char 15 16)) #\f)
+($check char=? (char-downcase (digit->char 35 36)) #\z)
+
+;; errors
+($check-error (digit->char))
+($check-error (digit->char #\0))
+($check-error (digit->char 0 10 10))
+($check-error (digit->char 0 1))
+($check-error (digit->char 0 37))
+($check-error (digit->char 0 0))
+($check-error (digit->char 0 -1))
+($check-error (digit->char 10 10))
+($check-error (digit->char 2 2))
diff --git a/src/tests/combiners.k b/src/tests/combiners.k
@@ -223,6 +223,91 @@
. #0#))
(list #f #f #f #f))
+;; string-map
+($check-predicate (applicative? string-map))
+($check equal? (string-map char-downcase "") "")
+($check equal? (string-map char-upcase "abc") "ABC")
+($let ((char-max ($lambda chars
+ (integer->char
+ (apply max
+ (map char->integer chars))))))
+ ($check equal? (string-map char-max "abc" "ABC" "xyz" "XYZ")
+ "xyz")
+ ($check equal? (string-map char-max "abc" "ABC" . #0=("xyz" "XYZ". #0#))
+ "xyz"))
+
+($let ((p (cons () ())))
+ ($check eq?
+ ($sequence (string-map (wrap ($vau #ignore env
+ (set-car! p env)
+ #\a))
+ "a")
+ (car p))
+ (get-current-environment)))
+
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (string-map ($lambda (x)
+ (set-car! p (+ (car p) (char->integer x)))
+ #\a)
+ "abcd")
+ (car p))
+ (apply + (map char->integer (string->list "abcd")))))
+
+;; vector-map
+($check-predicate (applicative? vector-map))
+($check equal? (vector-map inert? (vector #inert #ignore #inert))
+ (vector #t #f #t))
+($check equal? (vector-map inert? (vector)) (vector))
+($check equal? (vector-map max (vector 1 2) .
+ #0=((vector 3 4) (vector 5 6). #0#))
+ (vector 5 6))
+
+($let ((p (cons () ())))
+ ($check eq?
+ ($sequence (vector-map (wrap ($vau #ignore env
+ (set-car! p env)))
+ (vector 1))
+ (car p))
+ (get-current-environment)))
+
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (vector-map ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (vector 1 2 3 4))
+ (car p))
+ 10))
+
+;; bytevector-map
+($check-predicate (applicative? bytevector-map))
+($check equal? (bytevector-map + (bytevector)) (bytevector))
+($check equal? (bytevector-map ($lambda (x) (+ x 1)) (bytevector 1 2 3))
+ (bytevector 2 3 4))
+($check equal? (bytevector-map max (bytevector 1 2) (bytevector 3 4)
+ (bytevector 5 6))
+ (bytevector 5 6))
+($check equal? (bytevector-map max (bytevector 1 2) . #0=((bytevector 3 4)
+ (bytevector 5 6) . #0#))
+ (bytevector 5 6))
+
+($let ((p (cons () ())))
+ ($check eq?
+ ($sequence (bytevector-map (wrap ($vau #ignore env
+ (set-car! p env)
+ 1))
+ (bytevector 1))
+ (car p))
+ (get-current-environment)))
+
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (bytevector-map ($lambda (x)
+ (set-car! p (+ (car p) x))
+ 1)
+ (bytevector 1 2 3 4))
+ (car p))
+ 10))
;;;
;;; Error Checking and Robustness
@@ -318,3 +403,55 @@
($check-error (map list (list 1 2) #inert))
($check-error (map cons (list 1 2)))
+
+;; string-map
+($check-error (string-map))
+($check-error (string-map char-upcase)) ; the list can't be empty
+($check-error (string-map ($lambda ls #\a) "abc" "ab"))
+($check-error (string-map ($lambda ls #\a) "abc" . #0=("ab" . #0#)))
+
+($check-error (string-map char->number "abc"))
+($check-error (string-map char>=? "abc" "def"))
+
+($check-error (string-map char-upcase #\a))
+($check-error (string-map char-upcase (list #\a)))
+($check-error (string-map #inert "abc"))
+($check-error (string-map (unwrap char-upcase) "abc"))
+($check-error (string-map char-upcase "abc" "def"))
+($check-error (string-map char-upcase . #0=("abc". #0#)))
+
+;; vector-map
+($check-error (vector-map))
+($check-error (vector-map char-upcase)) ; the list can't be empty
+($check-error (vector-map + (vector 1 2 3) (vector 1 2)))
+($check-error (vector-map + (vector 1 2 3) . #0=((vector 1 2) . #0#)))
+
+($check-error (vector-map char-upcase #\a))
+($check-error (vector-map char-upcase (list #\a)))
+($check-error (vector-map + (bytevector 1)))
+($check-error (vector-map #inert (vector)))
+($check-error (vector-map (unwrap +) (vector 1 2 3)))
+($check-error (vector-map ($lambda (x) (+ x 1))
+ (vector 1 2) (vector 1 2)))
+($check-error (vector-map ($lambda (x) (+ x 1)) .
+ #0=((vector 1 2) . #0#)))
+
+;; bytevector-map
+($check-error (bytevector-map))
+($check-error (bytevector-map +)) ; the list can't be empty
+($check-error (bytevector-map + (bytevector 1 2) (bytevector 1 2 3)))
+($check-error (bytevector-map + (bytevector 1 2) .
+ #0=((bytevector 1 2 3) . #0#)))
+
+($check-error (bytevector-map number->char (bytevector 41 42 43)))
+($check-error (bytevector-map + (bytevector 100 200) (bytevector 300 400)))
+
+($check-error (bytevector-map + 1))
+($check-error (bytevector-map + (list 1)))
+($check-error (bytevector-map + (vector 1)))
+($check-error (bytevector-map #inert (bytevector 1 2 3)))
+($check-error (bytevector-map (unwrap char-upcase) (bytevector 1 2 3)))
+($check-error (bytevector-map ($lambda (x) (+ x 1))
+ (bytevector 1 2 3) (bytevector 1 2 3)))
+($check-error (bytevector-map ($lambda (x) (+ x 1)) .
+ #0=((bytevector 1 2 3) . #0#)))
diff --git a/src/tests/control.k b/src/tests/control.k
@@ -26,11 +26,11 @@
(enc #inert))))
($check-not-predicate (inert? (memoize #inert)))
($check-not-predicate (inert? 1))
-;($check-not-predicate (inert? 1.0))
+($check-not-predicate (inert? 1.0))
($check-not-predicate (inert? #e+infinity))
-;($check-not-predicate (inert? #i+infinity))
-;($check-not-predicate (inert? #undefined))
-;($check-not-predicate (inert? #real-with-no-primary-value))
+($check-not-predicate (inert? #i+infinity))
+($check-not-predicate (inert? #undefined))
+($check-not-predicate (inert? #real))
($check-not-predicate (inert? "string"))
($check-not-predicate (inert? #\a))
($check-not-predicate (inert? (get-current-input-port)))
@@ -146,6 +146,198 @@
#f))
+;; string-for-each
+($check-predicate (applicative? string-for-each))
+($check eq? (string-for-each char-upcase "abcd") #inert)
+($check eq? (string-for-each char<? "abcd" "efgh") #inert)
+
+($let ((p (cons () ())))
+ ($check eq?
+ ($sequence (string-for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ "a")
+ (car p))
+ (get-current-environment)))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (string-for-each ($lambda (x)
+ (set-car! p (+ (car p)
+ (char->integer x))))
+ "abcd")
+ (car p))
+ (apply + (map char->integer (string->list "abcd")))))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (string-for-each ($lambda (x y )
+ (set-car! p (+ (car p)
+ (char->integer x)
+ (char->integer y))))
+ "abc"
+ "def")
+ (car p))
+ (apply + (map char->integer (string->list "abcdef")))))
+
+
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (string-for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=("abc"
+ "def"
+ . #0#))
+ (car p))
+ #f))
+
+
+;; vector-for-each
+($check-predicate (applicative? vector-for-each))
+($check eq? (vector-for-each + (vector 1 2 3)) #inert)
+($check eq? (vector-for-each <? (vector 1 2) (vector 3 4))
+ #inert)
+
+($let ((p (cons () ())))
+ ($check eq?
+ ($sequence (vector-for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ (vector 1))
+ (car p))
+ (get-current-environment)))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (vector-for-each ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (vector 1 2 3 4))
+ (car p))
+ 10))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (vector-for-each ($lambda (x y )
+ (set-car! p (+ (car p) x y)))
+ (vector 1 2 3 4)
+ (vector 10 20 30 40))
+ (car p))
+ 110))
+
+
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (vector-for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=((vector 1 2)
+ (vector 3 4)
+ . #0#))
+ (car p))
+ #f))
+
+;; bytevector-for-each
+($check-predicate (applicative? bytevector-for-each))
+($check eq? (bytevector-for-each + (bytevector 1 2 3)) #inert)
+($check eq? (bytevector-for-each <? (bytevector 1 2) (bytevector 3 4))
+ #inert)
+
+($let ((p (cons () ())))
+ ($check eq?
+ ($sequence (bytevector-for-each (wrap ($vau #ignore env
+ (set-car! p env)))
+ (bytevector 1))
+ (car p))
+ (get-current-environment)))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (bytevector-for-each ($lambda (x)
+ (set-car! p (+ (car p) x)))
+ (bytevector 1 2 3 4))
+ (car p))
+ 10))
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (bytevector-for-each ($lambda (x y )
+ (set-car! p (+ (car p) x y)))
+ (bytevector 1 2 3 4)
+ (bytevector 10 20 30 40))
+ (car p))
+ 110))
+
+($let ((p (cons 0 ())))
+ ($check eq?
+ ($sequence (bytevector-for-each ($lambda ls
+ (set-car! p (finite-list? ls)))
+ . #0=((bytevector 1 2)
+ (bytevector 3 4)
+ . #0#))
+ (car p))
+ #f))
+
+;; $when
+($check-predicate (operative? $when))
+($check-predicate (inert? ($when #t)))
+($check-predicate (inert? ($when #f)))
+($check-predicate (inert? ($when #t 1)))
+($check-predicate (inert? ($when #f 1)))
+($check-predicate (inert? ($when #t 1 2)))
+($check-predicate (inert? ($when #f 1 2)))
+
+($let ((p (cons () ())))
+ ($check equal? ($sequence ($when #f (set-car! p 1))
+ (car p))
+ ()))
+
+($let ((p (cons () ())))
+ ($check eq? ($sequence ($when ($sequence
+ (set-car! p (get-current-environment))
+ #f))
+ (car p))
+ (get-current-environment)))
+
+($let ((p (cons () ())))
+ ($check eq? ($sequence ($when #t (set-car! p (get-current-environment)))
+ (car p))
+ (get-current-environment)))
+
+;; check tail recursiveness
+($let ((p (cons 1 2)))
+ ($check-predicate ($sequence ($when #t ($let/cc cont1
+ (set-car! p cont1)
+ ($when #t
+ ($let/cc cont2
+ (set-cdr! p cont2)))))
+ (eq? (car p) (cdr p)))))
+
+;; $unless
+($check-predicate (operative? $unless))
+($check-predicate (inert? ($unless #t)))
+($check-predicate (inert? ($unless #f)))
+($check-predicate (inert? ($unless #t 1)))
+($check-predicate (inert? ($unless #f 1)))
+($check-predicate (inert? ($unless #t 1 2)))
+($check-predicate (inert? ($unless #f 1 2)))
+
+($let ((p (cons () ())))
+ ($check equal? ($sequence ($unless #t (set-car! p 1))
+ (car p))
+ ()))
+
+($let ((p (cons () ())))
+ ($check eq? ($sequence ($unless ($sequence
+ (set-car! p (get-current-environment))
+ #t))
+ (car p))
+ (get-current-environment)))
+
+($let ((p (cons () ())))
+ ($check eq? ($sequence ($unless #f (set-car! p (get-current-environment)))
+ (car p))
+ (get-current-environment)))
+
+;; check tail recursiveness
+($let ((p (cons 1 2)))
+ ($check-predicate ($sequence ($unless #f ($let/cc cont1
+ (set-car! p cont1)
+ ($unless #f
+ ($let/cc cont2
+ (set-cdr! p cont2)))))
+ (eq? (car p) (cdr p)))))
+
;;;
;;; Error Checking and Robustness
;;;
@@ -185,8 +377,7 @@
;; for-each
($check-error (for-each))
-;; the list can't be empty
-($check-error (for-each list))
+($check-error (for-each list)) ; the list can't be empty
($check-error (for-each list (list 1 2) (list 1 2 3)))
($check-error (for-each list (list . #0=(1 2 . #0#)) (list 1 2 3)))
@@ -197,3 +388,62 @@
($check-error (for-each list (list 1 2) #inert))
($check-error (for-each cons (list 1 2)))
+
+
+;; string-for-each
+($check-error (string-for-each))
+($check-error (string-for-each char-upcase)) ; the list can't be empty
+
+($check-error (string-for-each char<? "ab" "abc"))
+
+($check-error (string-for-each char-upcase #inert))
+($check-error (string-for-each #inert "abc"))
+($check-error (string-for-each (unwrap char-upcase) "abc"))
+
+($check-error (string-for-each char<? "abc" #inert))
+($check-error (string-for-each cons "abc"))
+
+;; vector-for-each
+($check-error (vector-for-each))
+($check-error (vector-for-each char-upcase)) ; the list can't be empty
+
+($check-error (vector-for-each <? (vector 1 2) (vector 1 2 3)))
+
+($check-error (vector-for-each char-upcase #inert))
+($check-error (vector-for-each #inert (vector 1 2)))
+($check-error (vector-for-each (unwrap char-upcase) (vector 1)))
+
+($check-error (vector-for-each <? (vector 1 2) #inert))
+($check-error (vector-for-each cons (vector 1 2 3)))
+
+;; bytevector-for-each
+($check-error (bytevector-for-each))
+($check-error (bytevector-for-each +)) ; the list can't be empty
+
+($check-error (bytevector-for-each <? (bytevector 1 2)
+ (bytevector 1 2 3)))
+
+($check-error (bytevector-for-each + #inert))
+($check-error (bytevector-for-each #inert (bytevector 1 2 3)))
+($check-error (bytevector-for-each (unwrap char-upcase)
+ (bytevector 1 2)))
+
+($check-error (bytevector-for-each <? (bytevector 1 2) #inert))
+($check-error (bytevector-for-each cons
+ (bytevector 1 2 3)))
+
+
+;; $when
+($check-error ($when))
+($check-error ($when #t . 3))
+($check-error ($when #f . 3))
+($check-error ($when #inert 1))
+
+;; $unless
+($check-error ($unless))
+($check-error ($unless #t . 3))
+($check-error ($unless #f . 3))
+($check-error ($unless #inert 1))
+
+
+
diff --git a/src/tests/error.k b/src/tests/error.k
@@ -39,7 +39,10 @@
($check equal? (error-object-irritants e1) ())
($check equal? (error-object-irritants e2) (list 1 2 3))
($check equal? (error-object-irritants e3) ())
- ($check equal? (error-object-irritants e4) (list 1))
+;; error now uses the standard binding constructs from kghelper
+;; for now they don't encapsulate any data in the error, but
+;; they will in the future
+;; ($check equal? (error-object-irritants e4) (list 1))
($check-error (error-object-irritants))
($check-error (error-object-irritants e1 e2))
diff --git a/src/tests/numbers.k b/src/tests/numbers.k
@@ -60,7 +60,6 @@
($check equal? #i+infinity #i+infinity)
;; 12.5.1 number? finite? integer?
-
($check-predicate (number? 0 1 3/5 -3.14e0 #real))
($check-not-predicate (number? 5 "6" 7))
@@ -77,6 +76,15 @@
($check-not-predicate (integer? #real))
($check-not-predicate (integer? "0"))
+;; 12.?? exact-integer?
+($check-predicate (exact-integer? 0 8/2 -12/6))
+($check-not-predicate (exact-integer? 1.0))
+($check-not-predicate (exact-integer? #e+infinity))
+($check-not-predicate (exact-integer? #e-infinity))
+($check-not-predicate (exact-integer? #real))
+($check-not-predicate (exact-integer? "0"))
+
+
;; 12.5.2 =?
($check-predicate (=?))
@@ -415,3 +423,94 @@
;; 12.10 Complex features
;; not implemented
+
+;; String conversion
+
+;; 12.? number->string
+($check string-ci=? (number->string 0) "0")
+($check string-ci=? (number->string 1) "1")
+($check string-ci=? (number->string -1) "-1")
+($check string-ci=? (number->string 2 2) "10")
+($check string-ci=? (number->string -2 2) "-10")
+($check string-ci=? (number->string 8 8) "10")
+($check string-ci=? (number->string -8 8) "-10")
+($check string-ci=? (number->string 10 10) "10")
+($check string-ci=? (number->string -10 10) "-10")
+($check string-ci=? (number->string 16 16) "10")
+($check string-ci=? (number->string -16 16) "-10")
+; default base
+($check string-ci=? (number->string 10) (number->string 10 10))
+;; infinities, undefined and reals with no primary value
+($check string-ci=? (number->string #undefined) "#undefined")
+($check string-ci=? (number->string #real) "#real")
+($check string-ci=? (number->string #e+infinity) "#e+infinity")
+($check string-ci=? (number->string #e-infinity) "#e-infinity")
+($check string-ci=? (number->string #i+infinity) "#i+infinity")
+($check string-ci=? (number->string #i-infinity) "#i-infinity")
+;; rationals
+($check string-ci=? (number->string 13/17) "13/17")
+($check string-ci=? (number->string -17/13) "-17/13")
+($check string-ci=? (number->string #o-21/15 8) "-21/15")
+;; bigints
+($check string-ci=? (number->string #x1234567890abcdef 16)
+ "1234567890abcdef")
+
+; only bases 2, 8, 10, 16
+($check-error (number->string 10 3))
+; only numbers
+($check-error (number->string #inert))
+($check-error (number->string #inert 2))
+; only numbers
+($check-error (number->string "2"))
+($check-error (number->string "2" 8))
+; only base 10 with inexact numbers
+($check-error (number->string -1.0 2))
+($check-error (number->string 1.25 8))
+($check-error (number->string 3.0 16))
+
+;; 12.? string->number
+($check =? (string->number "0") 0)
+($check =? (string->number "1") 1)
+($check =? (string->number "-1") -1)
+($check =? (string->number "10" 2) 2)
+($check =? (string->number "-10" 2) -2)
+($check =? (string->number "10" 8) 8)
+($check =? (string->number "-10" 8) -8)
+($check =? (string->number "10" 10) 10)
+($check =? (string->number "-10" 10) -10)
+($check =? (string->number "10" 16) 16)
+($check =? (string->number "-10" 16) -16)
+; default base
+($check =? (string->number "10") (string->number "10" 10))
+;; infinities, undefined and reals with no primary value
+;; #undefined and #real can't be compared with =?
+($check equal? (string->number "#undefined") #undefined)
+($check equal? (string->number "#real") #real)
+($check =? (string->number "#e+infinity") #e+infinity)
+($check =? (string->number "#e-infinity") #e-infinity)
+($check =? (string->number "#i+infinity") #i+infinity)
+($check =? (string->number "#i-infinity") #i-infinity)
+;; rationals
+($check =? (string->number "13/17") 13/17)
+($check =? (string->number "-17/13") -17/13)
+($check =? (string->number "-21/15" 8) #o-21/15)
+;; bigints
+($check =? (string->number "1234567890abcdef" 16)
+ #x1234567890abcdef)
+($check =? (string->number "1234567890ABCDEF" 16)
+ #x1234567890abcdef)
+;; doubles
+($check =? (string->number "1.25e10") 1.25e10)
+($check =? (string->number "-1.25e10" 10) -1.25e10)
+
+; only bases 2, 8, 10, 16
+($check-error (string->number "10" 3))
+; only strings
+($check-error (string->number #inert))
+($check-error (string->number #inert 2))
+($check-error (string->number 2))
+($check-error (string->number 2 8))
+; only base 10 with inexact numbers
+($check-error (string->number "-1.0" 2))
+($check-error (string->number "1.25" 8))
+($check-error (string->number "3.0" 16))
diff --git a/src/tests/pair-mutation.k b/src/tests/pair-mutation.k
@@ -35,7 +35,29 @@
($check equal? ($let ((l (list* 1 2 3 4 5))) (encycle! l 0 3) l)
(list . #0=(1 2 3 . #0#)))
+;; list-set!
+($check-predicate (inert? (list-set! (list 0 1 2 3) 0 10)))
+($check equal? ($let ((l (list 0 1 2 3)))
+ (list-set! l 1 10)
+ (list-set! l 3 30)
+ l)
+ (list 0 10 2 30))
+($check equal? ($let ((l (list 0 . #1=(1 2 . #1#))))
+ (list-set! l 1 10)
+ (list-set! l 4 20)
+ l)
+ (list 0 . #2=(10 20 . #2#)))
+;; see kgpair_mut.c for rationale on allowing
+;; improper lists as argument to list-set!
+($check equal? ($let ((l (list* 0 1 2 3)))
+ (list-set! l 1 10)
+ (list-set! l 2 20)
+ l)
+ (list* 0 10 20 3))
+
;; append!
+($check-predicate (inert? (append! (list 1) (list 2))))
+
($let ()
($define! l1 (list 1 2))
($define! l2 (list 3 4))
@@ -159,6 +181,19 @@
($check-error (encycle! (list 1 2 3) 0 -2))
($check-error (encycle! (list 1 2 3) 0 #e+infinity))
+;; list-set!
+;; set-car! & set-cdr!
+($check-error (list-set!))
+($check-error (list-set! (list 1)))
+($check-error (list-set! (list 1) 0))
+($check-error (list-set! (list 1) 0 1 1))
+
+($check-error (list-set! #inert 0 0))
+($check-error (list-set! () 0 0))
+($check-error (list-set! (list 1 2) 2 0))
+($check-error (list-set! (list 1 2) -1 0))
+($check-error (list-set! (list* 1 2 3) 2 0))
+
;; append!
;; ASK does the report assert that the lists remains unmodified??
;; probably should for robust implementations
diff --git a/src/tests/pairs-and-lists.k b/src/tests/pairs-and-lists.k
@@ -31,11 +31,11 @@
(enc #inert))))
($check-not-predicate (null? (memoize #inert)))
($check-not-predicate (null? 1))
-;($check-not-predicate (null? 1.0))
+($check-not-predicate (null? 1.0))
($check-not-predicate (null? #e+infinity))
-;($check-not-predicate (null? #i+infinity))
-;($check-not-predicate (null? #undefined))
-;($check-not-predicate (null? #real-with-no-primary-value))
+($check-not-predicate (null? #i+infinity))
+($check-not-predicate (null? #undefined))
+($check-not-predicate (null? #real))
($check-not-predicate (null? "string"))
($check-not-predicate (null? #\a))
($check-not-predicate (null? (get-current-input-port)))
@@ -54,11 +54,11 @@
(enc #inert))))
($check-not-predicate (pair? (memoize #inert)))
($check-not-predicate (pair? 1))
-;($check-not-predicate (pair? 1.0))
+($check-not-predicate (pair? 1.0))
($check-not-predicate (pair? #e+infinity))
-;($check-not-predicate (pair? #i+infinity))
-;($check-not-predicate (pair? #undefined))
-;($check-not-predicate (pair? #real-with-no-primary-value))
+($check-not-predicate (pair? #i+infinity))
+($check-not-predicate (pair? #undefined))
+($check-not-predicate (pair? #real))
($check-not-predicate (pair? "string"))
($check-not-predicate (pair? #\a))
($check-not-predicate (pair? (get-current-input-port)))
@@ -128,6 +128,26 @@
($check eq? (cadddr tree16) 15)
($check eq? (cddddr tree16) 16))
+;; make-list
+($check-predicate (null? (make-list 0)))
+($check-predicate (mutable-pair? (make-list 1)))
+($check equal? (make-list 2) (list #inert #inert))
+($check equal? (make-list 3 "val") (list "val" "val" "val"))
+
+;; list-copy
+($check-predicate (null? (list-copy ())))
+($check-predicate (mutable-pair? (list-copy (list 1))))
+($check-predicate (mutable-pair? (list-copy (copy-es-immutable (list 1)))))
+($check equal? (list-copy (list 1 2 3)) (list 1 2 3))
+($check equal? (list-copy (list . #1=(1 2 . #1#))) (list . #2=(1 2 . #2#)))
+
+;; reverse
+($check-predicate (null? (reverse ())))
+($check-predicate (mutable-pair? (reverse (list 1))))
+($check-predicate (mutable-pair? (reverse (copy-es-immutable (list 1)))))
+($check equal? (reverse (list 1)) (list 1))
+($check equal? (reverse (list 1 2 3)) (list 3 2 1))
+
;; get-list-metrics
($check equal? (get-list-metrics ()) (list 0 1 0 0))
($check equal? (get-list-metrics #inert) (list 0 0 0 0))
@@ -152,7 +172,7 @@
;; list-ref
($check =? (list-ref (list 1 2 3 4 5) 0) 1)
($check =? (list-ref (list 1 2 3 4 5) 1) 2)
-;; see ground/pairs-and-lists.scm for rationale on allowing
+;; see kgpairs_lists.c for rationale on allowing
;; improper lists as argument to list-ref
($check =? (list-ref (list* 1 2 3 4) 2) 3)
($check =? (list-ref (list . #0=(1 2 3 4 5 . #0#)) 10) 1)
@@ -217,6 +237,7 @@
($check equal? (assoc #inert ()) ())
($check equal? (assoc 3 (list (list 1 10) (list 2 20))) ())
($check equal? (assoc 1 (list (list 1 10) (list 2 20))) (list 1 10))
+($check equal? (assoc 1 (list (list 1 10) (list 2 20)) =?) (list 1 10))
($check equal?
(assoc 1 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#)))
(list 1 10))
@@ -227,6 +248,10 @@
(assoc (list 1) (list (list (list 1) 1) (list (list 2) 2)))
(list (list 1) 1))
+($check equal?
+ (assoc 4 (list . #0=((list 1 10) (list 2 20) (list 1 15) . #0#))
+ =?)
+ ())
;; member?
($check-predicate (member? 1 (list 1 2)))
($check-predicate (member? 2 (list 1 2)))
@@ -239,6 +264,10 @@
($check-not-predicate
(member? 4 (list . #0=(1 2 1 . #0#))))
+($check-predicate (member? -1 (list 1 2) ($lambda (x y) (=? x (- 0 y)))))
+($check-not-predicate (member? 1 (list 1 2 . #0=(3 4 . #0#))
+ ($lambda (x y) (=? x (- 0 y)))))
+
;; finite-list?
($check-predicate (finite-list? ()))
($check-predicate (finite-list? (list 1)))
@@ -353,6 +382,27 @@
($check-error (cadddr tree8))
($check-error (cddddr tree8)))
+;; make-list
+($check-error (make-list))
+($check-error (make-list "str"))
+($check-error (make-list 1 "str" "str2"))
+($check-error (make-list -2))
+($check-error (make-list 3/4))
+($check-error (make-list #e+infinity))
+
+;; list-copy
+($check-error (list-copy))
+($check-error (list-copy () ()))
+($check-error (list-copy #inert))
+($check-error (list-copy (list* 1 2 3)))
+
+;; reverse
+($check-error (reverse))
+($check-error (reverse () ()))
+($check-error (reverse #inert))
+($check-error (reverse (list* 1 2 3)))
+($check-error (reverse (list 1 . #1=(2 . #1#))))
+
;; get-list-metrics
($check-error (get-list-metrics))
($check-error (get-list-metrics () ()))
@@ -408,22 +458,28 @@
;; asooc
($check-error (assoc))
($check-error (assoc 2))
-($check-error (assoc 2 (list (list 1 1) (list 2 2)) ()))
+($check-error (assoc 2 (list (list 1 1) (list 2 2)) () ()))
($check-error (assoc . #0=(2 (list (list 1 1) (list 2 2)) . #0#)))
+($check-error (assoc 2 (list (list 1 1) (list 2 2)) () (unwrap equal?)))
($check-error (assoc 2 (list* (list 1 1) 2)))
($check-error (assoc 2 (list* (list 1 1) (list 2 2) #inert)))
+($check-error (assoc 2 (list* 1 2) equal?))
($check-error (assoc 4 (list (list 1 1) (list 2 2) #inert (list 4 4))))
($check-error (assoc 2 (list (list 1 1) (list 2 2) #inert (list 4 4))))
+($check-error (assoc 2 (list (list 1 1) (list 2 2) #inert (list 4 4))
+ equal?))
;; member?
($check-error (member?))
($check-error (member? 2))
-($check-error (member? 2 (list 1 2) ()))
+($check-error (member? 2 (list 1 2) () ()))
($check-error (member? . #0=(2 (list 1 2) . #0#)))
+($check-error (member? 2 (list 1 2) (unwrap equal?)))
($check-error (member? 2 (list* 1 2)))
($check-error (member? 2 (list* 1 2 3)))
+($check-error (member? 2 (list* 1 2) equal?))
;; finite-list?
($check-error (countable-list? (cons () ()) . #inert))
diff --git a/src/tests/ports.k b/src/tests/ports.k
@@ -158,7 +158,6 @@
($check-error (call-with-closed-input-port close-output-file))
;; 15.1.7 read
-
($check-predicate (eof-object? ($input-test #inert (read))))
($check-predicate (eof-object? ($input-test "" (read))))
@@ -206,6 +205,8 @@
($check-error (write 0 (get-current-input-port)))
($check-error (call-with-closed-output-port ($lambda (p) (write 0 p))))
+;; write-simple
+;; read-line
;; 15.2.1 call-with-input-file call-with-output-file
;; 15.2.2 load
;; 15.2.3 get-module
diff --git a/src/tests/promises.k b/src/tests/promises.k
@@ -25,9 +25,10 @@
($check-error ($lazy))
($check-error ($lazy "too" "many"))
+($check equal? (force ($lazy (get-current-environment)))
+ (get-current-environment))
;; Test cases from R(-1)RK
-
($define! lazy-test-1
($sequence
($provide! (get-count p)
@@ -104,3 +105,15 @@
($check equal? (force (force (memoize ($lazy 0)))) 0)
($check equal? (force ($lazy (memoize 0))) 0)
($check equal? (force (force ($lazy (memoize 0)))) 0)
+
+;; 9.1.5? $delay
+
+($check-error (memoize))
+($check-error (memoize "too" "many"))
+
+($check equal? (force ($delay 0)) 0)
+($check equal? (force (force ($delay 0))) 0)
+($check equal? (force ($delay (get-current-environment)))
+ (get-current-environment))
+($check-predicate (promise? (force ($delay (memoize 0)))))
+($check equal? (force (force ($delay (memoize 0)))) 0)
diff --git a/src/tests/strings.k b/src/tests/strings.k
@@ -4,7 +4,9 @@
;;
;; XXX immutability of string constants
-
+;; this works because this file is loaded and the strings
+;; are immutable, but just reading the file wouldn't make them
+;; immutable
($check-predicate (immutable-string? ""))
($check-predicate (immutable-string? "abcd"))
@@ -84,6 +86,24 @@
($check equal? (string #\a #\b #\c) "abc")
($check-not-predicate ($let ((x (string #\a)) (y (string #\a))) (eq? x y)))
+;; XXX string-upcase string-downcase string-titlecase string-foldcase
+($check equal? (string-upcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyz")
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+($check equal? (string-titlecase "this is a regular sentence. this 1 2!")
+ "This Is A Regular Sentence. This 1 2!")
+($check equal? (string-downcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyz")
+ "abcdefghijklmnopqrstuvwxyz01234567890abcdefghijklmnopqrstuvwxyz")
+($check equal? (string-foldcase "ABCDEFGHIJKLMNOPQRSTUVWXYZ01234567890abcdefghijklmnopqrstuvwxyz")
+ "abcdefghijklmnopqrstuvwxyz01234567890abcdefghijklmnopqrstuvwxyz")
+($check-predicate (mutable-string? (string-upcase (string-copy "A0a"))))
+($check-predicate (mutable-string? (string-upcase "A0a")))
+($check-predicate (mutable-string? (string-downcase (string-copy "A0a"))))
+($check-predicate (mutable-string? (string-downcase "A0a")))
+($check-predicate (mutable-string? (string-titlecase (string-copy "A0a"))))
+($check-predicate (mutable-string? (string-titlecase "A0a")))
+($check-predicate (mutable-string? (string-foldcase (string-copy "A0a"))))
+($check-predicate (mutable-string? (string-foldcase "A0a")))
+
;; XXX string-length
($check equal? (string-length "") 0)
@@ -206,6 +226,80 @@
($check-error (list->string ($quote (#\a #0=(#\a . #0#)))))
+;; XXX string->vector
+
+($check equal? (string->vector "") (vector))
+($check equal? (string->vector "abc") (vector #\a #\B #\c))
+
+($check-not-predicate
+ ($let*
+ ( (str "abc")
+ (x (string->vector str))
+ (y (string->vector str)))
+ (eq? x y)))
+
+($check-predicate (mutable-vector? (string->vector "abc")))
+
+;; XXX vector->string
+
+($check equal? (vector->string (vector)) "")
+($check equal? (vector->string (vector #\a #\b #\c)) "abc")
+
+($check-not-predicate
+ ($let*
+ ( (cs (vector #\a #\b #\c))
+ (x (vector->string cs))
+ (y (vector->string cs)))
+ (eq? x y)))
+
+($check-predicate (mutable-string? (vector->string (vector #\a #\b))))
+
+;; errors
+($check-error (vector->string (vector 41)))
+($check-error (vector->string (vector "a")))
+
+;; XXX string->bytevector
+
+($check equal? (string->bytevector "") (bytevector))
+($check equal? (string->bytevector "aBc")
+ (bytevector (char->integer #\a)
+ (char->integer #\B)
+ (char->integer #\c)))
+
+($check-not-predicate
+ ($let*
+ ( (str "abc")
+ (x (string->bytevector str))
+ (y (string->bytevector str)))
+ (eq? x y)))
+
+($check-predicate (mutable-bytevector? (string->bytevector "abc")))
+
+;; XXX bytevector->string
+
+($check equal? (bytevector->string (bytevector)) "")
+($check equal? (bytevector->string (bytevector (char->integer #\a)
+ (char->integer #\b)
+ (char->integer #\c)))
+ "abc")
+
+($check-not-predicate
+ ($let*
+ ((cs (bytevector (char->integer #\a)
+ (char->integer #\b)
+ (char->integer #\c)))
+ (x (bytevector->string cs))
+ (y (bytevector->string cs)))
+ (eq? x y)))
+
+($check-predicate (mutable-string?
+ (bytevector->string (bytevector (char->integer #\a)
+ (char->integer #\b)))))
+
+;; errors
+($check-error (bytevector->string (bytevector 128))) ;; only ASCII
+
+
;; 13.1.1 string->symbol
;; XXX symbol->string
;;
diff --git a/src/tests/system.k b/src/tests/system.k
@@ -0,0 +1,27 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of system features.
+;;
+
+;; (R7RS 3rd draft, section 6.7.4) current-second
+
+($check-predicate (applicative? current-second))
+($check-predicate (number? (current-second)))
+
+;; TODO: Update before the year 2031....
+
+($let ((T-2011-01-01 1293836400) (T-2031-01-01 1924988400))
+ ($check-predicate (<? T-2011-01-01 (current-second)))
+ ($check-predicate (>? T-2031-01-01 (current-second))))
+
+;; (R7RS 3rd draft, section 6.7.4) current-jiffy jiffies-per-second
+
+($check-predicate (applicative? current-jiffy jiffies-per-second))
+($check-predicate (exact-integer? (current-jiffy) (jiffies-per-second)))
+($check-predicate (positive? (current-jiffy) (jiffies-per-second)))
+
+($let* ((jiffy1 (current-jiffy)) (jiffy2 (current-jiffy)))
+ ($check-predicate (<=? jiffy1 jiffy2)))
+
+($let* ((jps1 (jiffies-per-second)) (jps2 (jiffies-per-second)))
+ ($check-predicate (=? jps1 jps2)))
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -25,5 +25,6 @@
(load "tests/error.k")
(load "tests/bytevectors.k")
(load "tests/vectors.k")
+(load "tests/system.k")
(check-report)
diff --git a/src/tests/test-interpreter.sh b/src/tests/test-interpreter.sh
@@ -0,0 +1,225 @@
+#! /bin/sh
+#
+# Test of the stand-alone interpreter.
+#
+# Does not work in MSYS shell on Windows because
+# of different handling of command line arguments.
+# TODO: Write similar test script for Windows cmd.exe or PowerShell.
+#
+
+if [ $# -ne 1 ] ; then
+ echo "usage: test-interpreter.sh KLISP-EXECUTABLE" 1>&2
+ exit 1
+fi
+
+KLISP="$1"
+GEN_K="test-interpreter-gen.k"
+TMPERR="test-interpreter-err.log"
+
+# -- functions ----------------------------------------
+
+init()
+{
+ nfail=0
+ npass=0
+}
+
+check_match()
+{
+ expected="$1"
+ actual="$2"
+
+ if regexp=`expr match "$expected" '/\(.*\)/$'` ; then
+ expr match "$actual" "$regexp" >/dev/null
+ else
+ test "$actual" = "$expected"
+ fi
+}
+
+check_helper()
+{
+ expected_stdout="$1"
+ expected_stderr="$2"
+ expected_exitstatus="$3"
+ stdout="$4"
+ stderr="$5"
+ exitstatus="$6"
+ command="$7"
+
+ if ! check_match "$expected_stdout" "$stdout" ; then
+ echo "FAIL: $command"
+ echo " stdout => '$stdout'"
+ echo " expected: '$expected_stdout'" 1>&2
+ nfail=$((1 + $nfail))
+ elif ! check_match "$expected_stderr" "$stderr" ; then
+ echo "FAIL: $command"
+ echo " stderr => '$stderr'"
+ echo " expected: '$expected_stderr'" 1>&2
+ nfail=$((1 + $nfail))
+ elif [ $exitstatus -ne $expected_exitstatus ] ; then
+ echo "FAIL: $command"
+ echo " ==> exit status $exitstatus ; expected: $expected_exitstatus" 1>&2
+ nfail=$((1 + $nfail))
+ else
+ ## echo "OK: $command ==> $stdout"
+ npass=$((1 + $npass))
+ fi
+}
+
+check_o()
+{
+ expected_output="$1"
+ shift
+ o=`"$@" 2> $TMPERR`
+ s=$?
+ e=`cat $TMPERR`
+ check_helper "$expected_output" '' 0 "$o" "$e" "$s" "$*"
+}
+
+check_os()
+{
+ expected_output="$1"
+ expected_exitstatus="$2"
+ shift
+ shift
+ o=`"$@" 2> $TMPERR`
+ s=$?
+ e=`cat $TMPERR`
+ check_helper "$expected_output" '' "$expected_exitstatus" "$o" "$e" "$s" "$*"
+}
+
+check_oi()
+{
+ expected_output="$1"
+ input="$2"
+ shift
+ shift
+ o=`echo "$input" | "$@" 2> $TMPERR`
+ s=$?
+ e=`cat $TMPERR`
+ check_helper "$expected_output" '' 0 "$o" "$e" "$s" "echo '$input' | $*"
+}
+
+check_oe()
+{
+ expected_stdout="$1"
+ expected_stderr="$2"
+ shift
+ shift
+ o=`"$@" 2> $TMPERR`
+ s=$?
+ e=`cat $TMPERR`
+ check_helper "$expected_stdout" "$expected_stderr" 0 "$o" "$e" "$s" "$*"
+}
+
+report()
+{
+ echo "Tests Passed: $npass"
+ echo "Tests Failed: $nfail"
+ echo "Tests Total: $(($npass + $nfail))"
+}
+
+cleanup()
+{
+ rm -f "$GEN_K" "$TMPERR"
+}
+# -- tests --------------------------------------------
+
+init
+
+# script name on the command line
+
+echo '(display 123456)' > "$GEN_K"
+check_o '123456' $KLISP "$GEN_K"
+
+# empty command line and stdin not a terminal
+
+check_oi '' '' $KLISP
+
+# '-' on the command line
+
+check_oi '2' '(display (+ 1 1))' $KLISP -
+
+# option: -e
+
+check_o 'abcdef' $KLISP '-e (display "abc")' '-e' '(display "def")'
+
+# option: -i
+# The interpreter always show name and version
+# WAS check_oi 'klisp> ' '' $KLISP -i
+
+check_oi '/klisp [0-9.][0-9.]* .*\n.*klisp> /' '' $KLISP -i
+
+# option: -v
+
+check_o '/klisp [0-9.][0-9.]* .*/' $KLISP -v
+
+# '--' on the command line
+
+check_o '1' $KLISP '-e (display 1)' --
+
+# exit status
+
+check_os '' 0 $KLISP -e '(exit 0)'
+check_os '' 1 $KLISP -e '(exit 1)'
+check_os '' 2 $KLISP -e '(exit 2)'
+check_os '' 0 $KLISP -e '(exit #t)'
+check_os '' 1 $KLISP -e '(exit #f)'
+check_os '' 0 $KLISP -e '(exit #inert)'
+check_os '' 1 $KLISP -e '(exit ())'
+check_os '' 0 $KLISP -e '(exit)'
+check_os '' 0 $KLISP -e '1'
+check_os '' 3 $KLISP -e '(apply-continuation root-continuation 3)'
+
+## FIX the root continuation should exit without running any more
+## arguments, but it doesn't...
+check_os '' 0 $KLISP -e '(exit 0)' -e '(exit 1)'
+check_os '' 1 $KLISP -e '(exit 1)' -e '(exit 0)'
+
+# KLISP_INIT environment variable
+
+export KLISP_INIT='(display "init...")'
+check_o 'init...main' $KLISP -e '(display "main")'
+export KLISP_INIT=
+
+# other environment variables
+
+export KLISPTEST1=pqr
+check_o '"pqr"' $KLISP '-e (write (get-environment-variable "KLISPTEST1"))'
+check_o '#f' $KLISP '-e (write (get-environment-variable "KLISPTEST2"))'
+
+# script arguments
+
+check_o '()' $KLISP -e '(write(get-script-arguments))'
+check_oi '("-" "-i")' '' $KLISP -e '(write(get-script-arguments))' - -i
+check_o '("/dev/null" "y")' $KLISP -e '(write(get-script-arguments))' /dev/null y
+check_o '()' $KLISP -e '(write(get-script-arguments))' --
+check_o '("/dev/null")' $KLISP -e '(write(get-script-arguments))' -- /dev/null
+
+# interpreter arguments
+# (get-interpreter-arguments) returns all command line
+# arguments.
+
+
+check_o "(\"$KLISP\" \"-e\" \"(write(get-interpreter-arguments))\")" \
+ $KLISP -e '(write(get-interpreter-arguments))'
+check_o "(\"$KLISP\" \"-e\" \"(write(get-interpreter-arguments))\" \"--\")" \
+ $KLISP -e '(write(get-interpreter-arguments))' --
+check_oi "(\"$KLISP\" \"-e\" \"(write(get-interpreter-arguments))\" \"-\")" '' \
+ $KLISP -e '(write(get-interpreter-arguments))' -
+check_o "(\"$KLISP\" \"-e\" \"(write(get-interpreter-arguments))\" \"/dev/null\")" \
+ $KLISP -e '(write(get-interpreter-arguments))' /dev/null
+check_o "(\"$KLISP\" \"-e(write(get-interpreter-arguments))\" \"--\" \"/dev/null\")" \
+ $KLISP '-e(write(get-interpreter-arguments))' -- /dev/null
+check_o "(\"$KLISP\" \"-e(write(get-interpreter-arguments))\" \"--\" \"/dev/null\" \"a\" \"b\" \"c\")" \
+ $KLISP '-e(write(get-interpreter-arguments))' -- /dev/null a b c
+
+# stdout and stderr
+
+check_oe 'abc' '' $KLISP -e '(display "abc" (get-current-output-port))'
+check_oe '' 'abc' $KLISP -e '(display "abc" (get-current-error-port))'
+
+# done
+
+report
+cleanup
diff --git a/src/tests/vectors.k b/src/tests/vectors.k
@@ -86,7 +86,97 @@
($check-predicate (mutable-vector? (list->vector (list "a" "b"))))
;; (R7RS 3rd draft, section 6.3.6) vector-copy
-;; TODO: implement equal? for vectors first
+($check equal? (vector-copy (vector 1 2 3)) (vector 1 2 3))
+($check equal? (vector-copy (vector (vector 1 2 3) (vector 4 5 6)))
+ (vector (vector 1 2 3) (vector 4 5 6)))
+($check-predicate (mutable-vector? (vector-copy (vector 1 2 3))))
+
+($check-predicate
+ (mutable-vector?
+ (vector-copy (vector->immutable-vector (vector 1 2 3)))))
+
+;; XXX bytevector->vector
+
+($check equal? (bytevector->vector (u8)) (vector))
+($check equal? (bytevector->vector (u8 0 1 2)) (vector 0 1 2))
+
+($check-not-predicate
+ ($let*
+ ((bb (u8 0 1 2))
+ (x (bytevector->vector bb))
+ (y (bytevector->vector bb)))
+ (eq? x y)))
+
+($check-predicate (mutable-vector? (bytevector->vector (u8 0 1 2))))
+
+;; XXX vector->bytevector
+
+($check equal? (vector->bytevector (vector)) (u8))
+($check equal? (vector->bytevector (vector 0 1 2)) (u8 0 1 2))
+
+($check-not-predicate
+ ($let*
+ ((cs (vector 0 1 2))
+ (x (vector->bytevector cs))
+ (y (vector->bytevector cs)))
+ (eq? x y)))
+
+($check-predicate (mutable-bytevector? (vector->bytevector (vector 0 1))))
+
+
+;; errors
+($check-error (vector->bytevector (vector -1)))
+($check-error (vector->bytevector (vector 256)))
+($check-error (vector->bytevector (vector (integer->char 41))))
+
+;; XXX vector-copy!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let ((v (make-vector 5 0)))
+ ($check equal? (vector-copy! (vector 1 2 3 4 5) v) #inert)
+ ($check equal? v (vector 1 2 3 4 5))
+ ($check-no-error (vector-copy! (vector->immutable-vector (vector 9 9)) v))
+ ($check equal? v (vector 9 9 3 4 5))
+ ($check-error (vector-copy! (vector 1 2 3 4 5 6) v))
+ ($check-error
+ (vector-copy!
+ (vector 1)
+ (vector->immutable-vector (vector 1)))))
+
+;; (R7RS 3rd draft, ) vector-copy-partial
+
+($check equal? (vector-copy-partial (vector 1 2 3) 0 0) (vector))
+($check equal? (vector-copy-partial (vector 1 2 3) 0 2) (vector 1 2))
+($check equal? (vector-copy-partial (vector 1 2 3) 2 3) (vector 3))
+($check equal? (vector-copy-partial (vector 1 2 3) 3 3) (vector))
+($check-error (vector-copy-partial (vector 1 2 3) 2 4))
+($check-error (vector-copy-partial (vector 1 2 3) -1 0))
+
+;; R7RS 3rd draft, vector-copy-partial!
+;; additional property: returns #inert
+;; additional property: destination must be mutable
+;;
+($let*
+ ((v (make-vector 5 9))
+ (w (vector->immutable-vector v)))
+ ($check equal? (vector-copy-partial! (vector 1 2) 0 2 v 0) #inert)
+ ($check equal? v (vector 1 2 9 9 9))
+ ($check equal? (vector-copy-partial! (vector 5 6) 1 2 v 4) #inert)
+ ($check equal? v (vector 1 2 9 9 6))
+ ($check-error (vector-copy-partial! (vector 1 2) 0 2 v -1))
+ ($check-error (vector-copy-partial! (vector 1 2) 0 2 v 4))
+ ($check-error (vector-copy-partial! (vector 1 2) 2 3 v 0))
+ ($check-error (vector-copy-partial! (vector 1 2) -1 0 v 0))
+ ($check-error (vector-copy-partial! (vector 1 2) 0 2 w 0)))
+
+
+;; XXX vector-fill!
+($check-predicate (inert? (vector-fill! (vector 1 2) 0)))
+($check equal? ($let ((v (vector 1 2 3)))
+ (vector-fill! v "str")
+ v)
+ (vector "str" "str" "str"))
;; XXX vector->immutable-vector
