mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-13 08:20:31 -07:00
Code Issues Projects Releases Packages Wiki Activity

indent: d-f

Browse source
This commit is contained in:
Daniel Kochmański 2016-05-05 15:24:58 +02:00
parent 749b97d06c
commit ae7cae404d
15 changed files with 7971 additions and 8004 deletions
Download patch file Download diff file Expand all files Collapse all files

23
src/c/compiler.d
View file

@ -131,19 +131,18 @@ static int c_listA(cl_env_ptr env, cl_object args, int push);
static cl_object ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda);
static void FEillegal_variable_name(cl_object) ecl_attr_noreturn;
static void FEill_formed_input(void) ecl_attr_noreturn;
static void FEill_formed_input(void) ecl_attr_noreturn;
/* -------------------- SAFE LIST HANDLING -------------------- */
static cl_object
pop(cl_object *l) {
cl_object head, list = *l;
unlikely_if (ECL_ATOM(list))
FEill_formed_input();
head = ECL_CONS_CAR(list);
*l = ECL_CONS_CDR(list);
return head;
}
/* -------------------- SAFE LIST HANDLING -------------------- */
static cl_object
pop(cl_object *l) {
cl_object head, list = *l;
unlikely_if (ECL_ATOM(list))
FEill_formed_input();
head = ECL_CONS_CAR(list);
*l = ECL_CONS_CDR(list);
return head;
}
static cl_object
pop_maybe_nil(cl_object *l) {

1113
src/c/disassembler.d
View file

File diff suppressed because it is too large Load diff

1175
src/c/dpp.c
View file

File diff suppressed because it is too large Load diff

23
src/c/ecl_constants.h
View file

@ -1,19 +1,14 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
ecl_constants.c -- constant values for all_symbols.d
*/
/*
Copyright (c) 2010, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
* ecl_constants.h - contstant values for all_symbols.d
*
* Copyright (c) 2010 Juan Jose Garcia Ripoll
*
* See file 'LICENSE' for the copyright details.
*
*/
#include <float.h>
#include <ecl/ecl-inl.h>

109
src/c/ecl_features.h
View file

@ -1,120 +1,115 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
features.h -- names of features compiled into ECL
*/
/*
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi.
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
* features.h - names of features compiled into ECL
*
* Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
* Copyright (c) 1990 Giuseppe Attardi
* Copyright (c) 2001 Juan Jose Garcia Ripoll
*
* See file 'LICENSE' for the copyright details.
*
*/
ecl_def_string_array(feature_names,static,const) = {
ecl_def_string_array_elt("ECL"),
ecl_def_string_array_elt("COMMON"),
ecl_def_string_array_elt(ECL_ARCHITECTURE),
ecl_def_string_array_elt("FFI"),
ecl_def_string_array_elt("PREFIXED-API"),
ecl_def_string_array_elt("ECL"),
ecl_def_string_array_elt("COMMON"),
ecl_def_string_array_elt(ECL_ARCHITECTURE),
ecl_def_string_array_elt("FFI"),
ecl_def_string_array_elt("PREFIXED-API"),
#ifdef ECL_IEEE_FP
ecl_def_string_array_elt("IEEE-FLOATING-POINT"),
ecl_def_string_array_elt("IEEE-FLOATING-POINT"),
#endif
ecl_def_string_array_elt("COMMON-LISP"),
ecl_def_string_array_elt("ANSI-CL"),
ecl_def_string_array_elt("COMMON-LISP"),
ecl_def_string_array_elt("ANSI-CL"),
#if defined(GBC_BOEHM)
ecl_def_string_array_elt("BOEHM-GC"),
ecl_def_string_array_elt("BOEHM-GC"),
#endif
#ifdef ECL_THREADS
ecl_def_string_array_elt("THREADS"),
ecl_def_string_array_elt("THREADS"),
#endif
ecl_def_string_array_elt("CLOS"),
ecl_def_string_array_elt("CLOS"),
#ifdef ENABLE_DLOPEN
ecl_def_string_array_elt("DLOPEN"),
ecl_def_string_array_elt("DLOPEN"),
#endif
ecl_def_string_array_elt("ECL-PDE"),
ecl_def_string_array_elt("ECL-PDE"),
#if defined(unix) || defined(netbsd) || defined(openbsd) || defined(linux) || defined(darwin) || \
defined(freebsd) || defined(dragonfly) || defined(kfreebsd) || defined(gnu) || defined(nsk)
ecl_def_string_array_elt("UNIX"),
defined(freebsd) || defined(dragonfly) || defined(kfreebsd) || defined(gnu) || defined(nsk)
ecl_def_string_array_elt("UNIX"),
#endif
#ifdef BSD
ecl_def_string_array_elt("BSD"),
ecl_def_string_array_elt("BSD"),
#endif
#ifdef SYSV
ecl_def_string_array_elt("SYSTEM-V"),
ecl_def_string_array_elt("SYSTEM-V"),
#endif
#if defined(__MINGW32__)
ecl_def_string_array_elt("MINGW32"),
ecl_def_string_array_elt("WIN32"),
ecl_def_string_array_elt("MINGW32"),
ecl_def_string_array_elt("WIN32"),
#endif
#if defined(__WIN64__)
ecl_def_string_array_elt("WIN64"),
ecl_def_string_array_elt("WIN64"),
#endif
#ifdef _MSC_VER
ecl_def_string_array_elt("MSVC"),
ecl_def_string_array_elt("MSVC"),
#endif
#if defined(ECL_MS_WINDOWS_HOST)
ecl_def_string_array_elt("WINDOWS"),
ecl_def_string_array_elt("WINDOWS"),
#endif
#ifdef ECL_CMU_FORMAT
ecl_def_string_array_elt("CMU-FORMAT"),
ecl_def_string_array_elt("CMU-FORMAT"),
#endif
#ifdef ECL_CLOS_STREAMS
ecl_def_string_array_elt("CLOS-STREAMS"),
ecl_def_string_array_elt("CLOS-STREAMS"),
#endif
#if defined(HAVE_LIBFFI)
ecl_def_string_array_elt("DFFI"),
ecl_def_string_array_elt("DFFI"),
#endif
#ifdef ECL_UNICODE
ecl_def_string_array_elt("UNICODE"),
ecl_def_string_array_elt("UNICODE"),
#endif
#ifdef ECL_LONG_FLOAT
ecl_def_string_array_elt("LONG-FLOAT"),
ecl_def_string_array_elt("LONG-FLOAT"),
#endif
#ifdef ECL_RELATIVE_PACKAGE_NAMES
ecl_def_string_array_elt("RELATIVE-PACKAGE-NAMES"),
ecl_def_string_array_elt("RELATIVE-PACKAGE-NAMES"),
#endif
#ifdef ecl_uint16_t
ecl_def_string_array_elt("UINT16-T"),
ecl_def_string_array_elt("UINT16-T"),
#endif
#ifdef ecl_uint32_t
ecl_def_string_array_elt("UINT32-T"),
ecl_def_string_array_elt("UINT32-T"),
#endif
#ifdef ecl_uint64_t
ecl_def_string_array_elt("UINT64-T"),
ecl_def_string_array_elt("UINT64-T"),
#endif
#ifdef ecl_long_long_t
ecl_def_string_array_elt("LONG-LONG"),
ecl_def_string_array_elt("LONG-LONG"),
#endif
#ifdef ECL_EXTERNALIZABLE
ecl_def_string_array_elt("EXTERNALIZABLE"),
ecl_def_string_array_elt("EXTERNALIZABLE"),
#endif
#ifdef __cplusplus
ecl_def_string_array_elt("C++"),
ecl_def_string_array_elt("C++"),
#endif
#ifdef ECL_SSE2
ecl_def_string_array_elt("SSE2"),
ecl_def_string_array_elt("SSE2"),
#endif
#ifdef ECL_SEMAPHORES
ecl_def_string_array_elt("SEMAPHORES"),
ecl_def_string_array_elt("SEMAPHORES"),
#endif
#ifdef ECL_RWLOCK
ecl_def_string_array_elt("ECL-READ-WRITE-LOCK"),
ecl_def_string_array_elt("ECL-READ-WRITE-LOCK"),
#endif
#ifdef WORDS_BIGENDIAN
ecl_def_string_array_elt("BIG-ENDIAN"),
ecl_def_string_array_elt("BIG-ENDIAN"),
#else
ecl_def_string_array_elt("LITTLE-ENDIAN"),
ecl_def_string_array_elt("LITTLE-ENDIAN"),
#endif
#ifdef ECL_WEAK_HASH
ecl_def_string_array_elt("ECL-WEAK-HASH"),
ecl_def_string_array_elt("ECL-WEAK-HASH"),
#endif
ecl_def_string_array_elt(0)
ecl_def_string_array_elt(0)
};

635
src/c/error.d
View file

@ -1,21 +1,16 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
error.c -- Error handling.
*/
/*
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi.
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
* error.d - error handling
*
* Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
* Copyright (c) 1990 Giuseppe Attardi
* Copyright (c) 2001 Juan Jose Garcia Ripoll
*
* See file 'LICENSE' for the copyright details.
*
*/
#include <ecl/ecl.h>
#include <stdio.h>
@ -32,73 +27,73 @@
static cl_object
cl_symbol_or_object(cl_object x)
{
if (ECL_FIXNUMP(x))
return (cl_object)(cl_symbols + ecl_fixnum(x));
return x;
if (ECL_FIXNUMP(x))
return (cl_object)(cl_symbols + ecl_fixnum(x));
return x;
}
void
_ecl_unexpected_return()
{
ecl_internal_error(
"*** \n"
"*** A call to ERROR returned without handling the error.\n"
"*** This should have never happened and is usually a signal\n"
"*** that the debugger or the universal error handler were\n"
"*** improperly coded or altered. Please contact the maintainers\n"
"***\n");
ecl_internal_error(
"*** \n"
"*** A call to ERROR returned without handling the error.\n"
"*** This should have never happened and is usually a signal\n"
"*** that the debugger or the universal error handler were\n"
"*** improperly coded or altered. Please contact the maintainers\n"
"***\n");
}
void
ecl_internal_error(const char *s)
{
int saved_errno = errno;
fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s);
if (saved_errno) {
fprintf(stderr, " [%d: %s]\n", saved_errno,
strerror(saved_errno));
}
fflush(stderr);
si_dump_c_backtrace(ecl_make_fixnum(32));
int saved_errno = errno;
fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s);
if (saved_errno) {
fprintf(stderr, " [%d: %s]\n", saved_errno,
strerror(saved_errno));
}
fflush(stderr);
si_dump_c_backtrace(ecl_make_fixnum(32));
#ifdef SIGIOT
signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */
signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */
#endif
abort();
abort();
}
void
ecl_unrecoverable_error(cl_env_ptr the_env, const char *message)
{
/*
* Right now we have no means of specifying a jump point
* for really bad events. We just jump to the outermost
* frame, which is equivalent to quitting, and wait for
* someone to intercept this jump.
*/
ecl_frame_ptr destination;
cl_object tag;
/*
* Right now we have no means of specifying a jump point
* for really bad events. We just jump to the outermost
* frame, which is equivalent to quitting, and wait for
* someone to intercept this jump.
*/
ecl_frame_ptr destination;
cl_object tag;
/*
* We output the error message with very low level routines
* because we can not risk another stack overflow.
*/
writestr_stream(message, cl_core.error_output);
/*
* We output the error message with very low level routines
* because we can not risk another stack overflow.
*/
writestr_stream(message, cl_core.error_output);
tag = ECL_SYM_VAL(the_env, @'si::*quit-tag*');
the_env->nvalues = 0;
if (tag) {
destination = frs_sch(tag);
if (destination) {
ecl_unwind(the_env, destination);
}
}
if (the_env->frs_org <= the_env->frs_top) {
destination = ecl_process_env()->frs_org;
ecl_unwind(the_env, destination);
} else {
ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;");
}
tag = ECL_SYM_VAL(the_env, @'si::*quit-tag*');
the_env->nvalues = 0;
if (tag) {
destination = frs_sch(tag);
if (destination) {
ecl_unwind(the_env, destination);
}
}
if (the_env->frs_org <= the_env->frs_top) {
destination = ecl_process_env()->frs_org;
ecl_unwind(the_env, destination);
} else {
ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;");
}
}
/*****************************************************************************/
@ -108,26 +103,26 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message)
void
FEerror(const char *s, int narg, ...)
{
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
ecl_enable_interrupts();
funcall(4, @'si::universal-error-handler',
ECL_NIL, /* not correctable */
make_constant_base_string(s), /* condition text */
cl_grab_rest_args(args));
_ecl_unexpected_return();
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
ecl_enable_interrupts();
funcall(4, @'si::universal-error-handler',
ECL_NIL, /* not correctable */
make_constant_base_string(s), /* condition text */
cl_grab_rest_args(args));
_ecl_unexpected_return();
}
cl_object
CEerror(cl_object c, const char *err, int narg, ...)
{
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
ecl_enable_interrupts();
return funcall(4, @'si::universal-error-handler',
c, /* correctable */
make_constant_base_string(err), /* continue-format-string */
cl_grab_rest_args(args));
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
ecl_enable_interrupts();
return funcall(4, @'si::universal-error-handler',
c, /* correctable */
make_constant_base_string(err), /* continue-format-string */
cl_grab_rest_args(args));
}
/***********************
@ -137,245 +132,245 @@ CEerror(cl_object c, const char *err, int narg, ...)
void
FEprogram_error(const char *s, int narg, ...)
{
cl_object real_args, text;
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
text = make_constant_base_string(s);
real_args = cl_grab_rest_args(args);
if (cl_boundp(@'si::*current-form*') != ECL_NIL) {
/* When FEprogram_error is invoked from the compiler, we can
* provide information about the offending form.
*/
cl_object stmt = ecl_symbol_value(@'si::*current-form*');
if (stmt != ECL_NIL) {
real_args = @list(3, stmt, text, real_args);
text = make_constant_base_string("In form~%~S~%~?");
}
}
si_signal_simple_error(4,
@'program-error', /* condition name */
ECL_NIL, /* not correctable */
text,
real_args);
cl_object real_args, text;
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
text = make_constant_base_string(s);
real_args = cl_grab_rest_args(args);
if (cl_boundp(@'si::*current-form*') != ECL_NIL) {
/* When FEprogram_error is invoked from the compiler, we can
* provide information about the offending form.
*/
cl_object stmt = ecl_symbol_value(@'si::*current-form*');
if (stmt != ECL_NIL) {
real_args = @list(3, stmt, text, real_args);
text = make_constant_base_string("In form~%~S~%~?");
}
}
si_signal_simple_error(4,
@'program-error', /* condition name */
ECL_NIL, /* not correctable */
text,
real_args);
}
void
FEprogram_error_noreturn(const char *s, int narg, ...)
{
cl_object real_args, text;
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
text = make_constant_base_string(s);
real_args = cl_grab_rest_args(args);
if (cl_boundp(@'si::*current-form*') != ECL_NIL) {
/* When FEprogram_error is invoked from the compiler, we can
* provide information about the offending form.
*/
cl_object stmt = ecl_symbol_value(@'si::*current-form*');
if (stmt != ECL_NIL) {
real_args = @list(3, stmt, text, real_args);
text = make_constant_base_string("In form~%~S~%~?");
}
}
si_signal_simple_error(4,
@'program-error', /* condition name */
ECL_NIL, /* not correctable */
text,
real_args);
cl_object real_args, text;
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
text = make_constant_base_string(s);
real_args = cl_grab_rest_args(args);
if (cl_boundp(@'si::*current-form*') != ECL_NIL) {
/* When FEprogram_error is invoked from the compiler, we can
* provide information about the offending form.
*/
cl_object stmt = ecl_symbol_value(@'si::*current-form*');
if (stmt != ECL_NIL) {
real_args = @list(3, stmt, text, real_args);
text = make_constant_base_string("In form~%~S~%~?");
}
}
si_signal_simple_error(4,
@'program-error', /* condition name */
ECL_NIL, /* not correctable */
text,
real_args);
}
void
FEcontrol_error(const char *s, int narg, ...)
{
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
si_signal_simple_error(4,
@'control-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(s), /* format control */
cl_grab_rest_args(args)); /* format args */
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
si_signal_simple_error(4,
@'control-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(s), /* format control */
cl_grab_rest_args(args)); /* format args */
}
void
FEreader_error(const char *s, cl_object stream, int narg, ...)
{
cl_object message = make_constant_base_string(s);
cl_object args_list;
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
args_list = cl_grab_rest_args(args);
if (Null(stream)) {
/* Parser error */
si_signal_simple_error(4,
@'parse-error', /* condition name */
ECL_NIL, /* not correctable */
message, /* format control */
args_list);
} else {
/* Actual reader error */
cl_object prefix = make_constant_base_string("Reader error in file ~S, "
"position ~D:~%");
cl_object position = cl_file_position(1, stream);
message = si_base_string_concatenate(2, prefix, message);
args_list = cl_listX(3, stream, position, args_list);
si_signal_simple_error(6,
@'reader-error', /* condition name */
ECL_NIL, /* not correctable */
message, /* format control */
args_list, /* format args */
@':stream', stream);
}
cl_object message = make_constant_base_string(s);
cl_object args_list;
ecl_va_list args;
ecl_va_start(args, narg, narg, 0);
args_list = cl_grab_rest_args(args);
if (Null(stream)) {
/* Parser error */
si_signal_simple_error(4,
@'parse-error', /* condition name */
ECL_NIL, /* not correctable */
message, /* format control */
args_list);
} else {
/* Actual reader error */
cl_object prefix = make_constant_base_string("Reader error in file ~S, "
"position ~D:~%");
cl_object position = cl_file_position(1, stream);
message = si_base_string_concatenate(2, prefix, message);
args_list = cl_listX(3, stream, position, args_list);
si_signal_simple_error(6,
@'reader-error', /* condition name */
ECL_NIL, /* not correctable */
message, /* format control */
args_list, /* format args */
@':stream', stream);
}
}
void
FEcannot_open(cl_object fn)
{
cl_error(3, @'file-error', @':pathname', fn);
cl_error(3, @'file-error', @':pathname', fn);
}
void
FEend_of_file(cl_object strm)
{
cl_error(3, @'end-of-file', @':stream', strm);
cl_error(3, @'end-of-file', @':stream', strm);
}
void
FEclosed_stream(cl_object strm)
{
cl_error(3, @'stream-error', @':stream', strm);
cl_error(3, @'stream-error', @':stream', strm);
}
cl_object
si_signal_type_error(cl_object value, cl_object type)
{
return cl_error(5, @'type-error', @':expected-type', type,
@':datum', value);
return cl_error(5, @'type-error', @':expected-type', type,
@':datum', value);
}
void
FEwrong_type_argument(cl_object type, cl_object value)
{
si_signal_type_error(value, cl_symbol_or_object(type));
si_signal_type_error(value, cl_symbol_or_object(type));
}
void
FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type)
{
const char *message =
"In ~:[an anonymous function~;~:*function ~A~], "
"the value of the only argument is~& ~S~&which is "
"not of the expected type ~A";
cl_env_ptr env = ecl_process_env();
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
type = cl_symbol_or_object(type);
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
}
si_signal_simple_error(8,
@'type-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
cl_list(3, function, value, type),
@':expected-type', type,
@':datum', value);
const char *message =
"In ~:[an anonymous function~;~:*function ~A~], "
"the value of the only argument is~& ~S~&which is "
"not of the expected type ~A";
cl_env_ptr env = ecl_process_env();
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
type = cl_symbol_or_object(type);
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
}
si_signal_simple_error(8,
@'type-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
cl_list(3, function, value, type),
@':expected-type', type,
@':datum', value);
}
void
FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_object type)
{
const char *message =
"In ~:[an anonymous function~;~:*function ~A~], "
"the value of the ~:R argument is~& ~S~&which is "
"not of the expected type ~A";
cl_env_ptr env = ecl_process_env();
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
type = cl_symbol_or_object(type);
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
}
si_signal_simple_error(8,
@'type-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
cl_list(4, function, ecl_make_fixnum(narg),
value, type),
@':expected-type', type,
@':datum', value);
const char *message =
"In ~:[an anonymous function~;~:*function ~A~], "
"the value of the ~:R argument is~& ~S~&which is "
"not of the expected type ~A";
cl_env_ptr env = ecl_process_env();
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
type = cl_symbol_or_object(type);
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
}
si_signal_simple_error(8,
@'type-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
cl_list(4, function, ecl_make_fixnum(narg),
value, type),
@':expected-type', type,
@':datum', value);
}
void
FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_object type)
{
const char *message =
"In ~:[an anonymous function~;~:*function ~A~], "
"the value of the argument ~S is~& ~S~&which is "
"not of the expected type ~A";
cl_env_ptr env = ecl_process_env();
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
type = cl_symbol_or_object(type);
key = cl_symbol_or_object(key);
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
}
si_signal_simple_error(8,
@'type-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
cl_list(4, function, key, value, type),
@':expected-type', type,
@':datum', value);
const char *message =
"In ~:[an anonymous function~;~:*function ~A~], "
"the value of the argument ~S is~& ~S~&which is "
"not of the expected type ~A";
cl_env_ptr env = ecl_process_env();
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
type = cl_symbol_or_object(type);
key = cl_symbol_or_object(key);
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
}
si_signal_simple_error(8,
@'type-error', /* condition name */
ECL_NIL, /* not correctable */
make_constant_base_string(message), /* format control */
cl_list(4, function, key, value, type),
@':expected-type', type,
@':datum', value);
}
void
FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx,
cl_index nonincl_limit)
{
const char *message1 =
"In ~:[an anonymous function~;~:*function ~A~], "
"the ~*index into the object~% ~A.~%"
"takes a value ~D out of the range ~A.";
const char *message2 =
"In ~:[an anonymous function~;~:*function ~A~], "
"the ~:R index into the object~% ~A~%"
"takes a value ~D out of the range ~A.";
cl_object limit = ecl_make_integer(nonincl_limit-1);
cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit);
cl_object message = make_constant_base_string((which<0) ? message1 : message2);
cl_env_ptr env = ecl_process_env();
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
}
cl_error(9,
@'simple-type-error', /* condition name */
@':format-control', message,
@':format-arguments',
cl_list(5, function, ecl_make_fixnum(which+1), a, ndx, type),
@':expected-type', type,
@':datum', ndx);
const char *message1 =
"In ~:[an anonymous function~;~:*function ~A~], "
"the ~*index into the object~% ~A.~%"
"takes a value ~D out of the range ~A.";
const char *message2 =
"In ~:[an anonymous function~;~:*function ~A~], "
"the ~:R index into the object~% ~A~%"
"takes a value ~D out of the range ~A.";
cl_object limit = ecl_make_integer(nonincl_limit-1);
cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit);
cl_object message = make_constant_base_string((which<0) ? message1 : message2);
cl_env_ptr env = ecl_process_env();
struct ecl_ihs_frame tmp_ihs;
function = cl_symbol_or_object(function);
if (!Null(function) && env->ihs_top && env->ihs_top->function != function) {
ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL);
}
cl_error(9,
@'simple-type-error', /* condition name */
@':format-control', message,
@':format-arguments',
cl_list(5, function, ecl_make_fixnum(which+1), a, ndx, type),
@':expected-type', type,
@':datum', ndx);
}
void
FEunbound_variable(cl_object sym)
{
cl_error(3, @'unbound-variable', @':name', sym);
cl_error(3, @'unbound-variable', @':name', sym);
}
void
FEundefined_function(cl_object fname)
{
cl_error(3, @'undefined-function', @':name', fname);
cl_error(3, @'undefined-function', @':name', fname);
}
void
FEprint_not_readable(cl_object x)
{
cl_error(3, @'print-not-readable', @':object', x);
cl_error(3, @'print-not-readable', @':object', x);
}
/*************
@ -385,49 +380,49 @@ FEprint_not_readable(cl_object x)
void
FEwrong_num_arguments(cl_object fun)
{
fun = cl_symbol_or_object(fun);
FEprogram_error("Wrong number of arguments passed to function ~S.",
1, fun);
fun = cl_symbol_or_object(fun);
FEprogram_error("Wrong number of arguments passed to function ~S.",
1, fun);
}
void
FEwrong_num_arguments_anonym(void)
{
FEprogram_error("Wrong number of arguments passed to an anonymous function", 0);
FEprogram_error("Wrong number of arguments passed to an anonymous function", 0);
}
void
FEinvalid_macro_call(cl_object name)
{
FEerror("Invalid macro call to ~S.", 1, name);
FEerror("Invalid macro call to ~S.", 1, name);
}
void
FEinvalid_variable(const char *s, cl_object obj)
{
FEerror(s, 1, obj);
FEerror(s, 1, obj);
}
void
FEassignment_to_constant(cl_object v)
{
FEprogram_error("SETQ: Tried to assign a value to the constant ~S.", 1, v);
FEprogram_error("SETQ: Tried to assign a value to the constant ~S.", 1, v);
}
void
FEinvalid_function(cl_object obj)
{
FEwrong_type_argument(@'function', obj);
FEwrong_type_argument(@'function', obj);
}
void
FEinvalid_function_name(cl_object fname)
{
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("Not a valid function name ~D"),
@':format-arguments', cl_list(1, fname),
@':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'),
@':datum', fname);
cl_error(9, @'simple-type-error', @':format-control',
make_constant_base_string("Not a valid function name ~D"),
@':format-arguments', cl_list(1, fname),
@':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'),
@':datum', fname);
}
/* bootstrap version */
@ -437,42 +432,42 @@ static cl_object
universal_error_handler(cl_object continue_string, cl_object datum,
cl_object args)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object stream;
if (recursive_error)
goto ABORT;
recursive_error = 1;
stream = cl_core.error_output;
if (!Null(stream)) {
ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL);
ecl_bds_bind(the_env, @'*print-level*', ecl_make_fixnum(3));
ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(3));
ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL);
ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10));
writestr_stream("\n;;; Unhandled lisp initialization error",
stream);
writestr_stream("\n;;; Message:\n", stream);
si_write_ugly_object(datum, stream);
writestr_stream("\n;;; Arguments:\n", stream);
si_write_ugly_object(args, stream);
ecl_bds_unwind_n(the_env, 5);
}
const cl_env_ptr the_env = ecl_process_env();
cl_object stream;
if (recursive_error)
goto ABORT;
recursive_error = 1;
stream = cl_core.error_output;
if (!Null(stream)) {
ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL);
ecl_bds_bind(the_env, @'*print-level*', ecl_make_fixnum(3));
ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(3));
ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL);
ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10));
writestr_stream("\n;;; Unhandled lisp initialization error",
stream);
writestr_stream("\n;;; Message:\n", stream);
si_write_ugly_object(datum, stream);
writestr_stream("\n;;; Arguments:\n", stream);
si_write_ugly_object(args, stream);
ecl_bds_unwind_n(the_env, 5);
}
ABORT:
ecl_internal_error("\nLisp initialization error.\n");
ecl_internal_error("\nLisp initialization error.\n");
}
void
FEdivision_by_zero(cl_object x, cl_object y)
{
cl_error(5, @'division-by-zero', @':operation', @'/',
@':operands', cl_list(2, x, y));
cl_error(5, @'division-by-zero', @':operation', @'/',
@':operands', cl_list(2, x, y));
}
cl_object
_ecl_strerror(int code)
{
const char *error = strerror(code);
return make_base_string_copy(error);
const char *error = strerror(code);
return make_base_string_copy(error);
}
/*************************************
@ -486,15 +481,15 @@ _ecl_strerror(int code)
void
FElibc_error(const char *msg, int narg, ...)
{
ecl_va_list args;
cl_object rest, error = _ecl_strerror(errno);
ecl_va_list args;
cl_object rest, error = _ecl_strerror(errno);
ecl_va_start(args, narg, narg, 0);
rest = cl_grab_rest_args(args);
ecl_va_start(args, narg, narg, 0);
rest = cl_grab_rest_args(args);
FEerror("~?~%C library explanation: ~A.", 3,
make_constant_base_string(msg), rest,
error);
FEerror("~?~%C library explanation: ~A.", 3,
make_constant_base_string(msg), rest,
error);
}
#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
@ -503,23 +498,23 @@ ecl_def_ct_base_string(unknown_error,"[Unable to get error message]",28,static,c
void
FEwin32_error(const char *msg, int narg, ...)
{
ecl_va_list args;
cl_object rest, win_msg_obj;
char *win_msg;
ecl_va_list args;
cl_object rest, win_msg_obj;
char *win_msg;
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER,
0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0)
win_msg_obj = unknown_error;
else {
win_msg_obj = make_base_string_copy(win_msg);
LocalFree(win_msg);
}
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER,
0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0)
win_msg_obj = unknown_error;
else {
win_msg_obj = make_base_string_copy(win_msg);
LocalFree(win_msg);
}
ecl_va_start(args, narg, narg, 0);
rest = cl_grab_rest_args(args);
FEerror("~?~%Windows library explanation: ~A.", 3,
make_constant_base_string(msg), rest,
win_msg_obj);
ecl_va_start(args, narg, narg, 0);
rest = cl_grab_rest_args(args);
FEerror("~?~%Windows library explanation: ~A.", 3,
make_constant_base_string(msg), rest,
win_msg_obj);
}
#endif
@ -528,32 +523,32 @@ FEwin32_error(const char *msg, int narg, ...)
************************************/
@(defun error (eformat &rest args)
@
ecl_enable_interrupts();
funcall(4, @'si::universal-error-handler', ECL_NIL, eformat,
cl_grab_rest_args(args));
_ecl_unexpected_return();
@(return);
@)
@ {
ecl_enable_interrupts();
funcall(4, @'si::universal-error-handler', ECL_NIL, eformat,
cl_grab_rest_args(args));
_ecl_unexpected_return();
@(return);
} @)
@(defun cerror (cformat eformat &rest args)
@
ecl_enable_interrupts();
return funcall(4, @'si::universal-error-handler', cformat, eformat,
cl_grab_rest_args(args));
@)
@ {
ecl_enable_interrupts();
return funcall(4, @'si::universal-error-handler', cformat, eformat,
cl_grab_rest_args(args));
} @)
@(defun si::serror (cformat eformat &rest args)
@
ecl_enable_interrupts();
return funcall(4, @'si::stack-error-handler', cformat, eformat,
cl_grab_rest_args(args));
@)
@ {
ecl_enable_interrupts();
return funcall(4, @'si::stack-error-handler', cformat, eformat,
cl_grab_rest_args(args));
} @)
void
init_error(void)
{
ecl_def_c_function(@'si::universal-error-handler',
(cl_objectfn_fixed)universal_error_handler,
3);
ecl_def_c_function(@'si::universal-error-handler',
(cl_objectfn_fixed)universal_error_handler,
3);
}

