void undump(char *s)
{
at *atf = OPEN_READ(s,0);
FILE *f = Gptr(atf);
int magic = readmagic32(f);
int version = read32(f);
if ( magic != DUMPMAGIC )
error(NIL, "incorrect dump file format", NIL);
if ( version > DUMPVERSION )
error(NIL, "dump file format version not supported", NIL);
/* The macro character map */
size_t sr = fread(char_map,1,256,f);
if (sr < 256 || feof(f) || ferror(f))
error(NIL, "corrupted dump file (1)",NIL);
/* The unified list */
at *val, *sym, *p = bread(f, NIL);
while (CONSP(p)) {
if (CONSP(Car(p))) {
sym = Caar(p);
val = Cdar(p);
ifn (SYMBOLP(sym))
error(NIL, "corrupted dump file (4)", NIL);
var_SET(sym, val);
} else if (SYMBOLP(Car(p)))
var_lock(Car(p));
val = p;
p = Cdr(p);
Cdr(val) = NIL;
}
/* define special symbols */
at_NULL = var_get(named("NULL"));
}
/*---------------------------------------------------------------------*/
void *
bgl_debug_trace_top() {
obj_t env = BGL_CURRENT_DYNAMIC_ENV();
#if !BMEMDEBUG
if( !env ) {
goto unknown;
} else {
struct bgl_dframe *top = BGL_ENV_GET_TOP_OF_FRAME( env );
if( !top ) goto unknown;
if( !SYMBOLP( top->name ) ) goto unknown;
return top->name;
}
unknown:
{
/* if we see no trace in a stack (or no stack at all) we */
/* check we are running a asynchronous fair-thread. */
void *th = bmem_thread ? ____bglthread_id_get() : 0;
if( SYMBOLP( th ) )
return th;
else
return BUNSPEC;
}
}
at *send_message(at *classname, at *obj, at *method, at *args)
{
class_t *cl = classof(obj);
/* find superclass */
if (classname) {
ifn (SYMBOLP(classname))
error(NIL, "not a class name", classname);
while (cl && cl->classname != classname)
cl = cl->super;
ifn (cl)
error(NIL, "cannot find class", classname);
}
/* send */
ifn (SYMBOLP(method))
error(NIL, "not a method name", method);
struct hashelem *hx = _getmethod(cl, method);
if (hx)
return call_method(obj, hx, args);
else if (method == at_pname) // special method?
return NEW_STRING(cl->name(obj));
/* send -unknown */
hx = _getmethod(cl, at_unknown);
if (hx) {
at *arg = new_cons(method, new_cons(args, NIL));
return call_method(obj, hx, arg);
}
/* fail */
error(NIL, "method not found", method);
}
static void
store_function_docstring (Lisp_Object obj, ptrdiff_t offset)
{
/* Don't use indirect_function here, or defaliases will apply their
docstrings to the base functions (Bug#2603). */
Lisp_Object fun = SYMBOLP (obj) ? XSYMBOL (obj)->function : obj;
/* The type determines where the docstring is stored. */
/* Lisp_Subrs have a slot for it. */
if (SUBRP (fun))
{
intptr_t negative_offset = - offset;
XSUBR (fun)->doc = (char *) negative_offset;
}
/* If it's a lisp form, stick it in the form. */
else if (CONSP (fun))
{
Lisp_Object tem;
tem = XCAR (fun);
if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
|| (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
{
tem = Fcdr (Fcdr (fun));
if (CONSP (tem) && INTEGERP (XCAR (tem)))
/* FIXME: This modifies typically pure hash-cons'd data, so its
correctness is quite delicate. */
XSETCAR (tem, make_number (offset));
}
else if (EQ (tem, Qmacro))
store_function_docstring (XCDR (fun), offset);
}
/* Bytecode objects sometimes have slots for it. */
else if (COMPILEDP (fun))
{
/* This bytecode object must have a slot for the
docstring, since we've found a docstring for it. */
if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_DOC_STRING)
ASET (fun, COMPILED_DOC_STRING, make_number (offset));
else
{
AUTO_STRING (format, "No docstring slot for %s");
CALLN (Fmessage, format,
(SYMBOLP (obj)
? SYMBOL_NAME (obj)
: build_string ("<anonymous>")));
}
}
}
static void validate_structure_layout(size_t slots, lref_t layout)
{
if (!CONSP(layout))
vmerror_wrong_type_n(2, layout);
size_t len = (size_t) get_c_long(llength(layout));
if (len != 2)
vmerror_arg_out_of_range(layout, _T("bad structure layout, length<>2"));
lref_t slot_layout = CAR(CDR(layout));
if (get_c_long(llength(slot_layout)) != (long) slots)
vmerror_arg_out_of_range(lcons(slot_layout, fixcons(slots)),
_T("bad structure layout, wrong number of slots"));
for (; CONSP(slot_layout); slot_layout = CDR(slot_layout))
{
if (!CONSP(CAR(slot_layout)))
vmerror_arg_out_of_range(lcons(slot_layout, layout),
_T("bad structure layout, bad slot layout"));
if (!SYMBOLP(CAR(CAR(slot_layout))))
vmerror_arg_out_of_range(layout,
_T("bad structure layout, missing slot name"));
}
}
void putmethod(class_t *cl, at *name, at *value)
{
ifn (SYMBOLP(name))
RAISEF("not a symbol", name);
if (value && !FUNCTIONP(value))
RAISEF("not a function", value);
clear_hashok(cl);
at **last = &(cl->methods);
at *list = *last;
while (CONSP(list)) {
at *q = Car(list);
ifn (CONSP(q))
RAISEF("not a pair", q);
if (Car(q) == name) {
if (value) {
/* replace */
Cdr(q) = value;
return;
} else {
/* remove */
*last = Cdr(list);
Cdr(list) = NIL;
return;
}
}
last = &Cdr(list);
list = *last;
}
/* not an existing method, append */
if (value)
*last = new_cons(new_cons(name, value), NIL);
}
static void
ase_metric_prnt(Lisp_Object obj, Lisp_Object pcf, int unused)
{
EMOD_ASE_DEBUG_METR("m:0x%08x@0x%08x (rc:%d)\n",
(unsigned int)(XASE_METRIC(obj)),
(unsigned int)obj, 1);
write_c_string("#<", pcf);
print_internal(XDYNACAT_TYPE(obj), pcf, unused);
{
if (NILP(XASE_METRIC_LDIST(obj))) {
write_hex_ptr(XASE_METRIC_DIST(obj),pcf);
} else {
Lisp_Object ldist = XASE_METRIC_LDIST(obj);
if (SYMBOLP(ldist)) {
Lisp_String *name =
symbol_name(XSYMBOL(ldist));
write_fmt_string(pcf, " #'%s", string_data(name));
} else if (SUBRP(ldist)) {
const char *name = subr_name(XSUBR(ldist));
write_fmt_string(pcf, " #'%s", name);
} else {
write_c_string(" #'(lambda ...)", pcf);
}
}
}
write_c_string(">", pcf);
return;
}
/*===========================================================================
R5RS : 6.3 Other data types : 6.3.3 Symbols
===========================================================================*/
SCM_EXPORT ScmObj
scm_p_symbolp(ScmObj obj)
{
DECLARE_FUNCTION("symbol?", procedure_fixed_1);
return MAKE_BOOL(SYMBOLP(obj));
}
/* _get-tvector-descriptor */
obj_t BGl__getzd2tvectorzd2descriptorz00zz__tvectorz00(obj_t BgL_envz00_1638,
obj_t BgL_idz00_1639)
{
AN_OBJECT;
{ /* Llib/tvector.scm 125 */
{ /* Llib/tvector.scm 126 */
obj_t BgL_auxz00_1726;
if (SYMBOLP(BgL_idz00_1639))
{ /* Llib/tvector.scm 126 */
BgL_auxz00_1726 = BgL_idz00_1639;
}
else
{
obj_t BgL_auxz00_1729;
BgL_auxz00_1729 =
BGl_typezd2errorzd2zz__errorz00(BGl_string2198z00zz__tvectorz00,
BINT(((long) 5056)), BGl_string2202z00zz__tvectorz00,
BGl_string2203z00zz__tvectorz00, BgL_idz00_1639);
FAILURE(BgL_auxz00_1729, BFALSE, BFALSE);
}
return get_tvector_descriptor(BgL_auxz00_1726);
}
}
}
char* whatis(Lisp_Object object) {
debug_print_buf[0] = '\0';
debug_print_buf[80] = '\0';
if (STRINGP(object)) {
snprintf(debug_print_buf, 80, "String %s", SSDATA(object));
return debug_print_buf;
} else if (INTEGERP(object)) {
int x = XINT(object);
snprintf(debug_print_buf, 80, "Number %d", x);
return debug_print_buf;
} else if (FLOATP(object)) {
struct Lisp_Float* floater = XFLOAT(object);
return "It's a float number!";
} else if (Qnil == object)
return "It's a lisp null";
else if (Qt == object)
return "It's a lisp 't'";
else if (SYMBOLP(object)) {
snprintf(debug_print_buf, 80, "Symbol named %s", SYMBOL_NAME(object));
return debug_print_buf;
} else if (CONSP(object))
return "It's a list!";
else if (MISCP(object))
return "It's a lisp misc!";
else if (VECTORLIKEP(object))
return "It's some kind of vector like thingie!";
else
return "I don't know what it is.";
}
static lref_t extend_env(lref_t actuals, lref_t formals, lref_t env)
{
if (SYMBOLP(formals))
return lcons(lcons(lcons(formals, NIL), lcons(actuals, NIL)), env);
else
return lcons(lcons(formals, actuals), env);
}
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;
}
/* Take the word before point (or Vabbrev_start_location, if non-nil),
and look it up in OBARRAY, and return the symbol (or zero). This
used to be the default method of searching, with the obvious
limitation that the abbrevs may consist only of word characters.
It is an order of magnitude faster than the proper abbrev_match(),
but then again, vi is an order of magnitude faster than Emacs.
This speed difference should be unnoticeable, though. I have tested
the degenerated cases of thousands of abbrevs being defined, and
abbrev_match() was still fast enough for normal operation. */
static Lisp_Symbol *abbrev_oblookup(struct buffer *buf, Lisp_Object obarray)
{
Bufpos wordstart, wordend;
Bufbyte *word, *p;
Bytecount idx;
Lisp_Object lookup;
CHECK_VECTOR(obarray);
if (!NILP(Vabbrev_start_location)) {
wordstart = get_buffer_pos_char(buf, Vabbrev_start_location,
GB_COERCE_RANGE);
Vabbrev_start_location = Qnil;
#if 0
/* Previously, abbrev-prefix-mark crockishly inserted a dash to
indicate the abbrev start point. It now uses an extent with
a begin glyph so there's no dash to remove. */
if (wordstart != BUF_ZV(buf)
&& BUF_FETCH_CHAR(buf, wordstart) == '-') {
buffer_delete_range(buf, wordstart, wordstart + 1, 0);
}
#endif
wordend = BUF_PT(buf);
} else {
Bufpos point = BUF_PT(buf);
wordstart = scan_words(buf, point, -1);
if (!wordstart)
return 0;
wordend = scan_words(buf, wordstart, 1);
if (!wordend)
return 0;
if (wordend > BUF_ZV(buf))
wordend = BUF_ZV(buf);
if (wordend > point)
wordend = point;
/* Unlike the original function, we allow expansion only after
the abbrev, not preceded by a number of spaces. This is
because of consistency with abbrev_match. */
if (wordend < point)
return 0;
}
if (wordend <= wordstart)
return 0;
p = word = (Bufbyte *) alloca(MAX_EMCHAR_LEN * (wordend - wordstart));
for (idx = wordstart; idx < wordend; idx++) {
Emchar c = BUF_FETCH_CHAR(buf, idx);
if (UPPERCASEP(buf, c))
c = DOWNCASE(buf, c);
p += set_charptr_emchar(p, c);
}
lookup = oblookup(obarray, word, p - word);
if (SYMBOLP(lookup) && !NILP(symbol_value(XSYMBOL(lookup))))
return XSYMBOL(lookup);
else
return NULL;
}
ScmObj
scm_symbol_value(ScmObj var, ScmObj env)
{
ScmRef ref;
ScmObj val;
DECLARE_INTERNAL_FUNCTION("scm_symbol_value");
SCM_ASSERT(IDENTIFIERP(var));
ref = scm_lookup_environment(var, env);
if (ref != SCM_INVALID_REF) {
/* Found in the environment. Since scm_s_body() may produce unbound
* variables as internal definitions, subsequent error check is
* required. */
val = DEREF(ref);
} else {
/* Fallback to top-level binding. */
#if SCM_USE_HYGIENIC_MACRO
if (FARSYMBOLP(var))
var = SCM_FARSYMBOL_SYM(var);
SCM_ASSERT(SYMBOLP(var));
#endif
val = SCM_SYMBOL_VCELL(var);
}
if (EQ(val, SCM_UNBOUND))
ERR_OBJ("unbound variable", var);
return val;
}
static void fast_read_loader_definition(lref_t reader, enum fasl_opcode_t opcode)
{
lref_t symbol_to_define;
fast_read(reader, &symbol_to_define, false);
if (!SYMBOLP(symbol_to_define))
vmerror_fast_read("Expected symbol for definition", reader, symbol_to_define);
lref_t definition;
fast_read(reader, &definition, false);
dscwritef(DF_SHOW_FAST_LOAD_FORMS,
(_T("; DEBUG: FASL defining ~s = ~s\n"), symbol_to_define, definition));
switch (opcode)
{
case FASL_OP_LOADER_DEFINEQ: /* quoted definition, do nothing. */
break;
case FASL_OP_LOADER_DEFINEA0:
definition = apply1(definition, 0, NULL);
break;
default:
panic("invalid opcode in fast_read_loader_definition");
break;
}
lidefine_global(symbol_to_define, definition);
}
void
VM::display_subr_profile()
{
scm_hashtable_t ht = m_heap->m_system_environment->variable;
hashtable_rec_t* ht_datum = ht->datum;
int n = ht_datum->capacity;
printf("%36s: %12s %12s %12s %14s\n", "subr", "push", "load", "apply", "total");
for (int i = 0; i < n; i++) {
if (SYMBOLP(ht_datum->elts[i])){
scm_symbol_t symbol = (scm_symbol_t)ht_datum->elts[i];
scm_gloc_t gloc = (scm_gloc_t)ht_datum->elts[n + i];
if (GLOCP(gloc)) {
scm_subr_t subr = (scm_subr_t)gloc->value;
if (SUBRP(subr)) {
if (subr->c_push + subr->c_load + subr->c_apply != 0) {
printf("%36s: %12llu %12llu %12llu %14llu\n",
symbol->name,
subr->c_push,
subr->c_load,
subr->c_apply,
subr->c_push + subr->c_load + subr->c_apply);
}
}
}
}
}
}
static void
xftfont_add_rendering_parameters (FcPattern *pat, Lisp_Object entity)
{
Lisp_Object tail;
int ival;
for (tail = AREF (entity, FONT_EXTRA_INDEX); CONSP (tail); tail = XCDR (tail))
{
Lisp_Object key = XCAR (XCAR (tail));
Lisp_Object val = XCDR (XCAR (tail));
if (EQ (key, QCantialias))
FcPatternAddBool (pat, FC_ANTIALIAS, NILP (val) ? FcFalse : FcTrue);
else if (EQ (key, QChinting))
FcPatternAddBool (pat, FC_HINTING, NILP (val) ? FcFalse : FcTrue);
else if (EQ (key, QCautohint))
FcPatternAddBool (pat, FC_AUTOHINT, NILP (val) ? FcFalse : FcTrue);
else if (EQ (key, QChintstyle))
{
if (INTEGERP (val))
FcPatternAddInteger (pat, FC_HINT_STYLE, XINT (val));
else if (SYMBOLP (val)
&& FcNameConstant (SDATA (SYMBOL_NAME (val)), &ival))
FcPatternAddInteger (pat, FC_HINT_STYLE, ival);
}
else if (EQ (key, QCrgba))
{
if (INTEGERP (val))
FcPatternAddInteger (pat, FC_RGBA, XINT (val));
else if (SYMBOLP (val)
&& FcNameConstant (SDATA (SYMBOL_NAME (val)), &ival))
FcPatternAddInteger (pat, FC_RGBA, ival);
}
else if (EQ (key, QClcdfilter))
{
if (INTEGERP (val))
FcPatternAddInteger (pat, FC_LCD_FILTER, ival = XINT (val));
else if (SYMBOLP (val)
&& FcNameConstant (SDATA (SYMBOL_NAME (val)), &ival))
FcPatternAddInteger (pat, FC_LCD_FILTER, ival);
}
#ifdef FC_EMBOLDEN
else if (EQ (key, QCembolden))
FcPatternAddBool (pat, FC_EMBOLDEN, NILP (val) ? FcFalse : FcTrue);
#endif
}
}
static Lisp_Object
x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type,
int local_request, struct mac_display_info *dpyinfo)
{
Lisp_Object local_value;
Lisp_Object handler_fn, value, type, check;
if (!x_selection_owner_p (selection_symbol, dpyinfo))
return Qnil;
local_value = LOCAL_SELECTION (selection_symbol, dpyinfo);
/* TIMESTAMP is a special case. */
if (EQ (target_type, QTIMESTAMP))
{
handler_fn = Qnil;
value = XCAR (XCDR (XCDR (local_value)));
}
else
{
/* Don't allow a quit within the converter.
When the user types C-g, he would be surprised
if by luck it came during a converter. */
ptrdiff_t count = SPECPDL_INDEX ();
specbind (Qinhibit_quit, Qt);
CHECK_SYMBOL (target_type);
handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist));
/* gcpro is not needed here since nothing but HANDLER_FN
is live, and that ought to be a symbol. */
if (!NILP (handler_fn))
value = call3 (handler_fn,
selection_symbol, (local_request ? Qnil : target_type),
XCAR (XCDR (local_value)));
else
value = Qnil;
unbind_to (count, Qnil);
}
if (local_request)
return value;
/* Make sure this value is of a type that we could transmit
to another application. */
type = target_type;
check = value;
if (CONSP (value)
&& SYMBOLP (XCAR (value)))
type = XCAR (value),
check = XCDR (value);
if (NILP (value) || mac_valid_selection_value_p (check, type))
return value;
signal_error ("Invalid data returned by selection-conversion function",
list2 (handler_fn, value));
}
object_t *symbol_name (object_t * lst)
{
DOC ("Return symbol name as string.");
REQ (lst, 1, c_sym ("symbol-name"));
if (!SYMBOLP (CAR (lst)))
THROW (wrong_type, UPREF (CAR (lst)));
return c_strs (xstrdup (SYMNAME (CAR (lst))));
}
object_t *symbolp (object_t * lst)
{
DOC ("Return t if object is a symbol.");
REQ (lst, 1, c_sym ("symbolp"));
if (SYMBOLP (CAR (lst)))
return T;
return NIL;
}
static void
show_arg(ScmObj arg, ScmObj env)
{
if (SYMBOLP(arg) && !UNBOUNDP(arg, env)) {
scm_format(scm_err, SCM_FMT_RAW_C, " - [~S]: ", SCM_SYMBOL_NAME(arg));
SCM_WRITE_SS(scm_err, scm_symbol_value(arg, env));
scm_port_newline(scm_err);
}
}
object_t *defmacro (object_t * lst)
{
DOC ("Define a new macro.");
if (!SYMBOLP (CAR (lst)) || !is_func_form (CDR (lst)))
THROW (c_sym ("bad-function-form"), UPREF (lst));
object_t *f = c_cons (macro, UPREF (CDR (lst)));
SET (CAR (lst), f);
return UPREF (CAR (lst));
}
object_t *lisp_value (object_t * lst)
{
DOC ("Get value stored in symbol.");
REQ (lst, 1, c_sym ("value"));
if (!SYMBOLP (CAR (lst)))
THROW (wrong_type, c_cons (c_sym ("value"), CAR (lst)));
return UPREF (GET (CAR (lst)));
}
/*---------------------------------------------------------------------*/
BGL_EXPORTED_DEF
obj_t
void_star_to_obj( void *cobj ) {
static obj_t id = BUNSPEC;
if( !SYMBOLP( id ) )
id = string_to_symbol( "VOID*" );
return cobj_to_foreign( id, cobj );
}
/* <anonymous:1945> */
obj_t BGl_zc3anonymousza31945ze3z83zz__modulez00(obj_t BgL_envz00_1657, obj_t BgL_xz00_1658)
{ AN_OBJECT;
{ /* Llib/module.scm 187 */
{
obj_t BgL_xz00_862;
{ /* Llib/module.scm 188 */
bool_t BgL_auxz00_2079;
BgL_xz00_862 = BgL_xz00_1658;
{ /* Llib/module.scm 188 */
bool_t BgL_testz00_2080;
if(
PAIRP(BgL_xz00_862))
{ /* Llib/module.scm 188 */
bool_t BgL_testz00_2083;
{ /* Llib/module.scm 188 */
obj_t BgL_auxz00_2084;
BgL_auxz00_2084 =
CAR(BgL_xz00_862);
BgL_testz00_2083 =
SYMBOLP(BgL_auxz00_2084); }
if(BgL_testz00_2083)
{ /* Llib/module.scm 188 */
BgL_testz00_2080 =
BGl_listzf3zf3zz__r4_pairs_and_lists_6_3z00(
CDR(BgL_xz00_862))
; } else
{ /* Llib/module.scm 188 */
BgL_testz00_2080 = ((bool_t)0)
; } } else
{ /* Llib/module.scm 188 */
BgL_testz00_2080 = ((bool_t)0)
; }
if(BgL_testz00_2080)
{ /* Llib/module.scm 188 */
BgL_auxz00_2079 = ((bool_t)1)
; } else
{ /* Llib/module.scm 188 */
{ /* Llib/module.scm 191 */
obj_t BgL_list1947z00_865;
{ /* Llib/module.scm 191 */
obj_t BgL_arg1948z00_866;obj_t BgL_arg1949z00_867;
BgL_arg1948z00_866 = BGl_symbol2360z00zz__modulez00;
{ /* Llib/module.scm 191 */
obj_t BgL_arg1951z00_869;
BgL_arg1951z00_869 =
MAKE_PAIR(BgL_xz00_862, BNIL);
BgL_arg1949z00_867 =
MAKE_PAIR(BGl_string2361z00zz__modulez00, BgL_arg1951z00_869); }
BgL_list1947z00_865 =
MAKE_PAIR(BgL_arg1948z00_866, BgL_arg1949z00_867); }
BGl_warningz00zz__errorz00(BgL_list1947z00_865); }
BgL_auxz00_2079 = ((bool_t)0); } }
return
BBOOL(BgL_auxz00_2079);} } }
}
/* _list->tvector */
obj_t BGl__listzd2ze3tvectorz31zz__tvectorz00(obj_t BgL_envz00_1647,
obj_t BgL_idz00_1648, obj_t BgL_lz00_1649)
{
AN_OBJECT;
{ /* Llib/tvector.scm 163 */
{ /* Llib/tvector.scm 164 */
obj_t BgL_auxz00_1838;
obj_t BgL_auxz00_1831;
{ /* Llib/tvector.scm 164 */
bool_t BgL_testz00_1839;
if (PAIRP(BgL_lz00_1649))
{ /* Llib/tvector.scm 164 */
BgL_testz00_1839 = ((bool_t) 1);
}
else
{ /* Llib/tvector.scm 164 */
BgL_testz00_1839 = NULLP(BgL_lz00_1649);
}
if (BgL_testz00_1839)
{ /* Llib/tvector.scm 164 */
BgL_auxz00_1838 = BgL_lz00_1649;
}
else
{
obj_t BgL_auxz00_1843;
BgL_auxz00_1843 =
BGl_typezd2errorzd2zz__errorz00(BGl_string2198z00zz__tvectorz00,
BINT(((long) 6767)), BGl_string2217z00zz__tvectorz00,
BGl_string2218z00zz__tvectorz00, BgL_lz00_1649);
FAILURE(BgL_auxz00_1843, BFALSE, BFALSE);
}}
if (SYMBOLP(BgL_idz00_1648))
{ /* Llib/tvector.scm 164 */
BgL_auxz00_1831 = BgL_idz00_1648;
}
else
{
obj_t BgL_auxz00_1834;
BgL_auxz00_1834 =
BGl_typezd2errorzd2zz__errorz00(BGl_string2198z00zz__tvectorz00,
BINT(((long) 6767)), BGl_string2217z00zz__tvectorz00,
BGl_string2203z00zz__tvectorz00, BgL_idz00_1648);
FAILURE(BgL_auxz00_1834, BFALSE, BFALSE);
}
return
BGl_listzd2ze3tvectorz31zz__tvectorz00(BgL_auxz00_1831,
BgL_auxz00_1838);
}
}
}
object_t *lisp_set (object_t * lst)
{
DOC ("Store object in symbol.");
REQ (lst, 2, c_sym ("set"));
if (!SYMBOLP (CAR (lst)))
THROW (wrong_type, c_cons (c_sym ("set"), CAR (lst)));
if (CONSTANTP (CAR (lst)))
THROW (c_sym ("setting-constant"), CAR (lst));
SET (CAR (lst), CAR (CDR (lst)));
return UPREF (CAR (CDR (lst)));
}
scm_port_t
make_bytevector_port(object_heap_t* heap, scm_obj_t name, int direction, scm_obj_t bytes, scm_obj_t transcoder)
{
assert(SYMBOLP(name));
scm_port_t obj = (scm_port_t)heap->allocate_collectible(sizeof(scm_port_rec_t));
memset(obj, 0, sizeof(scm_port_rec_t));
obj->hdr = scm_hdr_port;
obj->lock.init(true);
scoped_lock lock(obj->lock);
port_open_bytevector(obj, name, direction, bytes, transcoder);
return obj;
}
object_t *let (object_t * lst)
{
DOC ("Create variable bindings in a new scope, and eval "
"body in that scope.");
/* verify structure */
if (!LISTP (CAR (lst)))
THROW (c_sym ("bad-let-form"), UPREF (lst));
object_t *vlist = CAR (lst);
while (vlist != NIL)
{
object_t *p = CAR (vlist);
if (!LISTP (p))
THROW (c_sym ("bad-let-form"), UPREF (lst));
if (!SYMBOLP (CAR (p)))
THROW (c_sym ("bad-let-form"), UPREF (lst));
vlist = CDR (vlist);
}
object_t *p;
p = vlist = CAR (lst);
int cnt = 0;
while (p != NIL)
{
object_t *pair = CAR (p);
object_t *e = eval (CAR (CDR (pair)));
if (e == err_symbol)
{
/* Undo scoping */
p = vlist;
while (cnt)
{
sympop (CAR (CAR (p)));
p = CDR (p);
cnt--;
}
return err_symbol;
}
sympush (CAR (pair), e);
obj_destroy (e);
p = CDR (p);
cnt++;
}
object_t *r = eval_body (CDR (lst));
p = vlist;
while (p != NIL)
{
object_t *pair = CAR (p);
sympop (CAR (pair));
p = CDR (p);
}
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;
}
