static void fast_read_closure(lref_t reader, lref_t * retval)
{
lref_t env;
fast_read(reader, &env, false);
if (EOFP(env))
vmerror_fast_read("incomplete closure, missing environment", reader, NIL);
if (!(NULLP(env) || CONSP(env)))
vmerror_fast_read("malformed closure, bad environment", reader, env);
lref_t code;
fast_read(reader, &code, false);
if (EOFP(code))
vmerror_fast_read("Incomplete closure, missing code", reader, false);
if (!(NULLP(code) || CONSP(code)))
vmerror_fast_read("malformed closure, bad code", reader, code);
lref_t props;
fast_read(reader, &props, false);
if (EOFP(props))
vmerror_fast_read("incomplete closure, missing property list", reader, NIL);
if (!(NULLP(props) || CONSP(props)))
vmerror_fast_read("malformed closure, bad property list", reader, props);
*retval = lclosurecons(env, code, props);
}
static void *
dynlib_unbind_all_internal(uim_lisp plugin_alist_)
{
/* call dlclose(3) collectively at the end in order to avoid GC problem */
uim_lisp alist_ = plugin_alist_;
while (!NULLP(alist_)) {
uim_lisp plugin_, quit_proc_;
void (*dynlib_instance_quit)(void);
plugin_ = CAR(alist_);
quit_proc_ = CAR(CDR(CDR(CDR(plugin_))));
if (!FALSEP(quit_proc_)) {
dynlib_instance_quit = C_FPTR(quit_proc_);
(*dynlib_instance_quit)();
}
alist_ = CDR(alist_);
}
alist_ = plugin_alist_;
while (!NULLP(alist_)) {
uim_lisp plugin_, lib_;
void *library;
plugin_ = CAR(alist_);
lib_ = CAR(CDR(plugin_));
if (!FALSEP(lib_)) {
library = C_PTR(lib_);
dlclose(library);
}
alist_ = CDR(alist_);
}
return uim_scm_t();
}
lref_t lflush_whitespace(lref_t port, lref_t slc)
{
int ch = EOF;
if (NULLP(port))
port = CURRENT_INPUT_PORT();
if (!TEXT_PORTP(port))
vmerror_wrong_type_n(1, port);
if (PORT_OUTPUTP(port))
vmerror_unsupported(_T("cannot flush-whitespace output ports"));
bool skip_lisp_comments = true;
if (!NULLP(slc))
skip_lisp_comments = TRUEP(slc);
ch = flush_whitespace(port, skip_lisp_comments);
if (ch == EOF)
return lmake_eof();
return charcons((_TCHAR) ch);
}
static LISP lregister_converter(LISP fmt, LISP lext, LISP lcmd,
LISP sext, LISP scmd)
{
register_converter(get_c_string(fmt),
NULLP(lext)?NULL:get_c_string(lext),
NULLP(lcmd)?NULL:get_c_string(lcmd),
NULLP(sext)?NULL:get_c_string(sext),
NULLP(scmd)?NULL:get_c_string(scmd));
return NIL;
}
/* write-scheme-comment */
BGL_EXPORTED_DEF obj_t BGl_writezd2schemezd2commentz00zzwrite_schemez00(obj_t
BgL_portz00_3, obj_t BgL_sexpz00_4)
{
AN_OBJECT;
{ /* Write/scheme.scm 34 */
if (NULLP(BgL_sexpz00_4))
{ /* Write/scheme.scm 36 */
bgl_display_string(BGl_string1527z00zzwrite_schemez00, BgL_portz00_3);
return bgl_display_char(((unsigned char) '\n'), BgL_portz00_3);
}
else
{ /* Write/scheme.scm 36 */
if (NULLP(CDR(BgL_sexpz00_4)))
{ /* Write/scheme.scm 38 */
bgl_display_string(BGl_string1525z00zzwrite_schemez00,
BgL_portz00_3);
bgl_display_obj(CAR(BgL_sexpz00_4), BgL_portz00_3);
return bgl_display_char(((unsigned char) '\n'), BgL_portz00_3);
}
else
{ /* Write/scheme.scm 41 */
obj_t BgL_runner1522z00_104;
{ /* Write/scheme.scm 41 */
obj_t BgL_list1518z00_100;
{ /* Write/scheme.scm 41 */
obj_t BgL_arg1520z00_102;
BgL_arg1520z00_102 = MAKE_PAIR(BgL_sexpz00_4, BNIL);
BgL_list1518z00_100 =
MAKE_PAIR(BGl_string1525z00zzwrite_schemez00,
BgL_arg1520z00_102);
}
BgL_runner1522z00_104 =
BGl_consza2za2zz__r4_pairs_and_lists_6_3z00(BgL_portz00_3,
BgL_list1518z00_100);
}
{ /* Write/scheme.scm 41 */
obj_t BgL_aux1521z00_103;
BgL_aux1521z00_103 = CAR(BgL_runner1522z00_104);
BgL_runner1522z00_104 = CDR(BgL_runner1522z00_104);
return
BGl_fprintz00zz__r4_output_6_10_3z00(BgL_aux1521z00_103,
BgL_runner1522z00_104);
}
}
}
}
}
SCM_EXPORT ScmObj
scm_p_map(ScmObj proc, ScmObj args)
{
DECLARE_FUNCTION("map", procedure_variadic_1);
if (NULLP(args))
ERR("wrong number of arguments");
/* fast path for single arg case */
if (NULLP(CDR(args)))
return scm_map_single_arg(proc, CAR(args));
/* multiple args case */
return scm_map_multiple_args(proc, args, scm_false);
}
SCM_EXPORT scm_int_t
scm_validate_formals(ScmObj formals)
{
#if SCM_STRICT_ARGCHECK
scm_int_t len;
DECLARE_INTERNAL_FUNCTION("scm_validate_formals");
/*
* SigScheme does not perform the check for duplicate variable name in
* formals. It is an user's responsibility.
*
* R5RS: 4.1.4 Procedures
* It is an error for a <variable> to appear more than once in <formals>.
*/
/* This loop goes infinite if the formals is circular. SigSchme expects
* that user codes are sane here. */
for (len = 0; CONSP(formals); formals = CDR(formals), len++) {
if (!IDENTIFIERP(CAR(formals)))
return SCM_LISTLEN_ENCODE_ERROR(len);
}
if (NULLP(formals))
return len;
/* dotted list allowed */
if (IDENTIFIERP(formals))
return SCM_LISTLEN_ENCODE_DOTTED(len);
return SCM_LISTLEN_ENCODE_ERROR(len);
#else
/* Crashless loose validation:
* Regard any non-list object as symbol. Since the lookup operation search
* for a variable by EQ, this is safe although loosely allows
* R5RS-incompatible code. */
return scm_finite_length(formals);
#endif
}
static LISP x_get_cell(LISP row, LISP col, LISP bname)
{
int r, c;
char *p;
buffer *buf;
int s;
r = get_c_long(row);
c = get_c_long(col);
if (r < 1 || r > BUFFER_ROWS || c < 1 || c > BUFFER_COLS)
return NIL;
if (NULLP(bname)) {
buf = siag_buffer;
s = siag_sht;
} else if (TYPEP(bname, tc_string)) {
buf = find_sheet_by_name(bname->storage_as.string.data,
siag_buffer, &s);
if (buf == NULL) return NIL;
}
else return NIL;
switch (ret_type(buf, s, r, c)) {
case STRING:
p = ret_string(buf, s, r, c);
return strcons(strlen(p), p);
case LABEL:
p = ret_text(buf, s, r, c);
return strcons(strlen(p), p);
case EMPTY:
case ERROR:
return NIL;
default:
return flocons(ret_val(buf, s, r, c).number);
}
}
static ScmObj
continuation_stack_pop(void)
{
DECLARE_INTERNAL_FUNCTION("continuation_stack_pop");
return NULLP(l_continuation_stack) ? SCM_FALSE : POP(l_continuation_stack);
}
static void accept_command_line_arguments(int argc, _TCHAR * argv[])
{
lref_t arg_list = NIL;
lref_t arg_list_bud = NIL;
for (int ii = 0; ii < argc; ii++)
{
if (is_vm_argument(argv[ii]))
continue;
lref_t new_cell = lcons(strconsbuf(argv[ii]), NIL);
if (NULLP(arg_list_bud))
{
arg_list = arg_list_bud = new_cell;
}
else
{
SET_CDR(arg_list_bud, new_cell);
arg_list_bud = new_cell;
}
}
interp.startup_args = arg_list;
}
CELL make_keyword_counted(char* s, size_t len)
{
CELL list = g_interned_keywords;
for( ; !NULLP(list); list = CDR(list)) {
CELL keyword = CAR(list);
KEYWORD* p = GET_KEYWORD(keyword);
if (p->len == len && (opt_case_sensitive ? strncmp : strncasecmp)(p->data, s, len) == 0) {
return keyword;
}
}
CELL keyword = make_raw_keyword_counted(len);
KEYWORD* p = GET_KEYWORD(keyword);
if (opt_case_sensitive) {
memcpy(p->data, s, len);
}
else {
int i;
for(i=0; i<len; ++i) {
GET_KEYWORD(keyword)->data[i] = tolower(s[i]);
}
}
gc_root_1("make_keyword_counted", keyword);
g_interned_keywords = make_cons(keyword, g_interned_keywords);
gc_unroot();
return keyword;
}
lref_t lenvlookup(lref_t var, lref_t env)
{
lref_t frame;
for (frame = env; CONSP(frame); frame = CDR(frame))
{
lref_t tmp = CAR(frame);
if (!CONSP(tmp))
panic("damaged frame");
lref_t al, fl;
for (fl = CAR(tmp), al = CDR(tmp);
CONSP(fl);
fl = CDR(fl), al = CDR(al))
{
if (!CONSP(al))
vmerror_arg_out_of_range(NIL, _T("too few arguments"));
if (EQ(CAR(fl), var))
return al;
}
if (SYMBOLP(fl) && EQ(fl, var))
return lcons(al, NIL);
}
if (!NULLP(frame))
panic("damaged env");
return NIL;
}
CELL make_name_counted(char* s, size_t len)
{
CELL list = g_interned_names;
for( ; !NULLP(list); list = CDR(list)) {
CELL name = CAR(list);
NAME* p = GET_NAME(name);
if (p->len == len && (opt_case_sensitive ? strncmp : strncasecmp)(p->data, s, len) == 0) {
return name;
}
}
CELL name = make_raw_name_counted(len);
NAME* p = GET_NAME(name);
if (opt_case_sensitive) {
memcpy(p->data, s, len);
}
else {
int i;
for(i=0; i<len; ++i) {
p->data[i] = tolower(s[i]);
}
}
gc_root_1("make_name_counted", name);
g_interned_names = make_cons(name, g_interned_names);
gc_unroot();
return name;
}
CELL func_append(CELL frame)
{
if (FC == 0) {
return V_NULL;
}
CELL pre_tail = V_EMPTY;
CELL result = V_EMPTY;
CELL arg = V_EMPTY;
gc_root_4("func_append", frame, pre_tail, result, arg);
result = FV[FC-1];
int argi = 0;
while(argi < FC-1) {
arg = FV[argi++];
while(CONSP(arg)) {
const CELL next = make_cons(CAR(arg), FV[FC-1]);
if (EMPTYP(pre_tail)) {
pre_tail = result = next;
}
else {
pre_tail = CDR(pre_tail) = next;
}
arg = CDR(arg);
}
if (!NULLP(arg)) {
gc_unroot();
return make_exception("expects a <proper list> for all but last argument");
}
}
gc_unroot();
return result;
}
static LISP x_get_string(LISP row, LISP col, LISP bname)
{
int r, c;
int s;
char *p;
buffer *buf;
r = get_c_long(row);
c = get_c_long(col);
if (r < 1 || r > BUFFER_ROWS || c < 1 || c > BUFFER_COLS)
return NIL;
if (NULLP(bname)) {
buf = siag_buffer;
s = siag_sht;
} else if (TYPEP(bname, tc_string)) {
buf = find_sheet_by_name(bname->storage_as.string.data,
siag_buffer, &s);
if (buf == NULL) return NIL;
}
else return NIL;
if (ret_type(buf, s, r, c) == ERROR) p = "";
else p = ret_pvalue(NULL, buf, s, r, c, -1);
return strcons(strlen(p), p);
}
static void fasl_ensure_valid_table_index(lref_t reader, size_t index)
{
if (NULLP(FASL_READER_STREAM(reader)->table))
{
FASL_READER_STREAM(reader)->table =
vectorcons((index >=
DEFAULT_FASL_TABLE_SIZE) ? index +
DEFAULT_FASL_TABLE_SIZE : DEFAULT_FASL_TABLE_SIZE, NIL);
}
else
{
lref_t fasl_table = FASL_READER_STREAM(reader)->table;
assert(VECTORP(fasl_table));
size_t old_len = fasl_table->as.vector.dim;
if (index >= old_len)
{
size_t new_len =
(index >= old_len * 2) ? index + DEFAULT_FASL_TABLE_SIZE : (old_len * 2);
FASL_READER_STREAM(reader)->table =
vector_resize(fasl_table, new_len > SIZE_MAX ? SIZE_MAX : (size_t) new_len, NIL);
}
}
assert(VECTORP(FASL_READER_STREAM(reader)->table));
assert(index < (FASL_READER_STREAM(reader)->table)->as.vector.dim);
}
static void fast_read_hash(lref_t reader, lref_t * hash)
{
lref_t shallow;
fast_read(reader, &shallow, false);
*hash = hashcons(TRUEP(shallow));
lref_t elements;
fast_read(reader, &elements, false);
lref_t loc = NIL;
for (loc = elements; CONSP(loc); loc = CDR(loc))
{
lref_t kv = CAR(loc);
if (!CONSP(kv))
vmerror_fast_read("malformed key/value in hash table", reader, kv);
lhash_set(*hash, CAR(kv), CDR(kv));
}
if (!NULLP(loc))
vmerror_fast_read("malformed key/value list for hash table", reader, elements);
}
zvalue defined(zvalue s) const
{
if (NULLP(get(s)))
return NULL_ZVALUE;
return INTEGER_TO_ZVALUE(1);
}
size_t write_bytes(lref_t port, const void *buf, size_t size)
{
assert(!NULLP(port));
assert(PORT_CLASS(port)->write_bytes);
return PORT_CLASS(port)->write_bytes(port, buf, size);
}
int gnugol_header_out(QueryOptions_t *q)
{
assert(q != NULL);
if(q->header) {
char buffer[SNIPPETSIZE];
strncpy(buffer,q->keywords,SNIPPETSIZE);
STRIPHTML(buffer); // FIXME, need to convert % escapes to strings
switch(q->format) {
case FORMATHTML5:
GNUGOL_OUTF(q, "<html><head><meta charset=\"UTF-8\"><title>%s%s</title></head><body>", NULLP(q->header_str), NULLP(buffer));
break;
case FORMATHTML:
case FORMATELINKS:
GNUGOL_OUTF(q, "<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\"><title>%s%s</title></head><body>",NULLP(q->header_str), NULLP(buffer));
break;
case FORMATSSML:
GNUGOL_OUTF(q, "Result for <emphasis level='moderate'> %s </emphasis>\n", NULLP(buffer)); // FIXME keywords
break;
default: break;
}
}
return(0);
}
/* args*->args-list */
BGL_EXPORTED_DEF obj_t BGl_argsza2zd2ze3argszd2listz41zztools_argsz00(obj_t
BgL_expz00_6)
{
AN_OBJECT;
{ /* Tools/args.scm 106 */
if (NULLP(BgL_expz00_6))
{ /* Tools/args.scm 108 */
return BNIL;
}
else
{ /* Tools/args.scm 108 */
if (PAIRP(BgL_expz00_6))
{ /* Tools/args.scm 110 */
return
MAKE_PAIR(CAR(BgL_expz00_6),
BGl_argsza2zd2ze3argszd2listz41zztools_argsz00(CDR
(BgL_expz00_6)));
}
else
{ /* Tools/args.scm 111 */
obj_t BgL_list1538z00_144;
BgL_list1538z00_144 = MAKE_PAIR(BgL_expz00_6, BNIL);
return BgL_list1538z00_144;
}
}
}
}
lref_t initialize_port(lref_t port,
struct port_class_t * cls,
lref_t port_name,
enum port_mode_t mode,
lref_t user_object,
void *user_data)
{
assert(cls != NULL);
assert(!NULLP(port));
SET_PORT_PINFO(port, gc_malloc(sizeof(struct port_info_t)));
SET_PORT_CLASS(port, cls);
PORT_PINFO(port)->port_name = port_name;
PORT_PINFO(port)->user_data = user_data;
PORT_PINFO(port)->user_object = user_object;
PORT_PINFO(port)->mode = mode;
SET_PORT_TEXT_INFO(port, NULL);;
if (PORT_CLASS(port)->open)
PORT_CLASS(port)->open(port);
return port;
}
static lref_t *find_matching_escape(lref_t *start_frame, lref_t tag)
{
if (CURRENT_TIB()->escape_frame != NULL)
start_frame = fstack_prev_frame(CURRENT_TIB()->escape_frame);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: looking for escape tag ~a\n"), tag));
for(lref_t *frame = start_frame; frame != NULL; frame = fstack_prev_frame(frame))
{
if (fstack_frame_type(frame) != FRAME_ESCAPE)
continue;
lref_t ftag = frame[FOFS_ESCAPE_TAG];
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: frame: ~c&, tag ~a\n"), frame, ftag));
if (NULLP(ftag) || EQ(ftag, tag)) {
return frame;
}
}
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: No escape frame for tag ~a\n"), tag));
return NULL;
}
lref_t lread_line(lref_t port)
{
int ch;
if (NULLP(port))
port = CURRENT_INPUT_PORT();
if (!TEXT_PORTP(port))
vmerror_wrong_type_n(1, port);
if (PORT_OUTPUTP(port))
vmerror_unsupported(_T("cannot read-line from output ports"));
lref_t op = lopen_output_string();
bool read_anything = false;
for (ch = read_char(port); (ch != EOF) && (ch != _T('\n')); ch = read_char(port)) {
read_anything = true;
write_char(op, ch);
}
if (!read_anything && (ch == EOF))
return lmake_eof();
return lget_output_string(op);
}
static int
prepare_radix(const char *funcname, ScmObj args)
{
ScmObj radix;
int r;
DECLARE_INTERNAL_FUNCTION("(internal)");
ASSERT_PROPER_ARG_LIST(args);
/* dirty hack to replace internal function name */
SCM_MANGLE(name) = funcname;
if (NULLP(args)) {
r = 10;
} else {
radix = POP(args);
ASSERT_NO_MORE_ARG(args);
ENSURE_INT(radix);
r = SCM_INT_VALUE(radix);
if (!VALID_RADIXP(r))
ERR_OBJ("invalid radix", radix);
}
return r;
}
/**
* Lookup a variable of an env
*
* @return Reference to the variable. SCM_INVALID_REF if not found.
*/
SCM_EXPORT ScmRef
scm_lookup_environment(ScmObj var, ScmObj env)
{
ScmObj frame;
ScmRef ref;
#if SCM_USE_HYGIENIC_MACRO
scm_int_t depth, id_depth;
ScmObj env_save;
#endif /* SCM_USE_HYGIENIC_MACRO */
DECLARE_INTERNAL_FUNCTION("scm_lookup_environment");
SCM_ASSERT(IDENTIFIERP(var));
SCM_ASSERT(VALID_ENVP(env));
/* lookup in frames */
#if SCM_USE_HYGIENIC_MACRO
env_save = env;
depth = 0;
#endif
for (; !NULLP(env); env = CDR(env)) {
frame = CAR(env);
ref = scm_lookup_frame(var, frame);
if (ref != SCM_INVALID_REF)
return ref;
#if SCM_USE_HYGIENIC_MACRO
++depth;
#endif
}
SCM_ASSERT(NULLP(env));
#if SCM_USE_HYGIENIC_MACRO
if (FARSYMBOLP(var)) {
scm_int_t i;
id_depth = SCM_FARSYMBOL_ENV(var);
if (id_depth > depth)
scm_macro_bad_scope(var);
for (i = depth - id_depth; i--; )
env_save = CDR(env_save);
ref = lookup_n_frames(SCM_FARSYMBOL_SYM(var),
id_depth, env_save);
SCM_ASSERT(ref != SCM_INVALID_REF || SYMBOLP(SCM_FARSYMBOL_SYM(var)));
return ref;
}
#endif
return SCM_INVALID_REF;
}
zvalue* put_(zvalue val)
{
unsigned int h1 = val_hash_function(val);
unsigned int h2 = h1 | 0x0001;
unsigned int ix = h1 % size;
while (!NULLP(block[ix]) && !DELETEDP(block[ix]))
(ix += h2) %= size;
if (NULLP(block[ix]))
++occupied_and_deleted;
block[ix] = val;
return &block[ix];
}
static void
unwind_dynamic_extent(void)
{
if (NULLP(l_current_dynamic_extent))
PLAIN_ERR("corrupted dynamic extent");
l_current_dynamic_extent = CDR(l_current_dynamic_extent);
}
LISP lkill(LISP pid,LISP sig)
{long iflag;
iflag = no_interrupt(1);
if (kill(get_c_long(pid),
NULLP(sig) ? SIGKILL : get_c_long(sig)))
err("kill",llast_c_errmsg(-1));
else
no_interrupt(iflag);
return(NIL);}
lref_t lport_class_name(lref_t port)
{
if (NULLP(port))
port = CURRENT_INPUT_PORT();
if (!PORTP(port))
vmerror_wrong_type_n(1, port);
return strconsbuf(PORT_CLASS(port)->name);
}