412
src/c/eval.d
View file

@ -1,22 +1,16 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
eval.c -- Eval.
*/
/*
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi.
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
* eval.d - evaluation
*
* Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
* Copyright (c) 1990 Giuseppe Attardi
* Copyright (c) 2001 Juan Jose Garcia Ripoll
*
* See file 'LICENSE' for the copyright details.
*
*/
#include <ecl/ecl.h>
#include <ecl/ecl-inl.h>
@ -25,234 +19,230 @@
cl_object *
_ecl_va_sp(cl_narg narg)
{
return ecl_process_env()->stack_top - narg;
return ecl_process_env()->stack_top - narg;
}
/* Calling conventions:
Compiled C code calls lisp function supplying #args, and args.
Linking function performs check_args, gets jmp_buf with _setjmp, then
if cfun then stores C code address into function link location
and transfers to jmp_buf at cf_self
if cclosure then replaces #args with cc_env and calls cc_self
otherwise, it emulates funcall.
* Compiled C code calls lisp function supplying #args, and args.
* Linking function performs check_args, gets jmp_buf with _setjmp, then
* if cfun then stores C code address into function link location
* and transfers to jmp_buf at cf_self
* if cclosure then replaces #args with cc_env and calls cc_self
* otherwise, it emulates funcall.
*/
cl_object
ecl_apply_from_stack_frame(cl_object frame, cl_object x)
{
cl_object *sp = frame->frame.base;
cl_index narg = frame->frame.size;
cl_object fun = x;
AGAIN:
frame->frame.env->function = fun;
if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL))
FEundefined_function(x);
switch (ecl_t_of(fun)) {
case t_cfunfixed:
if (ecl_unlikely(narg != (cl_index)fun->cfun.narg))
FEwrong_num_arguments(fun);
return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
case t_cfun:
return APPLY(narg, fun->cfun.entry, sp);
case t_cclosure:
return APPLY(narg, fun->cclosure.entry, sp);
case t_instance:
switch (fun->instance.isgf) {
case ECL_STANDARD_DISPATCH:
case ECL_RESTRICTED_DISPATCH:
return _ecl_standard_dispatch(frame, fun);
case ECL_USER_DISPATCH:
fun = fun->instance.slots[fun->instance.length - 1];
goto AGAIN;
case ECL_READER_DISPATCH:
case ECL_WRITER_DISPATCH:
return APPLY(narg, fun->instance.entry, sp);
default:
FEinvalid_function(fun);
}
case t_symbol:
if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro))
FEundefined_function(x);
fun = ECL_SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:
return ecl_interpret(frame, ECL_NIL, fun);
case t_bclosure:
return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code);
default:
FEinvalid_function(x);
}
cl_object *sp = frame->frame.base;
cl_index narg = frame->frame.size;
cl_object fun = x;
AGAIN:
frame->frame.env->function = fun;
if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL))
FEundefined_function(x);
switch (ecl_t_of(fun)) {
case t_cfunfixed:
if (ecl_unlikely(narg != (cl_index)fun->cfun.narg))
FEwrong_num_arguments(fun);
return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
case t_cfun:
return APPLY(narg, fun->cfun.entry, sp);
case t_cclosure:
return APPLY(narg, fun->cclosure.entry, sp);
case t_instance:
switch (fun->instance.isgf) {
case ECL_STANDARD_DISPATCH:
case ECL_RESTRICTED_DISPATCH:
return _ecl_standard_dispatch(frame, fun);
case ECL_USER_DISPATCH:
fun = fun->instance.slots[fun->instance.length - 1];
goto AGAIN;
case ECL_READER_DISPATCH:
case ECL_WRITER_DISPATCH:
return APPLY(narg, fun->instance.entry, sp);
default:
FEinvalid_function(fun);
}
case t_symbol:
if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro))
FEundefined_function(x);
fun = ECL_SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:
return ecl_interpret(frame, ECL_NIL, fun);
case t_bclosure:
return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code);
default:
FEinvalid_function(x);
}
}
cl_objectfn
ecl_function_dispatch(cl_env_ptr env, cl_object x)
{
cl_object fun = x;
cl_object fun = x;
AGAIN:
if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL))
FEundefined_function(x);
switch (ecl_t_of(fun)) {
case t_cfunfixed:
env->function = fun;
return fun->cfunfixed.entry;
case t_cfun:
env->function = fun;
return fun->cfun.entry;
case t_cclosure:
env->function = fun;
return fun->cclosure.entry;
case t_instance:
env->function = fun;
return fun->instance.entry;
case t_symbol:
if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro))
FEundefined_function(x);
fun = ECL_SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:
env->function = fun;
return fun->bytecodes.entry;
case t_bclosure:
env->function = fun;
return fun->bclosure.entry;
default:
FEinvalid_function(x);
}
if (ecl_unlikely(fun == OBJNULL || fun == ECL_NIL))
FEundefined_function(x);
switch (ecl_t_of(fun)) {
case t_cfunfixed:
env->function = fun;
return fun->cfunfixed.entry;
case t_cfun:
env->function = fun;
return fun->cfun.entry;
case t_cclosure:
env->function = fun;
return fun->cclosure.entry;
case t_instance:
env->function = fun;
return fun->instance.entry;
case t_symbol:
if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro))
FEundefined_function(x);
fun = ECL_SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:
env->function = fun;
return fun->bytecodes.entry;
case t_bclosure:
env->function = fun;
return fun->bclosure.entry;
default:
FEinvalid_function(x);
}
}
cl_object
cl_funcall(cl_narg narg, cl_object function, ...)
{
cl_object output;
--narg;
{
ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame);
output = ecl_apply_from_stack_frame(frame, function);
ECL_STACK_FRAME_VARARGS_END(frame);
}
return output;
cl_object output;
--narg;
{
ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame);
output = ecl_apply_from_stack_frame(frame, function);
ECL_STACK_FRAME_VARARGS_END(frame);
}
return output;
}
@(defun apply (fun lastarg &rest args)
@
if (narg == 2 && ecl_t_of(lastarg) == t_frame) {
return ecl_apply_from_stack_frame(lastarg, fun);
} else {
cl_object out;
cl_index i;
struct ecl_stack_frame frame_aux;
const cl_object frame = ecl_stack_frame_open(the_env,
(cl_object)&frame_aux,
narg -= 2);
for (i = 0; i < narg; i++) {
ECL_STACK_FRAME_SET(frame, i, lastarg);
lastarg = ecl_va_arg(args);
}
if (ecl_t_of(lastarg) == t_frame) {
/* This could be replaced with a memcpy() */
for (i = 0; i < lastarg->frame.size; i++) {
ecl_stack_frame_push(frame, lastarg->frame.base[i]);
}
} else loop_for_in (lastarg) {
if (ecl_unlikely(i >= ECL_CALL_ARGUMENTS_LIMIT)) {
ecl_stack_frame_close(frame);
FEprogram_error_noreturn("CALL-ARGUMENTS-LIMIT exceeded",0);
}
ecl_stack_frame_push(frame, CAR(lastarg));
i++;
} end_loop_for_in;
out = ecl_apply_from_stack_frame(frame, fun);
ecl_stack_frame_close(frame);
return out;
@ {
if (narg == 2 && ecl_t_of(lastarg) == t_frame) {
return ecl_apply_from_stack_frame(lastarg, fun);
} else {
cl_object out;
cl_index i;
struct ecl_stack_frame frame_aux;
const cl_object frame = ecl_stack_frame_open(the_env,
(cl_object)&frame_aux,
narg -= 2);
for (i = 0; i < narg; i++) {
ECL_STACK_FRAME_SET(frame, i, lastarg);
lastarg = ecl_va_arg(args);
}
if (ecl_t_of(lastarg) == t_frame) {
/* This could be replaced with a memcpy() */
for (i = 0; i < lastarg->frame.size; i++) {
ecl_stack_frame_push(frame, lastarg->frame.base[i]);
}
@)
} else loop_for_in (lastarg) {
if (ecl_unlikely(i >= ECL_CALL_ARGUMENTS_LIMIT)) {
ecl_stack_frame_close(frame);
FEprogram_error_noreturn("CALL-ARGUMENTS-LIMIT exceeded",0);
}
ecl_stack_frame_push(frame, CAR(lastarg));
i++;
} end_loop_for_in;
out = ecl_apply_from_stack_frame(frame, fun);
ecl_stack_frame_close(frame);
return out;
}
}@)
cl_object
cl_eval(cl_object form)
{
return si_eval_with_env(1, form);
return si_eval_with_env(1, form);
}
@(defun constantp (arg &optional env)
@
return _ecl_funcall3(@'ext::constantp-inner', arg, env);
return _ecl_funcall3(@'ext::constantp-inner', arg, env);
@)
@(defun ext::constantp-inner (form &optional env)
cl_object value;
@
cl_object value;
@ {
AGAIN:
switch (ecl_t_of(form)) {
case t_list:
if (Null(form)) {
value = ECL_T;
break;
}
if (ECL_CONS_CAR(form) == @'quote') {
value = ECL_T;
break;
}
/*
value = cl_macroexpand(2, form, env);
if (value != form) {
form = value;
goto AGAIN;
}
*/
value = ECL_NIL;
break;
case t_symbol:
value = cl_macroexpand(2, form, env);
if (value != form) {
form = value;
goto AGAIN;
}
if (!(form->symbol.stype & ecl_stp_constant)) {
value = ECL_NIL;
break;
}
default:
value = ECL_T;
}
ecl_return1(the_env, value);
@)
switch (ecl_t_of(form)) {
case t_list:
if (Null(form)) {
value = ECL_T;
break;
}
if (ECL_CONS_CAR(form) == @'quote') {
value = ECL_T;
break;
}
/*
value = cl_macroexpand(2, form, env);
if (value != form) {
form = value;
goto AGAIN;
}
*/
value = ECL_NIL;
break;
case t_symbol:
value = cl_macroexpand(2, form, env);
if (value != form) {
form = value;
goto AGAIN;
}
if (!(form->symbol.stype & ecl_stp_constant)) {
value = ECL_NIL;
break;
}
default:
value = ECL_T;
}
ecl_return1(the_env, value);
} @)
@(defun ext::constant-form-value (form &optional env)
cl_object value;
@
{
AGAIN:
switch (ecl_t_of(form)) {
case t_list:
if (Null(form)) {
value = ECL_NIL;
break;
}
if (ECL_CONS_CAR(form) == @'quote') {
return cl_second(form);
}
/*
value = cl_macroexpand(2, form, env);
if (value != form) {
form = value;
goto AGAIN;
}
*/
ERROR:
FEerror("EXT:CONSTANT-FORM-VALUE invoked with a non-constant form ~A",
0, form);
break;
case t_symbol:
value = cl_macroexpand(2, form, env);
if (value != form) {
form = value;
goto AGAIN;
}
value = ECL_SYM_VAL(the_env, value);
break;
default:
value = form;
}
@(return value);
}
@)
cl_object value;
@ {
AGAIN:
switch (ecl_t_of(form)) {
case t_list:
if (Null(form)) {
value = ECL_NIL;
break;
}
if (ECL_CONS_CAR(form) == @'quote') {
return cl_second(form);
}
/* value = cl_macroexpand(2, form, env); */
/* if (value != form) { */
/* form = value; */
/* goto AGAIN; */
/* } */
ERROR:
FEerror("EXT:CONSTANT-FORM-VALUE invoked with a non-constant form ~A",
0, form);
break;
case t_symbol:
value = cl_macroexpand(2, form, env);
if (value != form) {
form = value;
goto AGAIN;
}
value = ECL_SYM_VAL(the_env, value);
break;
default:
value = form;
}
@(return value);
} @)

