proper creation of GUI stand-alone applications on Win32 and Win64.
;; in the public domain.
(defpackage "SB-BSD-SOCKETS"
- (:use "CL" "FFI" "SI")
+ (:use "CL" "FFI")
(:export "GET-HOST-BY-NAME" "GET-HOST-BY-ADDRESS"
"SOCKET-BIND" "SOCKET-ACCEPT" "SOCKET-CONNECT"
"SOCKET-PEERNAME" "SOCKET-NAME" "SOCKET-LISTEN"
" /* This callback is used as IO Completion routine by WSARecvFrom and WSASend and WSASendTo here below. */
static void CALLBACK _socket_io_done(DWORD dwError, DWORD cbTransferred, LPWSAOVERLAPPED lpOverlapped, DWORD dwFlags)
{
- lpOverlapped->hEvent = (HANDLE) cbTransferred;
+ lpOverlapped->hEvent = (HANDLE) (uintptr_t) cbTransferred;
}
"
)
mk_mt_test_for_thread_shutdown(env);
- len = (DWORD) RecvOverlapped.hEvent;
+ len = (DWORD) (uintptr_t) RecvOverlapped.hEvent;
}
else
{ @(return 0) = -1; goto _MKCL_RECEIVE_ERROR; }
mk_mt_test_for_thread_shutdown(env);
- len = (DWORD) SendOverlapped.hEvent;
+ len = (DWORD) (uintptr_t) SendOverlapped.hEvent;
}
else
{ @(return) = -1; goto _MKCL_SENDTO_ERROR; }
mk_mt_test_for_thread_shutdown(env);
- len = (DWORD) SendOverlapped.hEvent;
+ len = (DWORD) (uintptr_t) SendOverlapped.hEvent;
}
else
{ @(return) = -1; goto _MKCL_SEND_ERROR; }
mkcl_min
ucd.dat
help.doc
+HELP.DOC
BUILD-STAMP
TAGS
bare.lsp
ext/
bin/
encodings/
+ENCODINGS/
include/
lib/
test/
# See file '../Copyright' for full details.
#
#
-top_srcdir= /usr/home/Jean-Claude/mkcl-1.1.2/src
-srcdir = /usr/home/Jean-Claude/mkcl-1.1.2/src
+top_srcdir= /usr/home/Jean-Claude/mkcl-1.1.3/src
+srcdir = /usr/home/Jean-Claude/mkcl-1.1.3/src
# Programs used by "make":
#
bindir=${exec_prefix}/bin/
libdir=${exec_prefix}/lib/
includedir=${prefix}/include/
-mkcldir=${exec_prefix}/lib/mkcl-1.1.2/
-localmkcldir=./lib/mkcl-1.1.2/
+mkcldir=${exec_prefix}/lib/mkcl-1.1.3/
+localmkcldir=./lib/mkcl-1.1.3/
# Programs used by "make install":
#
SUBDIRS = c gc
LIBRARIES = libmkclgc.a
-LSP_LIBRARIES = mkcl_1.1.2.dll
+LSP_LIBRARIES = mkcl_1.1.3.dll
TARGETS = bin/mkcl$(EXE)
MKCL_HFILES = mkcl/config.h \
bin/mkcl-small$(EXE) liblsp.a $(LSP_LIBRARIES) ENCODINGS: compile.lsp lsp/config.lsp cmp/cmpdefs.lsp lsp/*.lsp clos/*.lsp cmp/*.lsp mkcl/mkcl-cmp.h mkcl/config.h BUILD-STAMP mkcl_min$(EXE) libmkcltop.a
- MKCL_LIBDIR=`pwd`/ ./mkcl_min$(EXE) compile
+ ./mkcl_min$(EXE) compile
for i in $(LSP_LIBRARIES) ; do \
if test -s $$i ; then \
case $$i in \
asdf.fasb libasdf.a: bin/mkcl-small$(EXE) build-asdf.lsp ../contrib/asdf/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf.lsp
bytecmp.fasb libbytecmp.a: bin/mkcl-small$(EXE) build-bytecmp.lsp ../contrib/bytecmp/bytecmp.lsp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-bytecmp.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-bytecmp.lsp
defsystem.fasb libdefsystem.a: bin/mkcl-small$(EXE) build-defsystem.lsp ../contrib/defsystem/defsystem.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-defsystem.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-defsystem.lsp
profile.fasb libprofile.a: bin/mkcl-small$(EXE) build-profile.lsp ../contrib/profile/profile.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-profile.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-profile.lsp
../contrib/sockets/package.lisp: ../contrib/sockets/sockets.lisp
touch ../contrib/sockets/package.lisp
sockets.fasb libsockets.a: bin/mkcl-small$(EXE) build-sockets.lsp ../contrib/sockets/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-sockets.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-sockets.lsp
serve-event.fasb libserve-event.a: bin/mkcl-small$(EXE) build-serve-event.lsp ../contrib/serve-event/serve-event.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-serve-event.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-serve-event.lsp
walker.fasb walker.a: bin/mkcl-small$(EXE) build-serve-event.lsp ../contrib/walker/walk.lsp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-walker.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-walker.lsp
../contrib/asdf-bundle/asdf-bundle.fas: bin/mkcl-small$(EXE) build-asdf-bundle.lsp ../contrib/asdf-bundle/*.lisp
if [ "$${LOCALAPPDATA}" ]; then (cd "$${LOCALAPPDATA}"; rm -rf ./common-lisp/cache/mkcl-*); elif [ "$${APPDATA}" ]; then (cd "$${APPDATA}"; rm -rf ./common-lisp/cache/mkcl-*); else rm -rf $$HOME/.cache/common-lisp/mkcl-*/$$(cd ..;pwd -P)/contrib/asdf-bundle; fi
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-bundle.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-bundle.lsp
trivial-features.fasb libtrivial-features.a: bin/mkcl-small$(EXE) build-asdf-contrib.lsp ../contrib/trivial-features*/src/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- trivial-features ../contrib/trivial-features*/
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- trivial-features ../contrib/trivial-features*/
cp -p ../contrib/trivial-features*/trivial-features.fasb .
cp -p ../contrib/trivial-features*/libtrivial-features.a .
trivial-garbage.fasb libtrivial-garbage.a: bin/mkcl-small$(EXE) build-asdf-contrib.lsp ../contrib/trivial-garbage*/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- trivial-garbage ../contrib/trivial-garbage*/
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- trivial-garbage ../contrib/trivial-garbage*/
cp -p ../contrib/trivial-garbage*/trivial-garbage.fasb .
cp -p ../contrib/trivial-garbage*/libtrivial-garbage.a .
alexandria.fasb libalexandria.a: bin/mkcl-small$(EXE) build-asdf-contrib.lsp ../contrib/alexandria*/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- alexandria ../contrib/alexandria*/
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- alexandria ../contrib/alexandria*/
cp -p ../contrib/alexandria*/alexandria.fasb .
cp -p ../contrib/alexandria*/libalexandria.a .
babel.fasb libbabel.a: bin/mkcl-small$(EXE) build-asdf-contrib.lsp trivial-features.fasb alexandria.fasb ../contrib/babel*/src/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- babel ../contrib/babel*/
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- babel ../contrib/babel*/
cp -p ../contrib/babel*/babel.fasb .
cp -p ../contrib/babel*/libbabel.a .
cffi.fasb libcffi.a: bin/mkcl-small$(EXE) build-asdf-contrib.lsp babel.fasb ../contrib/cffi*/src/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- cffi ../contrib/cffi*/
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- cffi ../contrib/cffi*/
cp -p ../contrib/cffi*/cffi.fasb .
cp -p ../contrib/cffi*/libcffi.a .
bordeaux-threads.fasb libbordeaux-threads.a: bin/mkcl-small$(EXE) build-asdf-contrib.lsp alexandria.fasb ../contrib/bordeaux-threads-*/src/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- bordeaux-threads ../contrib/bordeaux-threads-*/
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- bordeaux-threads ../contrib/bordeaux-threads-*/
cp -p ../contrib/bordeaux-threads*/bordeaux-threads.fasb .
cp -p ../contrib/bordeaux-threads*/libbordeaux-threads.a .
fiveam.fasb libfiveam.a: bin/mkcl-small$(EXE) build-asdf-contrib.lsp alexandria.fasb ../contrib/fiveam-*/src/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- fiveam ../contrib/fiveam-*/
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- fiveam ../contrib/fiveam-*/
cp -p ../contrib/fiveam*/src/fiveam.fasb .
cp -p ../contrib/fiveam*/src/libfiveam.a .
rt.fasb librt.a: bin/mkcl-small$(EXE) build-asdf-contrib.lsp babel.fasb ../contrib/rt*/*.lisp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- rt ../contrib/rt*/
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-asdf-contrib.lsp -- rt ../contrib/rt*/
cp -p ../contrib/rt*/rt.fasb .
cp -p ../contrib/rt*/librt.a .
cmp.fasb: bin/mkcl-small$(EXE) cmp/*.lsp build-cmp.lsp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-cmp.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-cmp.lsp
bin/mkcl-dyn: bin/mkcl-small$(EXE) cmp.fasb build-dynamic-mkcl.lsp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-dynamic-mkcl.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-dynamic-mkcl.lsp
bin/mkcl$(EXE): bin/mkcl-small$(EXE) cmp.fasb build-mkcl.lsp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-mkcl.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-mkcl.lsp
ifeq (mingw32,mingw32)
bin/mkcl-full$(EXE): bin/mkcl-small$(EXE) build-full-mkcl.lsp $(BUILTINS:%=lib%.a)
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-full-mkcl.lsp -- $(BUILTINS:%=lib%.a)
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-full-mkcl.lsp -- $(BUILTINS:%=lib%.a)
else
bin/mkcl-full$(EXE): bin/mkcl-small$(EXE) build-full-mkcl.lsp $(BUILTINS)
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-full-mkcl.lsp -- $(BUILTINS)
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load build-full-mkcl.lsp -- $(BUILTINS)
endif
HELP.DOC: dump-doc.lsp bin/mkcl$(EXE) doc/help.lsp
- MKCL_LIBDIR=$$(pwd)/ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load dump-doc.lsp
+ bin/mkcl-small$(EXE) -norc -q --external-format "(:ascii :lf)" -load dump-doc.lsp
mkcl_min$(EXE): $(LIBRARIES) libmkclgc.a libmkclmin.a c/cinit.o c/all_symbols.o .gdbinit
(unless (compiler::build-program
"bin/mkcl"
:extra-ld-flags "-Wl,--stack,0x800000" ;; Stack of 8MB.
- :epilogue-code '(PROGN (REQUIRE "CMP") (SI::TOP-LEVEL))
+ :epilogue-code '(PROGN (UNLESS (IGNORE-ERRORS (REQUIRE "CMP"))
+ (TERPRI)
+ (PRINC ";;; Failed to load compiler module!")
+ (TERPRI))
+ (SI::TOP-LEVEL))
)
(mkcl:quit :exit-code 1))
.d.c:
$(DPP) $< $@
-#unixfsys.o: unixfsys.c
-# $(CC) -DMKCL_LIBDIR="\"@mkcldir@\"" -DMKCL_VERSION="\"@PACKAGE_VERSION@\"" $(CFLAGS) -o $@ -c $<
$(DCFILES) all_symbols.c cinit.c: $(DPP)
# See file '../../Copyright' for full details.
#
#
-top_srcdir= /usr/home/Jean-Claude/mkcl-1.1.2/src
-srcdir = /usr/home/Jean-Claude/mkcl-1.1.2/src/c
-VPATH = /usr/home/Jean-Claude/mkcl-1.1.2/src/c
+top_srcdir= /usr/home/Jean-Claude/mkcl-1.1.3/src
+srcdir = /usr/home/Jean-Claude/mkcl-1.1.3/src/c
+VPATH = /usr/home/Jean-Claude/mkcl-1.1.3/src/c
# Programs used by "make":
#
+static inline void * MKCL_GC_MEMALIGN(MKCL, mkcl_index alignment, mkcl_index size)
+{
+ void * new;
+
+ MKCL_GC_NO_INTR(env, new = MK_GC_memalign(alignment, size));
+
+ if (mkcl_likely(new != NULL))
+ return new;
+ else
+ {
+ grow_memory(env);
+ MKCL_GC_NO_INTR(env, new = MK_GC_memalign(alignment, size));
+ if (mkcl_likely(new != NULL))
+ return new;
+ else
+ mkcl_lose(env, "Memory exhausted, quitting program.");
+ }
+}
+
+void * mkcl_alloc_pages(MKCL, mkcl_index nb_pages)
+{
+ long pagesize = mkcl_core.pagesize;
+
+ return MKCL_GC_MEMALIGN(env, pagesize, nb_pages * pagesize);
+}
+
/****************************************************/
mkcl_object mkcl_alloc_cdisplay(MKCL, mkcl_index nb_levels)
mkcl_dealloc(MKCL, void *ptr)
{
/* Intentionally left empty! Broken on any platform after all... */
+ /* Beside, we believe that the GC will do the right thing, eventually... */
}
void *
#include <mkcl/mkcl.h>
#include <string.h>
+#if __unix
+#include <sys/mman.h>
+#endif
#include <mkcl/internal.h>
struct mkcl_fficall_reg *
rtype = MKCL_CADR(cbk_info);
argtypes = MKCL_CADDR(cbk_info);
- arg_buffer += 4; /* Skip return address */
+ arg_buffer += sizeof(void *); /* Skip saved stack frame pointer */
+ arg_buffer += sizeof(void *); /* Skip return address */
+
for (i=0; !mkcl_endp(env, argtypes); argtypes = MKCL_CDR(argtypes), i++) {
tag = mkcl_foreign_type_code(env, MKCL_CAR(argtypes));
size = mkcl_fixnum_to_word(mk_si_size_of_foreign_elt_type(env, MKCL_CAR(argtypes)));
void *
mkcl_dynamic_callback_make(MKCL, mkcl_object data, enum mkcl_ffi_calling_convention cc_type)
{
- /*
- * push %esp 54
- * pushl <data> 68 <addr32>
- * call mkcl_dynamic_callback_call E8 <disp32>
- * [ Here we could use also lea 4(%esp), %esp, but %ecx seems to be free ]
- * pop %ecx 59
- * pop %ecx 59
- * ret c3
- * nop 90
- * nop 90
- */
- char *buf = (char*)mkcl_alloc_atomic_align(env, sizeof(char)*16, 4);
- *(char*) (buf+0) = 0x54;
- *(char*) (buf+1) = 0x68;
- *(long*) (buf+2) = (long)data;
- *(unsigned char*) (buf+6) = 0xE8;
- *(long*) (buf+7) = (long)mkcl_dynamic_callback_execute - (long)(buf+11);
- *(char*) (buf+11) = 0x59;
- *(char*) (buf+12) = 0x59;
+ char *buf = mkcl_alloc_pages(env, 1); /* An entire page (usually 4096 bytes) for a single callback!
+ * That is quite some waist. FIXME. JCB */
+ unsigned char * ip = buf; /* the instruction pointer (ip) */
+ union { unsigned char b[4]; void * p; unsigned long l; unsigned short s; } imm; /* a staging buffer for immediate data */
+
+#define i(byte) *(ip++) = (byte)
+#define immed_ptr(val_ptr) imm.p = (val_ptr); i(imm.b[0]); i(imm.b[1]); i(imm.b[2]); i(imm.b[3]);
+#define immed16(val_short) imm.s = (val_short); i(imm.b[0]); i(imm.b[1]);
+#define immed32(val_long) imm.l = (val_long); i(imm.b[0]); i(imm.b[1]); i(imm.b[2]); i(imm.b[3]);
+
+
+ /* pushl %ebp */ i(0x55); /* build stack frame, step 1 of 2 */
+ /* movl %esp, %ebp */ i(0x89); i(0xe5); /* build stack frame, step 2 of 2 */
+ /* pushl %esp */ i(0x54); /* push arg_list pointer */
+ /* movl <addr32>, %eax */ i(0xb8); immed_ptr(data);
+ /* pushl %eax */ i(0x50); /* push data */
+ /* movl <addr32>, %eax */ i(0xb8); immed_ptr(mkcl_dynamic_callback_execute);
+ /* call *%eax */ i(0xff); i(0xd0); /* call mkcl_dynamic_callback_execute() */
+ /* addl $16, %esp */ i(0x83); i(0xc4); i(0x10); /* cleanup arg list of previous call, 16 bytes. */
+ /* leave */ i(0xc9); /* undo stack frame */
+#ifndef MKCL_WINDOWS
+ /* ret */ i(0xc3); /* return */
+#else
if (cc_type == MKCL_FFI_CC_CDECL) {
- *(unsigned char*) (buf+13) = 0xc3;
- *(unsigned short*)(buf+14) = 0x9090;
+ /* ret */ i(0xc3); /* return */
} else { /* This would be MKCL_FFI_CC_STDCALL. JCB */
mkcl_object arg_types = MKCL_CADDR(data);
- int byte_size = 0;
- const unsigned int mask = 3;
+ unsigned long arg_list_byte_size = 0;
+ const unsigned long mask = 3;
while (MKCL_CONSP(arg_types)) {
- int sz = mkcl_fixnum_to_word(mk_si_size_of_foreign_elt_type(env, MKCL_CAR(arg_types)));
- byte_size += ((sz+mask)&(~mask));
+ unsigned int sz = mkcl_fixnum_to_word(mk_si_size_of_foreign_elt_type(env, MKCL_CAR(arg_types)));
+ arg_list_byte_size += ((sz+mask)&(~mask));
arg_types = MKCL_CDR(arg_types);
}
- *(unsigned char*) (buf+13) = 0xc2;
- *(unsigned short*)(buf+14) = (unsigned short)byte_size; /* This caps the value (of what?) to 65536! JCB */
+ if (arg_list_byte_size > USHRT_MAX)
+ {
+ /* popl %ecx */ i(0x59); /* get return %eip. */
+ /* addl <immed32>, %esp */ i(0x81); i(0xc4); immed32(arg_list_byte_size); /* pop byte_size bytes. */
+ /* jmp *%ecx */ i(0xff); i(0xe1); /* jump to return %eip. */
+ }
+ else
+ {
+ /* ret <immed16> */ i(0xc2); immed16(arg_list_byte_size); /* return and pop byte_size bytes. */
+ }
}
+#endif
+ /* nop */ i(0x90); /* Fill with nop until end of I-cache line (multiple of 16 bytes). */
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+
+#if __unix
+ int rc = mprotect(buf, mkcl_core.pagesize, PROT_READ | /* PROT_WRITE | */ PROT_EXEC);
+ if (rc)
+ mkcl_FElibc_error(env, "mkcl_dynamic_callback_make() failed on mprotect()", 0);
+#endif
+#if 0
+ printf("\nIn mkcl_dynamic_callback_make(), returning %p.\n", buf); fflush(NULL); /* debug JCB */
+#endif
return buf;
}
/* -*- mode: c -*- */
/*
- ffi_x86.c -- Nonportable component of the FFI
+ ffi_x86_64.c -- Nonportable component of the FFI, for 64-bit (AMD x86_64) Linux/Unix.
*/
/*
Copyright (c) 2005, Juan Jose Garcia Ripoll.
#include <mkcl/mkcl.h>
#include <string.h>
+#include <sys/mman.h>
#include <mkcl/internal.h>
#define MAX_INT_REGISTERS 6
mkcl_fficall_align16(env); /* Size of a cache line. */
bufsize = fficall->buffer_sp - fficall->buffer;
-#if 0
- printf("\nIn mkcl_fficall_execute(), stack arguments size = %lu.\n", bufsize); fflush(NULL);
-#endif
/* Save current stack pointer and then push stack based arguments. */
asm volatile ("mov %%rsp, %0\n\t"
static const mkcl_object mkcl_dynamic_callback_import_thread_name = (mkcl_object) &mkcl_dynamic_callback_import_thread_name__obj_;
-static void
+static unsigned long
mkcl_dynamic_callback_execute(long i1, long i2, long i3, long i4, long i5, long i6,
double f1, double f2, double f3, double f4,
double f5, double f6, double f7, double f8,
char stack_mark = 0;
mkcl_object fun, rtype, argtypes;
mkcl_object result;
- mkcl_index /* i, */ size, i_reg_index, f_reg_index;
+ mkcl_index size, i_reg_index, f_reg_index;
union mkcl_ffi_values output;
enum mkcl_ffi_tag tag;
long i_reg[MAX_INT_REGISTERS];
result = mkcl_apply_from_temp_stack_frame(env, frame, fun);
mkcl_disable_interrupts(env);
-#if 1
mkcl_cleanup_thread_lisp_context(env);
-#else
- mkcl_bds_unwind1(env);
-#endif
} MKCL_CATCH_ALL_END;
thread->thread.status = mkcl_thread_done;
}
mkcl_release_current_thread(imported_env);
errno = 0;
- switch (tag) {
- register unsigned long rax asm("rax");
- case MKCL_FFI_CHAR: rax = output.c; return;
- case MKCL_FFI_UNSIGNED_CHAR: rax = output.uc; return;
- case MKCL_FFI_BYTE: rax = output.b; return;
- case MKCL_FFI_UNSIGNED_BYTE: rax = output.ub; return;
- case MKCL_FFI_INT16_T: rax = output.i16; return;
- case MKCL_FFI_UINT16_T: rax = output.u16; return;
- case MKCL_FFI_SHORT: rax = output.s; return;
- case MKCL_FFI_UNSIGNED_SHORT: rax = output.us; return;
- case MKCL_FFI_INT32_T: rax = output.i32; return;
- case MKCL_FFI_UINT32_T: rax = output.u32; return;
- case MKCL_FFI_INT:
- case MKCL_FFI_UNSIGNED_INT:
- case MKCL_FFI_LONG:
- case MKCL_FFI_UNSIGNED_LONG:
- case MKCL_FFI_INT64_T:
- case MKCL_FFI_UINT64_T:
- case MKCL_FFI_LONG_LONG:
- case MKCL_FFI_UNSIGNED_LONG_LONG:
- case MKCL_FFI_POINTER_VOID:
- case MKCL_FFI_CSTRING:
- case MKCL_FFI_OBJECT: rax = output.ul; return;
- case MKCL_FFI_DOUBLE: asm("movsd (%0),%%xmm0" :: "a" (&output.d)); return;
- case MKCL_FFI_FLOAT: asm("movss (%0),%%xmm0" :: "a" (&output.f)); return;
- case MKCL_FFI_VOID: return;
- /* default: mkcl_FEerror(env, "Invalid return type for a C function callback", 0); */
+ {
+ unsigned long val = 0;
+
+ switch (tag) {
+ case MKCL_FFI_CHAR: val = output.c; break;
+ case MKCL_FFI_UNSIGNED_CHAR: val = output.uc; break;
+ case MKCL_FFI_BYTE: val = output.b; break;
+ case MKCL_FFI_UNSIGNED_BYTE: val = output.ub; break;
+ case MKCL_FFI_INT16_T: val = output.i16; break;
+ case MKCL_FFI_UINT16_T: val = output.u16; break;
+ case MKCL_FFI_SHORT: val = output.s; break;
+ case MKCL_FFI_UNSIGNED_SHORT: val = output.us; break;
+ case MKCL_FFI_INT32_T: val = output.i32; break;
+ case MKCL_FFI_UINT32_T: val = output.u32; break;
+ case MKCL_FFI_INT:
+ case MKCL_FFI_UNSIGNED_INT:
+ case MKCL_FFI_LONG:
+ case MKCL_FFI_UNSIGNED_LONG:
+ case MKCL_FFI_INT64_T:
+ case MKCL_FFI_UINT64_T:
+ case MKCL_FFI_LONG_LONG:
+ case MKCL_FFI_UNSIGNED_LONG_LONG:
+ case MKCL_FFI_POINTER_VOID:
+ case MKCL_FFI_CSTRING:
+ case MKCL_FFI_OBJECT: val = output.ul; break;
+ case MKCL_FFI_DOUBLE: asm("movsd (%0),%%xmm0" :: "a" (&output.d)); break;
+ case MKCL_FFI_FLOAT: asm("movss (%0),%%xmm0" :: "a" (&output.f)); break;
+ case MKCL_FFI_VOID: break;
+ default: mkcl_FEerror(env, "Invalid C callback function return type", 0); break;
+ }
+ return val;
}
}
-void*
+void *
mkcl_dynamic_callback_make(MKCL, mkcl_object data, enum mkcl_ffi_calling_convention cc_type)
{
- /*
- * push %rbp 55
- * push %rsp 54
- * mov <addr64>,%rax 48 b8 <addr64>
- * push %rax 50
- * mov <addr64>,%rax 48 b8 <addr64>
- * callq *%rax 48 ff d0
- * pop %rcx 59
- * pop %rcx 59
- * pop %rbp 5d
- * ret c3
- * nop 90
- * nop 90
- */
- char *buf = (char*)mkcl_alloc_atomic_align(env, 32, 8);
- *(char*) (buf+0) = 0x55;
- *(char*) (buf+1) = 0x54;
- *(short*)(buf+2) = 0xb848;
- *(intptr_t*) (buf+4) = (intptr_t)data;
- *(char*) (buf+12) = 0x50;
- *(short*)(buf+13) = 0xb848;
- *(intptr_t*) (buf+15) = (intptr_t)mkcl_dynamic_callback_execute;
- *(int*) (buf+23) = (int)0x00d0ff48; /* leading null byte is overwritten */
- *(char*) (buf+26) = 0x59;
- *(char*) (buf+27) = 0x59;
- *(char*) (buf+28) = 0x5d;
- *(char*) (buf+29) = 0xc3;
- *(short*)(buf+30) = 0x9090;
+ char *buf = mkcl_alloc_pages(env, 1); /* An entire page (usually 4096 bytes) for a single callback!
+ * That is quite some waste. FIXME. JCB */
+
+ unsigned char * ip = buf; /* the instruction pointer (ip) */
+ union { unsigned char b[8]; void * p; long long ll; long l; } imm; /* a staging buffer for immediate data */
+
+#define i(byte) *(ip++) = (byte)
+#define immed_ptr(val_ptr) imm.p = (val_ptr); \
+ i(imm.b[0]); i(imm.b[1]); i(imm.b[2]); i(imm.b[3]); i(imm.b[4]); i(imm.b[5]); i(imm.b[6]); i(imm.b[7]);
+
+
+ /* pushq %rbp */ i(0x55); /* build stack frame, step 1 of 2 */
+ /* movq %rsp, %rbp */ i(0x48); i(0x89); i(0xe5); /* build stack frame, step 2 of 2 */
+ /* pushq %rsp */ i(0x54); /* push mem_arg_list pointer */
+ /* movq <addr64>, %rax */ i(0x48); i(0xb8); immed_ptr(data);
+ /* pushq %rax */ i(0x50); /* push data */
+ /* movq <addr64>, %rax */ i(0x48); i(0xb8); immed_ptr(mkcl_dynamic_callback_execute);
+ /* callq *%rax */ i(0x48); i(0xff); i(0xd0); /* call mkcl_dynamic_callback_execute() */
+ /* addq $16, %rsp */ i(0x48); i(0x83); i(0xc4); i(0x10); /* cleanup mem_arg list of previous call, 16 bytes. */
+ /* leave */ i(0xc9); /* undo stack frame */
+ /* ret */ i(0xc3); /* return */
+ /* nop */ i(0x90); /* Fill with nop until end of I-cache line (multiple of 16 bytes). */
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+
+ {
+ int rc = mprotect(buf, mkcl_core.pagesize, PROT_READ | /* PROT_WRITE | */ PROT_EXEC);
+ if (rc)
+ mkcl_FElibc_error(env, "mkcl_dynamic_callback_make() failed on mprotect()", 0);
+ }
return buf;
}
/* -*- mode: c -*- */
/*
- ffi_x86.c -- Nonportable component of the FFI
+ ffi_x86_64_w64.c -- Nonportable component of the FFI for Microsoft Win64 on x86_64.
*/
/*
Copyright (c) 2005, Juan Jose Garcia Ripoll.
static const mkcl_object mkcl_dynamic_callback_import_thread_name = (mkcl_object) &mkcl_dynamic_callback_import_thread_name__obj_;
-static void
+static uint64_t
mkcl_dynamic_callback_execute(int64_t i1, int64_t i2, int64_t i3, int64_t i4,
mkcl_object cbk_info, char *arg_buffer)
{
mkcl_env env = MKCL_ENV();
mkcl_env imported_env = NULL;
+#if 0
+ printf("\nIn mkcl_dynamic_callback_execute(), i1 = %llx, i2 = %llx, i3 = %llx, i4 = %llx,\n\t cbk_info = %p, arg_buffer = %p.\n", i1, i2, i3, i4, cbk_info, arg_buffer); fflush(NULL);
+#endif
+
if (env == NULL)
{
env = imported_env = mkcl_import_current_thread(mkcl_dynamic_callback_import_thread_name, mk_cl_Cnil, NULL, NULL);
reg[3].i = i4;
arg_buffer += 2*sizeof(void*); /* Skip return address and base pointer */
- arg_buffer += 4*sizeof(int64_t); /* Skip homes of the 4 register arguments */
+ arg_buffer += 4*sizeof(int64_t); /* Skip the spill-over homes of the 4 register arguments */
for (; !mkcl_endp(env, argtypes); argtypes = MKCL_CDR(argtypes))
{
result = mkcl_apply_from_temp_stack_frame(env, frame, fun);
mkcl_disable_interrupts(env);
-#if 1
mkcl_cleanup_thread_lisp_context(env);
-#else
- mkcl_bds_unwind1(env);
-#endif
} MKCL_CATCH_ALL_END;
thread->thread.status = mkcl_thread_done;
}
mkcl_release_current_thread(imported_env);
errno = 0;
- switch (tag) {
- register uint64_t rax asm("rax");
- case MKCL_FFI_CHAR: rax = output.c; return;
- case MKCL_FFI_UNSIGNED_CHAR: rax = output.uc; return;
- case MKCL_FFI_BYTE: rax = output.b; return;
- case MKCL_FFI_UNSIGNED_BYTE: rax = output.ub; return;
- case MKCL_FFI_INT16_T: rax = output.i16; return;
- case MKCL_FFI_UINT16_T: rax = output.u16; return;
- case MKCL_FFI_SHORT: rax = output.s; return;
- case MKCL_FFI_UNSIGNED_SHORT: rax = output.us; return;
- case MKCL_FFI_INT32_T: rax = output.i32; return;
- case MKCL_FFI_UINT32_T: rax = output.u32; return;
- case MKCL_FFI_INT: rax = output.i; return;
- case MKCL_FFI_UNSIGNED_INT: rax = output.ui; return;
- case MKCL_FFI_LONG: rax = output.l; return;
- case MKCL_FFI_UNSIGNED_LONG: rax = output.ul; return;
-
- case MKCL_FFI_INT64_T:
- case MKCL_FFI_UINT64_T:
- case MKCL_FFI_LONG_LONG:
- case MKCL_FFI_UNSIGNED_LONG_LONG:
- case MKCL_FFI_POINTER_VOID:
- case MKCL_FFI_CSTRING:
- case MKCL_FFI_OBJECT:
- rax = output.ull; return;
- case MKCL_FFI_DOUBLE:
- asm("movsd (%0),%%xmm0" :: "a" (&output.d));
- return;
- case MKCL_FFI_FLOAT:
- asm("movss (%0),%%xmm0" :: "a" (&output.f));
- return;
- case MKCL_FFI_VOID:
- return;
- default:
- mkcl_FEerror(env, "Invalid C function callback return type", 0);
+ {
+ volatile uint64_t val = 0;
+ switch (tag) {
+ case MKCL_FFI_CHAR: val = output.c; break;
+ case MKCL_FFI_UNSIGNED_CHAR: val = output.uc; break;
+ case MKCL_FFI_BYTE: val = output.b; break;
+ case MKCL_FFI_UNSIGNED_BYTE: val = output.ub; break;
+ case MKCL_FFI_INT16_T: val = output.i16; break;
+ case MKCL_FFI_UINT16_T: val = output.u16; break;
+ case MKCL_FFI_SHORT: val = output.s; break;
+ case MKCL_FFI_UNSIGNED_SHORT: val = output.us; break;
+ case MKCL_FFI_INT32_T: val = output.i32; break;
+ case MKCL_FFI_UINT32_T: val = output.u32; break;
+ case MKCL_FFI_INT: val = output.i; break;
+ case MKCL_FFI_UNSIGNED_INT: val = output.ui; break;
+ case MKCL_FFI_LONG: val = output.l; break;
+ case MKCL_FFI_UNSIGNED_LONG: val = output.ul; break;
+
+ case MKCL_FFI_INT64_T:
+ case MKCL_FFI_UINT64_T:
+ case MKCL_FFI_LONG_LONG:
+ case MKCL_FFI_UNSIGNED_LONG_LONG:
+ case MKCL_FFI_POINTER_VOID:
+ case MKCL_FFI_CSTRING:
+ case MKCL_FFI_OBJECT:
+ val = output.ull; break;
+ case MKCL_FFI_DOUBLE:
+ asm("movsd (%0),%%xmm0" :: "a" (&output.d));
+ break;
+ case MKCL_FFI_FLOAT:
+ asm("movss (%0),%%xmm0" :: "a" (&output.f));
+ break;
+ case MKCL_FFI_VOID:
+ break;
+ default:
+ mkcl_FEerror(env, "Invalid C function callback return type", 0);
+ }
+ {
+#if 0
+ register uint64_t rax asm("rax");
+ rax = val;
+#endif
+ asm __volatile__ ("mov %0,%%rax\n\t" :: "m" (val));
+ return val;
+ }
}
}
void*
mkcl_dynamic_callback_make(MKCL, mkcl_object data, enum mkcl_ffi_calling_convention cc_type)
{
- /*
- * push %rbp 55
- * push %rsp 54
- * mov <addr64>,%rax 48 b8 <addr64>
- * push %rax 50
- * push %r9 41 51 ; push arg3
- * push %r8 41 50 ; push arg2
- * push %rdx 52 ; push arg1
- * push %rcx 51 ; push arg0
- * mov <addr64>,%rax 48 b8 <addr64>
- * callq *%rax 48 ff d0
- * pop %rcx 59
- * pop %rcx 59
- * pop %rbp 5d
- * ret c3
- * nop 90
- * nop 90
- * nop 90
- * nop 90
- * nop 90
- * nop 90
- * nop 90
- * nop 90
- * nop 90
- * nop 90
- * nop 90
- * nop 90
- */
+ unsigned char *buf = mkcl_alloc_pages(env, 1); /* An entire page (usually 4096 bytes) for a single callback!
+ * That is quite some waste. FIXME. JCB */
+ unsigned char * ip = buf; /* the instruction pointer (ip) */
+ union { unsigned char b[8]; void * p; long long ll; long l; } imm; /* a staging buffer for immediate data */
+
+#define i(byte) *(ip++) = (byte)
+#define immed_ptr(val_ptr) imm.p = (val_ptr); \
+ i(imm.b[0]); i(imm.b[1]); i(imm.b[2]); i(imm.b[3]); i(imm.b[4]); i(imm.b[5]); i(imm.b[6]); i(imm.b[7]);
+
+
+ /* pushq %rbp */ i(0x55); /* build stack frame, step 1 of 2 */
+ /* movq %rsp, %rbp */ i(0x48); i(0x89); i(0xe5); /* build stack frame, step 2 of 2 */
+ /* pushq %rsp */ i(0x54); /* push arg_list pointer */
+ /* movq <addr64>, %rax */ i(0x48); i(0xb8); immed_ptr(data);
+ /* pushq %rax */ i(0x50); /* push data */
+ /* pushq %r9 */ i(0x41); i(0x51); /* push arg3 */
+ /* pushq %r8 */ i(0x41); i(0x50); /* push arg2 */
+ /* pushq %rdx */ i(0x52); /* push arg1 */
+ /* pushq %rcx */ i(0x51); /* push arg0 */
+ /* movq <addr64>, %rax */ i(0x48); i(0xb8); immed_ptr(mkcl_dynamic_callback_execute);
+ /* callq *%rax */ i(0x48); i(0xff); i(0xd0); /* call mkcl_dynamic_callback_execute() */
+ /* addq $48, %rsp */ i(0x48); i(0x83); i(0xc4); i(0x30); /* cleanup arg list of previous call, 48 bytes. */
+ /* leave */ i(0xc9); /* undo stack frame */
+ /* ret */ i(0xc3); /* return */
+ /* nop */ i(0x90); /* Fill with nop until end of I-cache line (multiple of 16 bytes). */
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
+ /* nop */ i(0x90);
/*
* we could also adjust the SP register this way
*
*/
- /* round the size of the routine to the next I-cache line boundary (48=3*16). */
- char *buf = (char*)mkcl_alloc_atomic_align(env, 48, 8);
-
- *(unsigned char*) (buf+0) = 0x55;
- *(unsigned char*) (buf+1) = 0x54;
- *(unsigned short*)(buf+2) = 0xb848;
- *(uintptr_t*) (buf+4) = (uintptr_t)data;
- *(unsigned char*) (buf+12) = 0x50;
- *(unsigned short*)(buf+13) = 0x5141;
- *(unsigned short*)(buf+15) = 0x5041;
- *(unsigned char*) (buf+17) = 0x52;
- *(unsigned char*) (buf+18) = 0x51;
- *(unsigned short*)(buf+19) = 0xb848;
- *(uintptr_t*) (buf+21) = (uintptr_t)mkcl_dynamic_callback_execute;
- *(unsigned int*) (buf+29) = (unsigned int)0x00d0ff48;/* leading null byte is overwritten */
- *(unsigned char*) (buf+32) = 0x59;
- *(unsigned char*) (buf+33) = 0x59;
- *(unsigned char*) (buf+34) = 0x5d;
- *(unsigned char*) (buf+35) = 0xc3;
- *(unsigned long*) (buf+36) = 0x90909090;
- *(uint64_t*)(buf+40) = 0x9090909090909090LL;
+ { /* By default on Win64 data is PAGE_READWRITE only and we would get
+ an ACCESS_VIOLATION if we didn't set it to EXECUTE. */
+ DWORD old_protection_flags;
+ BOOL ok = VirtualProtect(buf, mkcl_core.pagesize, PAGE_EXECUTE_READ, &old_protection_flags);
+
+ if (!ok)
+ mkcl_FEwin32_error(env, "mkcl_dynamic_callback_make() failed on VirtualProtect()", 0);
+ }
+#if 0
+ printf("\nIn mkcl_dynamic_callback_make(), data = %p, returning = %p.\n", data, buf); fflush(NULL);
+#endif
return buf;
}
size_t size = fficall->buffer_size;
size_t new_size;
-#if 0
- printf("\nIn mkcl_fficall_overflow(): new_bytes = %lu", new_bytes); fflush(NULL);
-#endif
if (size < MKCL_FFICALL_ARGS_STAGING_AREA_GROWTH_INCREMENT)
if (new_bytes < size)
new_size = size + size;
else
new_size = size + new_bytes;
-#if 0
- printf("\nIn mkcl_fficall_overflow(): sp = %lu, old size = %lu, new_size = %lu",
- fficall->buffer_sp - fficall->buffer, size, new_size);
- fflush(NULL);
-#endif
-
char * new_buffer = mkcl_alloc(env, new_size);
char * new_buffer_sp = new_buffer + (fficall->buffer_sp - fficall->buffer);
fficall->buffer = new_buffer;
fficall->buffer_sp = new_buffer_sp;
fficall->buffer_size = new_size;
-
-#if 0
- mkcl_FEerror(env, "Stack overflow on SI:CALL-CFUN", 0);
-#endif
}
mkcl_object
{
struct mkcl_fficall *fficall = env->fficall;
-#if 0
- printf("\nIn mkcl_fficall_push_bytes(): data = %p, bytes = %lu", data, bytes);
- printf("\nIn mkcl_fficall_push_bytes(): buffer = %p, sp = %lu\n", fficall->buffer, fficall->buffer_sp - fficall->buffer);
- fflush(NULL);
-#endif
-
-#if 0
- fficall->buffer_size += bytes;
- if (fficall->buffer_size >= MKCL_FFICALL_LIMIT)
- mkcl_fficall_overflow(env);
-#else
if (((fficall->buffer_sp + bytes) - fficall->buffer) > fficall->buffer_size)
mkcl_fficall_overflow(env, bytes);
-#endif
memcpy(fficall->buffer_sp, (char*)data, bytes);
fficall->buffer_sp += bytes;
}
mkcl_fficall_push_bytes(env, &data, sizeof(int));
}
-#if 0
-void
-mkcl_fficall_align(MKCL, int data)
-{ /* Note that the value of 'data' must be a power of 2 for this code to work. */
- struct mkcl_fficall *fficall = env->fficall;
-
-#if 0
- printf("\nIn mkcl_fficall_align(): data = %d\n", data); fflush(NULL);
-#endif
-
- if (data == 1)
- return;
- else {
- size_t sp = fficall->buffer_sp - fficall->buffer;
- size_t mask = data - 1;
- size_t new_sp = (sp + mask) & ~mask;
-
-#if 0
- if (new_sp >= MKCL_FFICALL_LIMIT)
- mkcl_fficall_overflow(env);
-#else
- if (new_sp > fficall->buffer_size)
- mkcl_fficall_overflow(env, 16); /* This case should never happen! JCB */
-#endif
-
- if (new_sp != sp)
- { printf("\nIn mkcl_fficall_align(): sp = %lu, new_sp = %lu\n", sp, new_sp); fflush(NULL); }
-
- fficall->buffer_sp = fficall->buffer + new_sp;
- /* fficall->buffer_size = new_sp; */
- }
-}
-#endif
void mkcl_fficall_align4(MKCL)
{
-#if 1
struct mkcl_fficall * const fficall = env->fficall;
fficall->buffer_sp = (char *) (((intptr_t) (fficall->buffer_sp + 0x3)) & ~((uintptr_t)0x3));
-#else
- mkcl_fficall_align(env, 4);
-#endif
}
void mkcl_fficall_align8(MKCL)
{
-#if 1
struct mkcl_fficall * const fficall = env->fficall;
fficall->buffer_sp = (char *) (((intptr_t) (fficall->buffer_sp + 0x7)) & ~((uintptr_t)0x7));
-#else
- mkcl_fficall_align(env, 8);
-#endif
}
void mkcl_fficall_align16(MKCL)
{
-#if 1
struct mkcl_fficall * const fficall = env->fficall;
fficall->buffer_sp = (char *) (((intptr_t) (fficall->buffer_sp + 0xF)) & ~((uintptr_t)0xF));
-#else
- mkcl_fficall_align(env, 16);
-#endif
}
@(defun si::call-cfun (fun return_type arg_types args &optional (cc_type @':cdecl'))
type = mkcl_foreign_type_code(env, MKCL_CAR(arg_types));
if (type == MKCL_FFI_CSTRING) {
object = mkcl_null_terminated_base_string(env, MKCL_CAR(args));
- /* if (MKCL_CAR(args) != object) */
- /* fficall->cstring = MKCL_CONS(env, object, fficall->cstring); */
} else {
object = MKCL_CAR(args);
}
{
mkcl_object return_value = mkcl_foreign_ref_elt(env, &fficall->output, return_type_tag);
- /* fficall->buffer_size = 0; */
- fficall->buffer_sp = fficall->buffer;
- /* fficall->cstring = mk_cl_Cnil; */
-
+ fficall->buffer_sp = fficall->buffer;
@(return return_value);
}
@)
mkcl_object cbk;
@
data = mk_cl_list(env, 3, fun, rtype, argtypes);
-#if 0
- cbk = mkcl_make_foreign(env, @':pointer-void', 0,
- mkcl_dynamic_callback_make(env, data, mkcl_foreign_cc_code(env, cctype)));
-#else
cbk = mkcl_make_foreign(env, @':void', 0, mkcl_dynamic_callback_make(env, data, mkcl_foreign_cc_code(env, cctype)));
-#endif
mk_si_put_sysprop(env, sym, @':callback', MKCL_CONS(env, cbk, data));
@(return cbk);
if (!mkcl_stringp(env, s) || !s->base_string.hasfillp)
mkcl_FEerror(env, "~S is not a string with a fill-pointer.", 1, s);
strm->stream.ops = duplicate_dispatch_table(env, &str_out_ops);
- strm->stream.mode = (short)mkcl_smm_string_output;
+ strm->stream.mode = mkcl_smm_string_output;
MKCL_STRING_OUTPUT_STREAM_STRING(strm) = s;
MKCL_STRING_OUTPUT_STREAM_COLUMN(strm) = 0;
if (mkcl_type_of(s) == mkcl_t_base_string) {
strm = alloc_stream(env);
strm->stream.ops = duplicate_dispatch_table(env, &str_in_ops);
- strm->stream.mode = (short)mkcl_smm_string_input;
+ strm->stream.mode = mkcl_smm_string_input;
MKCL_STRING_INPUT_STREAM_STRING(strm) = strng;
MKCL_STRING_INPUT_STREAM_POSITION(strm) = istart;
MKCL_STRING_INPUT_STREAM_LIMIT(strm) = iend;
/******************************************/
-
static void
-set_stream_elt_type(MKCL, mkcl_object stream, mkcl_word byte_size, mkcl_stream_flag_set flags, mkcl_object external_format)
+set_file_stream_elt_type_defaults(MKCL, mkcl_object stream)
+{
+ stream->stream.flags = MKCL_STREAM_TEXT | MKCL_STREAM_LF;
+ stream->stream.byte_size = 8;
+ MKCL_IO_STREAM_ELT_TYPE(stream) = @'base-char';
+ stream->stream.format = mkcl_cons(env, @':iso-8859-1', mkcl_list1(env, @':LF'));
+ stream->stream.format_table = mk_cl_Cnil;
+ stream->stream.encoder = passthrough_encoder;
+ stream->stream.decoder = passthrough_decoder;
+}
+
+static mkcl_object
+set_file_stream_elt_type(MKCL, mkcl_object stream, mkcl_word byte_size, mkcl_stream_flag_set flags, mkcl_object external_format)
{
if (byte_size == 0) flags |= MKCL_STREAM_TEXT;
flags &= ~MKCL_STREAM_SIGNED_BYTES;
element_type = @'unsigned-byte';
} else {/* byte_size == 0 */
- mkcl_FEerror(env, "Binary stream of unspecified element-type", 0);
+ static const mkcl_base_string_object(reason_string_obj, "Binary stream of unspecified element-type");
+ @(return mk_cl_Cnil ((mkcl_object) &reason_string_obj));
}
- MKCL_IO_STREAM_ELT_TYPE(stream) = mk_cl_list(env, 2, element_type, MKCL_MAKE_FIXNUM(byte_size));
- stream->stream.format = element_type;
- stream->stream.ops->read_char = not_character_read_char;
- stream->stream.ops->write_char = not_character_write_char;
-
if (external_format == @':LITTLE-ENDIAN')
flags |= MKCL_STREAM_LITTLE_ENDIAN;
else if (external_format == @':BIG-ENDIAN')
flags |= MKCL_STREAM_LITTLE_ENDIAN; /* Good for x86 and x86_64. JCB */
}
else if (!mkcl_Null(external_format))
- mkcl_FEerror(env, "Invalid binary stream external-format specifier: ~S", 1, external_format);
+ {
+ static const mkcl_base_string_object(reason_control_string_obj,
+ "Invalid binary stream external-format specifier: ~S");
+ @(return mk_cl_Cnil mk_cl_format(env, 3, mk_cl_Cnil, (mkcl_object) &reason_control_string_obj, external_format));
+ }
+
+ /* commit new binary parameters to object */
+ MKCL_IO_STREAM_ELT_TYPE(stream) = mk_cl_list(env, 2, element_type, MKCL_MAKE_FIXNUM(byte_size));
+ stream->stream.format = element_type;
+ stream->stream.ops->read_char = not_character_read_char;
+ stream->stream.ops->write_char = not_character_write_char;
}
else
{ /* Text stream */
mkcl_object line_termination;
-
- stream->stream.ops->read_char = eformat_read_char;
- stream->stream.ops->write_char = eformat_write_char;
+ mkcl_character (*read_char)(MKCL, mkcl_object strm);
+ mkcl_character (*write_char)(MKCL, mkcl_object strm, mkcl_character c);
+ mkcl_object stream_format = stream->stream.format;
+ mkcl_object stream_format_table = stream->stream.format_table;
+ mkcl_eformat_encoder encoder = stream->stream.encoder;
+ mkcl_eformat_decoder decoder = stream->stream.decoder;
+ mkcl_object element_type = MKCL_IO_STREAM_ELT_TYPE(stream);
+
+ read_char = eformat_read_char;
+ write_char = eformat_write_char;
+#ifdef MKCL_WINDOWS
+ line_termination = @':CRLF'; /* default line termination */
+#else
+ line_termination = @':LF'; /* default line termination */
+#endif
if (external_format == @':default')
{
external_format = mkcl_symbol_value(env, @'si::*default-external-format*');
if (external_format == @':default')
- { /* This is the hardcoded fallback. */
- external_format = mkcl_core.default_default_external_format;
- }
+ external_format = mkcl_core.default_default_external_format; /* This is the hardcoded fallback. */
}
if (MKCL_CONSP(external_format)) {
external_format = mk_cl_car(env, format_spec);
line_termination = mk_cl_cadr(env, format_spec);
- if (!mkcl_Null(mk_cl_cddr(env, format_spec)))
- mkcl_FEerror(env, "Invalid external-format specifier: ~S", 1, external_format);
+ if (!mkcl_Null(mk_cl_cddr(env, format_spec))) {
+ static const mkcl_base_string_object(reason_control_string_obj, "Invalid external-format specifier: ~S");
+ @(return mk_cl_Cnil mk_cl_format(env, 3, mk_cl_Cnil, (mkcl_object) &reason_control_string_obj, external_format));
+ }
if (line_termination == @':CR')
flags = (flags | MKCL_STREAM_CR) & ~MKCL_STREAM_LF;
flags = (flags | MKCL_STREAM_LF) & ~MKCL_STREAM_CR;
else if (line_termination == @':CRLF')
flags = flags | (MKCL_STREAM_CR | MKCL_STREAM_LF);
- else
- mkcl_FEerror(env, "Invalid line termination specifier: ~S", 1, line_termination);
- } else {
-#ifdef MKCL_WINDOWS
- line_termination = @':CRLF'; /* default line termination */
-#else
- line_termination = @':LF'; /* default line termination */
-#endif
+ else {
+ static const mkcl_base_string_object(reason_control_string_obj, "Invalid line termination specifier: ~S");
+ @(return mk_cl_Cnil mk_cl_format(env, 3, mk_cl_Cnil, (mkcl_object) &reason_control_string_obj, line_termination));
+ }
}
if (external_format == @':ISO-8859-1' || external_format == @':LATIN-1')
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'base-char';
+ element_type = @'base-char';
byte_size = 8;
- stream->stream.format = @':iso-8859-1';
- stream->stream.encoder = passthrough_encoder;
- stream->stream.decoder = passthrough_decoder;
+ stream_format = @':iso-8859-1';
+ encoder = passthrough_encoder;
+ decoder = passthrough_decoder;
}
else if (external_format == @':UTF-8')
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'character';
+ element_type = @'character';
byte_size = 8;
- stream->stream.format = @':utf-8';
- stream->stream.encoder = utf_8_encoder;
- stream->stream.decoder = utf_8_decoder;
+ stream_format = @':utf-8';
+ encoder = utf_8_encoder;
+ decoder = utf_8_decoder;
}
else if (external_format == @':UTF-16')
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'character';
+ element_type = @'character';
byte_size = 8*2;
- stream->stream.format = @':utf-16';
- stream->stream.encoder = utf_16_encoder;
- stream->stream.decoder = utf_16_decoder;
+ stream_format = @':utf-16';
+ encoder = utf_16_encoder;
+ decoder = utf_16_decoder;
}
else if (external_format == @':UTF-16BE')
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'character';
+ element_type = @'character';
byte_size = 8*2;
- stream->stream.format = @':utf-16be';
- stream->stream.encoder = utf_16be_encoder;
- stream->stream.decoder = utf_16be_decoder;
-
- if (flags | MKCL_STREAM_LITTLE_ENDIAN)
- mkcl_FEerror(env, "Incoherent stream format :UTF-16BE on a little-endian stream", 0);
+ stream_format = @':utf-16be';
+ encoder = utf_16be_encoder;
+ decoder = utf_16be_decoder;
+
+ if (flags | MKCL_STREAM_LITTLE_ENDIAN) {
+ static const mkcl_base_string_object(reason_string_obj,
+ "Incoherent stream format :UTF-16BE on a little-endian stream");
+ @(return mk_cl_Cnil ((mkcl_object) &reason_string_obj));
+ }
}
else if (external_format == @':UTF-16LE')
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'character';
+ element_type = @'character';
byte_size = 8*2;
- stream->stream.format = @':utf-16le';
- stream->stream.encoder = utf_16le_encoder;
- stream->stream.decoder = utf_16le_decoder;
+ stream_format = @':utf-16le';
+ encoder = utf_16le_encoder;
+ decoder = utf_16le_decoder;
flags |= MKCL_STREAM_LITTLE_ENDIAN;
}
else if (external_format == @':UTF-32')
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'character';
+ element_type = @'character';
byte_size = 8*4;
- stream->stream.format = @':utf-32';
- stream->stream.encoder = utf_32_encoder;
- stream->stream.decoder = utf_32_decoder;
+ stream_format = @':utf-32';
+ encoder = utf_32_encoder;
+ decoder = utf_32_decoder;
}
else if (external_format == @':UTF-32BE')
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'character';
+ element_type = @'character';
byte_size = 8*4;
- stream->stream.format = @':utf-32be';
- stream->stream.encoder = utf_32be_encoder;
- stream->stream.decoder = utf_32be_decoder;
-
- if (flags | MKCL_STREAM_LITTLE_ENDIAN)
- mkcl_FEerror(env, "Incoherent stream format :UTF-32BE on a little-endian stream", 0);
+ stream_format = @':utf-32be';
+ encoder = utf_32be_encoder;
+ decoder = utf_32be_decoder;
+
+ if (flags | MKCL_STREAM_LITTLE_ENDIAN) {
+ static const mkcl_base_string_object(reason_string_obj,
+ "Incoherent stream format :UTF-32BE on a little-endian stream");
+ @(return mk_cl_Cnil ((mkcl_object) &reason_string_obj));
+ }
}
else if (external_format == @':UTF-32LE')
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'character';
+ element_type = @'character';
byte_size = 8*4;
- stream->stream.format = @':utf-32le';
- stream->stream.encoder = utf_32le_encoder;
- stream->stream.decoder = utf_32le_decoder;
+ stream_format = @':utf-32le';
+ encoder = utf_32le_encoder;
+ decoder = utf_32le_decoder;
flags |= MKCL_STREAM_LITTLE_ENDIAN;
}
else if (external_format == @':US-ASCII' || external_format == @':ASCII')
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'base-char';
+ element_type = @'base-char';
byte_size = 8;
- stream->stream.format = @':us-ascii';
- stream->stream.encoder = ascii_encoder;
- stream->stream.decoder = ascii_decoder;
+ stream_format = @':us-ascii';
+ encoder = ascii_encoder;
+ decoder = ascii_decoder;
}
else if (MKCL_SYMBOLP(external_format))
{
mkcl_object format_table = mkcl_funcall1(env, @+'si::make-encoding', external_format);
+ mkcl_object failure_reason = MKCL_VALUES(1);
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'character';
- byte_size = 8;
- stream->stream.format_table = format_table;
- stream->stream.format = external_format;
- if (MKCL_CONSP(format_table))
- {
- stream->stream.encoder = user_multistate_encoder;
- stream->stream.decoder = user_multistate_decoder;
- }
+ if (mkcl_Null(format_table))
+ { @(return mk_cl_Cnil failure_reason); }
else
{
- stream->stream.encoder = user_encoder;
- stream->stream.decoder = user_decoder;
+ element_type = @'character';
+ byte_size = 8;
+ stream_format_table = format_table;
+ stream_format = external_format;
+ if (MKCL_CONSP(format_table))
+ {
+ encoder = user_multistate_encoder;
+ decoder = user_multistate_decoder;
+ }
+ else
+ {
+ encoder = user_encoder;
+ decoder = user_decoder;
+ }
}
}
else if (MKCL_HASH_TABLE_P(external_format))
{
- MKCL_IO_STREAM_ELT_TYPE(stream) = @'character';
+ element_type = @'character';
byte_size = 8;
- stream->stream.format = stream->stream.format_table = external_format;
- stream->stream.encoder = user_encoder;
- stream->stream.decoder = user_decoder;
+ stream_format = external_format;
+ stream_format_table = external_format;
+ encoder = user_encoder;
+ decoder = user_decoder;
}
else
- mkcl_FEerror(env, "Invalid or unsupported stream :external-format ~S with flags #x~X",
- 2, external_format, MKCL_MAKE_FIXNUM(flags));
+ {
+ static const mkcl_base_string_object(reason_string_obj,
+ "Invalid or unsupported stream :external-format ~S with flags #x~X");
+ @(return mk_cl_Cnil mk_cl_format(env, 4,
+ mk_cl_Cnil, (mkcl_object) &reason_string_obj,
+ external_format, MKCL_MAKE_FIXNUM(flags)));
+ }
if (stream->stream.ops->write_char == eformat_write_char && (flags & MKCL_STREAM_CR)) {
if (flags & MKCL_STREAM_LF) {
- stream->stream.ops->read_char = eformat_read_char_crlf;
- stream->stream.ops->write_char = eformat_write_char_crlf;
+ read_char = eformat_read_char_crlf;
+ write_char = eformat_write_char_crlf;
line_termination = @':CRLF';
} else {
- stream->stream.ops->read_char = eformat_read_char_cr;
- stream->stream.ops->write_char = eformat_write_char_cr;
+ read_char = eformat_read_char_cr;
+ write_char = eformat_write_char_cr;
line_termination = @':CR';
}
}
- stream->stream.format = mkcl_cons(env, stream->stream.format, mkcl_list1(env, line_termination));
+ /* commit new text parameters to object */
+ MKCL_IO_STREAM_ELT_TYPE(stream) = element_type;
+ stream->stream.format = mkcl_cons(env, stream_format, mkcl_list1(env, line_termination));
+ stream->stream.format_table = stream_format_table;
+ stream->stream.ops->read_char = read_char;
+ stream->stream.ops->write_char = write_char;
+ stream->stream.encoder = encoder;
+ stream->stream.decoder = decoder;
}
{
read_byte = generic_read_byte_be;
write_byte = generic_write_byte_be;
}
+
if (mkcl_input_stream_p(env, stream)) {
stream->stream.ops->read_byte = read_byte;
}
}
stream->stream.flags = flags;
stream->stream.byte_size = byte_size;
+ @(return stream mk_cl_Cnil);
}
mkcl_object
{
mkcl_call_stack_check(env);
if (mkcl_unlikely(MKCL_INSTANCEP(stream))) {
- mkcl_FEerror(env, "Cannot change external format of stream ~A", 1, stream);
- @(return);
+ static const mkcl_base_string_object(reason_control_string_obj, "Cannot change external format of stream ~A");
+ @(return mk_cl_Cnil mk_cl_format(env, 3, mk_cl_Cnil, (mkcl_object) &reason_control_string_obj, stream));
}
switch (stream->stream.mode)
{
case mkcl_smm_io_socket:
{
mkcl_object elt_type = mkcl_stream_element_type(env, stream);
- if (mkcl_unlikely(!(elt_type == @'character' || elt_type == @'base-char')))
- mkcl_FEerror(env, "Cannot change external format of binary stream ~A", 1, stream);
- set_stream_elt_type(env, stream, stream->stream.byte_size, stream->stream.flags, format);
+
+ if (mkcl_unlikely(!(elt_type == @'character' || elt_type == @'base-char'))){
+ static const mkcl_base_string_object(reason_control_string_obj,
+ "Cannot change external format of binary stream ~A");
+ @(return mk_cl_Cnil mk_cl_format(env, 3, mk_cl_Cnil, (mkcl_object) &reason_control_string_obj, stream));
+ } else {
+ mkcl_object status = set_file_stream_elt_type(env, stream, stream->stream.byte_size, stream->stream.flags, format);
+ mkcl_object failure_reason = MKCL_VALUES(1);
+
+ if (mkcl_Null(status))
+ { @(return mk_cl_Cnil failure_reason); }
+ else
+ { @(return mk_cl_Ct mk_cl_Cnil); }
+ }
}
break;
default:
- mkcl_FEerror(env, "Cannot change external format of stream ~A", 1, stream);
- break;
+ {
+ static const mkcl_base_string_object(reason_control_string_obj, "Cannot change external format of stream ~A");
+ @(return mk_cl_Cnil mk_cl_format(env, 3, mk_cl_Cnil, (mkcl_object) &reason_control_string_obj, stream));
+ }
}
- @(return);
}
mkcl_FEerror(env, "Not a valid mode ~D for make_file_stream_from_fd()", 1, MKCL_MAKE_FIXNUM(smm));
}
int flags = 0;
- set_stream_elt_type(env, stream, byte_size, flags, external_format);
+ set_file_stream_elt_type_defaults(env, stream);
+ set_file_stream_elt_type(env, stream, byte_size, flags, external_format);
stream->stream.last_op = 0;
mk_si_set_finalizer(env, stream, mk_cl_Ct);
return stream;
flags = MKCL_STREAM_C_STDIO_STREAM;
- set_stream_elt_type(env, stream, byte_size, flags, external_format);
+ set_file_stream_elt_type_defaults(env, stream);
+ set_file_stream_elt_type(env, stream, byte_size, flags, external_format);
MKCL_IO_STREAM_FILENAME(stream) = fname; /* not really used */
MKCL_IO_STREAM_COLUMN(stream) = 0;
MKCL_IO_STREAM_FILE(stream) = f;
mkcl_object error_output;
mkcl_object null_stream;
#ifdef MKCL_WINDOWS
- /* We presume the 3 standard streams were opened in TEXT mode. */
- mkcl_object external_format = mk_cl_list(env, 2, @':UTF-8', @':LF'); /* temporary default to be adjusted in late init */
- /* WSAStartUp() to be called here? */
WSADATA wsadata;
if (WSAStartup(MAKEWORD(2,2), &wsadata) != NO_ERROR) /* We demand WinSock 2.2 */
mkcl_FEerror(env, "Unable to initialize Windows Socket library", 0);
/* Microsoft's documentation says that we should have a matching call to WSACleanup(), but when? JCB */
-#else
- mkcl_object external_format = @':default';
#endif
+ mkcl_object external_format = @':default';
null_stream = make_stream_from_FILE(env,
mkcl_make_simple_base_string(env, "/dev/null"),
null_stream = mk_cl_make_two_way_stream(env, null_stream, mk_cl_make_broadcast_stream(env, 0));
mkcl_core.null_stream = null_stream;
- standard_input = make_file_stream_from_fd(env,
- mkcl_make_simple_base_string(env, "stdin"),
- STDIN_FILENO, mkcl_smm_input_file,
- 0, external_format);
- standard_output = make_file_stream_from_fd(env,
- mkcl_make_simple_base_string(env, "stdout"),
- STDOUT_FILENO, mkcl_smm_output_file,
- 0, external_format);
- error_output = make_file_stream_from_fd(env,
- mkcl_make_simple_base_string(env, "stderr"),
- STDERR_FILENO, mkcl_smm_output_file,
- 0, external_format);
+#ifdef MKCL_WINDOWS
+ if (mkcl_has_console())
+#endif
+ {
+ standard_input = make_file_stream_from_fd(env,
+ mkcl_make_simple_base_string(env, "stdin"),
+ STDIN_FILENO, mkcl_smm_input_file,
+ 0, external_format);
+ standard_output = make_file_stream_from_fd(env,
+ mkcl_make_simple_base_string(env, "stdout"),
+ STDOUT_FILENO, mkcl_smm_output_file,
+ 0, external_format);
+ error_output = make_file_stream_from_fd(env,
+ mkcl_make_simple_base_string(env, "stderr"),
+ STDERR_FILENO, mkcl_smm_output_file,
+ 0, external_format);
+ }
+#ifdef MKCL_WINDOWS
+ else
+ {
+ standard_input = null_stream;
+ standard_output = mkcl_make_string_output_stream(env, 128, TRUE, @':default');
+ error_output = standard_output;
+ }
+#endif
mkcl_core.standard_input = standard_input;
MKCL_SET(@'*standard-input*', standard_input);
MKCL_SET(@'*debug-io*', aux);
}
- mkcl_def_c_function(env, @'si::stream-encoding-error', /*(mkcl_objectfn_fixed)*/ stream_encoding_error_boot_stub, 3);
- mkcl_def_c_function(env, @'si::stream-decoding-error', /*(mkcl_objectfn_fixed)*/ stream_decoding_error_boot_stub, 3);
+ mkcl_def_c_function(env, @'si::stream-encoding-error', stream_encoding_error_boot_stub, 3);
+ mkcl_def_c_function(env, @'si::stream-decoding-error', stream_decoding_error_boot_stub, 3);
}
void
mkcl_init_late_file(MKCL)
{
#ifdef MKCL_WINDOWS
- if (mk_cl_fboundp(env, @'si::make-encoding'))
+ if (mkcl_has_console() && mk_cl_fboundp(env, @'si::make-encoding'))
{
mkcl_object external_format = mkcl_external_format_from_codepage(env, GetACP());
mkcl_object stdin_external_format = mkcl_external_format_from_codepage(env, GetConsoleCP());
mkcl_object stdout_external_format = mkcl_external_format_from_codepage(env, GetConsoleOutputCP());
- mkcl_core.default_default_external_format = external_format;
- MKCL_SET(@'si::*default-external-format*', external_format);
- MKCL_SETQ(env, @'si::*default-external-format*', external_format);
+ mkcl_object default_format_table = mkcl_funcall1(env, @+'si::make-encoding', external_format);
+
+ if (!mkcl_Null(default_format_table))
+ {
+ mkcl_core.default_default_external_format = external_format;
+ MKCL_SET(@'si::*default-external-format*', external_format);
+ MKCL_SETQ(env, @'si::*default-external-format*', external_format);
+ }
mk_si_stream_external_format_set(env, mkcl_core.standard_input, stdin_external_format);
mk_si_stream_external_format_set(env, mkcl_core.standard_output, stdout_external_format);
if (mkcl_type_of(obj) == mkcl_t_thread)
{
fprintf(stderr, ";; MKCL: thread = %s\n", obj->thread.name->base_string.self);
- mkcl_println(env, obj, mkcl_core.error_output);
}
else
fprintf(stderr, ";; MKCL: non-thread object: %p, type = %d\n", obj, mkcl_type_of(obj));
*argc_ref = nArgs;
}
}
+
+bool mkcl_has_console()
+{
+ HWND console_window = GetConsoleWindow();
+
+ return (console_window != NULL);
+}
#endif /* MKCL_WINDOWS */
(*space* *space*) ;; JCB
(*speed* *speed*) ;; JCB
(*compiler-floating-point-exclusion-set* *compiler-floating-point-exclusion-set*) ;; JCB
+ (ffi::*referenced-libraries* ffi::*referenced-libraries*) ;; JCB
))
(defun next-lcl () (list 'LCL (incf *lcl*)))
(defun mkcl-library-directory ()
"Finds the directory in which the MKCL core library was installed."
(cond (*mkcl-library-directory*)
- ((mkcl:probe-file-p lib-dir-probe)
- lib-dir
- )
+ ((mkcl:probe-file-p lib-dir-probe) lib-dir)
(*mkcl-default-library-directory*)
((error "Unable to find library directory")))))
-
(defun libs-ld-flags (libraries mkcl-libraries mkcl-shared external-shared)
(declare (ignorable mkcl-shared))
- (let ((libdir (namestring (mkcl-library-directory)))
- (out (reverse libraries)))
+ (let ((mkcl-libdir (namestring (mkcl-library-directory)))
+ out)
+
+ (dolist (lib-set (si:dyn-list libraries ffi::*referenced-libraries*))
+ (dolist (lib-spec lib-set)
+ (if (pathnamep lib-spec)
+ (push (mkcl:str+ (namestring lib-spec) " ") out)
+ (let ((lib-spec-as-path (pathname lib-spec)))
+ (if (or (pathname-directory lib-spec-as-path) (pathname-type lib-spec-as-path))
+ (push (mkcl:str+ (namestring lib-spec-as-path) " ") out)
+ (push (mkcl:str+ "-l" lib-spec " ") out))))))
+
#-mkcl-bootstrap
- (unless mkcl-shared (setq libdir (mkcl:bstr+ libdir "mkcl-" (si:mkcl-version) "/")))
+ (unless mkcl-shared (setq mkcl-libdir (mkcl:bstr+ mkcl-libdir "mkcl-" (si:mkcl-version) "/")))
(dolist (lib mkcl-libraries)
- (push (mkcl:bstr+ "\"" libdir lib "\" ") out)
+ (push (mkcl:bstr+ "\"" mkcl-libdir lib "\" ") out)
)
(unless external-shared
(push "-Wl,-Bstatic " out)
env->own_thread->thread.status = mkcl_thread_done;
/* MKCL's shutdown watchdog should be inserted here. */
return mkcl_shutdown_watchdog(env);
-#if 0
- mkcl_thread_exit(env, MKCL_THREAD_KILLED);
- return(-1); /* This line is normally never reached. */
-#endif
}
}~%")
} MKCL_CATCH_ALL_END;
env->own_thread->thread.status = mkcl_thread_done;
return mkcl_shutdown_watchdog(env);
-#if 0
- mkcl_thread_exit(env, MKCL_THREAD_KILLED);
- return(-1);
-#endif
}
}~%")
object-files
extra-ld-flags
(init-name nil)
- (prologue-code "" prologue-p)
- (epilogue-code (when (eq target :program) '(SI::TOP-LEVEL)))
(libraries nil) ;; a list of strings, each naming a library
(use-mkcl-shared-libraries t)
(use-external-shared-libraries t)
#+windows (subsystem :console) ;; only for :program target on :windows
+ (prologue-code "" prologue-p)
+ (epilogue-code (when (and (eq target :program) #+windows (eq subsystem :console)) '(SI::TOP-LEVEL)))
&aux
(*builder-to-delete* nil)
output-internal-name
(ecase target
(:program
(format c-file +lisp-program-init+ init-name "" submodules "")
- (format c-file #+windows (ecase subsystem (:console +lisp-program-main+)
+ (format c-file #+windows (ecase subsystem
+ (:console +lisp-program-main+)
(:windows +lisp-program-winmain+))
#-windows +lisp-program-main+
prologue-code init-name epilogue-code)
(close c-file)
(rename-file c-file c-pathname)
(compiler-cc c-basename o-basename work-dir)
- #+mingw32
+ #+(or mingw32 mingw64)
(ecase subsystem
(:console (push "-mconsole" object-files))
(:windows (push "-mwindows" object-files)))
(compiler-conditions)
(data-init)
(t1expr form)
- (let (#+(or mingw32 msvc cygwin)(*self-destructing-fasl* t))
+ (let (#+(or mingw32 mingw64 msvc cygwin)(*self-destructing-fasl* t))
(compiler-pass2 c-pathname h-pathname data-pathname init-name :input-designator (format nil "~A" definition)))
(setf si:*compiler-constants* (data-dump data-file #|data-pathname|# :close-when-done t))
#! /bin/sh
# From configure.in Revision.
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.67 for mkcl 1.1.2.
+# Generated by GNU Autoconf 2.67 for mkcl 1.1.3.
#
#
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
# Identity of this package.
PACKAGE_NAME='mkcl'
PACKAGE_TARNAME='mkcl'
-PACKAGE_VERSION='1.1.2'
-PACKAGE_STRING='mkcl 1.1.2'
+PACKAGE_VERSION='1.1.3'
+PACKAGE_STRING='mkcl 1.1.3'
PACKAGE_BUGREPORT=''
PACKAGE_URL=''
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures mkcl 1.1.2 to adapt to many kinds of systems.
+\`configure' configures mkcl 1.1.3 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of mkcl 1.1.2:";;
+ short | recursive ) echo "Configuration of mkcl 1.1.3:";;
esac
cat <<\_ACEOF
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-mkcl configure 1.1.2
+mkcl configure 1.1.3
generated by GNU Autoconf 2.67
Copyright (C) 2010 Free Software Foundation, Inc.
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by mkcl $as_me 1.1.2, which was
+It was created by mkcl $as_me 1.1.3, which was
generated by GNU Autoconf 2.67. Invocation command line was
$ $0 $@
boehm_configure_flags=""
- TARGETS='bin/mkcl$(EXE)'
+ TARGETS='bin/mkcl$(EXE)'
SUBDIRS=c
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by mkcl $as_me 1.1.2, which was
+This file was extended by mkcl $as_me 1.1.3, which was
generated by GNU Autoconf 2.67. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
-mkcl config.status 1.1.2
+mkcl config.status 1.1.3
configured by $0, generated by GNU Autoconf 2.67,
with options \\"\$ac_cs_config\\"
dnl Jean-Claude Beaudoin 2012.04.28
dnl
-AC_INIT([mkcl],[1.1.2],[])
+AC_INIT([mkcl],[1.1.3],[])
AC_REVISION([$Revision$])
AC_CONFIG_SRCDIR([bare.lsp.in])
AC_CONFIG_AUX_DIR([${srcdir}/gc])
(defmacro define-symbol-macro (&whole whole symbol expansion)
(cond ((not (symbolp symbol))
- (error "DEFINE-SYMBOL-MACRO: ~A is not a symbol" symbol))
+ (simple-program-error "DEFINE-SYMBOL-MACRO: ~A is not a symbol" symbol))
((specialp symbol)
- (error "DEFINE-SYMBOL-MACRO: cannot redefine a special variable, ~A" symbol))
+ (simple-program-error "DEFINE-SYMBOL-MACRO: cannot redefine a special variable, ~A" symbol))
(t
`(define-when (:load-toplevel :execute) ;;progn
(put-sysprop ',symbol 'si::symbol-macro
(not (eval-feature (second x))))
(t (error "~S is not a valid feature expression." x))))
+(sys:*make-constant 'keyword-package (find-package "KEYWORD"))
+
(defun do-read-feature (stream subchar arg test)
(when arg
(error "Reading from ~S: no number should appear between # and ~A"
stream subchar))
- (let ((feature (let ((*package* (find-package "KEYWORD")))
+ (let ((feature (let ((*package* keyword-package #|(find-package "KEYWORD")|#))
(read stream t nil t))))
(if (and (not *read-suppress*) (eq (eval-feature feature) test))
(read stream t nil t)
(:nicknames "UFFI")
(:export "CLINES" "DEFENTRY" "DEFLA" "DEFCBODY" "DEFINLINE" "C-INLINE" ;; extension to UFFI
"DEFCALLBACK" "CALLBACK" ;; extension to UFFI
+ "FOREIGN" ;; extension to UFFI
;; The UFFI Protocol
"DEF-CONSTANT" "DEF-FOREIGN-TYPE" "DEF-ENUM" "DEF-STRUCT"
;;; FOREIGN TYPES
;;;
+(deftype foreign () 'si:foreign)
+
(defvar *ffi-types* (make-hash-table :size 128))
(defun foreign-elt-type-p (name)
(def-foreign-type ,name :int)
,@forms)))
+;;;----------------------------------------------------------------------
+;;;
+
+(defun %foreign-data-set (obj ndx type value)
+ (cond ((foreign-elt-type-p type)
+ (si::foreign-set-elt obj ndx type value))
+ ((atom type)
+ (error "Unknown foreign primitive type: ~A" type))
+ ((eq (first type) '*)
+ (si::foreign-set-elt obj ndx :pointer-void value))
+ (t
+ (si::foreign-set obj ndx value))))
+
+(defun %foreign-data-ref (obj ndx type size) ;;&optional (size 0 size-p))
+ (cond ((foreign-elt-type-p type) ;; primitive types.
+ (si::foreign-ref-elt obj ndx type))
+ ((atom type)
+ (error "Unknown foreign primitive type: ~A" type))
+ ((eq (first type) '*) ;; pointer types
+ (si::foreign-recast (si::foreign-ref-elt obj ndx :pointer-void)
+ (size-of-foreign-type (second type))
+ type))
+ (t ;; agregate types (:struct :union :array)
+ ;;(si::foreign-ref obj ndx (if size-p size (size-of-foreign-type type)) type)
+ (si::foreign-ref obj ndx size type)
+ )))
;;;----------------------------------------------------------------------
;;; STRUCTURE TYPES
(slot-position struct-type field)
(unless slot-size
(error "~A is not a field of the type ~A" field struct-type))
- (%foreign-ref object slot-ndx slot-type slot-size)))
+ (%foreign-data-ref object slot-ndx slot-type slot-size)))
(defun (setf get-slot-value) (value object struct-type field)
(multiple-value-bind (slot-ndx slot-type slot-size)
(slot-position struct-type field)
(unless slot-size
(error "~A is not a field of the type ~A" field struct-type))
- (%foreign-set object slot-ndx slot-type value)))
+ (%foreign-data-set object slot-ndx slot-type value)))
(defun get-slot-pointer (object struct-type field)
(multiple-value-bind (slot-ndx slot-type slot-size)
(error "Out of bounds when accessing array ~A." array))
(%foreign-data-set (si::foreign-recast array (+ ndx element-size) array-type) ndx element-type value)))
-(defun %foreign-data-set (obj ndx type value)
- (cond ((foreign-elt-type-p type)
- (si::foreign-set-elt obj ndx type value))
- ((atom type)
- (error "Unknown foreign primitive type: ~A" type))
- ((eq (first type) '*)
- (si::foreign-set-elt obj ndx :pointer-void value))
- (t
- (si::foreign-set obj ndx value))))
-
-(defun %foreign-data-ref (obj ndx type &optional (size 0 size-p))
- (cond ((foreign-elt-type-p type) ;; primitive types.
- (si::foreign-ref-elt obj ndx type))
- ((atom type)
- (error "Unknown foreign primitive type: ~A" type))
- ((eq (first type) '*) ;; pointer types
- (si::foreign-recast (si::foreign-ref-elt obj ndx :pointer-void)
- (size-of-foreign-type (second type))
- type))
- (t ;; agregate types (:struct :union :array)
- (si::foreign-ref obj ndx (if size-p size (size-of-foreign-type type)) type))))
;;;----------------------------------------------------------------------
;;; UNIONS
)))))
nil)
-#|
-;; This code, here commented out, is useful only for the UFFI interface and only on
-;; MS-Windows were the linker demands to have access to the linkee function object code
-;; at link time. JCB
-;; This whole facility is in deep need of a redesign anyway, so it is decommissoned for now.
-;; Use CFFI instead. JCB
-(defvar +loaded-libraries+ nil)
-
-(defun do-load-foreign-library (tmp &optional system-library) ;; What is the use of this? JCB
- (let* ((path (cond ((pathnamep tmp) tmp)
- ((mkcl:probe-file-p (setf tmp (pathname (string tmp)))) tmp)
- (t (compile-file-pathname tmp :type #+msvc :lib #-msvc :dll))))
- (filename (namestring path))
- (pack (find-package "COMPILER"))
- (flag (if system-library
- (concatenate 'string "-l" tmp)
- filename)))
- (unless (find filename ffi::+loaded-libraries+ :test #'string-equal)
- (setf (symbol-value (intern "*LD-FLAGS*" pack))
- (concatenate 'string (symbol-value (intern "*LD-FLAGS*" pack)) " " flag))
- (setf (symbol-value (intern "*BUNDLE-LD-FLAGS*" pack))
- (concatenate 'string (symbol-value (intern "*BUNDLE-LD-FLAGS*" pack))
- " " flag))
- (setf (symbol-value (intern "*SHARED-LD-FLAGS*" pack))
- (concatenate 'string (symbol-value (intern "*SHARED-LD-FLAGS*" pack))
- " " flag))
- (push filename ffi::+loaded-libraries+))
- t))
-|#
-
-(defmacro load-foreign-library (filename &key module supporting-libraries force-load
- system-library)
- (declare (ignore module force-load supporting-libraries))
- (let (#|(compile-form (and (constantp filename)
- `((eval-when (:compile-toplevel)
- (do-load-foreign-library ,filename
- ,system-library)))))|#
- (dyn-form (unless system-library
- `((si:load-foreign-module ,filename)))))
- ;;(declare (ignore compile-form)) ;; JCB
- `(progn #|,@compile-form|# ,@dyn-form)))
+(defvar *referenced-libraries* nil) ;; used by the CMP compiler during link phase.
+
+(defun do-load-foreign-library (tmp)
+ (let* ((path (if (pathnamep tmp) tmp (pathname (string tmp))))
+ (filename (namestring path))
+ )
+ (unless (find filename ffi::*referenced-libraries* :test #+unix #'string= #+windows #'string-equal)
+ (push filename ffi::*referenced-libraries*)
+ t)))
+
+(defmacro load-foreign-library (filename &key module supporting-libraries force-load)
+ (declare (ignore module force-load supporting-libraries))
+ (let ((compile-form (and (constantp filename)
+ `(eval-when (:compile-toplevel)
+ (do-load-foreign-library ,filename))))
+ (dyn-form `(si:load-foreign-module ,filename)))
+ (or compile-form dyn-form)
+ ))
;;;----------------------------------------------------------------------
;;; CALLBACKS
;;;
(defun clines (&rest args)
- (error "The special form clines cannot be used in the interpreter: ~A"
- args))
+ (declare (ignore args))
+ ;;(error "The special form clines cannot be used in the interpreter: ~A" args) ;; why be so anal?
+ )
(eval-when (:load-toplevel :execute)
(defmacro c-inline (args arg-types ret-type &rest others)
(defun load-encoding (name)
#-unicode
- (error "Cannot load encoding ~A because this MKCL instance does not have Unicode support" name)
+ (values nil (format nil "Cannot load encoding ~A because this MKCL instance does not have Unicode support" name))
#+unicode
(let ((filename (make-pathname :name (symbol-name name) :defaults "SYS:ENCODINGS;")))
(cond ((mkcl:probe-file-p filename)
(read-sequence s in)
s)))
(t
- (error "Unable to find mapping file ~A for encoding ~A" filename name)))))
+ (values nil (format nil "Unable to find mapping file ~A for encoding ~A" filename name))))))
(defun make-encoding (mapping)
#-unicode
- (error "Not a valid external format ~A" mapping)
+ (values nil (format nil "Not a valid external format ~A" mapping))
#+unicode
(cond
((symbolp mapping)
#+unicode '(:UTF-8 :UTF-16 :UTF-16BE :UTF-16LE :UTF-32 :UTF-32BE :UTF-32LE :ISO-8859-1 :US-ASCII :DEFAULT)
#-unicode '(:DEFAULT)
:test #'string=)
- (values (intern (symbol-name mapping) (find-package "KEYWORD"))) ;; This is a built-in mapping.
+ (values (intern (symbol-name mapping) keyword-package #|(find-package "KEYWORD")|#)) ;; This is a built-in mapping.
(let* ((mk-ext-pkg (find-package "MK-EXT"))
(var (find-symbol (symbol-name mapping) mk-ext-pkg)))
(unless var
(progn
(when mk-ext-was-closed (reopen-package mk-ext-pkg))
(setq var (intern (symbol-name mapping) mk-ext-pkg))
- (setq encoding (make-encoding (load-encoding mapping)))
+ (multiple-value-bind (array-map failure-reason)
+ (load-encoding mapping)
+ (if array-map
+ (setq encoding (make-encoding array-map))
+ (values nil failure-reason)))
(set var encoding)
)
(when mk-ext-was-closed (close-package mk-ext-pkg)))))
(setf (gethash byte output) unicode-char)
(setf (gethash unicode-char output) byte))))
(t
- (error "Not a valid external format ~A" mapping))))
-
+ (values nil (format nil "Not a valid external format ~A" mapping)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
/* alloc.c / alloc_2.c */
+ extern MKCL_API void * mkcl_alloc_pages(MKCL, mkcl_index nb_pages);
extern MKCL_API mkcl_object mkcl_alloc_cdisplay(MKCL, mkcl_index nb_levels);
extern MKCL_API mkcl_object mkcl_alloc_clevel_block(MKCL, mkcl_object producer, const union mkcl_lispunion * const outer, const mkcl_index nb_vars);
extern MKCL_API mkcl_object mkcl_alloc_raw_instance(MKCL, mkcl_index nb_slots);
extern MKCL_API mkcl_object mk_si_argc(MKCL);
extern MKCL_API mkcl_object mkcl_argv(MKCL, mkcl_index index);
extern MKCL_API mkcl_object mk_si_argv(MKCL, mkcl_object index);
+#ifdef MKCL_WINDOWS
+ extern MKCL_API void mkcl_get_commandline_args_from_Windows(int * argc_ref, char *** argv_ref);
+ extern MKCL_API bool mkcl_has_console();
+#endif
extern MKCL_API mkcl_object mk_mkcl_getenv(MKCL, mkcl_object var);
extern MKCL_API mkcl_object mkcl_getenv(MKCL, mkcl_object var);
extern MKCL_API mkcl_object mk_mkcl_setenv(MKCL, mkcl_object var, mkcl_object value);
#ifdef __MINGW32__
/* These defines have to be done before any system include. */
# define __USE_MINGW_ANSI_STDIO 1
+# include <w32api.h>
# define WINVER WindowsXP /* Don't want to support below that. JCB */
# ifndef __MSVCRT_VERSION__
/* High byte is the major version, low byte is the minor. */
#ifdef MKCL_WINDOWS
# define WIN32_LEAN_AND_MEAN 1 /* Do not include winsock.h */
+#ifndef WINVER
+# define WINVER 0x0501 /* We require at least Windows XP or later. */
+# define _WIN32_WINNT WINVER
+#endif
# include <winsock2.h>
# include <windows.h>
# include <malloc.h> /* for alloca() */
common-lisp.net / projects/mkcl/mkcl.git / commitdiff
