commit 73a392ee8a61281cc9fdcf7d60047683d826966f
parent f9f3fdc53469d08641e5048f104d6dbb9beb60e2
Author: Andres Navarro <canavarro82@gmail.com>
Date: Wed, 9 Nov 2011 14:24:34 -0300
Merged last batch of changes from r7rs branch
Diffstat:
48 files changed, 3485 insertions(+), 212 deletions(-)
diff --git a/COPYRIGHT b/COPYRIGHT
@@ -9,7 +9,7 @@ under the MIT license.
===============================================================================
-klisp Parts: Copyright (C) 2011 Andres Navarro.
+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.
diff --git a/README b/README
@@ -1,4 +1,4 @@
-README for klisp 0.1
+README for klisp 0.2
* What is klisp?
--------------
@@ -22,7 +22,7 @@ README for klisp 0.1
klisp is freely available for both academic and commercial purposes.
See COPYRIGHT for details.
klisp can be downloaded at
- http://www.bitbucket.org/AndresNavarro/klisp
+ https://bitbucket.org/AndresNavarro/klisp
* Installation
@@ -41,5 +41,7 @@ README for klisp 0.1
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 made by Oto Havle in his fork
+ over at https://bitbucket.org/havleoto/klisp
(end of README)
diff --git a/manual/html/Introduction.html b/manual/html/Introduction.html
@@ -66,20 +66,22 @@ done); applicatives themselves are mere facilitators to computation.
<p>klisp is freely available for both academic and commercial purposes.
See LICENSE for details. it can be downloaded at
-<a href="http://www.bitbucket.org/AndresNavarro/klisp">http://www.bitbucket.org/AndresNavarro/klisp</a>
+<a href="https://bitbucket.org/AndresNavarro/klisp">https://bitbucket.org/AndresNavarro/klisp</a>
<p>klisp is developed by Andres Navarro, a Computer Science
undergraduate at Buenos Aires University (UBA). You can reach him at
-<a href="mailto:canavarro82@gmail.com">canavarro82@gmail.com</a>.
+<a href="mailto:canavarro82@gmail.com">canavarro82@gmail.com</a>. Significant contributions are being
+done by Oto Havle, his fork is at
+<a href="https://bitbucket.org/havleoto/klisp">https://bitbucket.org/havleoto/klisp</a>.
- <p>This manual describes klisp version 0.1, presuming some familiarity
+ <p>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.
- <p>This is edition 0.1.
+ <p>This is edition 0.2.
<ul class="menu">
<li><a accesskey="1" href="Caveats.html#Caveats">Caveats</a>: Flaws and a request for help.
diff --git a/manual/html/License.html b/manual/html/License.html
@@ -39,7 +39,7 @@ The two projects whose code klisp uses, Lua & IMath, are also distributed
under the MIT license.
<ul>
-<li>klisp Parts: Copyright © 2011 Andres Navarro.
+<li>klisp Parts: Copyright © 2011 Andres Navarro, Oto Havle.
<li>Lua Parts: Copyright © 1994-2010 Lua.org, PUC-Rio.
<li>IMath Parts: Copyright © 2002-2007 Michael J. Fromberger.
<li>srfi-78: Copyright © 2005-2006 Sebastian Egner.
diff --git a/manual/html/Ports.html b/manual/html/Ports.html
@@ -317,6 +317,55 @@ within those strings and character objects are output as if by
<p>SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
</p></blockquote></div>
+<div class="defun">
+— flush-output-port: <b>(</b><var>flush-output-port </var>[<var>port</var>])<var><a name="index-g_t_0028-282"></a></var><br>
+<blockquote><p> If the <code>port</code> optional argument is not specified, then the
+value of the <code>output-port</code> keyed dynamic variable is used. If
+the <code>port</code> is closed or if it is not an output port, an error is
+signaled.
+
+ <p>Applicative <code>flush-ouput-port</code> flushes any buffered data in the
+output port to the underlying file or device. The result returned by
+<code>flush-output-port</code> is inert.
+
+ <p>SOURCE NOTE: this is missing from Kernel, it is taken from r7rs Scheme.
+</p></blockquote></div>
+
+<div class="defun">
+— file-exists?: <b>(</b><var>file-exists? string</var>)<var><a name="index-g_t_0028-283"></a></var><br>
+<blockquote><p> <code>string</code> should be the name/path for a file.
+
+ <p>Predicate <code>file-exists?</code> checks to see if a file named
+<code>string</code> exists.
+
+ <p>SOURCE NOTE: this is missing from Kernel, it is taken from r7rs Scheme.
+</p></blockquote></div>
+
+<div class="defun">
+— delete-file: <b>(</b><var>delete-file string</var>)<var><a name="index-g_t_0028-284"></a></var><br>
+<blockquote><p> <code>string</code> should be the name/path for an existing file.
+
+ <p>Applicative <code>delete-file</code> deletes the file named <code>string</code>.
+If it doesn't exists or can't be deleted, an error is signaled. The
+result returned by <code>delete-file</code> is inert.
+
+ <p>SOURCE NOTE: this is missing from Kernel, it is taken from r7rs Scheme.
+</p></blockquote></div>
+
+<div class="defun">
+— rename-file: <b>(</b><var>rename-file string1 string2</var>)<var><a name="index-g_t_0028-285"></a></var><br>
+<blockquote><p> <code>string1</code> should be the name/path for an existing file,
+<code>string2</code> should be the name/path for a non existing file.
+
+ <p>Applicative <code>rename-file</code> renames the file named <code>string1</code>
+to <code>string2</code>. If the file doesn't exists or can't be renamed for
+any reason, an error is signaled. The result returned by
+<code>rename-file</code> is inert.
+
+ <p>SOURCE NOTE: this is missing from Kernel AND Scheme, it is taken
+from C, being quite similar to <code>delete-file</code>.
+</p></blockquote></div>
+
<!-- appendices -->
<!-- TODO -->
<!-- *-texinfo-*- -->
diff --git a/manual/klisp.info b/manual/klisp.info
@@ -3,8 +3,8 @@ klisp.texi.
This file documents klisp.
- This is edition 0.1 of the klisp Reference Manual, for klisp version
-0.1.
+ This is edition 0.2 of the klisp Reference Manual, for klisp version
+0.2.
Copyright (C) 2011 Andres Navarro
@@ -21,8 +21,8 @@ the header "Permission to copy this report", that reads:
File: klisp.info, Node: Top, Next: License, Prev: (dir), Up: (dir)
- This Info file contains edition 0.1 of the klisp Reference Manual,
-corresponding to klisp version 0.1.
+ This Info file contains edition 0.2 of the klisp Reference Manual,
+corresponding to klisp version 0.2.
Copyright (C) 2011 Andres Navarro
@@ -67,7 +67,7 @@ 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.
+ * klisp Parts: Copyright (C) 2011 Andres Navarro, Oto Havle.
* Lua Parts: Copyright (C) 1994-2010 Lua.org, PUC-Rio.
@@ -136,20 +136,21 @@ applicatives themselves are mere facilitators to computation.
klisp is freely available for both academic and commercial purposes.
See LICENSE for details. it can be downloaded at
-`http://www.bitbucket.org/AndresNavarro/klisp'
+`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>.
+<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.1, presuming some familiarity
+ 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.1.
+ This is edition 0.2.
* Menu:
@@ -2373,6 +2374,50 @@ klisp and was taken from Scheme.
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
+ -- flush-output-port: (flush-output-port [port])
+ 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
@@ -2662,32 +2707,32 @@ Index
Tag Table:
Node: Top703
Node: License2601
-Node: Introduction4272
-Node: Caveats7095
-Node: Kernel History7881
-Node: Conventions9326
-Node: Some Terms9997
-Node: Evaluation Notation10668
-Node: Printing Notation11689
-Node: Error Messages12165
-Node: Format of Descriptions12813
-Node: A Sample Applicative Description13377
-Node: Acknowledgements15140
-Node: Booleans15526
-Node: Equivalence18068
-Node: Symbols18861
-Node: Control20227
-Node: Pairs and lists22544
-Node: Environments39567
-Node: Combiners49774
-Node: Continuations55810
-Node: Encapsulations63984
-Node: Promises65437
-Node: Keyed Variables69360
-Node: Numbers72131
-Node: Strings91630
-Node: Characters96977
-Node: Ports99687
-Node: Alphabetical Index110985
+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 Index112780
End Tag Table
diff --git a/manual/src/intro.texi b/manual/src/intro.texi
@@ -12,7 +12,7 @@ under the MIT license.
@itemize @bullet
@item
-klisp Parts: Copyright @copyright{} 2011 Andres Navarro.
+klisp Parts: Copyright @copyright{} 2011 Andres Navarro, Oto Havle.
@item
Lua Parts: Copyright @copyright{} 1994-2010 Lua.org, PUC-Rio.
@item
@@ -78,20 +78,22 @@ done); applicatives themselves are mere facilitators to computation.
klisp is freely available for both academic and commercial purposes.
See LICENSE for details. it can be downloaded at
-@url{http://www.bitbucket.org/AndresNavarro/klisp}
+@url{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
-@email{canavarro82@@gmail.com}.
+@email{canavarro82@@gmail.com}. Significant contributions are being
+done by Oto Havle, his fork is at
+@url{https://bitbucket.org/havleoto/klisp}.
- This manual describes klisp version 0.1, presuming some familiarity
+ 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.1.
+ This is edition 0.2.
@menu
* Caveats:: Flaws and a request for help.
diff --git a/manual/src/klisp.texi b/manual/src/klisp.texi
@@ -19,8 +19,8 @@ This file documents klisp.
@c The edition number appears in several places in this file
@c and also in the file intro.texi.
-This is edition 0.1 of the klisp Reference Manual,
-for klisp version 0.1.
+This is edition 0.2 of the klisp Reference Manual,
+for klisp version 0.2.
Copyright (C) 2011 Andres Navarro
@@ -40,10 +40,10 @@ permission is granted to copy it in whole or in part without fee.
@titlepage
@title klisp Reference Manual
-@subtitle klisp version 0.1
+@subtitle klisp version 0.2
@c The edition number appears in several places in this file
@c and also in the file intro.texi.
-@subtitle Edition 0.1, May 2011
+@subtitle Edition 0.2, October 2011
@author by Andres Navarro
@page
@@ -51,8 +51,8 @@ permission is granted to copy it in whole or in part without fee.
Copyright @copyright{} 2011 Andres Navarro
@sp 2
-This is edition 0.1 of the @cite{klisp Reference Manual},
-for klisp Version 01.,@*
+This is edition 0.2 of the @cite{klisp Reference Manual},
+for klisp Version 0.2,@*
May 2011.@*
@sp 2
@@ -73,8 +73,8 @@ permission is granted to copy it in whole or in part without fee.
@node Top, License, (dir), (dir)
@ifinfo
-This Info file contains edition 0.1 of the klisp Reference Manual,
-corresponding to klisp version 0.1.
+This Info file contains edition 0.2 of the klisp Reference Manual,
+corresponding to klisp version 0.2.
Copyright @copyright{} 2011 Andres Navarro
diff --git a/manual/src/ports.texi b/manual/src/ports.texi
@@ -270,3 +270,48 @@ within those strings and character objects are output as if by
SOURCE NOTE: this is missing from Kernel, it is taken from Scheme.
@end deffn
+
+@deffn flush-output-port (flush-output-port [port])
+ If the @code{port} optional argument is not specified, then the
+value of the @code{output-port} keyed dynamic variable is used. If
+the @code{port} is closed or if it is not an output port, an error is
+signaled.
+
+ Applicative @code{flush-ouput-port} flushes any buffered data in the
+output port to the underlying file or device. The result returned by
+@code{flush-output-port} is inert.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from r7rs Scheme.
+@end deffn
+
+@deffn file-exists? (file-exists? string)
+ @code{string} should be the name/path for a file.
+
+ Predicate @code{file-exists?} checks to see if a file named
+@code{string} exists.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from r7rs Scheme.
+@end deffn
+
+@deffn delete-file (delete-file string)
+ @code{string} should be the name/path for an existing file.
+
+ Applicative @code{delete-file} deletes the file named @code{string}.
+If it doesn't exists or can't be deleted, an error is signaled. The
+result returned by @code{delete-file} is inert.
+
+ SOURCE NOTE: this is missing from Kernel, it is taken from r7rs Scheme.
+@end deffn
+
+@deffn rename-file (rename-file string1 string2)
+ @code{string1} should be the name/path for an existing file,
+@code{string2} should be the name/path for a non existing file.
+
+ Applicative @code{rename-file} renames the file named @code{string1}
+to @code{string2}. If the file doesn't exists or can't be renamed for
+any reason, an error is signaled. The result returned by
+@code{rename-file} is inert.
+
+ SOURCE NOTE: this is missing from Kernel AND Scheme, it is taken
+from C, being quite similar to @code{delete-file}.
+@end deffn
diff --git a/src/Makefile b/src/Makefile
@@ -15,6 +15,12 @@ RANLIB= ranlib
RM= rm -f
LIBS= -lm $(MYLIBS)
+# Set USE_LIBFFI=1 (or other nonempty string) to enable libffi-dependent
+# code.
+USE_LIBFFI=
+MINGW_LIBFFI_CFLAGS = -I/usr/local/lib/libffi-3.0.10/include
+MINGW_LIBFFI_LDFLAGS = -L/usr/local/lib/
+
MYCFLAGS=
MYLDFLAGS=
MYLIBS=
@@ -34,7 +40,9 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
kgpromises.o kgkd_vars.o kgks_vars.o kgports.o kgchars.o kgnumbers.o \
- kgstrings.o kgblobs.o kgsystem.o
+ kgstrings.o kgblobs.o kgsystem.o kgerror.o \
+ $(if $(USE_LIBFFI),kgffi.o)
+
# TEMP: in klisp there is no distinction between core & lib
LIB_O=
@@ -54,7 +62,7 @@ o: $(ALL_O)
a: $(ALL_A)
$(KRN_A): $(CORE_O) $(LIB_O)
- $(AR) $@ $?
+ $(AR) $@ $? $(MINGW_LDFLAGS)
$(RANLIB) $@
$(KRN_T): $(KRN_O) $(KRN_A)
@@ -88,11 +96,18 @@ generic:
mingw:
$(MAKE) "KRN_A=klisp01.dll" "KRN_T=klisp.exe" \
- "AR=$(CC) -shared -o" "RANLIB=strip --strip-unneeded" \
- "MYCFLAGS=-DKLISP_BUILD_AS_DLL" "MYLIBS=" "MYLDFLAGS=-s" klisp.exe
+ "AR=$(CC) -shared -o" \
+ "RANLIB=strip --strip-unneeded" \
+ "MYCFLAGS=-DKLISP_BUILD_AS_DLL $(if $(USE_LIBFFI),-DKUSE_LIBFFI=1 $(MINGW_LIBFFI_CFLAGS))" \
+ "MYLIBS=$(if $(USE_LIBFFI), $(MINGW_LIBFFI_LDFLAGS) -lffi.dll)" \
+ "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
+ $(MAKE) all \
+ "MYCFLAGS=-DKLISP_USE_POSIX $(if $(USE_LIBFFI),-DKUSE_LIBFFI=1 -Dread=klisp_read -Dwrite=klisp_write)" \
+ "MYLIBS=$(if $(USE_LIBFFI), -ldl -lffi)"
# list targets that do not create files (but not all makes understand .PHONY)
.PHONY: all default o clean
@@ -160,6 +175,10 @@ kgequalp.o: kgequalp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kstring.h kblob.h kcontinuation.h kerror.h \
kghelpers.h kapplicative.h koperative.h kenvironment.h ksymbol.h kgeqp.h \
kinteger.h imath.h krational.h imrat.h kgequalp.h
+kgerror.o: kgerror.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kstring.h kpair.h kgc.h kerror.h kghelpers.h \
+ kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
+ kgerror.h
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
@@ -199,7 +218,8 @@ kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgequalp.h kgsymbols.h kgcontrol.h kgpairs_lists.h kgpair_mut.h \
kgenvironments.h kgenv_mut.h kgcombiners.h kgcontinuations.h \
kgencapsulations.h kgpromises.h kgkd_vars.h kgks_vars.h kgnumbers.h \
- kgstrings.h kgchars.h kgports.h kgblobs.h ktable.h keval.h krepl.h kscript.h kgsystem.h
+ kgstrings.h kgchars.h kgports.h kgblobs.h ktable.h keval.h krepl.h \
+ kscript.h kgsystem.h kgerror.h kgffi.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
ksymbol.h kstring.h kghelpers.h kpair.h kgc.h kenvironment.h kgchars.h \
@@ -212,6 +232,10 @@ kgsystem.o: kgsystem.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kerror.h kghelpers.h kapplicative.h \
koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h \
kgsystem.h
+kgffi.o: kgsystem.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kpair.h kgc.h kerror.h kghelpers.h kapplicative.h \
+ koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h \
+ kblob.h kencapsulation.h kgencapsulations.h kgffi.h
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 \
diff --git a/src/examples/ffi-gsl.k b/src/examples/ffi-gsl.k
@@ -0,0 +1,66 @@
+;;
+;; Dynamic FFI callback example.
+;; Interfacing GNU Scientific Library.
+;;
+;; struct gsl_function_struct {
+;; double (* function) (double x, void * params);
+;; void * params;
+;; };
+;; typedef struct gsl_function_struct gsl_function ;
+;;
+;; int gsl_deriv_central (const gsl_function * f, double x, double h, double * result, double * abserr)
+;;
+;; (ffi-make-callback APPLICATIVE CALL-INTERFACE) creates a C callable
+;; function with interface CALL-INTERFACE and returns pointer
+;; to the entry point. The function will in turn call APPLICATIVE.
+;;
+
+($define! gsl (ffi-load-library "libgsl.so"))
+($define! abi "FFI_DEFAULT_ABI")
+
+($define! make-gsl-function
+ ($let
+ ( ((pointer-size alingment ref set!) (ffi-type-suite "pointer"))
+ (cif (ffi-make-call-interface abi "double" (list "double" "pointer"))) )
+ ($lambda (f)
+ ($let
+ ( (gslf (make-blob (* 2 pointer-size)) )
+ (aux ($lambda (x params) (f x))))
+ (set! (list gslf 0) (ffi-make-callback aux cif))
+ gslf))))
+
+($define! gsl-deriv-central
+ ($let
+ ( (gsl_deriv_central (ffi-make-applicative gsl "gsl_deriv_central"
+ (ffi-make-call-interface abi "sint" (list "pointer" "double" "double" "pointer" "pointer"))))
+ ((double-size alingment ref set!) (ffi-type-suite "double")))
+ ($lambda (f)
+ ($let
+ ((gslf (make-gsl-function f)))
+ ($lambda (x h)
+ ($let
+ ( (result (make-blob double-size))
+ (abserr (make-blob double-size)))
+ (gsl_deriv_central gslf x h result abserr)
+ (list (ref result) (ref abserr))))))))
+
+(display "Testing gsl_deriv_central...")
+(newline)
+
+($define! f
+ ($lambda (x)
+ (display (list "callback called with x = " x))
+ (newline)
+ (+ (* 2.0 x x) 3.0)))
+($define! df (gsl-deriv-central f))
+
+(for-each
+ ($lambda (x)
+ ($let*
+ ( (fx (f x))
+ ((dfx abserr) (df x 0.001)))
+ (for-each
+ display
+ (list "x = " x ", f(x) = " fx ", f'(x) = " dfx ", |error| <= " abserr))
+ (newline)))
+ (list -1.0 0.0 1.0 2.0))
diff --git a/src/examples/ffi-gtk.k b/src/examples/ffi-gtk.k
@@ -0,0 +1,21 @@
+;;
+;; Dynamic FFI example.
+;;
+;; Inspired by example gtk.lua from Lua Alien FFI library
+;; (the original is only 11 lines long, though...)
+;;
+
+($define! gtk (ffi-load-library "libgtk-x11-2.0.so.0"))
+($define! i "sint")
+($define! p "pointer")
+($define! make
+ ($lambda (rtype name . atypes)
+ (ffi-make-applicative gtk name
+ (ffi-make-call-interface "FFI_DEFAULT_ABI" rtype atypes))))
+
+($define! gtk-init (make "void" "gtk_init" p p))
+($define! gtk-message-dialog-new (make p "gtk_message_dialog_new" p i i i "string"))
+($define! gtk-dialog-run (make i "gtk_dialog_run" p))
+
+(gtk-init () ())
+(gtk-dialog-run (gtk-message-dialog-new () 0 0 1 "Klisp Rocks!"))
diff --git a/src/examples/ffi-sdl.k b/src/examples/ffi-sdl.k
@@ -0,0 +1,205 @@
+;;
+;; Dynamic FFI example.
+;; Interfacing Simple DirectMedia Layer Library.
+;;
+;; Tested with SDL 1.2 on Debian Squeeze, x86.
+;; It is quite likely that this program will not work
+;; with other versions and other operating systems.
+;;
+;; Dynamic FFI is inherently unsafe. The user is responsible
+;; for specifying correct argument types, data structure
+;; layout, alignment, etc. even though it is platform dependent.
+;;
+;; usage:
+;; .../src$ make posix USE_LIBFFI=1
+;; .../src$ ./klisp examples/ffi-sdl.k
+;;
+;; The program shall create a window and responding
+;; to mouse click.
+;;
+
+($define! sdl-import
+ ($let
+ ( (libsdl (ffi-load-library "libSDL.so"))
+ (abi "FFI_DEFAULT_ABI"))
+ ($lambda (rtype name . args)
+ (ffi-make-applicative libsdl name
+ (ffi-make-call-interface abi rtype args)))))
+
+($define! SDL_INIT_TIMER #x00000001)
+($define! SDL_INIT_AUDIO #x00000010)
+($define! SDL_INIT_VIDEO #x00000020)
+($define! SDL_INIT_NOPARACHUTE #x01000000)
+
+($define! sdl-init (sdl-import "sint" "SDL_Init" "uint32"))
+($define! sdl-quit (sdl-import "void" "SDL_Quit"))
+
+($define! SDL_SWSURFACE #x00000000)
+($define! SDL_HWSURFACE #x00000001)
+
+($define! sdl-set-video-mode (sdl-import "pointer" "SDL_SetVideoMode" "sint" "sint" "sint" "uint32"))
+($define! sdl-wm-set-caption (sdl-import "void" "SDL_WM_SetCaption" "string" "pointer"))
+
+($define! sdl-wait-event
+ ($let
+ ((SDL_WaitEvent (sdl-import "sint" "SDL_WaitEvent" "pointer")))
+ ($lambda ()
+ ($let*
+ ( (buffer (make-blob 512))
+ (ok (SDL_WaitEvent buffer)))
+ ($if (zero? ok)
+ (apply-continuation error-continuation "SDL_WaitEvent signalled error")
+ buffer)))))
+
+($define! align
+ ($lambda (offset alignment)
+ (+ offset (mod (- alignment (mod offset alignment)) alignment))))
+
+($define! $quote
+ ($vau (x) denv x))
+
+($define! $define-struct-projectors!
+ ($letrec*
+ ( (aux
+ ($lambda (fields offset denv)
+ ($if (null? fields)
+ ()
+ ($let*
+ ( (((projector-name type-string) . tail) fields)
+ ((size alignment ref set!) (ffi-type-suite type-string))
+ (aligned-offset (align offset alignment))
+ (projector-function ($lambda (blob) (ref (list blob aligned-offset)))))
+ (write (list projector-name size alignment aligned-offset))
+ (newline)
+ (eval
+ (list
+ ($quote $define!)
+ projector-name
+ (list ($quote $quote) projector-function))
+ denv)
+ (aux tail (+ size aligned-offset) denv))))))
+ ($vau fields denv
+ (aux fields 0 denv))))
+
+($define! SDL_QUIT 12)
+($define! SDL_MOUSEMOTION 4)
+($define! SDL_MOUSEBUTTONDOWN 5)
+($define! SDL_MOUSEBUTTONUP 6)
+
+($define-struct-projectors!
+ (event-type "uint8"))
+
+($define-struct-projectors!
+ (MouseMotionEvent.type "uint8")
+ (MouseMotionEvent.state "uint8")
+ (MouseMotionEvent.which "uint8")
+ (MouseMotionEvent.x "uint16")
+ (MouseMotionEvent.y "uint16")
+ (MouseMotionEvent.xrel "sint16")
+ (MouseMotionEvent.yrel "sint16"))
+
+($define-struct-projectors!
+ (MouseButtonEvent.type "uint8")
+ (MouseButtonEvent.which "uint8")
+ (MouseButtonEvent.button "uint8")
+ (MouseButtonEvent.state "uint8")
+ (MouseButtonEvent.x "uint16")
+ (MouseButtonEvent.y "uint16"))
+
+($define! with-sdl
+ ($lambda (window-title worker)
+ (display "Initializing SDL...")
+ ($let ((status (sdl-init SDL_INIT_VIDEO)))
+ (write status)
+ (newline)
+ ($if (<? status 0)
+ (apply error-continuation "error initializing SDL")
+ ($sequence
+ (guard-dynamic-extent
+ ()
+ ($lambda ()
+ ($let* ((screen (sdl-set-video-mode 640 480 32 SDL_HWSURFACE)))
+ ($if (null? screen)
+ (apply-continuation error-contination "unable to set video mode")
+ ($sequence
+ (sdl-wm-set-caption window-title ())
+ (worker screen)))))
+ (list
+ (list
+ error-continuation
+ ($lambda (v divert)
+ (display "Error. Deinitializing SDL...")
+ (sdl-quit)
+ (display "done.")
+ (newline)
+ v))))
+ (display "Finished. Deinitializing SDL...")
+ (sdl-quit)
+ (display "done.")
+ (newline))))))
+
+($define-struct-projectors!
+ (SDL_Surface.flags "uint32")
+ (SDL_Surface.format "pointer")
+ (SDL_Surface.w "sint")
+ (SDL_Surface.h "sint")
+ (SDL_Surface.pitch "uint16")
+ (SDL_Surface.pixels "pointer")
+ (SDL_Surface.offset "sint"))
+
+($define! draw-pixel
+ ($let
+ ( ((pixel-size pixel-alignment pixel-ref pixel-set!) (ffi-type-suite "uint32"))
+ (SDL_MapRGB (sdl-import "uint32" "SDL_MapRGB" "pointer" "uint8" "uint8" "uint8"))
+ (SDL_LockSurface (sdl-import "sint" "SDL_LockSurface" "pointer"))
+ (SDL_UnlockSurface (sdl-import "void" "SDL_UnlockSurface" "pointer"))
+ (SDL_Flip (sdl-import "sint" "SDL_Flip" "pointer")))
+ ($lambda (screen (x y) (r g b))
+ ($if (<? (SDL_LockSurface screen) 0)
+ (apply error-continuation "SDL_LockSurface failed")
+ ())
+ ($let
+ ( (pixels (SDL_Surface.pixels screen))
+ (pitch (SDL_Surface.pitch screen))
+ (color (SDL_MapRGB (SDL_Surface.format screen) r g b)))
+ ;(display (list color x y pixel-size pitch (SDL_Surface.flags screen)))
+ (pixel-set!
+ (list pixels (+ (* x pixel-size) (* y pitch)))
+ color))
+ (SDL_UnlockSurface screen)
+ (SDL_Flip screen))))
+
+($define! event-loop
+ ($lambda (screen drawing)
+ ($let*
+ ( (ev (sdl-wait-event))
+ (t (event-type ev)))
+ ($cond
+ ( (equal? t SDL_QUIT)
+ ())
+ ( (and? drawing (equal? t SDL_MOUSEMOTION))
+ (draw-pixel
+ screen
+ (list (MouseMotionEvent.x ev) (MouseMotionEvent.y ev))
+ (list 0 255 0))
+ (event-loop screen #t))
+ ( (equal? t SDL_MOUSEBUTTONDOWN)
+ (draw-pixel
+ screen
+ (list (MouseButtonEvent.x ev) (MouseButtonEvent.y ev))
+ (list 255 0 0))
+ (event-loop screen #t))
+ ( (equal? t SDL_MOUSEBUTTONUP)
+ (draw-pixel
+ screen
+ (list (MouseButtonEvent.x ev) (MouseButtonEvent.y ev))
+ (list 0 0 255))
+ (event-loop screen #f))
+ (#t
+ (event-loop screen drawing))))))
+
+($define! main
+ ($lambda (argv)
+ (with-sdl "klisp ffi demo"
+ ($lambda (screen) (event-loop screen #f)))))
+
diff --git a/src/examples/ffi-win32.k b/src/examples/ffi-win32.k
@@ -0,0 +1,81 @@
+;;
+;; Windows API FFI example
+;; See ffi.k for general info.
+;;
+;; usage:
+;; 1) compile and install libffi 3.0.10
+;; 2) set PATH correctly so libffi-5.dll can be found
+;; 3) compile klisp: make mingw USE_LIBFFI=1
+;; 4) run test script: ....\src> klisp examples/ffi-win32.k
+;;
+
+($define! kernel32 (ffi-load-library "kernel32"))
+($define! abi "FFI_STDCALL")
+
+($define! DWORD "uint32")
+($define! BOOL "sint")
+
+($define! dword-void (ffi-make-call-interface abi DWORD ()))
+($define! u64-void (ffi-make-call-interface abi "uint64" ()))
+
+($define! GetLastError (ffi-make-applicative kernel32 "GetLastError" dword-void))
+($define! GetTickCount (ffi-make-applicative kernel32 "GetTickCount" dword-void))
+($define! GetTickCount64 (ffi-make-applicative kernel32 "GetTickCount64" u64-void))
+
+(display "Testing GetTickCount(), GetTickCount64() ... ")
+(write (list (GetTickCount) (GetTickCount64)))
+(newline)
+
+($define! (DWORD-size DWORD-alignment DWORD-ref DWORD-set!)
+ (ffi-type-suite DWORD))
+
+($define! (charptr-size charptr-alignment charptr-ref charptr-set!)
+ (ffi-type-suite "string"))
+
+($define! blob->list
+ ($lambda (blob index len)
+ ($if (>? len 0)
+ (cons
+ (blob-u8-ref blob index)
+ (blob->list blob (+ 1 index) (- len 1)))
+ ())))
+
+($define! blob->string
+ ($lambda (blob offset len)
+ (list->string (map integer->char (blob->list blob offset len)))))
+
+($define! advapi32 (ffi-load-library "advapi32"))
+
+($define! GetUserName
+ ($let
+ ( (win32-GetUserName (ffi-make-applicative advapi32 "GetUserNameA"
+ (ffi-make-call-interface abi BOOL (list "pointer" "pointer"))))
+ ((DWORD-size DWORD-alignment DWORD-ref DWORD-set!)
+ (ffi-type-suite DWORD)))
+ ($lambda ()
+ ($let ((buffer (make-blob 256)) (lenbuf (make-blob 4)))
+ (DWORD-set! lenbuf (blob-length buffer))
+ (win32-GetUserName buffer lenbuf)
+ (blob->string buffer 0 (- (DWORD-ref lenbuf) 1))))))
+
+(display "Testing GetUserName()...")
+(write (GetUserName))
+(newline)
+
+($define! user32 (ffi-load-library "user32"))
+
+($define! HWND "pointer")
+($define! UINT "uint32")
+($define! MB_OK 0)
+
+($define! MessageBox
+ ($let
+ ( (win32-MessageBox (ffi-make-applicative user32 "MessageBoxA"
+ (ffi-make-call-interface abi "sint" (list HWND "string" "string" UINT)))))
+ ($lambda (text caption)
+ (win32-MessageBox () text caption MB_OK))))
+
+(display "Testing MessageBox()...")
+(MessageBox "FFI test" "klisp")
+(display "done.")
+(newline)
diff --git a/src/examples/ffi.k b/src/examples/ffi.k
@@ -0,0 +1,336 @@
+;;
+;; Basic FFI examples.
+;;
+;; usage:
+;; .../src$ make posix USE_LIBFFI=1
+;; .../src$ ./klisp examples/ffi-sdl.k
+;;
+
+
+;; (ffi-load-library DLLNAME) ... loads the C library DLLNAME
+;; and returns opaque handle.
+;;
+;; (ffi-load-library) ... returns a handle, which can be used
+;; to access the functions linked statically to the interpreter
+;;
+;; Unloading not supported. ffi-load-library is actually
+;; a wrapper around dlopen()
+;;
+($define! libc (ffi-load-library "libc.so.6"))
+($define! self (ffi-load-library))
+
+;; (ffi-make-call-interface ABI RETURN-TYPE ARGUMENT-TYPES) returns
+;; libffi call interface object. It is actually a wrapper around
+;; ffi_prep_cif().
+;;
+;; The parameter ABI determines the C call convention. Only
+;; "FFI_DEFAULT_ABI" is supported.
+;;
+;; RETURN-TYPE determines the return type and ARGUMENT-TYPES
+;; is a list which determines the arguments. The types
+;; are specified as strings:
+;;
+;; type C type klisp type note
+;; ----------------------------------------------------
+;; "void" void inert (only return)
+;; "sint" signed int fixint
+;; "string" (char *) string
+;; "uint8" uint8_t fixint
+;; "uint16" uint16_t fixint
+;; "uint32" uint32_t fixint, bigint
+;; "uint64" uint64_t fixint, bigint
+;; "float" float double
+;; "double" double double
+;; "pointer" (void *) blob (only for arguments)
+;; string (only for arguments)
+;; nil
+;; pointer (TAG_USER)
+;;
+;; Other data types not supported yet. Varargs function
+;; not supported by libffi.
+;;
+
+($define! abi "FFI_DEFAULT_ABI")
+($define! cif-int-void (ffi-make-call-interface abi "sint" ()))
+($define! cif-string-string (ffi-make-call-interface abi "string" (list "string")))
+($define! cif-int-string (ffi-make-call-interface abi "sint" (list "string")))
+($define! cif-double-double (ffi-make-call-interface abi "double" (list "double")))
+
+;; (ffi-make-applicative LIB-HANDLE FUNCTION-NAME CALL-INTERFACE)
+;;
+;; Looks up the function FUNCTION-NAME in the library referenced
+;; by LIB-HANDLE. Creates an applicative which calls the function
+;; using the interface CALL-INTERFACE. Conversion from/to klisp
+;; types is handled automatically.
+;;
+;; It is a wrapper around dlsym(). The types should match the
+;; actual C function prototype, the interpreter might crash
+;; otherwise.
+;;
+
+($define! getpid (ffi-make-applicative self "getpid" cif-int-void))
+($define! getppid (ffi-make-applicative self "getppid" cif-int-void))
+($define! system (ffi-make-applicative self "system" cif-int-string))
+($define! getenv (ffi-make-applicative self "getenv" cif-string-string))
+($define! lgamma (ffi-make-applicative self "lgamma" cif-double-double))
+
+(display "Testing getpid(), getppid() ...")
+(write (list (getpid) (getppid)))
+(newline)
+
+(display "Testing getenv(\"HOME\")...")
+(write (getenv "HOME"))
+(newline)
+
+(display "Testing system(\"ls /\")...")
+(newline)
+(write (system "ls /"))
+(newline)
+
+(display "Testing lgamma(9.87)...")
+(write (lgamma 9.87))
+(newline)
+
+($define! unix-write-string
+ ($let*
+ ( (unix-write (ffi-make-applicative libc "write"
+ (ffi-make-call-interface abi
+ "sint" (list "sint" "pointer" "sint")))))
+ ($lambda (s) (unix-write 0 s (string-length s)))))
+
+(display "Testing unix write()...")
+(unix-write-string "ABCDEFGH")
+(newline)
+
+($define! strtoull
+ (ffi-make-applicative libc "strtoull"
+ (ffi-make-call-interface abi
+ "uint64" (list "string" "pointer" "sint"))))
+
+(display "Testing strtoull(\"0x123456789ABCDEF\", NULL, 0)...")
+(write (strtoull "0x123456789ABCDEF" () 0))
+(display "...")
+(write #x123456789ABCDEF)
+(display "= #x123456789ABCDEF")
+(newline)
+
+;; (ffi-type-suite TYPE) returns a four-element list
+;; (SIZE ALIGNMENT REF SET!). SIZE is the size of
+;; the data type in bytes. ALIGNMENT is preferred
+;; alignment. REF and SET! are applicatives.
+;;
+;; (REF MEMORY-LOCATION)
+;; (SET! MEMORY-LOCATION VALUE)
+;;
+;; MEMORY-LOCATION is either blob, string, pointer,
+;; or a two-element list (MEMORY-LOCATION OFFSET).
+;; The offset specification can not be nested, i.e.
+;; ((blob 1) 2) is not valid memory location.
+;;
+($define!
+ (sint-size sint-alignment sint-ref sint-set!)
+ (ffi-type-suite "sint"))
+
+(display "\"sint\" data type size and alignment: ")
+(write (list sint-size sint-alignment))
+(newline)
+
+;; Using ffi-type-suite, one can define means to convert
+;; C structs (stored in blobs or arbitrary memory locations)
+;; to lists.
+;;
+($define! align
+ ($lambda (offset alignment)
+ (+ offset (mod (- alignment offset) alignment))))
+
+($define! regularize-location
+ ($lambda (location)
+ ($if (pair? location)
+ location
+ (list location 0))))
+
+($define! decode-struct
+ ($lambda type-strings
+ ($letrec*
+ ( (suites (map ffi-type-suite type-strings))
+ (decode ($lambda (base offset tail)
+ ($if (null? tail)
+ ()
+ ($let (((size alignment ref set!) (car tail)))
+ (cons
+ (ref (list base (align offset alignment)))
+ (decode
+ base
+ (+ size (align offset alignment))
+ (cdr tail))))))))
+ ($lambda (location)
+ ($let (((base offset) (regularize-location location)))
+ (decode base offset suites))))))
+
+;; For example,
+;;
+;; struct timeval {
+;; time_t tv_sec; /* seconds */
+;; suseconds_t tv_usec; /* microseconds */
+;; };
+;;
+($define! struct-timeval-ref
+ (decode-struct "sint" "sint"))
+
+($define! gettimeofday
+ ($let
+ ( (unix-gettimeofday
+ (ffi-make-applicative libc "gettimeofday"
+ (ffi-make-call-interface abi
+ "sint" (list "pointer" "pointer")))))
+ ($lambda ()
+ ($let* ((buffer (make-blob (* 2 sint-size))))
+ (unix-gettimeofday buffer ())
+ ($let (((tv_sec tv_usec) (struct-timeval-ref buffer)))
+ (list tv_sec (/ tv_usec 1000000)))))))
+
+(display "Testing gettimeofday(), assuming 32-bit arch...")
+(write (gettimeofday))
+(newline)
+
+($define! localtime
+ ($let
+ ( (localtime-r
+ (ffi-make-applicative libc "localtime_r"
+ (ffi-make-call-interface abi
+ "pointer" (list "pointer" "pointer"))))
+ (decoder
+ (decode-struct "sint" "sint" "sint" "sint" "sint" "sint" "sint" "sint")))
+ ($lambda (t)
+ ($let*
+ ( (t-buf (make-blob sint-size))
+ (tm-buf (make-blob 128)) )
+ (sint-set! t-buf t)
+ (localtime-r t-buf tm-buf)
+ ($let
+ (((tm_sec tm_min tm_hour tm_mday tm_mon tm_year . rest)
+ (decoder tm-buf)))
+ (list
+ (list (+ 1900 tm_year) (+ 1 tm_mon) tm_mday)
+ (list tm_hour tm_min tm_sec)))))))
+
+(display "Testing localtime()...")
+(write
+ ($let (((tm_sec tm_usec) (gettimeofday)))
+ (localtime tm_sec)))
+(newline)
+
+;; Some C structs are more complex:
+;;
+;; struct hostent {
+;; char *h_name; /* official name of host */
+;; char **h_aliases; /* alias list */
+;; int h_addrtype; /* host address type */
+;; int h_length; /* length of address */
+;; char **h_addr_list; /* list of addresses */
+;; }
+;;
+;; Network address is just byte array. IPv4 address
+;; contains 4 bytes, IPv6 address contains 16 bytes.
+;;
+;; (ffi-memmove DESTINATION SOURCE SIZE) copies
+;; SIZE bytes from SOURCE to DESTINATION. Both SOURCE
+;; and DESTINATION are memory locations as described above.
+;; ffi-memmove can copy data between blobs and arbitrary
+;; memory locations.
+;;
+($define! copy-location
+ ($lambda (location size)
+ ($let ((blob (make-blob size)))
+ (ffi-memmove blob location size)
+ blob)))
+
+($define! blob->list
+ ($letrec
+ ((aux ($lambda (blob index)
+ ($if (<? index (blob-length blob))
+ (cons
+ (blob-u8-ref blob index)
+ (aux blob (+ 1 index)))
+ ()))))
+ ($lambda (blob)
+ (aux blob 0))))
+
+($define! parse-address
+ ($lambda (location size)
+ (blob->list (copy-location location size))))
+
+($define!
+ (voidptr-size voidptr-alignment voidptr-ref voidptr-set!)
+ (ffi-type-suite "pointer"))
+
+($define! null-terminated-array->list
+ ($letrec
+ ( (aux
+ ($lambda (base offset)
+ ($if (null? (voidptr-ref (list base offset)))
+ ()
+ (cons
+ (list base offset)
+ (aux base (+ offset voidptr-size)))))))
+ ($lambda (location)
+ (apply aux (regularize-location location)))))
+
+($define!
+ (charptr-size charptr-alignment charptr-ref charptr-set!)
+ (ffi-type-suite "string"))
+
+($define! parse-hostent
+ ($letrec*
+ ( (decode-1
+ (decode-struct "string" "pointer" "sint" "sint" "pointer")))
+ ($lambda (pointer)
+ ($let
+ ( ((h_name h_aliases h_addrtype h_length h_addr_list) (decode-1 pointer)))
+ (list
+ h_name
+ (map
+ charptr-ref
+ (null-terminated-array->list h_aliases))
+ (map
+ ($lambda (a) (parse-address (voidptr-ref a) h_length))
+ (null-terminated-array->list h_addr_list)))))))
+
+($define! gethostbyname
+ ($let
+ ((unix-gethostbyname
+ (ffi-make-applicative libc "gethostbyname"
+ (ffi-make-call-interface abi "pointer" (list "string")))))
+ ($lambda (hostname)
+ (parse-hostent (unix-gethostbyname hostname)))))
+
+(display "Testing gehostbyname(\"localhost\")...")
+(write (gethostbyname "localhost"))
+(newline)
+
+(display "Testing gehostbyname(\"www.google.com\")...")
+(write (gethostbyname "www.google.com"))
+(newline)
+
+;;
+;; Detecting machine endianess.
+;;
+
+($define!
+ (uint32-size uint32-alignment uint32-ref uint32-set!)
+ (ffi-type-suite "uint32"))
+
+($define! endianess
+ ($let
+ ((buffer (make-blob 4)))
+ (uint32-set! buffer #x01020304)
+ ($let
+ ((bytes (blob->list buffer)))
+ ($cond
+ ((equal? bytes (list 1 2 3 4)) "big-endian")
+ ((equal? bytes (list 4 3 2 1)) "little-endian")
+ (#t "unknown")))))
+
+(display "Guessing endianess...")
+(write endianess)
+(newline)
diff --git a/src/kerror.c b/src/kerror.c
@@ -2,12 +2,15 @@
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
+#include <errno.h>
+#include <string.h>
#include "klisp.h"
#include "kpair.h"
#include "kstate.h"
#include "kmem.h"
#include "kstring.h"
+#include "kerror.h"
/* TODO: check that all objects passed to throw are rooted */
@@ -98,3 +101,111 @@ void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants)
/* call_cont protects error from gc */
kcall_cont(K, K->error_cont, error_obj);
}
+
+void klispE_throw_system_error_with_irritants(klisp_State *K, const char *service, int errnum, TValue irritants)
+{
+ TValue error_description = klispE_describe_errno(K, service, errnum);
+ krooted_tvs_push(K, error_description);
+ TValue all_irritants = kimm_cons(K, error_description, irritants);
+ krooted_tvs_push(K, all_irritants);
+ TValue error_obj = klispE_new(K, K->next_obj, K->curr_cont,
+ kcaddr(error_description),
+ all_irritants);
+ krooted_tvs_push(K, error_obj);
+ clear_buffers(K);
+ kcall_cont(K, K->system_error_cont, error_obj);
+}
+
+/* The array symbolic_error_codes[] assigns locale and target
+ * platform configuration independent strings to errno values.
+ *
+ * Generated from Linux header files:
+ *
+ * awk '{printf(" c(%s),\n", $2)}' /usr/include/asm-generic/errno-base.h
+ * awk '{printf(" c(%s),\n", $2)}' /usr/include/asm-generic/errno.h
+ *
+ * and removed errnos not present in mingw.
+ *
+ */
+#define c(N) [N] = # N
+static const char * const symbolic_error_codes[] = {
+ c(EPERM),
+ c(ENOENT),
+ c(ESRCH),
+ c(EINTR),
+ c(EIO),
+ c(ENXIO),
+ c(E2BIG),
+ c(ENOEXEC),
+ c(EBADF),
+ c(ECHILD),
+ c(EAGAIN),
+ c(ENOMEM),
+ c(EACCES),
+ c(EFAULT),
+ c(EBUSY),
+ c(EEXIST),
+ c(EXDEV),
+ c(ENODEV),
+ c(ENOTDIR),
+ c(EISDIR),
+ c(EINVAL),
+ c(ENFILE),
+ c(EMFILE),
+ c(ENOTTY),
+ c(EFBIG),
+ c(ENOSPC),
+ c(ESPIPE),
+ c(EROFS),
+ c(EMLINK),
+ c(EPIPE),
+ c(EDOM),
+ c(ERANGE),
+ /**/
+ c(EDEADLK),
+ c(ENAMETOOLONG),
+ c(ENOLCK),
+ c(ENOSYS),
+ c(ENOTEMPTY),
+};
+#undef c
+
+/* klispE_describe_errno(K, ERRNUM, SERVICE) returns a list
+ *
+ * (SERVICE CODE MESSAGE ERRNUM)
+ *
+ * SERVICE (string) identifies the failed system call or service,
+ * e.g. "rename" or "fopen".
+ *
+ * CODE (string) is a platform-independent symbolic representation
+ * of the error. It corresponds to symbolic constants of <errno.h>,
+ * e.g. "ENOENT" or "ENOMEM".
+ *
+ * MESSAGE (string) platform-dependent human-readable description.
+ * The MESSAGE may depend on locale or operating system configuration.
+ *
+ * ERRNUM (fixint) is the value of errno for debugging puroposes.
+ *
+ */
+TValue klispE_describe_errno(klisp_State *K, const char *service, int errnum)
+{
+ const char *code = NULL;
+ int tabsize = sizeof(symbolic_error_codes) / sizeof(symbolic_error_codes[0]);
+ if (0 <= errnum && errnum < tabsize)
+ code = symbolic_error_codes[errnum];
+ if (code == NULL)
+ code = "UNKNOWN";
+
+ TValue service_tv = kstring_new_b_imm(K, service);
+ krooted_tvs_push(K, service_tv);
+ TValue code_tv = kstring_new_b_imm(K, code);
+ krooted_tvs_push(K, code_tv);
+ TValue message_tv = kstring_new_b_imm(K, strerror(errnum));
+ krooted_tvs_push(K, message_tv);
+
+ TValue v = kimm_list(K, 4, service_tv, code_tv, message_tv, i2tv(errnum));
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ return v;
+}
diff --git a/src/kerror.h b/src/kerror.h
@@ -9,6 +9,7 @@
#define kerror_h
#include <stdbool.h>
+#include <errno.h>
#include "klisp.h"
#include "kstate.h"
@@ -21,6 +22,8 @@ void klispE_free(klisp_State *K, Error *error);
void klispE_throw_simple(klisp_State *K, char *msg);
void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants);
+void klispE_throw_system_error_with_irritants(klisp_State *K, const char *service, int errnum, TValue irritants);
+
/* evaluates K__ more than once */
#define klispE_throw_simple_with_irritants(K__, msg__, ...) \
{ TValue ls__ = klist(K__, __VA_ARGS__); \
@@ -28,6 +31,17 @@ void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants);
/* the pop is implicit in throw_with_irritants */ \
klispE_throw_with_irritants(K__, msg__, ls__); }
+#define klispE_throw_errno_with_irritants(K__, service__, ...) \
+ { \
+ int errnum__ = errno; \
+ 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);
+TValue klispE_describe_errno(klisp_State *K, const char *service, int errnum);
#endif
diff --git a/src/kgc.c b/src/kgc.c
@@ -580,6 +580,7 @@ static void markroot (klisp_State *K) {
markvalue(K, K->module_params_sym);
markvalue(K, K->root_cont);
markvalue(K, K->error_cont);
+ markvalue(K, K->system_error_cont);
markvalue(K, K->kd_in_port_key);
markvalue(K, K->kd_out_port_key);
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -253,6 +253,7 @@ void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree,
/* 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);
+ krooted_tvs_push(K, ls);
/* this is needed because seq continuation doesn't check for
nil sequence */
@@ -264,6 +265,7 @@ void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree,
}
krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
ktail_eval(K, kcar(ls), new_env);
}
diff --git a/src/kgencapsulations.h b/src/kgencapsulations.h
@@ -18,6 +18,9 @@
#include "kstate.h"
#include "kghelpers.h"
+/* needed by kgffi.c */
+void enc_typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
/* 8.1.1 make-encapsulation-type */
void make_encapsulation_type(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv);
diff --git a/src/kgerror.c b/src/kgerror.c
@@ -0,0 +1,83 @@
+/*
+** kgerror.c
+** Error handling features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.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, TValue ptree,
+ TValue denv)
+{
+ 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, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "error object", ttiserror, error_tv);
+ Error *err_obj = tv2error(error_tv);
+ assert(ttisstring(err_obj->msg));
+ kapply_cc(K, err_obj->msg);
+}
+
+void error_object_irritants(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "error object", ttiserror, error_tv);
+ Error *err_obj = tv2error(error_tv);
+ kapply_cc(K, err_obj->irritants);
+}
+
+void do_exception_cont(klisp_State *K, TValue *xparams, TValue obj)
+{
+ UNUSED(xparams);
+ /* Just pass error object to general error continuation. */
+ kapply_cc(K, obj);
+}
+
+/* Create system-error-continuation. */
+void kinit_error_hierarchy(klisp_State *K)
+{
+ assert(ttiscontinuation(K->error_cont));
+ assert(ttisinert(K->system_error_cont));
+
+ K->system_error_cont = kmake_continuation(K, K->error_cont, do_exception_cont, 0);
+ TValue symbol = ksymbol_new(K, "system-error-continuation", KNIL);
+ krooted_tvs_push(K, symbol);
+ kadd_binding(K, K->ground_env, symbol, K->system_error_cont);
+ krooted_tvs_pop(K);
+}
+
+/* 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);
+}
diff --git a/src/kgerror.h b/src/kgerror.h
@@ -0,0 +1,29 @@
+/*
+** 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/kgffi.c b/src/kgffi.c
@@ -0,0 +1,1111 @@
+/*
+** kgffi.c
+** Foreign function interface
+** See Copyright Notice in klisp.h
+*/
+
+/*
+ * Detect dynamic linking facilities.
+ *
+ */
+#if !defined(KLISP_USE_POSIX) && defined(_WIN32)
+# define KGFFI_WIN32 true
+#else
+# define KGFFI_DLFCN true
+#endif
+
+#include <assert.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+#include <string.h>
+
+#if KGFFI_DLFCN
+# include <dlfcn.h>
+#elif KGFFI_WIN32
+# include <windows.h>
+#else
+# error
+#endif
+
+#include <ffi.h>
+
+#include "imath.h"
+#include "kstate.h"
+#include "kobject.h"
+#include "kinteger.h"
+#include "kpair.h"
+#include "kerror.h"
+#include "kblob.h"
+#include "kencapsulation.h"
+#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
+ * memory read/writes. */
+
+#define KGFFI_CHECK_ALIGNMENT 1
+
+typedef struct ffi_codec_s ffi_codec_t;
+struct ffi_codec_s {
+ const char *name;
+ ffi_type *libffi_type;
+ TValue (*decode)(ffi_codec_t *self, klisp_State *K, const void *buf);
+ void (*encode)(ffi_codec_t *self, klisp_State *K, TValue v, void *buf);
+};
+
+typedef struct {
+ ffi_cif cif;
+ size_t buffer_size;
+ ffi_codec_t *rcodec;
+ size_t nargs;
+ ffi_type **argtypes;
+ ffi_codec_t **acodecs;
+} ffi_call_interface_t;
+
+typedef struct {
+ ffi_closure libffi_closure;
+ klisp_State *K;
+ Table *table;
+ size_t index;
+} ffi_callback_t;
+
+#define CB_INDEX_N 0
+#define CB_INDEX_STACK 1
+#define CB_INDEX_FIRST_CALLBACK 2
+
+static TValue ffi_decode_void(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ UNUSED(K);
+ UNUSED(buf);
+ return KINERT;
+}
+
+static void ffi_encode_void(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ /* useful only with callbacks */
+ UNUSED(self);
+ UNUSED(K);
+ UNUSED(buf);
+ if (!ttisinert(v))
+ klispE_throw_simple_with_irritants(K, "only inert can be cast to C void", 1, v);
+}
+
+static TValue ffi_decode_sint(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ UNUSED(K);
+ return i2tv(* (int *) buf);
+}
+
+static void ffi_encode_sint(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ if (!ttisfixint(v)) {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C int", 1, v);
+ return;
+ }
+ /* TODO: bigint, ... */
+ * (int *) buf = ivalue(v);
+}
+
+static TValue ffi_decode_pointer(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ void *p = *(void **)buf;
+ return (p) ? p2tv(p) : KNIL;
+}
+
+static void ffi_encode_pointer(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ if (ttisblob(v)) {
+ *(void **)buf = tv2blob(v)->b;
+ } else if (ttisstring(v)) {
+ *(void **)buf = kstring_buf(v);
+ } else if (ttisnil(v)) {
+ *(void **)buf = NULL;
+ } else if (tbasetype_(v) == K_TAG_USER) {
+ /* TODO: do not use internal macro tbasetype_ */
+ *(void **)buf = pvalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "neither blob, string, pointer or nil", 1, v);
+ }
+}
+
+static TValue ffi_decode_string(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ char *s = *(char **) buf;
+ return (s) ? kstring_new_b_imm(K, s) : KNIL;
+}
+
+static void ffi_encode_string(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ if (ttisstring(v)) {
+ *(void **)buf = kstring_buf(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "not a string", 1, v);
+ }
+}
+
+static TValue ffi_decode_uint8(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ UNUSED(K);
+ return i2tv(*(uint8_t *)buf);
+}
+
+static void ffi_encode_uint8(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v) && 0 <= ivalue(v) && ivalue(v) <= UINT8_MAX) {
+ *(uint8_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C uint8_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_sint8(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ UNUSED(K);
+ return i2tv(*(int8_t *)buf);
+}
+
+static void ffi_encode_sint8(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v) && INT8_MIN <= ivalue(v) && ivalue(v) <= INT8_MAX) {
+ *(int8_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C int8_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_uint16(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return i2tv(*(uint16_t *)buf);
+}
+
+static void ffi_encode_uint16(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v) && 0 <= ivalue(v) && ivalue(v) <= UINT16_MAX) {
+ *(uint16_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C uint16_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_sint16(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return i2tv(*(int16_t *)buf);
+}
+
+static void ffi_encode_sint16(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisfixint(v) && INT16_MIN <= ivalue(v) && ivalue(v) <= INT16_MAX) {
+ *(int16_t *) buf = ivalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C int16_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_uint32(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ uint32_t x = *(uint32_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[4];
+ for (int i = 3; i >= 0; i--) {
+ d[i] = (x & 0xFF);
+ x >>= 8;
+ }
+ mp_int_read_unsigned(K, tv2bigint(res), d, 4);
+
+ krooted_tvs_pop(K);
+ return res;
+ }
+}
+
+static void ffi_encode_uint32(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ uint32_t tmp;
+
+ if (ttisfixint(v) && 0 <= ivalue(v)) {
+ *(uint32_t *) buf = ivalue(v);
+ } else if (ttisbigint(v) && mp_int_to_uint(tv2bigint(v), &tmp) == MP_OK) {
+ *(uint32_t *) buf = tmp;
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C uint32_t", 1, v);
+ return;
+ }
+}
+
+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;
+ }
+}
+
+static void ffi_encode_uint64(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ /* TODO */
+ UNUSED(self);
+
+ if (ttisfixint(v) && 0 <= ivalue(v)) {
+ *(uint64_t *) buf = ivalue(v);
+ } else if (ttisbigint(v)
+ && mp_int_compare_zero(tv2bigint(v)) >= 0
+ && mp_int_unsigned_len(tv2bigint(v)) <= 8) {
+ uint8_t d[8];
+
+ mp_int_to_unsigned(K, tv2bigint(v), d, 8);
+ uint64_t tmp = d[0];
+ for (int i = 1; i < 8; i++)
+ tmp = (tmp << 8) | d[i];
+ *(uint64_t *) buf = tmp;
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to convert to C uint64_t", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_double(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return d2tv(*(double *)buf);
+}
+
+static void ffi_encode_double(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisdouble(v)) {
+ *(double *) buf = dvalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to cast to C double", 1, v);
+ return;
+ }
+}
+
+static TValue ffi_decode_float(ffi_codec_t *self, klisp_State *K, const void *buf)
+{
+ UNUSED(self);
+ return d2tv((double) *(float *)buf);
+}
+
+static void ffi_encode_float(ffi_codec_t *self, klisp_State *K, TValue v, void *buf)
+{
+ UNUSED(self);
+ if (ttisdouble(v)) {
+ /* TODO: avoid double rounding for rationals/bigints ?*/
+ *(float *) buf = dvalue(v);
+ } else {
+ klispE_throw_simple_with_irritants(K, "unable to cast to C float", 1, v);
+ return;
+ }
+}
+
+static ffi_codec_t ffi_codecs[] = {
+ { "string", &ffi_type_pointer, ffi_decode_string, ffi_encode_string },
+#define SIMPLE_TYPE(t) { #t, &ffi_type_ ## t, ffi_decode_ ## t, ffi_encode_ ## t }
+ SIMPLE_TYPE(void),
+ SIMPLE_TYPE(sint),
+ SIMPLE_TYPE(pointer),
+ SIMPLE_TYPE(uint8),
+ SIMPLE_TYPE(sint8),
+ SIMPLE_TYPE(uint16),
+ SIMPLE_TYPE(sint16),
+ SIMPLE_TYPE(uint32),
+ SIMPLE_TYPE(uint64),
+ SIMPLE_TYPE(float),
+ SIMPLE_TYPE(double)
+#undef SIMPLE_TYPE
+};
+
+#ifdef KGFFI_WIN32
+static TValue ffi_win32_error_message(klisp_State *K, DWORD dwMessageId)
+{
+ LPTSTR s;
+ if (0 == FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER,
+ NULL,
+ dwMessageId,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
+ &s, 0, NULL)) {
+ return kstring_new_b_imm(K, "Unknown error");
+ } else {
+ TValue v = kstring_new_b_imm(K, s);
+ LocalFree(s);
+ return v;
+ }
+}
+#endif
+
+void ffi_load_library(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: encapsulation key denoting loaded library
+ */
+
+ TValue filename = ptree;
+ const char *filename_c =
+ get_opt_tpar(K, "ffi-load-library", K_TSTRING, &filename)
+ ? kstring_buf(filename) : NULL;
+
+#if KGFFI_DLFCN
+ void *handle = dlopen(filename_c, RTLD_LAZY | RTLD_GLOBAL);
+ if (handle == NULL) {
+ krooted_tvs_push(K, filename);
+ const char *err_c = dlerror();
+ TValue err = (err_c == NULL) ? KNIL : kstring_new_b_imm(K, err_c);
+ klispE_throw_simple_with_irritants(K, "couldn't load dynamic library",
+ 2, filename, err);
+ return;
+ }
+#elif KGFFI_WIN32
+ /* TODO: unicode and wide character issues ??? */
+ HMODULE handle = LoadLibrary(filename_c);
+ if (handle == NULL) {
+ krooted_tvs_push(K, filename);
+ TValue err = ffi_win32_error_message(K, GetLastError());
+ klispE_throw_simple_with_irritants(K, "couldn't load dynamic library",
+ 2, filename, err);
+ return;
+ }
+#else
+# error
+#endif
+ TValue key = xparams[0];
+ krooted_tvs_push(K, key);
+
+ TValue safe_filename = (filename_c) ? filename : kstring_new_b_imm(K, "interpreter binary or statically linked library");
+ krooted_tvs_push(K, safe_filename);
+
+ TValue lib_tv = kcons(K, p2tv(handle), safe_filename);
+ krooted_tvs_push(K, lib_tv);
+
+ TValue enc = kmake_encapsulation(K, key, lib_tv);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ kapply_cc(K, enc);
+}
+
+static ffi_abi tv2ffi_abi(klisp_State *K, TValue v)
+{
+ if (!strcmp("FFI_DEFAULT_ABI", kstring_buf(v))) {
+ return FFI_DEFAULT_ABI;
+ } else if (!strcmp("FFI_SYSV", kstring_buf(v))) {
+ return FFI_SYSV;
+#if KGFFI_WIN32
+ } else if (!strcmp("FFI_STDCALL", kstring_buf(v))) {
+ return FFI_STDCALL;
+#endif
+ } else {
+ klispE_throw_simple_with_irritants(K, "unsupported FFI ABI", 1, v);
+ return 0;
+ }
+}
+
+static ffi_codec_t *tv2ffi_codec(klisp_State *K, TValue v)
+{
+ for (size_t i = 0; i < sizeof(ffi_codecs)/sizeof(ffi_codecs[0]); i++) {
+ if (!strcmp(ffi_codecs[i].name, kstring_buf(v)))
+ return &ffi_codecs[i];
+ }
+ klispE_throw_simple_with_irritants(K, "unsupported FFI type", 1, v);
+ return NULL;
+}
+
+inline size_t align(size_t offset, size_t alignment)
+{
+ assert(alignment > 0);
+ return offset + (alignment - offset % alignment) % alignment;
+}
+
+void ffi_make_call_interface(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: encapsulation key denoting call interface
+ */
+
+#define ttislist(v) (ttispair(v) || ttisnil(v))
+ bind_3tp(K, ptree,
+ "abi string", ttisstring, abi_tv,
+ "rtype string", ttisstring, rtype_tv,
+ "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);
+
+ krooted_tvs_push(K, abi_tv);
+ krooted_tvs_push(K, rtype_tv);
+ krooted_tvs_push(K, argtypes_tv);
+ TValue key = xparams[0];
+ krooted_tvs_push(K, key);
+ size_t blob_size = sizeof(ffi_call_interface_t) + (sizeof(ffi_codec_t *) + sizeof(ffi_type)) * nargs;
+ TValue blob = kblob_new_imm(K, blob_size);
+ krooted_tvs_push(K, blob);
+ TValue enc = kmake_encapsulation(K, key, blob);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ ffi_call_interface_t *p = (ffi_call_interface_t *) tv2blob(blob)->b;
+ p->acodecs = (ffi_codec_t **) ((char *) p + sizeof(ffi_call_interface_t));
+ p->argtypes = (ffi_type **) ((char *) p + sizeof(ffi_call_interface_t) + nargs * sizeof(ffi_codec_t *));
+
+ p->nargs = nargs;
+ p->rcodec = tv2ffi_codec(K, rtype_tv);
+ if (p->rcodec->decode == NULL) {
+ klispE_throw_simple(K, "this type is not allowed as a return type");
+ return;
+ }
+
+ p->buffer_size = p->rcodec->libffi_type->size;
+ TValue tail = argtypes_tv;
+ for (int i = 0; i < nargs; i++) {
+ p->acodecs[i] = tv2ffi_codec(K, kcar(tail));
+ if (p->acodecs[i]->encode == NULL) {
+ klispE_throw_simple(K, "this type is not allowed in argument list");
+ return;
+ }
+ ffi_type *t = p->acodecs[i]->libffi_type;
+ p->argtypes[i] = t;
+ p->buffer_size = align(p->buffer_size, t->alignment) + t->size;
+ tail = kcdr(tail);
+ }
+ ffi_abi abi = tv2ffi_abi(K, abi_tv);
+
+ ffi_status status = ffi_prep_cif(&p->cif, abi, nargs, p->rcodec->libffi_type, p->argtypes);
+ switch (status) {
+ case FFI_OK:
+ break;
+ case FFI_BAD_ABI:
+ klispE_throw_simple(K, "FFI_BAD_ABI");
+ return;
+ case FFI_BAD_TYPEDEF:
+ klispE_throw_simple(K, "FFI_BAD_TYPEDEF");
+ return;
+ default:
+ klispE_throw_simple(K, "unknown error in ffi_prep_cif");
+ return;
+ }
+ kapply_cc(K, enc);
+}
+
+void do_ffi_call(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: function pointer
+ ** xparams[1]: call interface (encapsulated blob)
+ */
+
+ void *funptr = pvalue(xparams[0]);
+ ffi_call_interface_t *p = (ffi_call_interface_t *) tv2blob(kget_enc_val(xparams[1]))->b;
+
+
+ int64_t buffer[(p->buffer_size + sizeof(int64_t) - 1) / sizeof(int64_t)];
+ void *aptrs[p->nargs];
+
+ size_t offset = 0;
+ void *rptr = (unsigned char *) buffer + offset;
+ offset += p->rcodec->libffi_type->size;
+
+ TValue tail = ptree;
+ for (int i = 0; i < p->nargs; i++) {
+ if (!ttispair(tail)) {
+ klispE_throw_simple(K, "too few arguments");
+ return;
+ }
+ ffi_type *t = p->acodecs[i]->libffi_type;
+ offset = align(offset, t->alignment);
+ aptrs[i] = (unsigned char *) buffer + offset;
+ p->acodecs[i]->encode(p->acodecs[i], K, kcar(tail), aptrs[i]);
+ offset += t->size;
+ tail = kcdr(tail);
+ }
+ assert(offset == p->buffer_size);
+ if (!ttisnil(tail)) {
+ klispE_throw_simple(K, "too many arguments");
+ return;
+ }
+
+ ffi_call(&p->cif, funptr, rptr, aptrs);
+
+ TValue result = p->rcodec->decode(p->rcodec, K, rptr);
+ kapply_cc(K, result);
+}
+
+void ffi_make_applicative(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: encapsulation key denoting dynamically loaded library
+ ** xparams[1]: encapsulation key denoting call interface
+ */
+
+ bind_3tp(K, ptree,
+ "dynamic library", ttisencapsulation, lib_tv,
+ "function name string", ttisstring, name_tv,
+ "call interface", ttisencapsulation, cif_tv);
+ if (!kis_encapsulation_type(lib_tv, xparams[0])) {
+ klispE_throw_simple(K, "first argument shall be dynamic library");
+ return;
+ }
+ if (!kis_encapsulation_type(cif_tv, xparams[1])) {
+ klispE_throw_simple(K, "third argument shall be call interface");
+ return;
+ }
+
+ TValue lib_name = kcdr(kget_enc_val(lib_tv));
+ assert(ttisstring(lib_name));
+
+#if KGFFI_DLFCN
+ void *handle = pvalue(kcar(kget_enc_val(lib_tv)));
+ (void) dlerror();
+ void *funptr = dlsym(handle, kstring_buf(name_tv));
+ const char *err_c = dlerror();
+ if (err_c) {
+ krooted_tvs_push(K, name_tv);
+ krooted_tvs_push(K, lib_name);
+ TValue err = kstring_new_b_imm(K, err_c);
+ klispE_throw_simple_with_irritants(K, "couldn't find symbol",
+ 3, lib_name, name_tv, err);
+ return;
+ }
+ if (!funptr) {
+ klispE_throw_simple_with_irritants(K, "symbol is NULL", 2,
+ lib_name, name_tv);
+ }
+#elif KGFFI_WIN32
+ HMODULE handle = pvalue(kcar(kget_enc_val(lib_tv)));
+ void *funptr = GetProcAddress(handle, kstring_buf(name_tv));
+ if (NULL == funptr) {
+ TValue err = ffi_win32_error_message(K, GetLastError());
+ klispE_throw_simple_with_irritants(K, "couldn't find symbol",
+ 3, lib_name, name_tv, err);
+ return;
+ }
+#else
+# error
+#endif
+
+ TValue app = kmake_applicative(K, do_ffi_call, 2, p2tv(funptr), cif_tv);
+
+#if KTRACK_SI
+ krooted_tvs_push(K, app);
+ krooted_tvs_push(K, lib_name);
+ TValue tail = kcons(K, i2tv((int) funptr), i2tv(0));
+ krooted_tvs_push(K, tail);
+ TValue si = kcons(K, lib_name, tail);
+ krooted_tvs_push(K, si);
+ kset_source_info(K, kunwrap(app), si);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+#endif
+
+ kapply_cc(K, app);
+}
+
+static void ffi_callback_push(ffi_callback_t *cb, TValue v)
+{
+ /* assume v is rooted */
+ TValue *s = klispH_setfixint(cb->K, cb->table, CB_INDEX_STACK);
+ *s = kimm_cons(cb->K, v, *s);
+}
+
+static TValue ffi_callback_pop(ffi_callback_t *cb)
+{
+ TValue *s = klispH_setfixint(cb->K, cb->table, CB_INDEX_STACK);
+ TValue v = kcar(*s);
+ krooted_tvs_push(cb->K, v);
+ *s = kcdr(*s);
+ krooted_tvs_pop(cb->K);
+ return v;
+}
+
+static TValue ffi_callback_guard(ffi_callback_t *cb, klisp_Ofunc fn)
+{
+ TValue app = kmake_applicative(cb->K, fn, 1, p2tv(cb));
+ krooted_tvs_push(cb->K, app);
+ TValue ls1 = kimm_list(cb->K, 2, cb->K->root_cont, app);
+ krooted_tvs_push(cb->K, ls1);
+ TValue ls2 = kimm_list(cb->K, 1, ls1);
+ krooted_tvs_pop(cb->K);
+ krooted_tvs_pop(cb->K);
+ return ls2;
+}
+
+void do_ffi_callback_encode_result(klisp_State *K, TValue *xparams,
+ TValue obj)
+{
+ /*
+ ** xparams[0]: cif
+ ** xparams[1]: p2tv(libffi return buffer)
+ */
+ ffi_call_interface_t *p = (ffi_call_interface_t *) kblob_buf(kget_enc_val(xparams[0]));
+ void *ret = pvalue(xparams[1]);
+ p->rcodec->encode(p->rcodec, K, obj, ret);
+ kapply_cc(K, KINERT);
+}
+
+void do_ffi_callback_decode_arguments(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ /*
+ ** xparams[0]: p2tv(ffi_callback_t)
+ ** xparams[1]: p2tv(libffi return buffer)
+ ** xparams[2]: p2tv(libffi argument array)
+ */
+
+ ffi_callback_t *cb = pvalue(xparams[0]);
+ void *ret = pvalue(xparams[1]);
+ void **args = pvalue(xparams[2]);
+
+ /* get the lisp applicative and the call interface
+ * from the auxilliary table. */
+
+ const TValue *slot = klispH_setfixint(K, cb->table, cb->index);
+ TValue app_tv = kcar(*slot);
+ TValue cif_tv = kcdr(*slot);
+ assert(ttisapplicative(app_tv));
+ assert(ttisencapsulation(cif_tv));
+ krooted_tvs_push(K, app_tv);
+ krooted_tvs_push(K, cif_tv);
+ ffi_call_interface_t *p = (ffi_call_interface_t *) kblob_buf(kget_enc_val(cif_tv));
+
+ /* Decode arguments. */
+
+ TValue tail = KNIL;
+ for (int i = p->nargs - 1; i >= 0; i--) {
+ krooted_tvs_push(K, ptree);
+ TValue arg = p->acodecs[i]->decode(p->acodecs[i], K, args[i]);
+ krooted_tvs_pop(K);
+ tail = kimm_cons(K, arg, tail);
+ }
+ krooted_tvs_push(K, tail);
+
+ /* Setup continuation for encoding return value. */
+
+ TValue encoding_cont = kmake_continuation(K, kget_cc(K), do_ffi_callback_encode_result, 2, cif_tv, p2tv(ret));
+ kset_cc(K, encoding_cont);
+
+ /* apply the callback applicative */
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ while(ttisapplicative(app_tv))
+ app_tv = tv2app(app_tv)->underlying;
+ ktail_call(K, app_tv, tail, denv);
+}
+
+void do_ffi_callback_return(klisp_State *K, TValue *xparams, TValue obj)
+{
+ UNUSED(obj);
+ /*
+ ** xparams[0]: p2tv(ffi_callback_t)
+ **
+ ** Signal normal return and force the "inner" trampoline
+ ** loop to exit.
+ */
+ ffi_callback_t *cb = pvalue(xparams[0]);
+ ffi_callback_push(cb, i2tv(1));
+ K->next_func = NULL;
+}
+
+void do_ffi_callback_entry_guard(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ UNUSED(xparams);
+ /* The entry guard is invoked only if the user captured
+ * the continuation under foreign callback and applied
+ * it later after the foreign callback terminated.
+ *
+ * The auxilliary stack (stored in the callback hash table)
+ * now does not correspond to the actual state of callback
+ * nesting.
+ */
+ klispE_throw_simple(K, "tried to re-enter continuation under FFI callback");
+}
+
+void do_ffi_callback_exit_guard(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: p2tv(ffi_callback_t)
+ **
+ ** Signal abnormal return and force the "inner" trampoline
+ ** loop to exit to ffi_callback_entry(). The parameter tree
+ ** will be processed there.
+ */
+ ffi_callback_t *cb = pvalue(xparams[0]);
+ ffi_callback_push(cb, i2tv(0));
+ K->next_func = NULL;
+}
+
+static void ffi_callback_entry(ffi_cif *cif, void *ret, void **args, void *user_data)
+{
+ ffi_callback_t *cb = (ffi_callback_t *) user_data;
+ klisp_State *K = cb->K;
+
+ /* save state of the interpreter */
+
+ volatile jmp_buf saved_error_jb;
+ memcpy(&saved_error_jb, &K->error_jb, sizeof(K->error_jb));
+ ffi_callback_push(cb, K->curr_cont);
+
+ /* Set up continuation for normal return path. */
+
+ TValue return_cont = kmake_continuation(K, K->curr_cont, do_ffi_callback_return, 1, p2tv(cb));
+ krooted_tvs_push(K, return_cont);
+ kset_cc(K, return_cont);
+
+ /* Do not decode arguments yet. The decoding may fail
+ * and raise errors. Let klisp core handle all errors
+ * inside guarded continuation. */
+
+ TValue app = kmake_applicative(K, do_ffi_callback_decode_arguments, 3, p2tv(cb), p2tv(ret), p2tv(args));
+ krooted_tvs_push(K, app);
+
+ TValue entry_guard = ffi_callback_guard(cb, do_ffi_callback_entry_guard);
+ krooted_tvs_push(K, entry_guard);
+ TValue exit_guard = ffi_callback_guard(cb, do_ffi_callback_exit_guard);
+ krooted_tvs_push(K, exit_guard);
+
+ 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);
+
+ guard_dynamic_extent(K, NULL, ptree, K->next_env);
+
+ /* Enter new "inner" trampoline loop. */
+
+ klispS_run(K);
+
+ /* restore longjump buffer of the outer trampoline loop */
+
+ memcpy(&K->error_jb, &saved_error_jb, sizeof(K->error_jb));
+
+ /* Now, the "inner" trampoline loop exited. The exit
+ was forced by return_cont or exit_guard. */
+
+ if (ivalue(ffi_callback_pop(cb))) {
+ /* Normal return - reinstall old continuation. It will be
+ * used after the foreign call which originally called
+ * this callback eventually returns. */
+ kset_cc(K, ffi_callback_pop(cb));
+ } else {
+ /* Abnormal return - throw away the old continuation
+ ** and longjump back in the "outer" trampoline loop.
+ ** Longjump unwinds the stack space used by the foreign
+ ** call which originally called this callback. After
+ ** that the interpreter state will look like normal
+ ** normal return from the exit guard.
+ */
+ (void) ffi_callback_pop(cb);
+ klispS_apply_cc(K, kcar(K->next_value));
+ longjmp(K->error_jb, 1);
+ }
+}
+
+
+void ffi_make_callback(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: encapsulation key denoting call interface
+ ** xparams[1]: callback data table
+ */
+
+ bind_2tp(K, ptree,
+ "applicative", ttisapplicative, app_tv,
+ "call interface", ttisencapsulation, cif_tv);
+ if (!kis_encapsulation_type(cif_tv, xparams[0])) {
+ klispE_throw_simple(K, "second argument shall be call interface");
+ return;
+ }
+ ffi_call_interface_t *p = (ffi_call_interface_t *) kblob_buf(kget_enc_val(cif_tv));
+ TValue cb_tab = xparams[1];
+
+ /* Allocate memory for libffi closure. */
+
+ void *code;
+ ffi_callback_t *cb = ffi_closure_alloc(sizeof(ffi_callback_t), &code);
+
+ /* Get the index of this callback in the callback table. */
+
+ TValue *n_tv = klispH_setfixint(K, tv2table(cb_tab), 0);
+ assert(n_tv != &kfree);
+ int32_t new_index = ivalue(*n_tv);
+ *n_tv = i2tv(new_index + 1);
+
+ /* Prepare the C part of callback data */
+
+ cb->K = K;
+ cb->table = tv2table(xparams[1]);
+ cb->index = new_index;
+
+ /* TODO: The closure leaks. Should be finalized. */
+
+ /* Prepare the lisp part of callback data */
+
+ krooted_tvs_push(K, cb_tab);
+ krooted_tvs_push(K, app_tv);
+ krooted_tvs_push(K, cif_tv);
+
+ TValue item_tv = kimm_cons(K, app_tv, cif_tv);
+ krooted_tvs_push(K, item_tv);
+
+ TValue *slot = klispH_setfixint(K, tv2table(cb_tab), new_index);
+ *slot = item_tv;
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ /* Initialize callback. */
+
+ ffi_status status = ffi_prep_closure_loc(&cb->libffi_closure, &p->cif, ffi_callback_entry, cb, code);
+ if (status != FFI_OK) {
+ ffi_closure_free(cb);
+ klispE_throw_simple(K, "unknown error in ffi_prep_closure_loc");
+ return;
+ }
+
+ /* return the libffi closure entry point */
+
+ TValue funptr_tv = p2tv(code);
+ kapply_cc(K, funptr_tv);
+}
+
+static uint8_t * ffi_memory_location(klisp_State *K, bool allow_nesting,
+ TValue v, bool mutable, size_t size)
+{
+ if (ttisblob(v)) {
+ if (mutable && kblob_immutablep(v)) {
+ klispE_throw_simple_with_irritants(K, "blob not mutable", 1, v);
+ return NULL;
+ } else if (size > kblob_size(v)) {
+ klispE_throw_simple_with_irritants(K, "blob too small", 1, v);
+ return NULL;
+ } else {
+ return kblob_buf(v);
+ }
+ } else if (ttisstring(v)) {
+ if (mutable && kstring_immutablep(v)) {
+ klispE_throw_simple_with_irritants(K, "string not mutable", 1, v);
+ return NULL;
+ } else if (size > kstring_size(v)) {
+ klispE_throw_simple_with_irritants(K, "string too small", 1, v);
+ return NULL;
+ } else {
+ return (uint8_t *) kstring_buf(v);
+ }
+ } else if (tbasetype_(v) == K_TAG_USER) {
+ /* TODO: do not use internal macro tbasetype_ */
+ return (pvalue(v));
+ } else if (ttispair(v) && ttispair(kcdr(v)) && ttisnil(kcddr(v))) {
+ if (!allow_nesting) {
+ klispE_throw_simple_with_irritants(K, "offset specifications cannot be nested", 1, v);
+ return NULL;
+ }
+ TValue base_tv = kcar(v);
+ TValue offset_tv = kcadr(v);
+ if (!ttisfixint(offset_tv) || ivalue(offset_tv) < 0) {
+ klispE_throw_simple_with_irritants(K, "offset should be nonnegative fixint", 1, v);
+ return NULL;
+ } else {
+ size_t offset = ivalue(offset_tv);
+ uint8_t * p = ffi_memory_location(K, false, base_tv, mutable, size + offset);
+ return (p + offset);
+ }
+ } else {
+ klispE_throw_simple_with_irritants(K, "not a memory location", 1, v);
+ return NULL;
+ }
+}
+
+void ffi_memmove(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_3tp(K, ptree,
+ "any", anytype, dst_tv,
+ "any", anytype, src_tv,
+ "integer", ttisfixint, sz_tv);
+
+ if (ivalue(sz_tv) < 0)
+ klispE_throw_simple(K, "size should be nonnegative fixint");
+
+ size_t sz = (size_t) ivalue(sz_tv);
+ uint8_t * dst = ffi_memory_location(K, true, dst_tv, true, sz);
+ const uint8_t * src = ffi_memory_location(K, true, src_tv, false, sz);
+ memmove(dst, src, sz);
+
+ kapply_cc(K, KINERT);
+}
+
+static void ffi_type_ref(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: pointer to ffi_codec_t
+ */
+
+ bind_1tp(K, ptree, "any", anytype, location_tv);
+ ffi_codec_t *codec = pvalue(xparams[0]);
+ const uint8_t *ptr = ffi_memory_location(K, true, location_tv, false, codec->libffi_type->size);
+#if KGFFI_CHECK_ALIGNMENT
+ if ((size_t) ptr % codec->libffi_type->alignment != 0)
+ klispE_throw_simple(K, "unaligned memory read through FFI");
+#endif
+
+ TValue result = codec->decode(codec, K, ptr);
+ kapply_cc(K, result);
+}
+
+static void ffi_type_set(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(denv);
+ /*
+ ** xparams[0]: pointer to ffi_codec_t
+ */
+
+ bind_2tp(K, ptree,
+ "any", anytype, location_tv,
+ "any", anytype, value_tv);
+ ffi_codec_t *codec = pvalue(xparams[0]);
+ uint8_t *ptr = ffi_memory_location(K, true, location_tv, false, codec->libffi_type->size);
+#if KGFFI_CHECK_ALIGNMENT
+ if ((size_t) ptr % codec->libffi_type->alignment != 0)
+ klispE_throw_simple(K, "unaligned memory write through FFI");
+#endif
+
+ codec->encode(codec, K, value_tv, ptr);
+ kapply_cc(K, KINERT);
+}
+
+void ffi_type_suite(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ bind_1tp(K, ptree, "string", ttisstring, type_tv);
+ ffi_codec_t *codec = tv2ffi_codec(K, type_tv);
+
+ TValue size_tv = i2tv(codec->libffi_type->size);
+ krooted_tvs_push(K, size_tv);
+
+ TValue alignment_tv = i2tv(codec->libffi_type->alignment);
+ krooted_tvs_push(K, alignment_tv);
+
+ TValue getter_tv =
+ (codec->decode)
+ ? kmake_applicative(K, ffi_type_ref, 1, p2tv(codec))
+ : KINERT;
+ krooted_tvs_push(K, getter_tv);
+
+ TValue setter_tv =
+ (codec->encode)
+ ? kmake_applicative(K, ffi_type_set, 1, p2tv(codec))
+ : KINERT;
+ krooted_tvs_push(K, setter_tv);
+
+ TValue suite_tv = kimm_list(K, 4, size_tv, alignment_tv, getter_tv, setter_tv);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ kapply_cc(K, suite_tv);
+}
+
+/* init ground */
+void kinit_ffi_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ /* create encapsulation keys */
+
+ TValue dll_key = kmake_encapsulation_key(K);
+ TValue cif_key = kmake_encapsulation_key(K);
+
+ /* TODO: should be rooted */
+
+ /* create table for callback data */
+ TValue cb_tab = klispH_new(K, 0, 64, K_FLAG_WEAK_NOTHING);
+
+ TValue *v;
+ v = klispH_setfixint(K, tv2table(cb_tab), CB_INDEX_N);
+ *v = i2tv(CB_INDEX_FIRST_CALLBACK);
+ v = klispH_setfixint(K, tv2table(cb_tab), CB_INDEX_STACK);
+ *v = KNIL;
+
+ add_applicative(K, ground_env, "ffi-load-library", ffi_load_library, 1, dll_key);
+ add_applicative(K, ground_env, "ffi-make-call-interface", ffi_make_call_interface, 1, cif_key);
+ add_applicative(K, ground_env, "ffi-make-applicative", ffi_make_applicative, 2, dll_key, cif_key);
+ add_applicative(K, ground_env, "ffi-make-callback", ffi_make_callback, 2, cif_key, cb_tab);
+ add_applicative(K, ground_env, "ffi-memmove", ffi_memmove, 0);
+ add_applicative(K, ground_env, "ffi-type-suite", ffi_type_suite, 0);
+ 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);
+}
diff --git a/src/kgffi.h b/src/kgffi.h
@@ -0,0 +1,30 @@
+/*
+** kgffi.h
+** Foreign function interface
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgffi_h
+#define kgffi_h
+
+#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, TValue *xparams,
+ TValue ptree, TValue denv);
+
+/* init ground */
+void kinit_ffi_ground_env(klisp_State *K);
+
+#endif
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -96,7 +96,7 @@ void do_set_pass(klisp_State *K, TValue *xparams, TValue ptree,
abnormal passes */
/* TODO: reuse the code for guards in kgcontinuations.c */
-/* GC: this assumes that key is rooted */
+/* 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)
@@ -167,10 +167,16 @@ void do_bind(klisp_State *K, TValue *xparams, TValue ptree,
/* 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);
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -2338,12 +2338,12 @@ void kinit_numbers_ground_env(klisp_State *K)
add_applicative(K, ground_env, "exp", kexp, 0);
add_applicative(K, ground_env, "log", klog, 0);
/* 12.9.3 sin, cos, tan */
- add_applicative(K, ground_env, "sin", ktrig, 1, sin);
- add_applicative(K, ground_env, "cos", ktrig, 1, cos);
- add_applicative(K, ground_env, "tan", ktrig, 1, tan);
+ add_applicative(K, ground_env, "sin", ktrig, 1, p2tv(sin));
+ add_applicative(K, ground_env, "cos", ktrig, 1, p2tv(cos));
+ add_applicative(K, ground_env, "tan", ktrig, 1, p2tv(tan));
/* 12.9.4 asin, acos, atan */
- add_applicative(K, ground_env, "asin", katrig, 1, asin);
- add_applicative(K, ground_env, "acos", katrig, 1, acos);
+ add_applicative(K, ground_env, "asin", katrig, 1, p2tv(asin));
+ add_applicative(K, ground_env, "acos", katrig, 1, p2tv(acos));
add_applicative(K, ground_env, "atan", katan, 0);
/* 12.9.5 sqrt */
add_applicative(K, ground_env, "sqrt", ksqrt, 0);
diff --git a/src/kgports.c b/src/kgports.c
@@ -331,10 +331,6 @@ void call_with_file(klisp_State *K, TValue *xparams, TValue ptree,
/* GC: assume port is rooted */
TValue read_all_expr(klisp_State *K, TValue port)
{
- /* support unix script directive #! */
- int line_count = kscript_eat_directive(kport_file(port));
- kport_line(port) += line_count;
-
/* GC: root dummy and obj */
TValue tail = kget_dummy1(K);
TValue obj = KINERT;
@@ -555,6 +551,94 @@ void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, KINERT);
}
+/* 15.1.? flush-output-port */
+void flush(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ TValue port = ptree;
+
+ if (!get_opt_tpar(K, "flush-output-port", K_TPORT, &port)) {
+ port = kcdr(K->kd_out_port_key); /* access directly */
+ } else if (!kport_is_output(port)) {
+ klispE_throw_simple(K, "the port should be an output port");
+ return;
+ }
+ if (kport_is_closed(port)) {
+ klispE_throw_simple(K, "the port is already closed");
+ return;
+ }
+
+ FILE *file = kport_file(port);
+ if (file) { /* only do for file ports */
+ UNUSED(fflush(file)); /* TEMP for now don't signal errors on flush */
+ }
+ kapply_cc(K, KINERT);
+}
+
+/* 15.1.? file-exists? */
+void file_existsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ 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 */
+ 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, TValue ptree, TValue denv)
+{
+ 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);
+ return;
+ }
+}
+
+/* 15.1.? rename-file */
+void rename_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ 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);
+ return;
+ }
+}
+
/* init ground */
void kinit_ports_ground_env(klisp_State *K)
{
@@ -637,10 +721,28 @@ void kinit_ports_ground_env(klisp_State *K)
/* 15.2.? display */
add_applicative(K, ground_env, "display", display, 0);
- /* MAYBE: That's all there is in the report combined with r5rs scheme,
- but we will probably need: file-exists?, rename-file and remove-file.
- It would also be good to be able to select between append, truncate and
- error if a file exists, but that would need to be an option in all three
- methods of opening. Also some directory checking, traversing etc */
- /* BUT SEE r7rs draft for some of the above */
+ /* r7rs */
+
+ /* 15.1.? flush-output-port */
+ add_applicative(K, ground_env, "flush-output-port", flush, 0);
+
+ /* 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
+ * It would be good to be able to select between append, truncate and
+ * error if a file exists, but that would need to be an option in all three
+ * methods of opening. Also some directory checking, traversing, etc,
+ * would be nice
+ */
}
diff --git a/src/kgports.h b/src/kgports.h
@@ -87,6 +87,18 @@ void display(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
void do_close_file_ret(klisp_State *K, TValue *xparams, TValue obj);
+/* 15.1.? flush-output-port */
+void flush(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 15.1.? file-exists? */
+void file_existsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 15.1.? delete-file */
+void delete_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 15.1.? rename-file */
+void rename_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
/* init ground */
void kinit_ports_ground_env(klisp_State *K);
diff --git a/src/kground.c b/src/kground.c
@@ -37,6 +37,11 @@
#include "kgports.h"
#include "kgblobs.h"
#include "kgsystem.h"
+#include "kgerror.h"
+
+#if KUSE_LIBFFI
+# include "kgffi.h"
+#endif
/* for initing cont names */
#include "ktable.h"
@@ -139,6 +144,10 @@ void kinit_ground_env(klisp_State *K)
kinit_ports_ground_env(K);
kinit_blobs_ground_env(K);
kinit_system_ground_env(K);
+ kinit_error_ground_env(K);
+#if KUSE_LIBFFI
+ kinit_ffi_ground_env(K);
+#endif
/*
** Initialize the names of the continuation used in
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -239,7 +239,7 @@ bool kstring_ci_gep(TValue str1, TValue str2)
}
/* 13.2.5? substring */
-/* TEMP: at least for now this always returns mutable strings */
+/* Note: This will return an mutable string iff the source string is mutable */
void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
@@ -276,8 +276,10 @@ void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* the if isn't strictly necessary but it's clearer this way */
if (size == 0) {
new_str = K->empty_string;
- } else {
+ } else if (kstring_mutablep(str)) {
new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
+ } else {
+ new_str = kstring_new_bs_imm(K, kstring_buf(str)+start, size);
}
kapply_cc(K, new_str);
}
diff --git a/src/klisp.h b/src/klisp.h
@@ -38,8 +38,8 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud);
void klisp_close (klisp_State *K);
/******************************************************************************
-* Copyright (C) 2011 Andres Navarro. All rights reserved.
-* Lua parts: Copyright (C) 1994-2010 Lua.org, PUC-Rio. All rights reserved.
+* 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.
*
diff --git a/src/kport.c b/src/kport.c
@@ -14,6 +14,7 @@
#include "kerror.h"
#include "kstring.h"
#include "kgc.h"
+#include "kpair.h"
/* XXX: per the c spec, this truncates the file if it exists! */
/* Ask John: what would be best? Probably should also include delete,
@@ -27,7 +28,8 @@ TValue kmake_port(klisp_State *K, TValue filename, bool writep)
/* for now always use text mode */
FILE *f = fopen(kstring_buf(filename), writep? "w": "r");
if (f == NULL) {
- klispE_throw_simple(K, "could't open file");
+ klispE_throw_errno_with_irritants(K, "fopen", 2, filename,
+ kstring_new_b_imm(K, writep? "w": "r"));
return KINERT;
} else {
return kmake_std_port(K, filename, writep, f);
diff --git a/src/krational.c b/src/krational.c
@@ -102,7 +102,11 @@ bool krational_read_decimal(klisp_State *K, char *buf, int32_t base, TValue *out
/* check to see if there was a decimal point, will only
be written to out_decimalp if no error ocurr */
- bool decimalp = memchr(buf, '.', *end - buf) != NULL;
+ /* TEMP: mp_rat_read_ustring does not set *end if an error occurs.
+ * Do not let memchr() read past the end of the buffer. */
+ bool decimalp = (ret_val == MP_OK || ret_val == MP_TRUNC)
+ ? (memchr(buf, '.', *end - buf) != NULL)
+ : false;
/* handle exponents, avoid the case where the number finishes
in a decimal point (this isn't allowed by kernel */
diff --git a/src/krepl.c b/src/krepl.c
@@ -19,6 +19,7 @@
#include "ksymbol.h"
#include "kport.h"
#include "kpair.h"
+#include "kgerror.h"
/* for names */
#include "ktable.h"
@@ -68,6 +69,8 @@ void do_repl_eval(klisp_State *K, TValue *xparams, TValue obj)
if (ttiseof(obj)) {
/* read [EOF], should terminate the repl */
/* this will in turn call main_cont */
+ /* print a newline to allow the shell a fresh line */
+ printf("\n");
kset_cc(K, K->root_cont);
kapply_cc(K, KINERT);
} else {
@@ -262,6 +265,9 @@ void kinit_repl(klisp_State *K)
krooted_tvs_pop(K);
krooted_tvs_pop(K);
+ /* Create error continuation hierarchy. */
+ kinit_error_hierarchy(K);
+
#if KTRACK_SI
/* save the root cont in next_si to let the loop continuations have
source info, this is hackish but works */
diff --git a/src/kscript.c b/src/kscript.c
@@ -21,6 +21,7 @@
#include "kport.h"
#include "kpair.h"
#include "kgcontrol.h"
+#include "kgerror.h"
/* for names */
#include "ktable.h"
@@ -225,6 +226,9 @@ void kinit_script(klisp_State *K, int argc, char *argv[])
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));
@@ -242,27 +246,3 @@ void kinit_script(klisp_State *K, int argc, char *argv[])
#undef RSI
#undef G
}
-
-/* skips the unix script directive (#!), if present.
- returns number of lines skipped */
-int kscript_eat_directive(FILE *fr)
-{
- static const char pattern[] = "#! ";
- int c, n = 0;
-
- while (pattern[n] != '\0' && (c = getc(fr), c == pattern[n]))
- n++;
-
- if (pattern[n] == '\0') {
- while (c = getc(fr), c != EOF && c != '\n')
- ;
- return 1;
- } else {
- ungetc(c, fr);
- /* XXX/Temp notice that the standard doesn't guarantee that more than one
- ungetc in a row will be honored. Andres Navarro */
- while (n > 0)
- ungetc(pattern[--n], fr);
- return 0;
- }
-}
diff --git a/src/kscript.h b/src/kscript.h
@@ -18,9 +18,6 @@ void kinit_script(klisp_State *K, int argc, char *argv[]);
void do_script_exit(klisp_State *K, TValue *xparams, TValue obj);
void do_script_error(klisp_State *K, TValue *xparams, TValue obj);
-/* unix script directive handling */
-int kscript_eat_directive(FILE *fr);
-
/* default exit code in case of error according to SRFI-22 */
#define KSCRIPT_DEFAULT_ERROR_EXIT_CODE 70
diff --git a/src/kstate.c b/src/kstate.c
@@ -79,6 +79,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->module_params_sym = KINERT;
K->root_cont = KINERT;
K->error_cont = KINERT;
+ K->system_error_cont = KINERT;
K->frealloc = f;
K->ud = ud;
diff --git a/src/kstate.h b/src/kstate.h
@@ -73,6 +73,7 @@ struct klisp_State {
/* it is used in get-module */
TValue root_cont;
TValue error_cont;
+ TValue system_error_cont; /* initialized by kinit_error_hierarchy() */
klisp_Alloc frealloc; /* function to reallocate memory */
void *ud; /* auxiliary data to `frealloc' */
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -238,7 +238,8 @@ void ktok_set_source_info(klisp_State *K, TValue filename, int32_t line,
/*
** ktok_read_token() helpers
*/
-void ktok_ignore_whitespace_and_comments(klisp_State *K);
+void ktok_ignore_whitespace(klisp_State *K);
+void ktok_ignore_single_line_comment(klisp_State *K);
bool ktok_check_delimiter(klisp_State *K);
TValue ktok_read_string(klisp_State *K);
TValue ktok_read_special(klisp_State *K);
@@ -256,82 +257,92 @@ TValue ktok_read_token(klisp_State *K)
{
assert(ks_tbisempty(K));
- ktok_ignore_whitespace_and_comments(K);
- /*
- ** NOTE: We jumped over all whitespace
- ** so either the next token starts here or eof was reached,
- ** in any case we save the location of the port
- */
+ while(true) {
+ ktok_ignore_whitespace(K);
- /* save the source info of the start of the next token */
- ktok_save_source_info(K);
+ /* save the source info in case a token starts here */
+ ktok_save_source_info(K);
- int chi = ktok_peekc(K);
+ int chi = ktok_peekc(K);
- switch(chi) {
- case EOF:
- ktok_getc(K);
- return KEOF;
- case '(':
- ktok_getc(K);
- return K->ktok_lparen;
- 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");
+ switch(chi) {
+ case EOF:
+ ktok_getc(K);
+ return KEOF;
+ case ';':
+ ktok_ignore_single_line_comment(K);
+ continue;
+ case '(':
+ ktok_getc(K);
+ return K->ktok_lparen;
+ 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);
+/* TODO use read_until_delimiter in all these cases */
+ case '#': {
+ ktok_getc(K);
+ chi = ktok_peekc(K);
+ if ((chi != EOF) && (char) chi == '!') {
+ /* this handles the #! style script header too! */
+ ktok_ignore_single_line_comment(K);
+ continue;
+ } else {
+ /* also handles EOF case */
+ return ktok_read_special(K);
+ }
+ }
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': {
+ /* positive number, no exactness or radix indicator */
+ int32_t buf_len = ktok_read_until_delimiter(K);
+ char *buf = ks_tbget_buffer(K);
+ /* read number should free the tbbuffer */
+ return ktok_read_number(K, buf, buf_len, false, false, false, 10);
+ }
+ case '+': case '-':
+ /* signed number, no exactness or radix indicator */
+ return ktok_read_maybe_signed_numeric(K);
+ 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':
+ case 'V': case 'W': case 'X': case 'Y': case 'Z':
+ 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':
+ case 'v': case 'w': case 'x': case 'y': case 'z':
+ case '!': case '$': case '%': case '&': case '*': case '/': case ':':
+ case '<': case '=': case '>': case '?': case '@': case '^': case '_':
+ case '~':
+ /*
+ ** NOTE: the cases for '+', '-', '.' and numbers were already
+ ** considered so identifier-subsequent is used instead of
+ ** identifier-first-char (in the cases above)
+ */
+ return ktok_read_identifier(K);
+ default:
+ ktok_getc(K);
+ ktok_error(K, "unrecognized token starting char");
/* avoid warning */
return KINERT;
}
- case '"':
- return ktok_read_string(K);
-/* TODO use read_until_delimiter in all these cases */
- case '#':
- return ktok_read_special(K);
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9': {
- /* positive number, no exactness or radix indicator */
- int32_t buf_len = ktok_read_until_delimiter(K);
- char *buf = ks_tbget_buffer(K);
- /* read number should free the tbbuffer */
- return ktok_read_number(K, buf, buf_len, false, false, false, 10);
- }
- case '+': case '-':
- /* signed number, no exactness or radix indicator */
- return ktok_read_maybe_signed_numeric(K);
- 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':
- case 'V': case 'W': case 'X': case 'Y': case 'Z':
- 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':
- case 'v': case 'w': case 'x': case 'y': case 'z':
- case '!': case '$': case '%': case '&': case '*': case '/': case ':':
- case '<': case '=': case '>': case '?': case '@': case '^': case '_':
- case '~':
- /*
- ** NOTE: the cases for '+', '-', '.' and numbers were already
- ** considered so identifier-subsequent is used instead of
- ** identifier-first-char (in the cases above)
- */
- return ktok_read_identifier(K);
- default:
- ktok_getc(K);
- ktok_error(K, "unrecognized token starting char");
- /* avoid warning */
- return KINERT;
}
}
/*
** Comments and Whitespace
*/
-void ktok_ignore_comment(klisp_State *K)
+void ktok_ignore_single_line_comment(klisp_State *K)
{
int chi;
do {
@@ -339,28 +350,48 @@ void ktok_ignore_comment(klisp_State *K)
} while (chi != EOF && chi != '\n');
}
+void ktok_ignore_whitespace(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 {
+ return;
+ }
+ }
+ }
+}
+
+/* XXX temp for repl */
void ktok_ignore_whitespace_and_comments(klisp_State *K)
{
- /* NOTE: if it's not a whitespace or comment do nothing (even on eof) */
- bool end = false;
- while(!end) {
+ /* NOTE: if it's not whitespace do nothing (even on eof) */
+ while(true) {
int chi = ktok_peekc(K);
if (chi == EOF) {
- end = true;
+ return;
} else {
char ch = (char) chi;
if (ktok_is_whitespace(ch)) {
ktok_getc(K);
} else if (ch == ';') {
- ktok_ignore_comment(K); /* NOTE: this also reads again the ';' */
+ ktok_ignore_single_line_comment(K);
} else {
- end = true;
+ return;
}
}
}
}
+
/*
** Delimiter checking
*/
@@ -541,8 +572,9 @@ struct kspecial_token {
TValue ktok_read_special(klisp_State *K)
{
- /* the # is still pending (was only peeked) */
- int32_t buf_len = ktok_read_until_delimiter(K);
+ /* the # is already consumed, add it manually */
+ ks_tbadd(K, '#');
+ int32_t buf_len = ktok_read_until_delimiter(K) + 1;
char *buf = ks_tbget_buffer(K);
if (buf_len < 2) {
diff --git a/src/tests/characters.k b/src/tests/characters.k
@@ -0,0 +1,98 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of character features.
+;;
+
+;; 14.?.? char?
+
+($check-predicate (char?))
+($check-predicate (char? #\newline #\space #\0 #\A #\a #\~))
+
+($check-not-predicate (char? ""))
+($check-not-predicate (char? "a"))
+($check-not-predicate (char? 0))
+($check-not-predicate (char? #f))
+($check-not-predicate (char? ()))
+($check-not-predicate (char? #inert))
+
+;; XXX char=? char<? char<=? char>? char>=?
+
+($check-predicate (char=? #\A #\A))
+($check-not-predicate (char=? #\A #\B))
+($check-not-predicate (char=? #\a #\A))
+
+($check-predicate (char<? #\A #\B))
+($check-not-predicate (char<? #\A #\A))
+($check-not-predicate (char<? #\B #\A))
+
+($check-predicate (char<=? #\A #\A))
+($check-predicate (char<=? #\A #\B))
+($check-not-predicate (char<=? #\B #\A))
+
+($check-predicate (char>? #\B #\A))
+($check-not-predicate (char>? #\A #\A))
+($check-not-predicate (char>? #\A #\B))
+
+($check-predicate (char>=? #\A #\A))
+($check-predicate (char>=? #\B #\A))
+($check-not-predicate (char>=? #\A #\B))
+
+;; XXX char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?
+
+($check-predicate ($true-for-all-combinations? char-ci=? (#\A #\a) (#\A #\a)))
+($check-predicate ($false-for-all-combinations? char-ci=? (#\A #\a) (#\B #\b)))
+
+($check-predicate ($true-for-all-combinations? char-ci<? (#\A #\a) (#\B #\b)))
+($check-predicate ($false-for-all-combinations? char-ci<? (#\A #\a #\B #\b) (#\A #\a)))
+
+($check-predicate ($true-for-all-combinations? char-ci<=? (#\A #\a) (#\A #\a #\B #\b)))
+($check-predicate ($false-for-all-combinations? char-ci<=? (#\B #\b) (#\A #\a)))
+
+($check-predicate ($true-for-all-combinations? char-ci>? (#\B #\b) (#\A #\a)))
+($check-predicate ($false-for-all-combinations? char-ci>? (#\A #\a #\B #\b) (#\B #\b)))
+
+($check-predicate ($true-for-all-combinations? char-ci>=? (#\A #\a #\B #\b) (#\A #\a)))
+($check-predicate ($false-for-all-combinations? char-ci>=? (#\A #\a) (#\B #\b)))
+
+;; XXX char-alphabetic? char-numeric? char-whitespace?
+
+($check-predicate (char-alphabetic? #\a #\A #\b #\B #\k #\T #\y #\Y #\Z #\z))
+($check-predicate ($false-for-all? char-alphabetic? #\newline #\0 #\` #\@ #\{ #\[ #\~))
+
+($check-predicate (char-numeric? #\0 #\1 #\5 #\8 #\9))
+($check-predicate ($false-for-all? char-numeric? #\space #\/ #\: #\A))
+
+($check-predicate (char-whitespace? #\space #\newline))
+($check-predicate ($false-for-all? char-whitespace? #\0 #\a #\A #\:))
+; TODO ($check-predicate (char-whitespace? #\tab #\return ....))
+
+;; XXX char-upper-case? char-lower-case?
+
+($check-predicate (char-upper-case? #\A #\B #\R #\Y #\Z))
+($check-predicate ($false-for-all? char-upper-case? #\0 #\a #\z #\' #\@ #\{ #\[ #\~))
+($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
+
+($check equal? (char-upcase #\a) #\A)
+($check equal? (char-upcase #\z) #\Z)
+($check equal? (char-upcase #\R) #\R)
+($check equal? (char-upcase #\2) #\2)
+
+($check equal? (char-downcase #\A) #\a)
+($check equal? (char-downcase #\Z) #\z)
+($check equal? (char-downcase #\r) #\r)
+($check equal? (char-downcase #\9) #\9)
+
+;; XXX char->integer integer->char
+
+($check equal? (char->integer #\space) #x20)
+($check equal? (char->integer #\0) #x30)
+($check equal? (char->integer #\A) #x41)
+($check equal? (char->integer #\a) #x61)
+
+($check equal? (integer->char #x20) #\space)
+($check equal? (integer->char #x30) #\0)
+($check equal? (integer->char #x41) #\A)
+($check equal? (integer->char #x61) #\a)
diff --git a/src/tests/encapsulations.k b/src/tests/encapsulations.k
@@ -0,0 +1,59 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of encapsulation features.
+;;
+
+;; 8.1.1 make-encapsulation-type
+
+($let*
+ ( ((e1 p1? d1) (make-encapsulation-type))
+ ((e2 p2? d2) (make-encapsulation-type))
+ (v1 "test")
+ (v2 (list 1 2 3))
+ (r11 (e1 v1))
+ (r12 (e1 v2))
+ (r21 (e2 v1))
+ (r22 (e2 v2))
+ (r11* (e1 v1)))
+
+ ($check-not-predicate (equal? e1 e2))
+ ($check-not-predicate (equal? p1? p2?))
+ ($check-not-predicate (equal? d1 d2))
+
+ ($check-not-predicate (p1? v1))
+ ($check-not-predicate (p1? v2))
+ ($check-not-predicate (p1? e1))
+ ($check-not-predicate (p1? p1?))
+ ($check-not-predicate (p1? d2))
+ ($check-not-predicate (p1? 0))
+ ($check-not-predicate (p1? #f))
+ ($check-not-predicate (p1? #\x))
+ ($check-not-predicate (p1? (make-encapsulation-type)))
+
+ ($check-not-predicate (eq? r11 r12))
+ ($check-not-predicate (eq? r11 r21))
+ ($check-not-predicate (eq? r11 r22))
+ ($check-not-predicate (eq? r11 r11*))
+
+ ($check-not-predicate (equal? r11 r12))
+ ($check-not-predicate (equal? r11 r21))
+ ($check-not-predicate (equal? r11 r22))
+ ($check-not-predicate (equal? r11 r11*))
+
+ ($check-predicate (p1?))
+ ($check-predicate (p1? r11))
+
+ ($check-predicate (p1? r11 r12))
+ ($check-predicate (p2? r21 r22))
+ ($check-not-predicate (p1? r21))
+ ($check-not-predicate (p2? r11))
+
+ ($check eq? (d1 r11) v1)
+ ($check eq? (d1 r12) v2)
+ ($check eq? (d2 r21) v1)
+ ($check eq? (d2 r22) v2)
+
+ ($check-error (d1 r21))
+ ($check-error (d1 r22))
+ ($check-error (d2 r11))
+ ($check-error (d2 r12)))
diff --git a/src/tests/error.k b/src/tests/error.k
@@ -0,0 +1,69 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of error handling applicatives.
+;;
+
+;; XXX error
+;;
+($check-error (error "test"))
+
+;; XXX error-object? error-object-message error-object-irritants
+;;
+($let*
+ ( (capture-error-object
+ ($lambda (proc)
+ (guard-dynamic-extent
+ ()
+ proc
+ (list (list error-continuation
+ ($lambda (obj divert)
+ (apply divert obj)))))))
+ (e1 (capture-error-object ($lambda () (error "a"))))
+ (e2 (capture-error-object ($lambda () (error "b" 1 2 3))))
+ (e3 (capture-error-object ($lambda () (error))))
+ (e4 (capture-error-object ($lambda () (error 1)))))
+
+ ($check-predicate (error-object? e1 e2 e3))
+ ($check-not-predicate (error-object? ""))
+ ($check-not-predicate (error-object? #f))
+ ($check-not-predicate (error-object? ()))
+ ($check-not-predicate (error-object? 0))
+
+ ($check equal? (error-object-message e1) "a")
+ ($check equal? (error-object-message e2) "b")
+
+ ($check-error (error-object-message))
+ ($check-error (error-object-message e1 e2))
+ ($check-error (error-object-message "not an error object"))
+
+ ($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))
+
+ ($check-error (error-object-irritants))
+ ($check-error (error-object-irritants e1 e2))
+ ($check-error (error-object-irritants "not an error object")))
+
+;; XXX system-error-continuation
+
+($check-predicate (continuation? system-error-continuation))
+
+($let*
+ ( (catch-system-error
+ ($lambda (proc)
+ (guard-dynamic-extent
+ ()
+ proc
+ (list (list system-error-continuation
+ ($lambda (obj divert)
+ ($let
+ ( ( ((service code message errno) . tail)
+ (error-object-irritants obj)))
+ (apply divert (list* service code tail))))))))))
+
+ ($check equal?
+ (catch-system-error
+ ($lambda ()
+ (rename-file "nonexistent-file-name" "other-file-name")))
+ (list "rename" "ENOENT" "nonexistent-file-name" "other-file-name")))
diff --git a/src/tests/keyed-variables.k b/src/tests/keyed-variables.k
@@ -0,0 +1,87 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of features related to keyed variables.
+;;
+
+;; 10.1.1 make-keyed-dynamic-variable
+
+($check-error (make-keyed-dynamic-variable #f))
+
+($let*
+ ( ((b1 a1) (make-keyed-dynamic-variable))
+ ((b2 a2) (make-keyed-dynamic-variable))
+ (r1 ($lambda () (a1)))
+ (r2 ($lambda () (a2))))
+ ($check-predicate (applicative? b1))
+ ($check-predicate (applicative? a1))
+ ($check-error (b1 1 "not-a-combiner"))
+ ($check-error (b1 1 ($lambda ()) "extra-argument"))
+ ($check-error (b1 1))
+ ($check-error (a1 "extra-argument"))
+
+ ($check-not-predicate (equal? b1 b2))
+ ($check-not-predicate (equal? a1 a2))
+ ($check-predicate
+ (b1 1 ($vau () denv (not? ($binds? denv +)))))
+ ($check-not-predicate
+ (b1 1 ($vau () e1 (b2 2 ($vau () e2 (equal? e1 e2))))))
+
+ ($check equal? (b1 "value" ($lambda () "result")) "result")
+ ($check equal? (b1 0 r1) 0)
+ ($check equal? (b1 1 ($lambda () (b1 2 r1))) 2)
+ ($check equal? (b1 1 ($lambda () (b2 2 r1))) 1)
+ ($check equal? (b1 1 ($lambda () (b2 2 r2))) 2)
+
+ ($check-error (a1))
+ ($check-error (b1 0 r2)))
+
+;; 11.1.1 make-keyed-static-variable
+
+($check-error (make-keyed-static-variable #f))
+
+($let*
+ ( ((b1 a1) (make-keyed-static-variable))
+ ((b2 a2) (make-keyed-static-variable))
+ (e11 (b1 1 (get-current-environment)))
+ (e12 (b1 2 (get-current-environment)))
+ (e21 (b2 1 (get-current-environment)))
+ (e22 (b2 2 (get-current-environment)))
+ (e11* (b1 1 (get-current-environment)))
+ (r11 (eval ($quote ($lambda (a) (a))) e11))
+ (r12 (eval ($quote ($lambda (a) (a))) e12))
+ (r11_13
+ (eval
+ ($quote
+ ($let ((e13 (b1 3 (get-current-environment))))
+ (eval ($quote ($lambda (a) (a))) e13)))
+ e11))
+ (r11_22
+ (eval
+ ($quote
+ ($let ((e22 (b2 2 (get-current-environment))))
+ (eval ($quote ($lambda (a) (a))) e22)))
+ e11)))
+ ($check-predicate (applicative? b1))
+ ($check-predicate (applicative? a1))
+ ($check-error (b1 1 "not-an-environment"))
+ ($check-error (b1 1 (get-current-environment) "extra"))
+ ($check-error (b1 1))
+ ($check-error (a1 "extra-argument"))
+
+ ($check-not-predicate (equal? b1 b2))
+ ($check-not-predicate (equal? a1 a2))
+ ($check-predicate (environment? e11))
+ ($check-not-predicate (equal? e11 e12))
+ ($check-not-predicate (equal? e11 e21))
+ ($check-not-predicate (equal? e11 e11*))
+
+ ($check equal? (eval (list a1) e11) 1)
+ ($check equal? (eval (list a1) e12) 2)
+ ($check equal? (r11 a1) 1)
+ ($check equal? (r12 a1) 2)
+ ($check equal? (r11_13 a1) 3)
+ ($check equal? (r11_22 a1) 1)
+ ($check equal? (r11_22 a2) 2)
+
+ ($check-error (a1))
+ ($check-error (r11_13 a2)))
diff --git a/src/tests/ports.k b/src/tests/ports.k
@@ -2,12 +2,10 @@
;;
;; Tests of i/o features.
;;
-;; TODO: Make the test portable.
-;; TODO: Delete temporary files.
-
-;; Utilities for testing input and output features.
+;; Utilities for testing input and output features:
;;
;; temp-file .......... temporary file for input and output
+;; temp-file-2 ........ second temporary file for input and output
;; test-input-file .... pre-existing file for input
;; nonexistent-file ... valid file name denoting non-existent file
;; invalid-file ....... invalid file name
@@ -18,8 +16,14 @@
;; the contents of the file is the contents of the string.
;; Otherwise, empty file is prepared.
;;
+;; ($output-test PROGRAM) ... evaluates PROGRAM with current
+;; output port initialized for writing to a temporary file.
+;; Returns the contents of the temporary file as string.
+;;
-($define! temp-file "/tmp/klisp-ports-test.txt")
+;; Hope that the file names will work under both Unix and Windows.
+($define! temp-file "klisp-ports-test-1.txt")
+($define! temp-file-2 "klisp-ports-test-2.txt")
($define! test-input-file "tests/ports.k")
($define! nonexistent-file "nonexistent-file.txt")
($define! invalid-file "!@#$%^&*/invalid/file/name.txt")
@@ -27,7 +31,9 @@
($define! prepare-input
($lambda (text)
(with-output-to-file temp-file
- ($lambda () ($if (string? text) (display text) #inert)))))
+ ($lambda () ($if (string? text)
+ (display text)
+ #inert)))))
($define! read-string-until-eof
($lambda ()
@@ -61,6 +67,18 @@
(eval-with-output program denv)
(with-input-from-file temp-file read-string-until-eof)))
+($define! call-with-closed-input-port
+ ($lambda (program)
+ ($let ((port (open-input-file test-input-file)))
+ (close-input-file port)
+ (program port))))
+
+($define! call-with-closed-output-port
+ ($lambda (program)
+ ($let ((port (open-output-file temp-file)))
+ (close-output-file port)
+ (program port))))
+
;; 15.1.1 port?
($check-predicate (port? (get-current-input-port) (get-current-output-port)))
@@ -115,19 +133,27 @@
;; 15.1.5 open-input-file open-output-file
;; 15.1.6 close-input-file close-output-file
-($let ((p (open-input-file test-input-file)))
- ($check-predicate (port? p))
- ($check-predicate (input-port? p))
- ($check-not-predicate (equal? p (get-current-input-port)))
- ($check-not-predicate (equal? p (get-current-output-port)))
- (close-input-file p))
+($check-no-error
+ ($let ((p (open-input-file test-input-file)))
+ ($check-predicate (port? p))
+ ($check-predicate (input-port? p))
+ ($check-not-predicate (equal? p (get-current-input-port)))
+ ($check-not-predicate (equal? p (get-current-output-port)))
+ (close-input-file p)
+ (close-input-file p)))
-($let ((p (open-output-file temp-file)))
- ($check-predicate (port? p))
- ($check-predicate (output-port? p))
- ($check-not-predicate (equal? p (get-current-input-port)))
- ($check-not-predicate (equal? p (get-current-output-port)))
- (close-output-file p))
+($check-error (call-with-closed-output-port close-input-file))
+
+($check-no-error
+ ($let ((p (open-output-file temp-file)))
+ ($check-predicate (port? p))
+ ($check-predicate (output-port? p))
+ ($check-not-predicate (equal? p (get-current-input-port)))
+ ($check-not-predicate (equal? p (get-current-output-port)))
+ (close-output-file p)
+ (close-output-file p)))
+
+($check-error (call-with-closed-input-port close-output-file))
;; 15.1.7 read
@@ -142,19 +168,51 @@
($check equal? ($input-test "1 2" ($sequence (read) (read))) 2)
($check-predicate (eof-object? ($input-test "1 2" ($sequence (read) (read) (read)))))
+($check-error ((read (get-current-output-port))))
+($check-error (call-with-closed-input-port read))
+
;; 15.1.8 write
($check equal? ($output-test #inert) "")
-($check equal? ($output-test (write 123)) "123")
-($check equal? ($output-test (write (list 1 2 #t #f #inert ()))) "(1 2 #t #f #inert ())")
-($check equal? ($output-test (write (list 1 2 (list 3 4 5) (list* 6 7)))) "(1 2 (3 4 5) (6 . 7))")
+
+($check equal?
+ ($output-test (write (list 123 12345678901234567890 1/2 -3.14)))
+ "(123 12345678901234567890 1/2 -3.14)")
+($check equal?
+ ($output-test (write (list #e+infinity #e-infinity #i+infinity #i-infinity #real #undefined)))
+ "(#e+infinity #e-infinity #i+infinity #i-infinity #real #undefined)")
+($check equal?
+ ($output-test (write (list #\x #\newline #\space)))
+ "(#\\x #\\newline #\\space)")
+($check equal?
+ ($output-test (write (list #t #f)))
+ "(#t #f)")
+($check equal?
+ ($output-test (write (list #inert #ignore)))
+ "(#inert #ignore)")
+
+($check equal? ($output-test (write "")) "\"\"")
+($check equal? ($output-test (write "a\\b\"")) "\"a\\\\b\\\"\"")
+
+($check equal?
+ ($output-test (write (list 1 2 (list 3 4 5) () (list* 6 7))))
+ "(1 2 (3 4 5) () (6 . 7))")
+($check equal?
+ ($output-test (write ($quote #0=(1 2 #1=(3 4 . #0#) #2="abc" #3=(5 6 #1# #2# #3# . #0#)))))
+ "#0=(1 2 #1=(3 4 . #0#) #2=\"abc\" #3=(5 6 #1# #2# #3# . #0#))")
+
+($check-error (write 0 (get-current-input-port)))
+($check-error (call-with-closed-output-port ($lambda (p) (write 0 p))))
;; 15.2.1 call-with-input-file call-with-output-file
;; 15.2.2 load
;; 15.2.3 get-module
;; TODO
-;; Additional input functions: read-char peek-char
+;; Additional input functions: eof-object? read-char peek-char
+
+($check-predicate ($false-for-all? eof-object?
+ 0 -1 #t #f () "" (get-current-input-port)))
($check-predicate (eof-object? ($input-test "" (read-char))))
($check-predicate (eof-object? ($input-test "" (peek-char))))
@@ -167,12 +225,97 @@
($check equal? ($input-test "ab" ($sequence (read-char) (read-char))) #\b)
($check equal? ($input-test "ab" ($sequence (peek-char) (read-char))) #\a)
+($check equal? ($input-test "a" (read-char (get-current-input-port))) #\a)
+($check-error ((read-char (get-current-output-port))))
+($check-error (call-with-closed-input-port read-char))
+
+($check equal? ($input-test "a" (peek-char (get-current-input-port))) #\a)
+($check-error ((peek-char (get-current-output-port))))
+($check-error (call-with-closed-input-port peek-char))
+
;; Additional input functions: char-ready?
;; TODO
-;; Additional output functions: write-char newline display
+;; Additional output functions: write-char newline display flush-ouput-port
($check equal? ($output-test (write-char #\a)) "a")
-($check equal? ($output-test (newline)) (list->string (list #\newline)))
-($check equal? ($output-test (display "abc")) "abc")
+($check equal? ($output-test (write-char #\a (get-current-output-port))) "a")
+($check-error (write-char #\a (get-current-input-port)))
+($check-error (call-with-closed-output-port ($lambda (p) (write-char #\a p))))
+($check equal? ($output-test (newline)) (string #\newline))
+($check equal? ($output-test (newline (get-current-output-port))) (string #\newline))
+($check-error (newline (get-current-input-port)))
+($check-error (call-with-closed-output-port newline))
+
+($check equal? ($output-test (display "")) "")
+($check equal? ($output-test (display "abc")) "abc")
+($check equal? ($output-test (display "a\\b\"")) "a\\b\"")
+($check equal? ($output-test (display #\x)) "x")
+($check equal? ($output-test (display "abc" (get-current-output-port))) "abc")
+($check-error ($output-test (display "abc" (get-current-input-port))))
+($check-error (call-with-closed-output-port ($lambda (p) (display "abc" p))))
+
+($check equal? ($output-test (flush-output-port)) "")
+($check equal? ($output-test (flush-output-port (get-current-output-port))) "")
+($check-error (flush-output-port (get-current-input-port)))
+($check-error (call-with-closed-output-port flush-output-port))
+
+;; Currently, write and write-char flush automatically
+;; and flush-output-port causes no effect.
+;;
+;; ($define! colliding-output-test
+;; ($lambda (combiner)
+;; (call-with-output-file temp-file
+;; ($lambda (p1)
+;; (call-with-output-file temp-file
+;; ($lambda (p2)
+;; (combiner p1 p2)))))
+;; (with-input-from-file temp-file read-string-until-eof)))
+;;
+;; ($check equal?
+;; (colliding-output-test ($lambda (p1 p2)
+;; (display "1" p1)
+;; (display "2" p2)
+;; (flush-output-port p1)
+;; (flush-output-port p2)))
+;; "12")
+;;
+;; ($check equal?
+;; (colliding-output-test ($lambda (p1 p2)
+;; (display "1" p1)
+;; (display "2" p2)
+;; (flush-output-port p2)
+;; (flush-output-port p1)))
+;; "21")
+
+
+;; File manipulation functions: file-exists? delete-file rename-file
+
+($check-predicate (file-exists? test-input-file))
+($check-not-predicate (file-exists? nonexistent-file))
+($check-not-predicate (file-exists? invalid-file))
+
+($check-no-error (prepare-input "test"))
+($check-predicate (file-exists? temp-file))
+($check-no-error (delete-file temp-file))
+($check-not-predicate (file-exists? temp-file))
+($check-error (delete-file nonexistent-file))
+($check-error (delete-file invalid-file))
+
+($check-no-error (prepare-input "test"))
+($check-predicate (file-exists? temp-file))
+($check-not-predicate (file-exists? temp-file-2))
+($check-no-error (rename-file temp-file temp-file-2))
+($check-predicate (file-exists? temp-file-2))
+($check-not-predicate (file-exists? temp-file))
+($check-no-error (delete-file temp-file-2))
+
+($check-error (rename-file nonexistent-file temp-file))
+($check-error (rename-file invalid-file temp-file))
+
+;; Cleanup.
+;; Check that temporary files were deleted.
+
+($check-not-predicate (file-exists? temp-file))
+($check-not-predicate (file-exists? temp-file-2))
diff --git a/src/tests/promises.k b/src/tests/promises.k
@@ -0,0 +1,106 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of promises - lazy evaluation features.
+;;
+
+;; 9.1.1 promise?
+
+($check-predicate (promise?))
+($check-predicate (promise? ($lazy 0) (memoize 0)))
+($check-not-predicate (promise? 0))
+($check-not-predicate (promise? ()))
+($check-not-predicate (promise? #inert))
+
+;; 9.1.2 force
+
+($check equal? (force 0) 0)
+($check equal? (force (force 1)) 1)
+($check equal? (force ($lazy 2)) 2)
+($check equal? (force (force ($lazy 3))) 3)
+($check equal? (force ($lazy ($lazy 4))) 4)
+($check-error (force))
+($check-error (force "too" "many"))
+
+;; 9.1.3 $lazy
+
+($check-error ($lazy))
+($check-error ($lazy "too" "many"))
+
+;; Test cases from R(-1)RK
+
+($define! lazy-test-1
+ ($sequence
+ ($provide! (get-count p)
+ ($define! count 5)
+ ($define! get-count ($lambda () count))
+ ($define! p
+ ($let ((self (get-current-environment)))
+ ($lazy
+ ($if (<=? count 0)
+ count
+ ($sequence
+ ($set! self count (- count 1))
+ (force p)
+ ($set! self count (+ count 2))
+ count))))))
+ ($check equal? (get-count) 5)
+ ($check equal? (force p) 0)
+ ($check equal? (get-count) 10)))
+
+($define! lazy-test-2
+ ($let
+ ((temp-file "klisp-ports-test.txt"))
+ (with-output-to-file temp-file
+ ($lambda ()
+ ($define! p1 ($lazy (display "*")))
+ ($define! p2 ($lazy p1))
+ (force p2)
+ (force p1)))
+ ($let
+ ((result (with-input-from-file temp-file read)))
+ (delete-file temp-file)
+ result)))
+
+($check equal? lazy-test-2 ($quote *))
+
+;; The third test constructs infinite lazy list
+;; and forces first 100 elements. The Kernel Report
+;; version forces 10^10 elements.
+;;
+;; TODO: Test the original version in separate script
+;; as a benchmark.
+;;
+($define! lazy-test-3
+ ($sequence
+ ($define! stream-filter
+ ($lambda (p? s)
+ ($lazy
+ ($let ((v (force s)))
+ ($if (null? v)
+ v
+ ($let ((s (stream-filter p? (cdr v))))
+ ($if (p? (car v))
+ (cons (car v) s)
+ s)))))))
+ ($define! from
+ ($lambda (n)
+ ($lazy (cons n (from (+ n 1))))))
+ (force
+ (stream-filter ($lambda (n) (=? n 100))
+ (from 0)))))
+
+($check equal? (car lazy-test-3) 100)
+
+;; 9.1.4 memoize
+
+($check-error (memoize))
+($check-error (memoize "too" "many"))
+
+($check equal? (force (memoize 0)) 0)
+($check equal? (force (force (memoize 0))) 0)
+($check-predicate (promise? (force (memoize (memoize 0)))))
+($check equal? (force (force (memoize (memoize 0)))) 0)
+($check-predicate (promise? (force (memoize ($lazy 0)))))
+($check equal? (force (force (memoize ($lazy 0)))) 0)
+($check equal? (force ($lazy (memoize 0))) 0)
+($check equal? (force (force ($lazy (memoize 0)))) 0)
diff --git a/src/tests/strings.k b/src/tests/strings.k
@@ -0,0 +1,221 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of string features.
+;;
+
+;; XXX immutability of string constants
+
+($check-predicate (immutable-string? ""))
+($check-predicate (immutable-string? "abcd"))
+
+;; 13.?.? string?
+
+($check-predicate (string?))
+($check-predicate (string? "" "abcdef"))
+
+($check-not-predicate (string? #\a))
+($check-not-predicate (string? 0))
+($check-not-predicate (string? #f))
+($check-not-predicate (string? ()))
+($check-not-predicate (string? #inert))
+
+;; XXX string=? string<? string<=? string>? string>=?
+;; XXX string-ci=? string-ci<? string-ci<=? string-ci>? string-ci>=?
+
+($check-predicate (string=? "" ""))
+($check-predicate (string=? "abcd" "abcd"))
+($check-not-predicate (string=? "abcd" ""))
+($check-not-predicate (string=? "abcd" "ABCD"))
+($check-not-predicate (string=? "aa" "aaa"))
+
+($check-predicate (string<? "" "a"))
+($check-predicate (string<? "a" "b"))
+($check-predicate (string<? "a" "ab"))
+($check-predicate (string<? "A" "a"))
+($check-not-predicate (string<? "a" ""))
+($check-not-predicate (string<? "aaa" "a"))
+($check-not-predicate (string<? "b" "a"))
+
+($check-predicate ($true-for-all-combinations? string<=?
+ ("" "A") ("a" "A" "ab")))
+
+($check-predicate ($true-for-all-combinations? string>?
+ ("b" "c") ("" "a")))
+
+($check-predicate ($true-for-all-combinations? string>=?
+ ("b" "c") ("" "a" "b")))
+
+($check-predicate (string-ci=? "" ""))
+($check-predicate (string-ci=? "abcd" "AbCd"))
+($check-not-predicate (string-ci=? "abcd" ""))
+($check-not-predicate (string=? "aa" "AAA"))
+
+($check-predicate ($true-for-all-combinations? string-ci<?
+ ("" "a" "A") ("ab" "AB" "b" "B")))
+($check-predicate ($false-for-all-combinations? string-ci<?
+ ("b" "B") ("" "a" "A" "aa" "b" "B" "ab" "aB" "Ab" "AB")))
+
+($check-predicate ($true-for-all-combinations? string-ci<=?
+ ("" "A" "a") ("a" "A" "ab")))
+
+($check-predicate ($true-for-all-combinations? string-ci>?
+ ("b" "B" "c" "C") ("" "a" "A")))
+
+($check-predicate ($true-for-all-combinations? string-ci>=?
+ ("b" "B" "c" "C") ("" "a" "A" "b" "B")))
+
+;; XXX make-string
+
+($check-predicate (string? (make-string 0)))
+($check-predicate (string? (make-string 1)))
+($check equal? (make-string 0) "")
+($check equal? (make-string 0 #\a) "")
+($check equal? (make-string 3 #\a) "aaa")
+($check equal? (string-length (make-string 1000)) 1000)
+($check equal? (string-length (make-string 1000 #\a)) 1000)
+($check-error (make-string -1))
+($check-error (make-string -1 #\a))
+
+;; XXX string
+
+($check-predicate (string? (string)))
+($check-predicate (string? (string #\a #\b #\c)))
+($check equal? (string) "")
+($check equal? (string #\a #\b #\c) "abc")
+($check-not-predicate ($let ((x (string #\a)) (y (string #\a))) (eq? x y)))
+
+;; XXX string-length
+
+($check equal? (string-length "") 0)
+($check equal? (string-length "0123456789") 10)
+
+;; XXX string-ref
+
+($check equal? (string-ref "0123456789" 0) #\0)
+($check equal? (string-ref "0123456789" 9) #\9)
+($check-error (string-ref "0123456789" 10))
+($check-error (string-ref "0123456789" -1))
+($check-error (string-ref "" 0))
+
+;; XXX string-set!
+
+($check equal? ($let ((s (make-string 2 #\a))) (string-set! s 0 #\b) s) "ba")
+($check equal? ($let ((s (make-string 2 #\a))) (string-set! s 1 #\b) s) "ab")
+($check-error (string-set! (make-string 2) -1 #\a))
+($check-error (string-set! (make-string 2) 3 #\a))
+($check-error (string-set! "const" 3 #\a))
+
+;; XXX string-fill!
+
+($check equal? ($let ((s (make-string 3 #\a))) (string-fill! s #\b) s) "bbb")
+($check-error (string-fill! "const" #\x))
+
+;; Note: Empty string is always immutable. Therefore,
+;; it is an error to call string-fill! on empty string.
+
+($check-error (string-fill! (make-string 0) #\b))
+
+;; XXX substring
+
+($check equal? (substring "" 0 0) "")
+($check equal? (substring "abcdef" 0 0) "")
+($check equal? (substring "abcdef" 3 3) "")
+($check equal? (substring "abcdef" 5 5) "")
+($check equal? (substring "abcdef" 6 6) "")
+($check equal? (substring "abcdef" 2 5) "cde")
+($check equal? (substring "abcdef" 0 6) "abcdef")
+($check-error (substring "abcdef" -1 0))
+($check-error (substring "abcdef" 10 11))
+($check-error (substring "abcdef" 3 10))
+($check-error (substring "abcdef" 4 2))
+
+
+;; immutable strings are eq? iff string=?
+;; Andres Navarro
+($check-predicate
+ ($let* ((p "abc") (q (substring p 0 3)))
+ (eq? p q)))
+
+;; string-copy always generate mutable strings
+;; Andres Navarro
+($check-not-predicate
+ ($let* ((p (string-copy "abc")) (q (substring p 0 3)))
+ (eq? p q)))
+
+($check-predicate (immutable-string? (substring "abc" 0 0)))
+($check-predicate (immutable-string? (substring "abc" 0 1)))
+
+;; XXX string-append
+
+($check equal? (string-append) "")
+($check equal? (string-append "") "")
+($check equal? (string-append "a") "a")
+($check equal? (string-append "a" "b") "ab")
+($check equal? (string-append "a" "b" "c") "abc")
+
+($check-not-predicate
+ ($let* ((p "abc") (q (string-append p)))
+ (eq? p q)))
+
+($check-predicate (nonempty-mutable-string? (string-append "a" "b")))
+
+;; XXX string-copy
+
+($check equal? (string-copy "") "")
+($check equal? (string-copy "abcd") "abcd")
+
+($check-not-predicate
+ ($let* ((p "abc") (q (string-copy p)))
+ (eq? p q)))
+
+($check-predicate (nonempty-mutable-string? (string-copy "abc")))
+
+;; XXX string->immutable-string
+
+($check equal? (string->immutable-string "") "")
+($check equal? (string->immutable-string "abcd") "abcd")
+
+($check-not-predicate
+ ($let* ((p "abc") (q (string-copy p)))
+ (eq? p q)))
+
+($check-predicate (immutable-string? (string->immutable-string "")))
+($check-predicate (immutable-string? (string->immutable-string "abc")))
+($check-predicate (immutable-string? (string->immutable-string (make-string 10))))
+
+;; XXX string->list
+
+($check equal? (string->list "") ())
+($check equal? (string->list "abc") (list #\a #\b #\c))
+
+;; XXX list->string
+
+($check equal? (list->string ()) "")
+($check equal? (list->string (list #\a #\b #\c)) "abc")
+
+($check-not-predicate
+ ($let*
+ ( (cs (list #\a #\b #\c))
+ (x (list->string cs))
+ (y (list->string cs)))
+ (eq? x y)))
+
+($check-predicate (nonempty-mutable-string? (list->string (list #\a #\b))))
+
+($check-error (list->string ($quote (#\a #0=(#\a . #0#)))))
+
+;; 13.1.1 string->symbol
+;; XXX symbol->string
+;;
+
+($check-predicate (symbol? (string->symbol "abcd")))
+($check-predicate (symbol? (string->symbol "")))
+($check-predicate (symbol? (string->symbol "0")))
+($check-predicate (symbol? (string->symbol "#inert")))
+
+($check equal? (string->symbol "abcd") ($quote abcd))
+($check equal? (symbol->string ($quote abcd)) "abcd")
+
+($check equal?
+ ($quote sym)
+ (string->symbol (symbol->string ($quote sym))))
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -14,7 +14,13 @@
(load "tests/environments.k")
(load "tests/environment-mutation.k")
(load "tests/combiners.k")
+(load "tests/encapsulations.k")
+(load "tests/promises.k")
+(load "tests/keyed-variables.k")
(load "tests/numbers.k")
+(load "tests/strings.k")
+(load "tests/characters.k")
(load "tests/ports.k")
+(load "tests/error.k")
(check-report)
diff --git a/src/tests/test-helpers.k b/src/tests/test-helpers.k
@@ -7,6 +7,12 @@
($define! not-equal? ($lambda (x y) (not? (equal? x y))))
($define! $check-predicate ($vau (x) denv (eval (list $check eq? x #t) denv)))
($define! $check-not-predicate ($vau (x) denv (eval (list $check eq? x #f) denv)))
+($define! $check-no-error ($vau (x) denv
+ (eval (list $check
+ ($lambda (#ignore #ignore) #t)
+ x
+ #inert)
+ denv)))
($define! mutable-pair?
($lambda (obj)
@@ -24,4 +30,67 @@
(apply divert #f))))))))
($define! immutable-pair?
- ($lambda (obj) ($and? (pair? obj) (not? (mutable-pair? obj)))))
-\ No newline at end of file
+ ($lambda (obj) ($and? (pair? obj) (not? (mutable-pair? obj)))))
+
+($define! nonempty-mutable-string?
+ ($lambda (obj)
+ ($and?
+ (string? obj)
+ (>? (string-length obj) 0)
+ (guard-dynamic-extent
+ ()
+ ($lambda () (string-fill! obj #\x) #t)
+ (list
+ (list error-continuation
+ ($lambda (#ignore divert) (apply divert #f))))))))
+
+($define! immutable-string?
+ ($lambda (obj) ($and? (string? obj) (not? (nonempty-mutable-string? obj)))))
+
+;; XXX/TODO Some of these could be removed if we had eager comprehension in
+;; check.k (which would also complete the srfi-78 implementation). The problem
+;; is that the design adaptation from macros to operatives should be taken
+;; with some care. I intended to do it before the remaining tests, but since
+;; Oto Havle went ahead and wrote the tests without it, they have lost some
+;; priority. Andres Navarro
+
+;; ($false-for-all? P XS) evaluates to #t iff (P X) evaluates
+;; to #f for all members X of the list XS.
+;;
+($define! $false-for-all?
+ ($vau (p . xs) denv
+ (apply and?
+ (map ($lambda (x) (not? (eval (list p x) denv))) xs))))
+
+;; (cartesian-product XS YS) returns list of all pairs (X Y),
+;; where X is a member of the list XS and Y is a member of list YS.
+;;
+;; for example
+;; (cartesian-product (1 2) (3 4)) ===> ((1 3) (1 4) (2 3) (2 4))
+;;
+($define! cartesian-product
+ ($lambda (xs ys)
+ (apply append
+ (map ($lambda (x) (map ($lambda (y) (list x y)) ys)) xs))))
+
+;; ($true-for-all-combinations? BIN (X1 X2...) (Y1 Y1...))
+;; evaluates to #t, iff (BIN X Y) evaluates to #t for all X and Y.
+;;
+($define! $true-for-all-combinations?
+ ($vau (p xs ys) denv
+ (apply and?
+ (map ($lambda ((x y)) (eval (list p x y) denv))
+ (cartesian-product xs ys)))))
+
+;; ($false-for-all-combinations? BIN (X1 X2...) (Y1 Y2...))
+;; evaluates to #t, iff (BIN X Y) evaluates to #f for all X and Y.
+;;
+($define! $false-for-all-combinations?
+ ($vau (p xs ys) denv
+ (apply and?
+ (map ($lambda ((x y)) (not? (eval (list p x y) denv)))
+ (cartesian-product xs ys)))))
+
+;; ($quote V) evaluates to V. The value V itself is not evaluated.
+;; See section 5.5.1, page 67 of the Kernel Report.
+($define! $quote ($vau (x) #ignore x))