1233
src/c/ffi.d
View file

File diff suppressed because it is too large Load diff

153
src/c/ffi/backtrace.d
View file

@ -1,19 +1,14 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
backtrace.d -- C backtraces
*/
/*
Copyright (c) 2010, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
* backtrace.d - C backtraces
*
* Copyright (c) 2010 Juan Jose Garcia Ripoll
*
* See file 'LICENSE' for the copyright details.
*
*/
#include <stdio.h>
#include <stdlib.h>
@ -34,43 +29,43 @@
static int
backtrace(void **buffer, int n)
{
int nframes = (n > 32)? 32 : n;
int i;
switch (nframes) {
case 32: buffer[31] = __builtin_return_address(31);
case 31: buffer[30] = __builtin_return_address(30);
case 30: buffer[29] = __builtin_return_address(29);
case 29: buffer[28] = __builtin_return_address(28);
case 28: buffer[27] = __builtin_return_address(27);
case 27: buffer[26] = __builtin_return_address(26);
case 26: buffer[25] = __builtin_return_address(25);
case 25: buffer[24] = __builtin_return_address(24);
case 24: buffer[23] = __builtin_return_address(23);
case 23: buffer[22] = __builtin_return_address(22);
case 22: buffer[21] = __builtin_return_address(21);
case 21: buffer[20] = __builtin_return_address(20);
case 20: buffer[19] = __builtin_return_address(19);
case 19: buffer[18] = __builtin_return_address(18);
case 18: buffer[17] = __builtin_return_address(17);
case 17: buffer[16] = __builtin_return_address(16);
case 16: buffer[15] = __builtin_return_address(15);
case 15: buffer[14] = __builtin_return_address(14);
case 14: buffer[13] = __builtin_return_address(13);
case 13: buffer[12] = __builtin_return_address(12);
case 12: buffer[11] = __builtin_return_address(11);
case 11: buffer[10] = __builtin_return_address(10);
case 10: buffer[9] = __builtin_return_address(9);
case 9: buffer[8] = __builtin_return_address(8);
case 8: buffer[7] = __builtin_return_address(7);
case 7: buffer[6] = __builtin_return_address(6);
case 6: buffer[5] = __builtin_return_address(5);
case 5: buffer[4] = __builtin_return_address(4);
case 4: buffer[3] = __builtin_return_address(3);
case 3: buffer[2] = __builtin_return_address(2);
case 2: buffer[1] = __builtin_return_address(1);
case 1: buffer[0] = __builtin_return_address(0);
}
return nframes;
int nframes = (n > 32)? 32 : n;
int i;
switch (nframes) {
case 32: buffer[31] = __builtin_return_address(31);
case 31: buffer[30] = __builtin_return_address(30);
case 30: buffer[29] = __builtin_return_address(29);
case 29: buffer[28] = __builtin_return_address(28);
case 28: buffer[27] = __builtin_return_address(27);
case 27: buffer[26] = __builtin_return_address(26);
case 26: buffer[25] = __builtin_return_address(25);
case 25: buffer[24] = __builtin_return_address(24);
case 24: buffer[23] = __builtin_return_address(23);
case 23: buffer[22] = __builtin_return_address(22);
case 22: buffer[21] = __builtin_return_address(21);
case 21: buffer[20] = __builtin_return_address(20);
case 20: buffer[19] = __builtin_return_address(19);
case 19: buffer[18] = __builtin_return_address(18);
case 18: buffer[17] = __builtin_return_address(17);
case 17: buffer[16] = __builtin_return_address(16);
case 16: buffer[15] = __builtin_return_address(15);
case 15: buffer[14] = __builtin_return_address(14);
case 14: buffer[13] = __builtin_return_address(13);
case 13: buffer[12] = __builtin_return_address(12);
case 12: buffer[11] = __builtin_return_address(11);
case 11: buffer[10] = __builtin_return_address(10);
case 10: buffer[9] = __builtin_return_address(9);
case 9: buffer[8] = __builtin_return_address(8);
case 8: buffer[7] = __builtin_return_address(7);
case 7: buffer[6] = __builtin_return_address(6);
case 6: buffer[5] = __builtin_return_address(5);
case 5: buffer[4] = __builtin_return_address(4);
case 4: buffer[3] = __builtin_return_address(3);
case 3: buffer[2] = __builtin_return_address(2);
case 2: buffer[1] = __builtin_return_address(1);
case 1: buffer[0] = __builtin_return_address(0);
}
return nframes;
}
#endif
@ -81,17 +76,17 @@ backtrace(void **buffer, int n)
static char **
backtrace_symbols(void **buffer, int nframes)
{
Dl_info data[1];
int i;
char **strings = malloc(nframes * sizeof(char*));
for (i = 0; i < nframes; i++) {
if (dladdr(buffer[i], data)) {
strings[i] = data->dli_sname;
} else {
strings[i] = "unknown";
}
}
return strings;
Dl_info data[1];
int i;
char **strings = malloc(nframes * sizeof(char*));
for (i = 0; i < nframes; i++) {
if (dladdr(buffer[i], data)) {
strings[i] = data->dli_sname;
} else {
strings[i] = "unknown";
}
}
return strings;
}
# endif /* HAVE_BACKTRACE && HAVE_DLADDR */
#endif /* !HAVE_BACKTRACE_SYMBOLS */
@ -99,32 +94,32 @@ backtrace_symbols(void **buffer, int nframes)
cl_object
si_dump_c_backtrace(cl_object size)
{
cl_env_ptr the_env = ecl_process_env();
cl_env_ptr the_env = ecl_process_env();
#ifdef HAVE_BACKTRACE_SYMBOLS
{
void *pointers[32];
int nframes = backtrace(pointers, 32);
char **names = backtrace_symbols(pointers, nframes);
int i;
fprintf(stderr, "\n;;; ECL C Backtrace\n");
for (i = 0; i < nframes; i++) {
{
void *pointers[32];
int nframes = backtrace(pointers, 32);
char **names = backtrace_symbols(pointers, nframes);
int i;
fprintf(stderr, "\n;;; ECL C Backtrace\n");
for (i = 0; i < nframes; i++) {
#ifdef BACKTRACE_SYMBOLS_SIMPLE
fprintf(stderr, ";;; %4d %s (%p) \n", i, names[i], pointers[i]);
fprintf(stderr, ";;; %4d %s (%p) \n", i, names[i], pointers[i]);
#else
fprintf(stderr, ";;; %s\n", names[i]);
fprintf(stderr, ";;; %s\n", names[i]);
#endif
}
fflush(stderr);
free(names);
}
ecl_return1(the_env, ECL_T);
}
fflush(stderr);
free(names);
}
ecl_return1(the_env, ECL_T);
#else
ecl_return1(the_env, ECL_NIL);
ecl_return1(the_env, ECL_NIL);
#endif
}
cl_object
si_backtrace(cl_object start, cl_object end)
{
@(return ECL_NIL)
@(return ECL_NIL);
}

115
src/c/ffi/cdata.d
View file

@ -1,19 +1,14 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
cdata.d -- Data for compiled files.
*/
/*
Copyright (c) 2011, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
* cdata.d - data for compiled files
*
* Copyright (c) 2011 Juan Jose Garcia Ripoll
*
* See file 'LICENSE' for the copyright details.
*
*/
#include <string.h>
#include <ecl/ecl.h>
@ -23,8 +18,8 @@
#define HEADER_PREFIX_LENGTH 15
typedef struct {
char code[16];
cl_index offset, size;
char code[16];
cl_index offset, size;
} cdata_header;
ecl_def_ct_base_string(str_no_data,"",0,static,const);
@ -32,55 +27,55 @@ ecl_def_ct_base_string(str_no_data,"",0,static,const);
cl_object
si_get_cdata(cl_object filename)
{
cl_object map, array, displaced;
cdata_header *header;
map = si_mmap(3, filename, @':direction', @':input');
array = si_mmap_array(map);
{
char *v = (char*)array->base_string.self
+ array->base_string.dim
- sizeof(cdata_header);
header = (cdata_header*)v;
cl_object map, array, displaced;
cdata_header *header;
map = si_mmap(3, filename, @':direction', @':input');
array = si_mmap_array(map);
{
char *v = (char*)array->base_string.self
+ array->base_string.dim
- sizeof(cdata_header);
header = (cdata_header*)v;
}
if (memcmp(header->code, HEADER_PREFIX, HEADER_PREFIX_LENGTH)) {
displaced = str_no_data;
} else {
displaced = cl_funcall(8, @'make-array',
ecl_make_fixnum(header->size),
@':element-type', @'base-char',
@':displaced-to', array,
@':displaced-index-offset',
ecl_make_fixnum(header->offset));
}
@(return map displaced);
}
if (memcmp(header->code, HEADER_PREFIX, HEADER_PREFIX_LENGTH)) {
displaced = str_no_data;
} else {
displaced = cl_funcall(8, @'make-array',
ecl_make_fixnum(header->size),
@':element-type', @'base-char',
@':displaced-to', array,
@':displaced-index-offset',
ecl_make_fixnum(header->offset));
}
@(return map displaced);
}
cl_object
si_add_cdata(cl_object filename, cl_object data)
{
cl_object stream, offset;
cdata_header header;
cl_object stream, offset;
cdata_header header;
data = si_copy_to_simple_base_string(data);
stream = cl_open(9, filename,
@':element-type', @'base-char',
@':direction', @':output',
@':if-does-not-exist', @':error',
@':if-exists', @':append');
offset = ecl_file_length(stream);
ecl_file_position_set(stream, offset);
cl_write_sequence(2, data, stream);
memcpy(header.code, HEADER_PREFIX, HEADER_PREFIX_LENGTH);
header.offset = fixnnint(offset);
header.size = data->base_string.dim;
{
unsigned char *c = (unsigned char *)&header;
int i;
for (i = 0; i < sizeof(header); i++) {
ecl_write_byte(ecl_make_fixnum(c[i]), stream);
}
}
cl_close(1, stream);
@(return)
data = si_copy_to_simple_base_string(data);
stream = cl_open(9, filename,
@':element-type', @'base-char',
@':direction', @':output',
@':if-does-not-exist', @':error',
@':if-exists', @':append');
offset = ecl_file_length(stream);
ecl_file_position_set(stream, offset);
cl_write_sequence(2, data, stream);
memcpy(header.code, HEADER_PREFIX, HEADER_PREFIX_LENGTH);
header.offset = fixnnint(offset);
header.size = data->base_string.dim;
{
unsigned char *c = (unsigned char *)&header;
int i;
for (i = 0; i < sizeof(header); i++) {
ecl_write_byte(ecl_make_fixnum(c[i]), stream);
}
}
cl_close(1, stream);
@(return);
}

587
src/c/ffi/libraries.d
View file

@ -1,20 +1,15 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
load.d -- Shared library and bundle opening / copying / closing
*/
/*
Copyright (c) 1990, Giuseppe Attardi and William F. Schelter.
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
* libraries.d - shared library and bundle opening / copying / closing
*
* Copyright (c) 1990 Giuseppe Attardi
* Copyright (c) 2001 Juan Jose Garcia Ripoll
*
* See file 'LICENSE' for the copyright details.
*
*/
#include <ecl/ecl.h>
/*
@ -78,384 +73,384 @@
cl_object
ecl_make_codeblock()
{
cl_object block = ecl_alloc(t_codeblock);
block = ecl_alloc_object(t_codeblock);
block->cblock.self_destruct = 0;
block->cblock.locked = 0;
block->cblock.handle = NULL;
block->cblock.data = NULL;
block->cblock.data_size = 0;
block->cblock.temp_data = NULL;
block->cblock.temp_data_size = 0;
block->cblock.data_text = NULL;
block->cblock.next = ECL_NIL;
block->cblock.name = ECL_NIL;
block->cblock.links = ECL_NIL;
block->cblock.cfuns_size = 0;
block->cblock.cfuns = NULL;
block->cblock.source = ECL_NIL;
block->cblock.error = ECL_NIL;
block->cblock.refs = ecl_make_fixnum(0);
si_set_finalizer(block, ECL_T);
return block;
cl_object block = ecl_alloc(t_codeblock);
block = ecl_alloc_object(t_codeblock);
block->cblock.self_destruct = 0;
block->cblock.locked = 0;
block->cblock.handle = NULL;
block->cblock.data = NULL;
block->cblock.data_size = 0;
block->cblock.temp_data = NULL;
block->cblock.temp_data_size = 0;
block->cblock.data_text = NULL;
block->cblock.next = ECL_NIL;
block->cblock.name = ECL_NIL;
block->cblock.links = ECL_NIL;
block->cblock.cfuns_size = 0;
block->cblock.cfuns = NULL;
block->cblock.source = ECL_NIL;
block->cblock.error = ECL_NIL;
block->cblock.refs = ecl_make_fixnum(0);
si_set_finalizer(block, ECL_T);
return block;
}
static cl_object
copy_object_file(cl_object original)
{
int err;
cl_object copy = make_constant_base_string("TMP:ECL");
copy = si_coerce_to_filename(si_mkstemp(copy));
/*
* We either have to make a full copy to convince the loader to load this object
* file again, or we want to retain the possibility of overwriting the object
* file we load later on (case of Windows, which locks files that are loaded).
* The symlinks do not seem to work in latest versions of Linux.
*/
int err;
cl_object copy = make_constant_base_string("TMP:ECL");
copy = si_coerce_to_filename(si_mkstemp(copy));
/*
* We either have to make a full copy to convince the loader to load this object
* file again, or we want to retain the possibility of overwriting the object
* file we load later on (case of Windows, which locks files that are loaded).
* The symlinks do not seem to work in latest versions of Linux.
*/
#if defined(ECL_MS_WINDOWS_HOST)
ecl_disable_interrupts();
err = !CopyFile(original->base_string.self, copy->base_string.self, 0);
ecl_enable_interrupts();
if (err) {
FEwin32_error("Error when copying file from~&~3T~A~&to~&~3T~A",
2, original, copy);
}
ecl_disable_interrupts();
err = !CopyFile(original->base_string.self, copy->base_string.self, 0);
ecl_enable_interrupts();
if (err) {
FEwin32_error("Error when copying file from~&~3T~A~&to~&~3T~A",
2, original, copy);
}
#else
err = Null(si_copy_file(original, copy));
if (err) {
FEerror("Error when copying file from~&~3T~A~&to~&~3T~A",
2, original, copy);
}
err = Null(si_copy_file(original, copy));
if (err) {
FEerror("Error when copying file from~&~3T~A~&to~&~3T~A",
2, original, copy);
}
#endif
#ifdef cygwin
{
cl_object new_copy = make_constant_base_string(".dll");
new_copy = si_base_string_concatenate(2, copy, new_copy);
cl_rename_file(2, copy, new_copy);
copy = new_copy;
}
ecl_disable_interrupts();
err = chmod(copy->base_string.self, S_IRWXU) < 0;
ecl_enable_interrupts();
if (err) {
FElibc_error("Unable to give executable permissions to ~A",
1, copy);
}
{
cl_object new_copy = make_constant_base_string(".dll");
new_copy = si_base_string_concatenate(2, copy, new_copy);
cl_rename_file(2, copy, new_copy);
copy = new_copy;
}
ecl_disable_interrupts();
err = chmod(copy->base_string.self, S_IRWXU) < 0;
ecl_enable_interrupts();
if (err) {
FElibc_error("Unable to give executable permissions to ~A",
1, copy);
}
#endif
return copy;
return copy;
}
#ifdef ENABLE_DLOPEN
static void
set_library_error(cl_object block) {
cl_object output;
ecl_disable_interrupts();
cl_object output;
ecl_disable_interrupts();
#ifdef HAVE_DLFCN_H
output = make_base_string_copy(dlerror());
output = make_base_string_copy(dlerror());
#endif
#ifdef HAVE_MACH_O_DYLD_H
{
NSLinkEditErrors c;
int number;
const char *filename;
NSLinkEditError(&c, &number, &filename, &message);
output = make_base_string_copy(message);
}
{
NSLinkEditErrors c;
int number;
const char *filename;
NSLinkEditError(&c, &number, &filename, &message);
output = make_base_string_copy(message);
}
#endif
#if defined(ECL_MS_WINDOWS_HOST)
{
const char *message;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
FORMAT_MESSAGE_ALLOCATE_BUFFER,
0, GetLastError(), 0, (void*)&message, 0, NULL);
output = make_base_string_copy(message);
LocalFree(message);
}
{
const char *message;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
FORMAT_MESSAGE_ALLOCATE_BUFFER,
0, GetLastError(), 0, (void*)&message, 0, NULL);
output = make_base_string_copy(message);
LocalFree(message);
}
#endif
ecl_enable_interrupts();
block->cblock.error = output;
ecl_enable_interrupts();
block->cblock.error = output;
}
static void
dlopen_wrapper(cl_object block)
{
cl_object filename = block->cblock.name;
char *filename_string = (char*)filename->base_string.self;
cl_object filename = block->cblock.name;
char *filename_string = (char*)filename->base_string.self;
#ifdef HAVE_DLFCN_H
block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL);
block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL);
#endif
#ifdef HAVE_MACH_O_DYLD_H
{
NSObjectFileImage file;
static NSObjectFileImageReturnCode code;
code = NSCreateObjectFileImageFromFile(filename_string, &file);
if (code != NSObjectFileImageSuccess) {
block->cblock.handle = NULL;
} else {
NSModule out = NSLinkModule(file, filename_string,
NSLINKMODULE_OPTION_PRIVATE|
NSLINKMODULE_OPTION_BINDNOW|
NSLINKMODULE_OPTION_RETURN_ON_ERROR);
block->cblock.handle = out;
}}
{
NSObjectFileImage file;
static NSObjectFileImageReturnCode code;
code = NSCreateObjectFileImageFromFile(filename_string, &file);
if (code != NSObjectFileImageSuccess) {
block->cblock.handle = NULL;
} else {
NSModule out = NSLinkModule(file, filename_string,
NSLINKMODULE_OPTION_PRIVATE|
NSLINKMODULE_OPTION_BINDNOW|
NSLINKMODULE_OPTION_RETURN_ON_ERROR);
block->cblock.handle = out;
}}
#endif
#if defined(ECL_MS_WINDOWS_HOST)
block->cblock.handle = LoadLibrary(filename_string);
block->cblock.handle = LoadLibrary(filename_string);
#endif
if (block->cblock.handle == NULL)
set_library_error(block);
if (block->cblock.handle == NULL)
set_library_error(block);
}
static int
dlclose_wrapper(cl_object block)
{
if (block->cblock.handle != NULL) {
if (block->cblock.handle != NULL) {
#ifdef HAVE_DLFCN_H
dlclose(block->cblock.handle);
dlclose(block->cblock.handle);
#endif
#ifdef HAVE_MACH_O_DYLD_H
NSUnLinkModule(block->cblock.handle, NSUNLINKMODULE_OPTION_NONE);
NSUnLinkModule(block->cblock.handle, NSUNLINKMODULE_OPTION_NONE);
#endif
#if defined(ECL_MS_WINDOWS_HOST)
FreeLibrary(block->cblock.handle);
FreeLibrary(block->cblock.handle);
#endif
block->cblock.handle = NULL;
return TRUE;
}
return FALSE;
block->cblock.handle = NULL;
return TRUE;
}
return FALSE;
}
static cl_object
ecl_library_find_by_name(cl_object filename)
{
cl_object l;
for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
cl_object other = ECL_CONS_CAR(l);
cl_object name = other->cblock.name;
if (!Null(name) && ecl_string_eq(name, filename)) {
return other;
}
}
return ECL_NIL;
cl_object l;
for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
cl_object other = ECL_CONS_CAR(l);
cl_object name = other->cblock.name;
if (!Null(name) && ecl_string_eq(name, filename)) {
return other;
}
}
return ECL_NIL;
}
static cl_object
ecl_library_find_by_handle(void *handle)
{
cl_object l;
for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
cl_object other = ECL_CONS_CAR(l);
if (handle == other->cblock.handle) {
return other;
}
}
return ECL_NIL;
cl_object l;
for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
cl_object other = ECL_CONS_CAR(l);
if (handle == other->cblock.handle) {
return other;
}
}
return ECL_NIL;
}
static cl_object
ecl_library_open_inner(cl_object filename, bool self_destruct)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object block = ecl_make_codeblock();
block->cblock.self_destruct = self_destruct;
block->cblock.name = filename;
block->cblock.refs = ecl_make_fixnum(1);
const cl_env_ptr the_env = ecl_process_env();
cl_object block = ecl_make_codeblock();
block->cblock.self_destruct = self_destruct;
block->cblock.name = filename;
block->cblock.refs = ecl_make_fixnum(1);
ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) {
ecl_disable_interrupts();
GC_call_with_alloc_lock(dlopen_wrapper, block);
if (block->cblock.handle != NULL) {
/* Have we already loaded this library? If so, then unload this
* copy and increase the reference counter so that we can keep
* track (in lisp) of how many copies we use.
*/
cl_object other = ecl_library_find_by_handle(block->cblock.handle);
if (other != ECL_NIL) {
GC_call_with_alloc_lock(dlclose_wrapper, block);
block = other;
block->cblock.refs = ecl_one_plus(block->cblock.refs);
} else {
si_set_finalizer(block, ECL_T);
cl_core.libraries = CONS(block, cl_core.libraries);
}
}
ecl_enable_interrupts();
} ECL_WITH_GLOBAL_LOCK_END;
return block;
ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) {
ecl_disable_interrupts();
GC_call_with_alloc_lock(dlopen_wrapper, block);
if (block->cblock.handle != NULL) {
/* Have we already loaded this library? If so, then unload this
* copy and increase the reference counter so that we can keep
* track (in lisp) of how many copies we use.
*/
cl_object other = ecl_library_find_by_handle(block->cblock.handle);
if (other != ECL_NIL) {
GC_call_with_alloc_lock(dlclose_wrapper, block);
block = other;
block->cblock.refs = ecl_one_plus(block->cblock.refs);
} else {
si_set_finalizer(block, ECL_T);
cl_core.libraries = CONS(block, cl_core.libraries);
}
}
ecl_enable_interrupts();
} ECL_WITH_GLOBAL_LOCK_END;
return block;
}
cl_object
ecl_library_open(cl_object filename, bool force_reload) {
cl_object block;
bool self_destruct = 0;
char *filename_string;
cl_object block;
bool self_destruct = 0;
char *filename_string;
/* Coerces to a file name but does not merge with cwd */
filename = coerce_to_physical_pathname(filename);
filename = ecl_namestring(filename,
ECL_NAMESTRING_TRUNCATE_IF_ERROR |
ECL_NAMESTRING_FORCE_BASE_STRING);
/* Coerces to a file name but does not merge with cwd */
filename = coerce_to_physical_pathname(filename);
filename = ecl_namestring(filename,
ECL_NAMESTRING_TRUNCATE_IF_ERROR |
ECL_NAMESTRING_FORCE_BASE_STRING);
if (!force_reload) {
/* When loading a foreign library, such as a dll or a
* so, it cannot contain any executable top level
* code. In that case force_reload=0 and there is no
* need to reload it if it has already been loaded. */
block = ecl_library_find_by_name(filename);
if (!Null(block)) {
return block;
}
} else {
/* We are using shared libraries as modules and
* force_reload=1. Here we have to face the problem
* that many operating systems do not allow to load a
* shared library twice, even if it has changed. Hence
* we have to make a unique copy to be able to load
* the same FASL twice. In Windows this copy is
* _always_ made because otherwise it cannot be
* overwritten. In Unix we need only do that when the
* file has been previously loaded. */
if (!force_reload) {
/* When loading a foreign library, such as a dll or a
* so, it cannot contain any executable top level
* code. In that case force_reload=0 and there is no
* need to reload it if it has already been loaded. */
block = ecl_library_find_by_name(filename);
if (!Null(block)) {
return block;
}
} else {
/* We are using shared libraries as modules and
* force_reload=1. Here we have to face the problem
* that many operating systems do not allow to load a
* shared library twice, even if it has changed. Hence
* we have to make a unique copy to be able to load
* the same FASL twice. In Windows this copy is
* _always_ made because otherwise it cannot be
* overwritten. In Unix we need only do that when the
* file has been previously loaded. */
#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
filename = copy_object_file(filename);
self_destruct = 1;
filename = copy_object_file(filename);
self_destruct = 1;
#else
block = ecl_library_find_by_name(filename);
if (!Null(block)) {
filename = copy_object_file(filename);
self_destruct = 1;
}
block = ecl_library_find_by_name(filename);
if (!Null(block)) {
filename = copy_object_file(filename);
self_destruct = 1;
}
#endif
}
}
DO_LOAD:
block = ecl_library_open_inner(filename, self_destruct);
/*
* A second pass to ensure that the dlopen routine has not
* returned a library that we had already loaded. If this is
* the case, we close the new copy to ensure we do refcounting
* right.
*/
if (block->cblock.refs != ecl_make_fixnum(1)) {
if (force_reload) {
ecl_library_close(block);
filename = copy_object_file(filename);
self_destruct = 1;
goto DO_LOAD;
}
}
return block;
block = ecl_library_open_inner(filename, self_destruct);
/*
* A second pass to ensure that the dlopen routine has not
* returned a library that we had already loaded. If this is
* the case, we close the new copy to ensure we do refcounting
* right.
*/
if (block->cblock.refs != ecl_make_fixnum(1)) {
if (force_reload) {
ecl_library_close(block);
filename = copy_object_file(filename);
self_destruct = 1;
goto DO_LOAD;
}
}
return block;
}
void *
ecl_library_symbol(cl_object block, const char *symbol, bool lock) {
void *p;
if (block == @':default') {
cl_object l;
for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
cl_object block = ECL_CONS_CAR(l);
p = ecl_library_symbol(block, symbol, lock);
if (p) return p;
}
ecl_disable_interrupts();
void *p;
if (block == @':default') {
cl_object l;
for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) {
cl_object block = ECL_CONS_CAR(l);
p = ecl_library_symbol(block, symbol, lock);
if (p) return p;
}
ecl_disable_interrupts();
#if defined(ECL_MS_WINDOWS_HOST)
{
HANDLE hndSnap = NULL;
HANDLE hnd = NULL;
hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId());
if (hndSnap != INVALID_HANDLE_VALUE)
{
MODULEENTRY32 me32;
me32.dwSize = sizeof(MODULEENTRY32);
if (Module32First(hndSnap, &me32))
{
do
hnd = GetProcAddress(me32.hModule, symbol);
while (hnd == NULL && Module32Next(hndSnap, &me32));
}
CloseHandle(hndSnap);
}
p = (void*)hnd;
}
{
HANDLE hndSnap = NULL;
HANDLE hnd = NULL;
hndSnap = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId());
if (hndSnap != INVALID_HANDLE_VALUE)
{
MODULEENTRY32 me32;
me32.dwSize = sizeof(MODULEENTRY32);
if (Module32First(hndSnap, &me32))
{
do
hnd = GetProcAddress(me32.hModule, symbol);
while (hnd == NULL && Module32Next(hndSnap, &me32));
}
CloseHandle(hndSnap);
}
p = (void*)hnd;
}
#endif
#ifdef HAVE_DLFCN_H
p = dlsym(0, symbol);
p = dlsym(0, symbol);
#endif
#if !defined(ECL_MS_WINDOWS_HOST) && !defined(HAVE_DLFCN_H)
p = 0;
p = 0;
#endif
ecl_enable_interrupts();
} else {
ecl_disable_interrupts();
ecl_enable_interrupts();
} else {
ecl_disable_interrupts();
#ifdef HAVE_DLFCN_H
p = dlsym(block->cblock.handle, symbol);
p = dlsym(block->cblock.handle, symbol);
#endif
#if defined(ECL_MS_WINDOWS_HOST)
{
HMODULE h = (HMODULE)(block->cblock.handle);
p = GetProcAddress(h, symbol);
}
{
HMODULE h = (HMODULE)(block->cblock.handle);
p = GetProcAddress(h, symbol);
}
#endif
#ifdef HAVE_MACH_O_DYLD_H
NSSymbol sym;
sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle),
symbol);
if (sym == 0) {
p = 0;
} else {
p = NSAddressOfSymbol(sym);
}
NSSymbol sym;
sym = NSLookupSymbolInModule((NSModule)(block->cblock.handle),
symbol);
if (sym == 0) {
p = 0;
} else {
p = NSAddressOfSymbol(sym);
}
#endif
ecl_enable_interrupts();
/* Libraries whose symbols are being referenced by the FFI should not
* get garbage collected. Until we find a better solution we simply lock
* them for the rest of the runtime */
if (p) {
block->cblock.locked |= lock;
}
}
if (!p)
set_library_error(block);
return p;
ecl_enable_interrupts();
/* Libraries whose symbols are being referenced by the FFI should not
* get garbage collected. Until we find a better solution we simply lock
* them for the rest of the runtime */
if (p) {
block->cblock.locked |= lock;
}
}
if (!p)
set_library_error(block);
return p;
}
cl_object
ecl_library_error(cl_object block) {
return block->cblock.error;
return block->cblock.error;
}
bool
ecl_library_close(cl_object block) {
const cl_env_ptr the_env = ecl_process_env();
bool success = TRUE;
ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) {
ecl_disable_interrupts();
/* is it ever a case? no matter how many times i call
load-foreign-module it seems that block->cblock.refs = 1 */
if (block->cblock.refs > ecl_make_fixnum(1)) {
block->cblock.refs = ecl_one_minus(block->cblock.refs);
block = ECL_NIL;
} else if (block->cblock.handle != NULL) {
success = GC_call_with_alloc_lock(dlclose_wrapper, block);
cl_core.libraries = ecl_remove_eq(block, cl_core.libraries);
} else { /* block not loaded */
success = FALSE;
const cl_env_ptr the_env = ecl_process_env();
bool success = TRUE;
ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) {
ecl_disable_interrupts();
/* is it ever a case? no matter how many times i call
load-foreign-module it seems that block->cblock.refs = 1 */
if (block->cblock.refs > ecl_make_fixnum(1)) {
block->cblock.refs = ecl_one_minus(block->cblock.refs);
block = ECL_NIL;
} else if (block->cblock.handle != NULL) {
success = GC_call_with_alloc_lock(dlclose_wrapper, block);
cl_core.libraries = ecl_remove_eq(block, cl_core.libraries);
} else { /* block not loaded */
success = FALSE;
}
ecl_enable_interrupts();
} ECL_WITH_GLOBAL_LOCK_END;
if (block != ECL_NIL && block->cblock.self_destruct) {
if (!Null(block->cblock.name)) {
unlink((char*)block->cblock.name->base_string.self);
}
}
ecl_enable_interrupts();
} ECL_WITH_GLOBAL_LOCK_END;
if (block != ECL_NIL && block->cblock.self_destruct) {
if (!Null(block->cblock.name)) {
unlink((char*)block->cblock.name->base_string.self);
}
}
return success;
return success;
}
void
ecl_library_close_all(void)
{
while (cl_core.libraries != ECL_NIL) {
ecl_library_close(ECL_CONS_CAR(cl_core.libraries));
}
while (cl_core.libraries != ECL_NIL) {
ecl_library_close(ECL_CONS_CAR(cl_core.libraries));
}
}
ecl_def_ct_base_string(init_prefix, INIT_PREFIX, sizeof(INIT_PREFIX)-1, static, const);
@ -463,15 +458,15 @@ ecl_def_ct_base_string(init_prefix, INIT_PREFIX, sizeof(INIT_PREFIX)-1, static,
cl_object
_ecl_library_init_prefix(void)
{
return init_prefix;
return init_prefix;
}
ecl_def_ct_base_string(default_entry, INIT_PREFIX "CODE", sizeof(INIT_PREFIX "CODE")-1,
static, const);
static, const);
cl_object
_ecl_library_default_entry(void)
{
return default_entry;
return default_entry;
}
#endif /* ENABLE_DLOPEN */

177
src/c/ffi/mmap.d
View file

@ -1,19 +1,14 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
/*
mmap.d -- Mapping of binary files.
*/
/*
Copyright (c) 2011, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
* mmap.d - mapping of binary files
*
* Copyright (c) 2011 Juan Jose Garcia Ripoll
*
* See file 'LICENSE' for the copyright details.
*
*/
#include <ecl/ecl.h>
#ifdef HAVE_SYS_MMAN_H
@ -33,77 +28,77 @@
(external_format @':default'))
@
#ifdef HAVE_SYS_MMAN_H
{
cl_object output, stream;
int c_prot, c_flags, fd;
size_t len;
void *pa;
if (direction == @':input')
c_prot = PROT_READ;
else if (direction == @':output')
c_prot = PROT_WRITE;
else if (direction == @':io')
c_prot = PROT_READ | PROT_WRITE;
else
c_prot = PROT_NONE;
if (Null(filename)) {
c_flags = MAP_ANON | MAP_PRIVATE;
fd = -1;
len = ecl_to_unsigned_integer(length);
stream = ECL_NIL;
} else {
c_flags = MAP_SHARED;
stream = cl_open(13, filename,
{
cl_object output, stream;
int c_prot, c_flags, fd;
size_t len;
void *pa;
if (direction == @':input')
c_prot = PROT_READ;
else if (direction == @':output')
c_prot = PROT_WRITE;
else if (direction == @':io')
c_prot = PROT_READ | PROT_WRITE;
else
c_prot = PROT_NONE;
if (Null(filename)) {
c_flags = MAP_ANON | MAP_PRIVATE;
fd = -1;
len = ecl_to_unsigned_integer(length);
stream = ECL_NIL;
} else {
c_flags = MAP_SHARED;
stream = cl_open(13, filename,
@':direction', direction,
@':element-type', element_type,
@':if-exists', if_exists,
@':if-does-not-exist', if_does_not_exist,
@':external-format', @':default',
@':cstream', ECL_NIL);
fd = ecl_to_int(si_file_stream_fd(stream));
if (Null(length))
len = ecl_to_unsigned_integer(ecl_file_length(stream));
else
len = ecl_to_unsigned_integer(length);
}
output = si_make_vector(element_type, ecl_make_fixnum(0), ECL_NIL,
ECL_NIL, ECL_NIL, ECL_NIL);
pa = mmap(0, len, c_prot, c_flags, fd,
ecl_integer_to_off_t(offset));
if (pa == MAP_FAILED) {
FElibc_error("EXT::MMAP failed.", 0);
} else {
output->base_string.self = pa;
output->base_string.dim =
output->base_string.fillp = len;
}
@(return CONS(output, stream));
}
#else
{
cl_object output, vector;
if (Null(filename)) {
output = si_make_vector(element_type, length, ECL_NIL,
ECL_NIL, ECL_NIL, ECL_NIL);
} else {
cl_object stream = cl_open(13, filename,
@':direction', direction,
@':element-type', element_type,
@':if-exists', if_exists,
@':if-does-not-exist', if_does_not_exist,
@':external-format', @':default',
@':cstream', ECL_NIL);
fd = ecl_to_int(si_file_stream_fd(stream));
if (Null(length))
len = ecl_to_unsigned_integer(ecl_file_length(stream));
else
len = ecl_to_unsigned_integer(length);
}
output = si_make_vector(element_type, ecl_make_fixnum(0), ECL_NIL,
ECL_NIL, ECL_NIL, ECL_NIL);
pa = mmap(0, len, c_prot, c_flags, fd,
ecl_integer_to_off_t(offset));
if (pa == MAP_FAILED) {
FElibc_error("EXT::MMAP failed.", 0);
} else {
output->base_string.self = pa;
output->base_string.dim =
output->base_string.fillp = len;
}
@(return CONS(output, stream))
}
#else
{
cl_object output, vector;
if (Null(filename)) {
output = si_make_vector(element_type, length, ECL_NIL,
ECL_NIL, ECL_NIL, ECL_NIL);
} else {
cl_object stream = cl_open(13, filename,
@':direction', direction,
@':element-type', element_type,
@':if-exists', if_exists,
@':if-does-not-exist', if_does_not_exist,
@':external-format', @':pass-through',
@':cstream', ECL_T);
if (Null(length))
length = ecl_file_length(stream);
else
length = ecl_to_unsigned_integer(length);
output = si_make_vector(element_type, length, ECL_NIL,
ECL_NIL, ECL_NIL, ECL_NIL);
cl_read_sequence(2, output, stream);
cl_close(1, stream);
}
@(return output)
}
@':external-format', @':pass-through',
@':cstream', ECL_T);
if (Null(length))
length = ecl_file_length(stream);
else
length = ecl_to_unsigned_integer(length);
output = si_make_vector(element_type, length, ECL_NIL,
ECL_NIL, ECL_NIL, ECL_NIL);
cl_read_sequence(2, output, stream);
cl_close(1, stream);
}
@(return output);
}
#endif
@)
@ -111,9 +106,9 @@ cl_object
si_mmap_array(cl_object map)
{
#ifdef HAVE_SYS_MMAN_H
@(return cl_car(map));
@(return cl_car(map));
#else
@(return map);
@(return map);
#endif
}
@ -121,13 +116,13 @@ cl_object
si_munmap(cl_object map)
{
#ifdef HAVE_SYS_MMAN_H
cl_object array = cl_car(map);
cl_object stream = cl_cdr(map);
int code = munmap(array->base_string.self, array->base_string.dim);
if (code < 0) {
FElibc_error("Error when unmapping file.", 0);
}
cl_close(1, stream);
cl_object array = cl_car(map);
cl_object stream = cl_cdr(map);
int code = munmap(array->base_string.self, array->base_string.dim);
if (code < 0) {
FElibc_error("Error when unmapping file.", 0);
}
cl_close(1, stream);
#endif
@(return ECL_NIL)
@(return ECL_NIL);
}

6733
src/c/file.d
View file

File diff suppressed because it is too large Load diff

3447
src/c/format.d
View file

File diff suppressed because it is too large Load diff

40
src/doc/new-doc/developer-guide/sources.txi
View file

@ -57,3 +57,43 @@ auxiliaries used in compiled Lisp code
@item compiler.d
bytecode compiler
@item disassembler.d
bytecodes disassembler utilities
@item dpp.c
defun preprocessor
@item ecl_constants.h
contstant values for all_symbols.d
@item features.h
names of features compiled into ECL
@item error.d
error handling
@item eval.d
evaluation
@item ffi/backtrace.d
C backtraces
@item ffi/cdata.d
data for compiled files
@item ffi/libraries.d
shared library and bundle opening / copying / closing
@item ffi/mmap.d
mapping of binary files
@item ffi.d
user defined data types and foreign functions interface
@item file.d
file interface (implementation dependent)
@item format.d
format (this isn't ANSI compliant, we need it for bootstrapping though)