Commit db9573bc authored by Erick Gallesio's avatar Erick Gallesio

Starting integration of FFI

parent 78dddb63
......@@ -2110,7 +2110,7 @@ fi
# Define the identity of the package.
PACKAGE=stklos
VERSION=0.95
VERSION=0.96
cat >>confdefs.h <<_ACEOF
......
......@@ -2,12 +2,12 @@ dnl configure.in for STklos
dnl
dnl Author: Erick Gallesio [eg@unice.fr]
dnl Creation date: 28-Dec-1999 21:19 (eg)
dnl Last file update: 7-Jun-2007 10:55 (eg)
dnl Last file update: 12-Jun-2007 10:01 (eg)
AC_INIT(src/stklos.c)
AC_PREREQ(2.52)
AM_INIT_AUTOMAKE(stklos, 0.95)
AM_INIT_AUTOMAKE(stklos, 0.96)
AM_CONFIG_HEADER(src/stklosconf.h)
AC_PROG_MAKE_SET
......
;;;;
;;;; ffi.stk -- FFI support
;;;;
;;;; Copyright 2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 14-Bun-2007 09:24 (eg)
;;;; Last file update: 15-Jun-2007 12:20 (eg)
;;;;
(define-macro (define-external name parameters . args)
(define arg-type->number
(let ((table '((:void 0)
(:char 1)
(:short 2)
(:ushort 3)
(:int 4)
(:uint 5)
(:long 6)
(:ulong 7)
(:lonlong 8)
(:ulonlong 9)
(:float 10)
(:double 11)
(:boolean 12)
(:pointer 13)
(:string 14)
(:int8 15)
(:int16 16)
(:int32 17)
(:int64 18))))
(lambda (k argument?)
(let ((info (assoc k table)))
(if info
(let ((r (cadr info)))
(if (and (zero? r) argument?)
(error 'define-external "parameter of type :void are forbidden")
(cadr info)))
(error 'define-external "bad type name ~S" k))))))
(define (parse-parameters lst)
(map (lambda (x)
(cond
((keyword? x) (arg-type->number x #t))
((pair? x)
(match-case x
(((? symbol?) (? keyword?))
(arg-type->number (cadr x) #t))
(else
(error 'define-external "bad parameter description: ~S" x))))
(else
(error 'define-external "bad parameter description: ~S" x))))
lst))
(let ((args (parse-parameters parameters))
(lib-name (key-get args :library-name ""))
(entry-name (key-get args :entry-name (symbol->string name)))
(return-type (key-get args :return-type :void)))
`(define ,name
(%make-ext-func ,entry-name
',args
,(arg-type->number return-type #f)
,lib-name))))
(define-external isatty ((fd :int))
:return-type :boolean)
(define-external ttyname (:int)
:return-type :string)
(define-external labs (:long)
:return-type :long)
(define-external longabs (:long)
:entry-name "labs"
:return-type :long)
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 4-Jun-2000 15:07 (eg)
;;;; Last file update: 8-Jun-2007 10:32 (eg)
;;;; Last file update: 15-Jun-2007 12:09 (eg)
;;;;
;; This file defines the REPL module. This module does not export anything
......@@ -200,9 +200,9 @@ doc>
(let ((line1 (format "STklos version ~A\n" (version)))
(line2 "Copyright (C) 1999-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>\n")
(line3 (format "[~a/~a]\n" (machine-type) (%thread-system))))
(display (do-color 'bold 'red "* " 'bold 'green line1))
(display (do-color 'bold 'red " * " 'bold 'green line2))
(display (do-color 'bold 'red "* * " 'bold 'green line3 'normal))))
(display (do-color 'bold 'black "* " 'bold 'green line1))
(display (do-color 'bold 'black " * " 'bold 'green line2))
(display (do-color 'bold 'black "* * " 'bold 'green line3 'normal))))
((main-repl-hook))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 15-Jan-2007 12:10 (eg)
;;;; Last file update: 7-Jun-2007 12:21 (eg)
;;;; Last file update: 12-Jun-2007 10:01 (eg)
;;;;
;; ----------------------------------------------------------------------
......@@ -61,7 +61,7 @@
(format "~a-test" package)
spi)
(printf "\techo 'Running test'\n")
(printf "\tstklos -l ~a -e '(begin (import ~a-test) (run '\\''()))'\n\n"
(printf "\tstklos -c -l ~a -e '(begin (import ~a-test) (run '\\''()))'\n\n"
(format "~a-test.ostk" package)
package))
(printf "\t@echo '**** No test provided with package ~A'\n" package))))
......
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 14-May-2007 10:21 (eg)
# Last file update: 14-Jun-2007 13:47 (eg)
CC = @CC@
CFLAGS = @CFLAGS@ @STKCFLAGS@
......@@ -31,7 +31,7 @@ if NO_THREAD
endif
stklos_SOURCES = base64.c boolean.c boot.c char.c cond.c dynload.c env.c error.c \
extend.c fixnum.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
extend.c ffi.c fixnum.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c md5.c number.c object.c parameter.c path.c port.c print.c \
proc.c process.c promise.c read.c regexp.c \
signal.c sio.c socket.c sport.c stklos.c str.c struct.c \
......@@ -69,7 +69,7 @@ pcre = @PCRE@
pcrelib = @PCRELIB@
pcreinc = @PCREINC@
stklos_LDADD = $(compatlib) $(gmplib) $(pcrelib) $(gclib) -lm
stklos_LDADD = $(compatlib) $(gmplib) $(pcrelib) $(gclib) -lcinvoke -lm
stklos_LDFLAGS = @SH_MAIN_LOAD_FLAGS@
INCLUDES = $(gmpinc) $(pcreinc) $(gcinc)
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 14-May-2007 10:21 (eg)
# Last file update: 14-Jun-2007 13:47 (eg)
VPATH = @srcdir@
......@@ -52,14 +52,14 @@ am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(extraincdir)"
binPROGRAMS_INSTALL = $(INSTALL_PROGRAM)
PROGRAMS = $(bin_PROGRAMS)
am__stklos_SOURCES_DIST = base64.c boolean.c boot.c char.c cond.c \
dynload.c env.c error.c extend.c fixnum.c fport.c gnu-getopt.c \
gnu-glob.c hash.c keyword.c lib.c list.c misc.c md5.c number.c \
object.c parameter.c path.c port.c print.c proc.c process.c \
promise.c read.c regexp.c signal.c sio.c socket.c sport.c \
stklos.c str.c struct.c symbol.c system.c uvector.c vector.c \
vm.c vport.c thread-common.c thread-lurc.c mutex-common.c \
mutex-lurc.c thread-none.c mutex-none.c thread-pthreads.c \
mutex-pthreads.c
dynload.c env.c error.c extend.c ffi.c fixnum.c fport.c \
gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c list.c misc.c \
md5.c number.c object.c parameter.c path.c port.c print.c \
proc.c process.c promise.c read.c regexp.c signal.c sio.c \
socket.c sport.c stklos.c str.c struct.c symbol.c system.c \
uvector.c vector.c vm.c vport.c thread-common.c thread-lurc.c \
mutex-common.c mutex-lurc.c thread-none.c mutex-none.c \
thread-pthreads.c mutex-pthreads.c
@LURC_FALSE@@NO_THREAD_FALSE@@PTHREADS_TRUE@am__objects_1 = thread-common.$(OBJEXT) \
@LURC_FALSE@@NO_THREAD_FALSE@@PTHREADS_TRUE@ thread-pthreads.$(OBJEXT) \
@LURC_FALSE@@NO_THREAD_FALSE@@PTHREADS_TRUE@ mutex-common.$(OBJEXT) \
......@@ -71,18 +71,18 @@ am__stklos_SOURCES_DIST = base64.c boolean.c boot.c char.c cond.c \
@LURC_TRUE@ mutex-lurc.$(OBJEXT)
am_stklos_OBJECTS = base64.$(OBJEXT) boolean.$(OBJEXT) boot.$(OBJEXT) \
char.$(OBJEXT) cond.$(OBJEXT) dynload.$(OBJEXT) env.$(OBJEXT) \
error.$(OBJEXT) extend.$(OBJEXT) fixnum.$(OBJEXT) \
fport.$(OBJEXT) gnu-getopt.$(OBJEXT) gnu-glob.$(OBJEXT) \
hash.$(OBJEXT) keyword.$(OBJEXT) lib.$(OBJEXT) list.$(OBJEXT) \
misc.$(OBJEXT) md5.$(OBJEXT) number.$(OBJEXT) object.$(OBJEXT) \
parameter.$(OBJEXT) path.$(OBJEXT) port.$(OBJEXT) \
print.$(OBJEXT) proc.$(OBJEXT) process.$(OBJEXT) \
promise.$(OBJEXT) read.$(OBJEXT) regexp.$(OBJEXT) \
signal.$(OBJEXT) sio.$(OBJEXT) socket.$(OBJEXT) \
sport.$(OBJEXT) stklos.$(OBJEXT) str.$(OBJEXT) \
struct.$(OBJEXT) symbol.$(OBJEXT) system.$(OBJEXT) \
uvector.$(OBJEXT) vector.$(OBJEXT) vm.$(OBJEXT) \
vport.$(OBJEXT) $(am__objects_1)
error.$(OBJEXT) extend.$(OBJEXT) ffi.$(OBJEXT) \
fixnum.$(OBJEXT) fport.$(OBJEXT) gnu-getopt.$(OBJEXT) \
gnu-glob.$(OBJEXT) hash.$(OBJEXT) keyword.$(OBJEXT) \
lib.$(OBJEXT) list.$(OBJEXT) misc.$(OBJEXT) md5.$(OBJEXT) \
number.$(OBJEXT) object.$(OBJEXT) parameter.$(OBJEXT) \
path.$(OBJEXT) port.$(OBJEXT) print.$(OBJEXT) proc.$(OBJEXT) \
process.$(OBJEXT) promise.$(OBJEXT) read.$(OBJEXT) \
regexp.$(OBJEXT) signal.$(OBJEXT) sio.$(OBJEXT) \
socket.$(OBJEXT) sport.$(OBJEXT) stklos.$(OBJEXT) \
str.$(OBJEXT) struct.$(OBJEXT) symbol.$(OBJEXT) \
system.$(OBJEXT) uvector.$(OBJEXT) vector.$(OBJEXT) \
vm.$(OBJEXT) vport.$(OBJEXT) $(am__objects_1)
stklos_OBJECTS = $(am_stklos_OBJECTS)
am__DEPENDENCIES_1 =
stklos_DEPENDENCIES = $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_1) \
......@@ -246,7 +246,7 @@ DOCDB = DOCDB
@NO_THREAD_TRUE@THREAD_FILES = thread-none.c mutex-none.c
@PTHREADS_TRUE@THREAD_FILES = thread-common.c thread-pthreads.c mutex-common.c mutex-pthreads.c
stklos_SOURCES = base64.c boolean.c boot.c char.c cond.c dynload.c env.c error.c \
extend.c fixnum.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
extend.c ffi.c fixnum.c fport.c gnu-getopt.c gnu-glob.c hash.c keyword.c lib.c \
list.c misc.c md5.c number.c object.c parameter.c path.c port.c print.c \
proc.c process.c promise.c read.c regexp.c \
signal.c sio.c socket.c sport.c stklos.c str.c struct.c \
......@@ -283,7 +283,7 @@ gmpinc = @GMPINC@
pcre = @PCRE@
pcrelib = @PCRELIB@
pcreinc = @PCREINC@
stklos_LDADD = $(compatlib) $(gmplib) $(pcrelib) $(gclib) -lm
stklos_LDADD = $(compatlib) $(gmplib) $(pcrelib) $(gclib) -lcinvoke -lm
stklos_LDFLAGS = @SH_MAIN_LOAD_FLAGS@
INCLUDES = $(gmpinc) $(pcreinc) $(gcinc)
all: stklosconf.h
......@@ -381,6 +381,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/env.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/error.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/extend.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/ffi.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fixnum.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/fport.Po@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gnu-getopt.Po@am__quote@
......
......@@ -37168,7 +37168,7 @@ STk_instr STk_boot_code [] = {
0x55,
0x4f3,
0x55,
0x4fd,
0x50f,
0x55,
0x522,
0x55,
......@@ -37187,7 +37187,7 @@ STk_instr STk_boot_code [] = {
0x55,
0x4f3,
0x55,
0x4fd,
0x50f,
0x55,
0x524,
0x55,
......@@ -37206,7 +37206,7 @@ STk_instr STk_boot_code [] = {
0x55,
0x4f3,
0x55,
0x4fd,
0x50f,
0x55,
0x525,
0x55,
......
This diff is collapsed.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 23-Jan-1994 19:09
* Last file update: 26-Jan-2007 12:01 (eg)
* Last file update: 14-Jun-2007 15:09 (eg)
*
*/
......@@ -115,6 +115,11 @@ static void *find_function(char *path, char *fname, int error_if_absent)
return fct;
}
void *STk_find_external_function(char *path, char *fname, int error_if_absent)
{
return find_function(path, fname, error_if_absent);
}
SCM STk_load_object_file(SCM f, char *path)
{
......
This diff is collapsed.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 5-Jan-2000 12:17 (eg)
* Last file update: 14-May-2007 10:25 (eg)
* Last file update: 14-Jun-2007 09:23 (eg)
*/
......@@ -72,5 +72,6 @@ STk_init_library(int *argc, char ***argv, int stack_size)
STk_init_object() &&
STk_init_base64() &&
STk_init_md5() &&
STk_init_ffi() &&
(STk_library_initialized = TRUE);
}
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 11-Apr-2007 15:41 (eg)
* Last file update: 15-Jun-2007 11:46 (eg)
*
*/
#include <ctype.h>
......@@ -185,7 +185,7 @@ void STk_print(SCM exp, SCM port, int mode)
return;
case tc_keyword:
printkeyword(exp, port, mode);
break;
return;
case tc_string:
printstring(exp, port, mode);
return;
......@@ -193,7 +193,7 @@ void STk_print(SCM exp, SCM port, int mode)
STk_putc('{', port);
STk_print(BOX_VALUE(exp), port, mode);
STk_putc('}', port);
break;
return;
case tc_subr0: /* ==================> Utiliser un type tendu //FIXME */
case tc_subr1:
case tc_subr2:
......@@ -209,7 +209,12 @@ void STk_print(SCM exp, SCM port, int mode)
STk_puts(PRIMITIVE_NAME(exp), port);
STk_putc(']', port);
return;
default:
case tc_ext_func:
STk_puts("#[external-func ", port);
STk_puts(STRING_CHARS(STk_ext_func_name(exp)), port);
STk_putc(']', port);
return;
default:
{
struct extended_type_descr *xdescr = BOXED_XTYPE(exp);
......
......@@ -2,7 +2,7 @@
*
* p r o c . c -- Things about procedures
*
* Copyright 1993-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* Copyright 1993-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 15-Nov-1993 22:02
* Last file update: 25-Apr-2005 17:17 (eg)
* Last file update: 15-Jun-2007 12:15 (eg)
*/
#include "stklos.h"
......@@ -112,7 +112,8 @@ DEFINE_PRIMITIVE("procedure?", procedurep, subr1, (SCM obj))
case tc_next_method:
case tc_continuation:
case tc_parameter:
case tc_closure: return STk_true;
case tc_closure:
case tc_ext_func: return STk_true;
case tc_instance: return (STk_methodp(obj) != STk_false) ?
STk_true:
STk_genericp(obj);
......@@ -140,11 +141,12 @@ DEFINE_PRIMITIVE("%procedure-name", procedure_name, subr1, (SCM obj))
case tc_subr01:
case tc_subr12:
case tc_subr23:
case tc_vsubr:
case tc_apply: return STk_Cstring2string(PRIMITIVE_NAME(obj));
case tc_closure: if (CLOSURE_NAME(obj) != STk_false)
return STk_Cstring2string(SYMBOL_PNAME(CLOSURE_NAME(obj)));
/* NO BREAK */
case tc_apply: return STk_Cstring2string(PRIMITIVE_NAME(obj));
case tc_vsubr: return STk_ext_func_name(obj);
case tc_ext_func: return STk_ext_func_name(obj);
case tc_closure: if (CLOSURE_NAME(obj) != STk_false)
return STk_Cstring2string(SYMBOL_PNAME(CLOSURE_NAME(obj)));
/* NO BREAK */
default: return obj;
}
}
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 30-May-2007 17:00 (eg)
* Last file update: 15-Jun-2007 11:42 (eg)
*/
......@@ -179,7 +179,7 @@ typedef enum {
tc_hash_table, tc_port, tc_frame, tc_next_method, tc_promise, /* 25 */
tc_regexp, tc_process, tc_continuation, tc_values, tc_parameter, /* 30 */
tc_socket, tc_struct_type, tc_struct, tc_thread, tc_mutex, /* 35 */
tc_condv, tc_box, /* 40 */
tc_condv, tc_box, tc_ext_func, tc_pointer, /* 40 */
tc_last_standard /* must be last as indicated by its name */
} type_cell;
......@@ -475,6 +475,16 @@ extern struct extended_type_descr *STk_xtypes[];
int STk_new_user_type(struct extended_type_descr *);
int STk_init_extend(void);
/*
------------------------------------------------------------------------------
----
---- F F I . C
----
------------------------------------------------------------------------------
*/
SCM STk_call_ext_function(SCM fct, int argc, SCM *argv);
SCM STk_ext_func_name(SCM fct);
int STk_init_ffi(void);
/*
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 6-Jun-2007 09:14 (eg)
* Last file update: 15-Jun-2007 11:56 (eg)
*/
// INLINER values
......@@ -1657,7 +1657,11 @@ FUNCALL: /* (int nargs, int tailp) */
if (nargs == 0) {vm->val = STk_get_parameter(vm->val); break;}
if (nargs == 1) {vm->val = STk_set_parameter(vm->val, vm->sp[0]); break;}
goto error_invoke;
case tc_ext_func:
ACT_SAVE_PROC(vm->fp) = vm->val;
vm->val = STk_call_ext_function(vm->val, nargs, vm->sp+nargs-1); break;
default:
STk_error("bad function ~S. Cannot be applied", vm->val);
error_invoke:
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment