/* objects - Additional object functions */
/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */
/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */
/* You may give out copies of this software; for conditions see the */
/* file COPYING included with this distribution. */
#include "xlisp.h"
#include "xlstat.h"
/* external variables */
extern LVAL xlenv, xlfenv, xlvalue;
extern LVAL s_true, sk_own, s_lambda, sk_print, s_stdout, s_tracelist,
s_self, s_documentation, s_instance_slots, s_proto_name,
sk_dispose, s_unbound, s_set_slot_hook, s_message_hook;
extern LVAL s_lambda, xlenv, xlfenv, xldenv;
/* external functions */
extern VOID doenter P3H(LVAL, int, FRAMEP);
extern VOID doexit P2H(LVAL, LVAL);
/* macros to handle tracing *//**** fix to allow NIL? */
#define trenter(sym,argc,argv) {if (!null(sym)) doenter(sym,argc,argv);}
#define trexit(sym,val) {if (!null(sym)) doexit(sym,val);}
/* forward declarations */
LOCAL VOID make_prototype P6H(LVAL, LVAL, LVAL, LVAL, LVAL, int);
/**** make sure this is cleared often enough */
/**** make sure this is right too */
/**** clear every so often on gc?? */
/**** think about optimal cache size */
/**** think about other implementations, hashing functions */
/**** check distribution of hashed indices */
#define CACHED_METHODS
#ifdef CACHED_METHODS
#define METHOD_CACHE_SIZE 199
LVAL s_method_cache;
LOCAL VOID clear_method_cache(V);
#endif /* CACHED_METHODS */
/***********************************************************************/
/** **/
/** CLASS Definitions **/
/** **/
/***********************************************************************/
/* instance variable numbers for the class 'CLASS' */
# define CVARS 2 /* list of class variable names */
# define CVALS 3 /* list of class variable values */
# define SUPERCLASS 4
# define IVARTOTAL 6
/***********************************************************************/
/** **/
/** Utility Functions **/
/** **/
/***********************************************************************/
/* Built in KIND-OF-P function */
LVAL xskind_of_p(V)
{
LVAL x, y;
x = xlgetarg();
y = xlgetarg();
xllastarg();
return((kind_of_p(x, y)) ? s_true : NIL);
}
LVAL xsobject_null_method(V) { return(NIL); }
/***********************************************************************/
/***********************************************************************/
/*** ***/
/*** New Object System ***/
/*** ***/
/***********************************************************************/
/***********************************************************************/
#define OBJECT_SIZE 4
#define getslots(x) getelement(x, 1)
#define getmethods(x) getelement(x, 2)
#define getparents(x) getelement(x, 3)
#define getpreclist(x) getelement(x, 4)
#define setslots(x, v) setelement(x, 1, v)
#define setmethods(w, v) setelement(x, 2, v)
#define setparents(x, v) setelement(x, 3, v)
#define setpreclist(x, v) setelement(x, 4, v)
static LVAL object_class, root_object;
static LVAL s_hardware_object_proto, s_proto;
int in_send = FALSE;
/***********************************************************************/
/** **/
/** Utility Functions **/
/** **/
/***********************************************************************/
/* get SELF for the current message; signal an error if not in a message */
static LVAL get_self(V)
{
#ifdef BYTECODE
LVAL p = getvalue(s_self);
#else
LVAL p = xlxgetvalue(s_self);
#endif /* BYTECODE */
if (! objectp(p)) xlerror("bad object", p);
return(p);
}
#ifdef DODO
/* simple form of EQUAL test */
static equal P2C(LVAL, x, LVAL, y)
{
if (x == y) return(TRUE);
else if (consp(x) && consp(y)
&& equal(car(x), car(y)) && equal(cdr(x), cdr(y)))
return(TRUE);
else return(FALSE);
}
#endif /* DODO */
/* check if x is a member of list; use simple equal test */
static int is_member P2C(LVAL, x, LVAL, list)
{
int result = FALSE;
for (; ! result && consp(list); list = cdr(list))
if (equal(x, car(list))) result = TRUE;
return(result);
}
/* check if list contains any duplicates */
static int has_duplicates P1C(LVAL, list)
{
int result = FALSE;
for (; ! result && consp(list); list = cdr(list))
if (is_member(car(list), cdr(list))) result = TRUE;
return(result);
}
/* destructively delete duplicates from list x */
static LVAL delete_duplicates P1C(LVAL, x)
{
LVAL last, result;
if (x == NIL) return(NIL);
else if (consp(x)) {
for (; consp(x) && is_member(car(x), cdr(x)); x = cdr(x)) ;
result = x;
for (last = x, x = cdr(x); consp(x); x = cdr(x))
if (is_member(car(x), cdr(x))) rplacd(last, cdr(x));
else last = x;
}
else return xlerror("not a list", x);
return(result);
}
/* destructively append y to x */
static LVAL append_list P2C(LVAL, x, LVAL, y)
{
LVAL result;
if (x == NIL) result = y;
else if (consp(x)) {
result = x;
for (; consp(cdr(x)); x = cdr(x)) ;
rplacd(x, y);
}
else return xlerror("not a list", x);
return(result);
}
/* destructively delete x from list */
static LVAL delete P2C(LVAL, x, LVAL, list)
{
return(xlcallsubr2(xdelete, x, list));
}
/***********************************************************************/
/** **/
/** Predicate and Stack Access Functions **/
/** **/
/***********************************************************************/
static LVAL check_object P1C(LVAL, object)
{
if (! objectp(object)) xlerror("bad object", object);
return(object);
}
int kind_of_p P2C(LVAL, x, LVAL, y)
{
if (! objectp(x) || ! objectp(y)) return(FALSE);
return(is_member(y, getpreclist(x)));
}
/***********************************************************************/
/** **/
/** Precedence List Functions **/
/** **/
/***********************************************************************/
/* find set of object and ancestors */
static LVAL find_SC P1C(LVAL, object)
{
return(copylist(getpreclist(check_object(object))));
}
/* find set of object and ancestors */
static LVAL find_S P1C(LVAL, object)
{
LVAL result, parents;
xlstkcheck(2);
xlprotect(object);
xlsave(result);
parents = getparents(object);
for (result = NIL; consp(parents); parents = cdr(parents))
result = append_list(find_SC(car(parents)), result);
result = cons(object, result);
result = delete_duplicates(result);
xlpopn(2);
return(result);
}
/* find local precedence ordering */
static LVAL find_RC P1C(LVAL, object)
{
LVAL list, next;
xlstkcheck(2);
xlprotect(object);
xlsave(list);
list = copylist(getparents(check_object(object)));
for (next = list; consp(next); next = cdr(next)) {
rplaca(next, cons(object, car(next)));
object = cdr(car(next));
}
xlpopn(2);
return(list);
}
/* find partial precedence ordering */
static LVAL find_R P1C(LVAL, S)
{
LVAL result;
xlstkcheck(2);
xlprotect(S);
xlsave(result);
for (result = NIL; consp(S); S = cdr(S))
result = append_list(result, find_RC(car(S)));
result = delete_duplicates(result);
xlpopn(2);
return(result);
}
/* check if x has a predecessor according to R */
static int has_predecessor P2C(LVAL, x, LVAL, R)
{
int result = FALSE;
for (; ! result && consp(R); R = cdr(R))
if (consp(car(R)) && x == cdr(car(R))) result = TRUE;
return(result);
}
/* find list of objects in S without predecessors, by R */
static LVAL find_no_predecessor_list P2C(LVAL, S, LVAL, R)
{
LVAL result;
xlstkcheck(3);
xlprotect(S);
xlprotect(R);
xlsave(result);
for (result = NIL; consp(S); S = cdr(S))
if (! has_predecessor(car(S), R))
result = cons(car(S), result);
xlpopn(3);
return(result);
}
/* find the position of child, if any, of x in P, the list found so far */
static int child_position P2C(LVAL, x, LVAL, P)
{
int count;
for (count = 0; consp(P); P = cdr(P), count++)
if (is_member(x, getparents(car(P)))) return(count);
return(-1);
}
/* find the next object in the precedence list from objects with no */
/* predecessor and current list. */
static LVAL next_object P2C(LVAL, no_preds, LVAL, P)
{
LVAL result;
int count, tcount;
if (! consp(no_preds)) result = NIL;
else if (! consp(cdr(no_preds))) result = car(no_preds);
else {
for (count = -1, result = NIL; consp(no_preds); no_preds = cdr(no_preds)) {
tcount = child_position(car(no_preds), P);
if (tcount > count) {
result = car(no_preds);
count = tcount;
}
}
}
return(result);
}
/* remove object x from S */
static LVAL trim_S P2C(LVAL, x, LVAL, S)
{
LVAL next;
while (consp(S) && x == car(S)) S = cdr(S);
for (next = S; consp(S) && consp(cdr(next));)
if (x == car(cdr(next))) rplacd(next, cdr(cdr(next)));
else next = cdr(next);
return(S);
}
/* remove all pairs containing x from R. x is assumed to have no */
/* predecessors, so only the first position is checked. */
static LVAL trim_R P2C(LVAL, x, LVAL, R)
{
LVAL next;
while (consp(R) && consp(car(R)) && x == car(car(R))) R = cdr(R);
for (next = R; consp(R) && consp(cdr(next));)
if (consp(car(next)) && x == car(car(cdr(next))))
rplacd(next, cdr(cdr(next)));
else next = cdr(next);
return(R);
}
/* calculat the object's precedence list */
static LVAL precedence_list P1C(LVAL, object)
{
LVAL R, S, P, no_preds, next;
check_object(object);
xlstkcheck(5);
xlprotect(object);
xlsave(R);
xlsave(S);
xlsave(P);
xlsave(no_preds);
S = find_S(object);
R = find_R(S);
P = NIL;
while (consp(S)) {
no_preds = find_no_predecessor_list(S, R);
next = next_object(no_preds, P);
if (next == NIL) xlfail("inconsistent precedence order");
else {
P = append_list(P, consa(next));
S = trim_S(next, S);
R = trim_R(next, R);
}
}
xlpopn(5);
return(P);
}
/***********************************************************************/
/** **/
/** Object Construction Functions **/
/** **/
/***********************************************************************/
static LVAL calculate_preclist P1C(LVAL, object)
{
LVAL result, parent, parents;
parents = getparents(check_object(object));
if (consp(parents)) {
xlstkcheck(2);
xlprotect(object);
xlsave(result);
if (! consp(cdr(parents))) {
parent = check_object(car(parents));
result = getpreclist(parent);
result = cons(object, result);
}
else result = precedence_list(object);
xlpopn(2);
}
else xlerror("bad parent list", parents);
return(result);
}
static VOID check_parents P1C(LVAL, parents)
{
if (parents == NIL) return;
else if (objectp(parents)) return;
else if (consp(parents)) {
for (; consp(parents); parents = cdr(parents))
check_object(car(parents));
}
else xlerror("bad parents", parents);
if (consp(parents) && has_duplicates(parents))
xlfail("parents may not contain duplicates");
}
static LVAL make_object P2C(LVAL, parents, LVAL, object)
{
check_parents(parents);
xlstkcheck(2);
xlprotect(parents);
xlprotect(object);
if (! objectp(object))
object = newobject(object_class, OBJECT_SIZE);
setpreclist(object, getpreclist(root_object));
if (parents == NIL) setparents(object, consa(root_object));
else if (objectp(parents)) setparents(object, consa(parents));
else setparents(object, parents);
setpreclist(object, calculate_preclist(object));
xlpopn(2);
return(object);
}
LVAL xsmake_object(V)
{
LVAL parents, object;
xlsave1(parents);
parents = makearglist(xlargc, xlargv);
object = make_object(parents, NIL);
xlpop();
return(object);
}
LVAL xsreparent_object(V)
{
LVAL parents, object;
object = xlgaobject();
#ifdef CACHED_METHODS
clear_method_cache();
#endif /* CACHED_METHODS */
xlsave1(parents);
if (kind_of_p(object, getvalue(s_hardware_object_proto)))
send_message(object, sk_dispose);
parents = makearglist(xlargc, xlargv);
object = make_object(parents, object);
xlpop();
return(object);
}
/***********************************************************************/
/** **/
/** Slot Access Functions **/
/** **/
/***********************************************************************/
#define make_slot_entry(x, y) cons((x), (y))
#define slot_entry_p(x) consp((x))
#define slot_entry_key(x) car((x))
#define slot_entry_value(x) cdr((x))
#define set_slot_entry_value(x, v) rplacd((x), (v))
static LVAL find_own_slot P2C(LVAL, x, LVAL, slot)
{
LVAL slots;
if (! objectp(x)) return(NIL);
for (slots = getslots(x); consp(slots); slots = cdr(slots))
if (slot_entry_p(car(slots)) && slot_entry_key(car(slots)) == slot)
return(car(slots));
return(NIL);
}
static LVAL find_slot P2C(LVAL, x, LVAL, slot)
{
LVAL slot_entry, preclist;
if (! objectp(x)) slot_entry = NIL;
else {
for (slot_entry = NIL, preclist = getpreclist(x);
slot_entry == NIL && consp(preclist);
preclist = cdr(preclist))
slot_entry = find_own_slot(car(preclist), slot);
}
return(slot_entry);
}
static VOID add_slot P3C(LVAL, x, LVAL, slot, LVAL, value)
{
LVAL slot_entry;
xlstkcheck(3);
xlprotect(x);
xlprotect(slot);
xlprotect(value);
check_object(x);
if (! symbolp(slot)) xlerror("not a symbol", slot);
slot_entry = find_own_slot(x, slot);
if (slot_entry != NIL) set_slot_entry_value(slot_entry, value);
else {
xlsave1(slot_entry);
slot_entry = make_slot_entry(slot, value);
setslots(x, cons(slot_entry, getslots(x)));
xlpop();
}
xlpopn(3);
}
static LVAL delete_slot P2C(LVAL, x, LVAL, slot)
{
LVAL entry, slots;
if (! objectp(x)) return(NIL);
else {
entry = find_own_slot(x, slot);
if (entry == NIL) return(NIL);
else {
slots = getslots(x);
setslots(x, delete(entry, slots));
return(s_true);
}
}
}
LVAL slot_value P2C(LVAL, x, LVAL, slot)
{
LVAL slot_entry;
check_object(x);
slot_entry = find_slot(x, slot);
if (slot_entry_p(slot_entry)) return(slot_entry_value(slot_entry));
else xlerror("no slot by this name", slot);
/* not reached */
return(NIL);
}
/*#define CONSTRAINTHOOKS*/
#ifdef CONSTRAINTHOOKS
LOCAL VOID check_hooks P3C(LVAL, object, LVAL, sym, LVAL, slot)
{
LVAL hook, hooksym, olddenv;
hooksym = (slot) ? s_set_slot_hook : s_message_hook;
hook = getvalue(hooksym);
if (hook != s_unbound && hook != NIL) {
/* rebind the hook function to nil */
olddenv = xldenv;
xldbind(hooksym,NIL);
xsfuncall2(hook, object, sym);
/* unbind the hook symbol */
xlunbind(olddenv);
}
}
#endif /* CONSTRAINTHOOKS */
LVAL set_slot_value P3C(LVAL, x, LVAL, slot, LVAL, value)
{
LVAL slot_entry;
check_object(x);
slot_entry = find_own_slot(x, slot);
if (slot_entry_p(slot_entry)) {
set_slot_entry_value(slot_entry, value);
#ifdef CONSTRAINTHOOKS
check_hooks(x, slot_entry_key(slot_entry), TRUE);
#endif /* CONSTRAINTHOOKS */
}
else {
if (find_slot(x, slot) != NIL)
xlerror("object does not own slot", slot);
else xlerror("no slot by this name", slot);
}
return(value);
}
LVAL xshas_slot(V)
{
LVAL x, slot, own, slot_entry;
x = xlgaobject();
slot = xlgasymbol();
if (! xlgetkeyarg(sk_own, &own)) own = NIL;
slot_entry = (own == NIL) ? find_slot(x, slot) : find_own_slot(x, slot);
return((slot_entry != NIL) ? s_true : NIL);
}
LVAL xsadd_slot(V)
{
LVAL x, slot, value;
x = xlgaobject();
slot = xlgasymbol();
value = (moreargs()) ? xlgetarg() : NIL;
xllastarg();
add_slot(x, slot, value);
return(value);
}
LVAL xsdelete_slot(V)
{
LVAL x, slot;
x = xlgaobject();
slot = xlgasymbol();
xllastarg();
return(delete_slot(x, slot));
}
LVAL xsslot_value(V)
{
LVAL x, slot, value = NULL;
int set = FALSE;
x = get_self(); /*xlgaobject();*/
slot = xlgasymbol();
if (moreargs()) {
set = TRUE;
value = xlgetarg();
}
xllastarg();
if (set) return(set_slot_value(x, slot, value));
else return(slot_value(x, slot));
}
/***********************************************************************/
/** **/
/** Method Access Functions **/
/** **/
/***********************************************************************/
#define make_method_entry(x, y) cons((x), (y))
#define method_entry_p(x) consp((x))
#define method_entry_key(x) car((x))
#define method_entry_method(x) cdr((x))
#define set_method_entry_method(x, v) rplacd((x), (v))
static LVAL find_own_method P2C(LVAL, x, LVAL, selector)
{
LVAL methods;
if (! objectp(x)) return(NIL);
for (methods = getmethods(x); consp(methods); methods = cdr(methods))
if (method_entry_p(car(methods))
&& method_entry_key(car(methods)) == selector)
return(car(methods));
return(NIL);
}
static LVAL find_method P2C(LVAL, x, LVAL, selector)
{
LVAL method_entry, preclist;
if (! objectp(x)) method_entry = NIL;
else {
for (method_entry = NIL, preclist = getpreclist(x);
method_entry == NIL && consp(preclist);
preclist = cdr(preclist))
method_entry = find_own_method(car(preclist), selector);
}
return(method_entry);
}
static VOID add_method P3C(LVAL, x, LVAL, selector, LVAL, method)
{
LVAL method_entry;
xlstkcheck(3);
xlprotect(x);
xlprotect(selector);
xlprotect(method);
#ifdef CACHED_METHODS
clear_method_cache();
#endif /* CACHED_METHODS */
check_object(x);
if (! symbolp(selector)) xlerror("not a symbol", selector);
switch (ntype(method)) {
case BCCLOSURE:
if (getbcname(getbcccode(method)) == NIL)
setbcname(getbcccode(method), selector);
break;
case CLOSURE:
if (getname(method) == NIL)
setname(method, selector);
break;
}
method_entry = find_own_method(x, selector);
if (method_entry != NIL)
set_method_entry_method(method_entry, method);
else {
xlsave1(method_entry);
method_entry = make_method_entry(selector, method);
setmethods(x, cons(method_entry, getmethods(x)));
xlpop();
}
xlpopn(3);
}
static LVAL delete_method P2C(LVAL, x, LVAL, selector)
{
LVAL entry, methods;
if (! objectp(x)) return(NIL);
else {
#ifdef CACHED_METHODS
clear_method_cache();
#endif /* CACHED_METHODS */
entry = find_own_method(x, selector);
if (entry == NIL) return(NIL);
else {
methods = getmethods(x);
setmethods(x, delete(entry, methods));
return(s_true);
}
}
}
static LVAL message_method P2C(LVAL, x, LVAL, selector)
{
LVAL method_entry;
check_object(x);
method_entry = find_method(x, selector);
if (method_entry_p(method_entry))
return(method_entry_method(method_entry));
else xlfail("no method for this selector");
/* not reached */
return(NIL);
}
#ifdef DODO
static LVAL set_message_method P3C(LVAL, x, LVAL, selector, LVAL, method)
{
LVAL method_entry;
check_object(x);
method_entry = find_method(x, selector);
if (method_entry_p(method_entry))
set_method_entry_method(method_entry, method);
else xlfail("no method for this selector");
return(method);
}
#endif /* DODO */
LVAL xshas_method(V)
{
LVAL x, selector, own, method_entry;
x = xlgaobject();
selector = xlgasymbol();
if (! xlgetkeyarg(sk_own, &own)) own = NIL;
method_entry = (own == NIL)
? find_method(x, selector) : find_own_method(x, selector);
return((method_entry != NIL) ? s_true : NIL);
}
LVAL xsadd_method(V)
{
LVAL x, selector, method;
x = xlgaobject();
selector = xlgasymbol();
method = (moreargs()) ? xlgetarg() : NIL;
xllastarg();
add_method(x, selector, method);
return(method);
}
LVAL xsdelete_method(V)
{
LVAL x, selector;
x = xlgaobject();
selector = xlgasymbol();
xllastarg();
return(delete_method(x, selector));
}
LVAL xsmessage_method(V)
{
LVAL x, selector;
x = xlgaobject();
selector = xlgasymbol();
xllastarg();
return(message_method(x, selector));
}
/***********************************************************************/
/** **/
/** Message Sending Functions **/
/** **/
/***********************************************************************/
static LVAL current_preclist = NIL;
static LVAL current_selector = NIL;
#ifdef CACHED_METHODS
static int cache_cleared = TRUE;
#define mhash(x, y) \
(((((unsigned long) CVPTR(x)) << 2) ^ ((unsigned long) CVPTR(y))) \
% METHOD_CACHE_SIZE)
/*
#define mhash(x, y) \
((((unsigned long) (x)) ^ (((unsigned long) y) >> 4)) % METHOD_CACHE_SIZE)
*/
LOCAL VOID clear_method_cache(V)
{
LVAL cache;
int i, n;
if (! cache_cleared) {
cache = getvalue(s_method_cache);
n = getsize(cache);
for (i = 0; i < n; i++) setelement(cache, i, NIL);
}
}
LOCAL LVAL find_cached_method P1C(LVAL, selector)
{
LVAL keylist, preclist, method_entry, cache, clist, centry;
int index;
/* skip leading entries in precedence list that have no methods */
for (preclist = current_preclist;
consp(preclist) && !consp(getmethods(car(preclist)));
preclist = cdr(preclist));
/* look for a cached method */
cache = getvalue(s_method_cache);
for (clist = getelement(cache, mhash(preclist, selector));
consp(clist);
clist = cdr(clist)) {
centry = car(clist);
if (preclist == car(centry)
&& selector == method_entry_key(car(cdr(centry)))) {
current_preclist = cdr(cdr(centry));
return(car(cdr(centry)));
}
}
/* no cached method found -- do it the hard way */
for (keylist = preclist; consp(preclist); preclist = cdr(preclist)) {
method_entry = find_own_method(car(preclist), selector);
if (! null(method_entry)) {
xlsave1(centry);
centry = cons(method_entry, preclist);
centry = cons(keylist,centry);
index = mhash(keylist, selector);
clist = cons(centry, getelement(cache, index));
setelement(cache, index, clist);
cache_cleared = FALSE;
current_preclist = preclist;
xlpop();
return(method_entry);
}
}
return(NIL);
}
#endif /* CACHED_METHODS */
/*#define SAFEMESS*/
#ifndef SAFEMESS
static LVAL callmethod P4C(LVAL, method, LVAL, object, int, argc, LVAL *, argv)
{
LVAL *newfp;
/* build a new argument stack frame */
if (xlsp + 4 + argc > xlargstktop) xlargstkoverflow();
newfp = xlsp;
*xlsp++ = cvfixnum((FIXTYPE)(newfp - xlfp));
*xlsp++ = method;
*xlsp++ = cvfixnum((FIXTYPE) (argc + 1));
/* copy the arguments */
*xlsp++ = object;
MEMCPY(xlsp, argv, sizeof(LVAL) * argc);
xlsp += argc;
/* establish the new stack frame */
xlfp = newfp;
return(xlapply(argc + 1));
}
#endif /* SAFEMESS */
static LVAL sendmsg P2C(LVAL, object, LVAL, selector)
{
LVAL method_entry, method = NULL, old_preclist, val, old_selector;
#ifndef CACHED_METHODS
LVAL preclist;
#endif /* */
#ifdef BYTECODE
LVAL olddenv;
#endif /* BYTECODE */
LVAL tracing = NIL;
#ifdef SAFEMESS
LVAL args;
#endif
old_selector = current_selector;
current_selector = selector;
#ifdef BYTECODE
/***** bind SELF dynamically -- should be different special variable */
olddenv = xldenv;
xldbind(s_self, object);
#endif /* BYTECODE */
/* look for the message in the precedence list */
old_preclist = current_preclist;
#ifdef CACHED_METHODS
method_entry = find_cached_method(selector);
#else
for (method_entry = NIL, preclist = current_preclist;
method_entry == NIL && consp(preclist);
preclist = cdr(preclist)) {
method_entry = find_own_method(car(preclist), selector);
current_preclist = preclist;
}
#endif /* CACHED_METHODS */
if (method_entry == NIL)
xlerror("no method for this message", selector);
/* else if (! method_entry_p(method_entry)) xlfail("bad method entry"); */
else method = method_entry_method(method_entry);
/* invoke the method */
if (getvalue(s_tracelist) && is_member(selector,getvalue(s_tracelist)))
tracing = selector;
trenter(tracing,xlargc,xlargv);
#ifdef SAFEMESS
xlsave1(args);
args = makearglist(xlargc, xlargv);
args = cons(object, args);
val = xlapply(pushargs(method, args));
xlpop();
#else
/*#define FASTMESS*/
#ifdef FASTMESS
{
LVAL *p, *oldfp, *oldsp, *oldargv;
int i, oldargc;
switch (xlargv - xlfp) {
case 3: /* call-next -- selector was not on the stack */
oldsp = xlsp;
oldfp = xlfp;
/* shift the arguments up by one */
if (xlsp >= xlargstktop) xlargstkoverflow();
for (p = xlargv + xlargc - 1; p >= xlargv; p--) p[1] = p[0];
xlsp++;
xlargc++;
/* install the object as first argument */
xlargv[0] = object;
xlfp[2] = cvfixnum((FIXTYPE) xlargc);
/* overwrite the function in the current call frame with the method */
xlfp[1] = method;
/* execute the call */
val = xlapply(xlargc);
xlsp = oldsp;
xlfp = oldfp;
break;
case 5:
oldsp = xlsp;
oldfp = xlfp;
oldargv = xlargv;
oldargc = xlargc;
/* decrement xlargv and shift the arguments down by one */
xlargv--;
for (i = 0, p = xlargv + 1; i < xlargc; i++, p++) xlargv[i] = *p;
xlargc++;
/* install the object as first argument */
xlargv--;
xlargv[0] = object;
xlfp[2] = cvfixnum((FIXTYPE) xlargc);
/* overwrite the function in the current call frame with the method */
xlfp[1] = method;
/* execute the call */
val = xlapply(xlargc);
xlsp = oldsp;
xlfp = oldfp;
xlargv = oldargv;
xlargc = oldargc;
break;
default: /* shouldn't happen */
stdputstr("default send \n");
val = callmethod(method, object, xlargc, xlargv);
}
}
#else
val = callmethod(method, object, xlargc, xlargv);
#endif /* FASTMESS */
#endif /* SAFEMESS */
trexit(tracing,val);
#ifdef BYTECODE
/*** unbind SELF */
xlunbind(olddenv);
#endif /* BYTECODE */
current_preclist = old_preclist;
current_selector = old_selector;
#ifdef CONSTRAINTHOOKS
check_hooks(object, method_entry_key(method_entry), FALSE);
#endif /* CONSTRAINTHOOKS */
return(val);
}
/* send message with arguments on the stack */
LVAL send_message_stk P2C(LVAL, object, LVAL, selector)
{
LVAL old_preclist, result;
int old_in_send = in_send;
old_preclist = current_preclist;
current_preclist = getpreclist(object);
in_send = TRUE;
result = sendmsg(object, selector);
current_preclist = old_preclist;
in_send = old_in_send;
return(result);
}
/* xmsendsuper - send a message to the superobject of an object */
LVAL xmsendsuper(V)
{
LVAL old_preclist, object, result;
int old_in_send = in_send;
object = get_self();
old_preclist = current_preclist;
if (! consp(current_preclist))
xlfail("no more objects in precedence list");
current_preclist = cdr(current_preclist);
in_send = TRUE;
result = sendmsg(object, xlgasymbol());
current_preclist = old_preclist;
in_send = old_in_send;
return(result);
}
/* xscall_next - call inherited version of current method */
LVAL xscall_next(V)
{
LVAL old_preclist, object, result;
int old_in_send = in_send;
object = get_self();
old_preclist = current_preclist;
if (! consp(current_preclist))
xlfail("no more objects in precedence list");
current_preclist = cdr(current_preclist);
in_send = TRUE;
result = sendmsg(object, current_selector);
current_preclist = old_preclist;
in_send = old_in_send;
return(result);
}
LVAL xmsend(V)
{
LVAL object, old_preclist, result;
int old_in_send = in_send;
object = xlgaobject();
if (! objectp(object)) return(NIL);
old_preclist = current_preclist;
current_preclist = getpreclist(object);
in_send = TRUE;
result = sendmsg(object, xlgasymbol());
current_preclist = old_preclist;
in_send = old_in_send;
return(result);
}
LVAL xscall_method(V)
{
LVAL object, self, old_preclist, result;
int old_in_send = in_send;
object = xlgaobject();
self = get_self();
old_preclist = current_preclist;
current_preclist = getpreclist(object);
in_send = TRUE;
result = sendmsg(self, xlgasymbol());
current_preclist = old_preclist;
in_send = old_in_send;
return(result);
}
VOID print_mobject P2C(LVAL, object, LVAL, stream)
{
send_message_1L(object, sk_print, stream);
}
LVAL xsshow_object(V)
{
LVAL x, fptr;
x = xlgaobject();
fptr = (moreargs() ? xlgetfile(TRUE) : getvalue(s_stdout));
xllastarg();
xlputstr(fptr, "Slots = "); xlprint(fptr, getslots(x), TRUE); xlterpri(fptr);
xlputstr(fptr, "Methods = "); xlprint(fptr, getmethods(x), TRUE); xlterpri(fptr);
xlputstr(fptr, "Parents = "); xlprint(fptr, getparents(x), TRUE); xlterpri(fptr);
xlputstr(fptr, "Precedence List = "); xlprint(fptr, getpreclist(x), TRUE); xlterpri(fptr);
return(NIL);
}
LVAL xsparents(V)
{
LVAL x;
x = xlgaobject();
xllastarg();
return(copylist(getparents(x)));
}
LVAL xsprecedence_list(V)
{
LVAL x;
x = xlgaobject();
xllastarg();
return(copylist(getpreclist(x)));
}
static LVAL get_cars P1C(LVAL, x)
{
LVAL next;
for (next = x; consp(next); next = cdr(next))
if (consp(car(next)))
rplaca(next, car(car(next)));
return(x);
}
LVAL xsobject_methods(V)
{
LVAL x;
x = xlgaobject();
xllastarg();
return(get_cars(copylist(getmethods(x))));
}
LVAL xsobject_slots(V)
{
LVAL x;
x = xlgaobject();
xllastarg();
return(get_cars(copylist(getslots(x))));
}
VOID statobsymbols(V)
{
object_class = getvalue(xlenter("OBJECT"));
root_object = getvalue(xlenter("*OBJECT*"));
s_hardware_object_proto = xlenter("HARDWARE-OBJECT-PROTO");
s_proto = xlenter("PROTO");
#ifdef CACHED_METHODS
s_method_cache = xlenter("*METHOD-CACHE*");
setvalue(s_method_cache, newvector(METHOD_CACHE_SIZE));
#endif /* CACHED_METHODS */
}
int lex_slot_value P3C(LVAL, object, LVAL, sym, LVAL *, pval)
{
int has = (find_slot(object, sym) != NIL);
if (has) *pval = slot_value(object, sym);
return(has);
}
VOID object_isnew P1C(LVAL, object)
{
LVAL slots, sym, ksym;
int i;
for (slots = getslots(object); consp(slots); slots = cdr(slots)) {
sym = car(car(slots));
if (! symbolp(sym)) xlerror("bad slot entry", car(slots));
#ifdef PACKAGES
ksym = xlintern(getstring(getpname(sym)), xlkeypack);
#else
sprintf(buf, ":%s", getstring(getpname(sym)));
ksym = xlenter(buf);
#endif /* PACKAGES */
/* go through the keys but don't modify or change xlarg[cv] */
for (i = 0; i + 1 < xlargc; i += 2) {
if (ksym == xlargv[i]) {
set_slot_value(object, sym, xlargv[i + 1]);
break;
}
}
}
}
LVAL xsobject_isnew(V)
{
LVAL object;
object = xlgaobject();
object_isnew(object);
return(object);
}
#define FIRST_METHOD_OFFSET 560
/* xsaddmsg - add a message to an object */
VOID xsaddmsg P2C(LVAL, object, char *, str)
{
LVAL fcn;
static offset = FIRST_METHOD_OFFSET;
xlsave1(fcn);
fcn = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
add_method(object, xlenter(str), fcn);
xlpop();
offset++;
}
VOID xsaddslot P2C(LVAL, object, char *, str)
{
add_slot(object, xlenter(str), NIL);
}
LVAL xsnewproto P2C(char *, str, LVAL, parents)
{
LVAL sym = xlenter(str), object;
xlsave1(object);
object = make_object(parents, NIL);
make_prototype(object, sym, NIL, NIL, NIL, TRUE);
xlpop();
return(object);
}
LVAL init_root_object(V)
{
LVAL s__object_ = xlenter("*OBJECT*");
object_class = getvalue(xlenter("OBJECT"));
root_object = newobject(object_class, OBJECT_SIZE);
setvalue(s__object_, root_object);
setpreclist(root_object, consa(root_object));
add_slot(root_object, s_instance_slots, NIL);
add_slot(root_object, s_proto_name, s__object_);
return(root_object);
}
static LVAL find_documentation P3C(LVAL, x, LVAL, sym, int, add)
{
LVAL doc;
if (! objectp(x)) return(NIL);
doc = find_own_slot(x, s_documentation);
if (doc == NIL && add) add_slot(x, s_documentation, NIL);
if (consp(doc)) doc = cdr(doc);
for (; consp(doc); doc = cdr(doc))
if (consp(car(doc)) && car(car(doc)) == sym) return(car(doc));
return(NIL);
}
/* x should be protected from gc before calling add_slot */
static VOID add_documentation P3C(LVAL, x, LVAL, sym, LVAL, value)
{
LVAL doc_entry;
xlstkcheck(3);
xlprotect(x);
xlprotect(sym);
xlprotect(value);
check_object(x);
if (! symbolp(sym)) xlerror("not a symbol", sym);
doc_entry = find_documentation(x, sym, TRUE);
if (doc_entry != NIL) rplacd(doc_entry, value);
else {
xlsave1(doc_entry);
doc_entry = cons(sym, value);
set_slot_value(x,
s_documentation,
cons(doc_entry, slot_value(x, s_documentation)));
xlpop();
}
xlpopn(3);
}
static LVAL get_documentation P2C(LVAL, x, LVAL, sym)
{
LVAL doc_entry;
check_object(x);
doc_entry = find_documentation(x, sym, FALSE);
return (consp(doc_entry) ? cdr(doc_entry) : NIL);
}
LVAL xsobject_documentation(V)
{
LVAL x, sym, val;
x = xlgaobject();
sym = xlgasymbol();
if (moreargs()) {
val = xlgetarg();
add_documentation(x, sym, val);
}
return(get_documentation(x, sym));
}
LVAL xsdefmeth(V)
{
LVAL object, sym, fargs, arglist, fcn;
xlstkcheck(3);
xlsave(fargs);
xlsave(arglist);
xlsave(fcn);
object = xleval(xlgetarg());
sym = xlgasymbol();
fargs = xlgalist();
arglist = makearglist(xlargc,xlargv);
if (! objectp(object)) xlerror("bad object", object);
/* install documentation string */
if (consp(arglist) && stringp(car(arglist)) && consp(cdr(arglist))) {
add_documentation(object, sym, car(arglist));
arglist = cdr(arglist);
}
/* create a new function definition */
fargs = cons(s_self, fargs);
fcn = xlclose(sym, s_lambda, fargs, arglist, xlenv, xlfenv);
/* add the method to the object */
add_method(object, sym, fcn);
/* restore the stack and return the symbol */
xlpopn(3);
return (sym);
}
/***********************************************************************/
/** **/
/** Prototype Construction Functions **/
/** **/
/***********************************************************************/
static LVAL instance_slots P2C(LVAL, x, LVAL, slots)
{
LVAL parents = getparents(x), result, sym, temp, tail;
xlsave1(result);
result = copylist(slots);
result = delete_duplicates(result);
for (tail = result; consp(tail) && consp(cdr(tail)); tail = cdr(tail));
for (; consp(parents); parents = cdr(parents)) {
for (temp = slot_value(car(parents), s_instance_slots);
consp(temp);
temp = cdr(temp)) {
sym = car(temp);
if (! is_member(sym, result)) {
if (result == NIL) {
result = consa(sym);
tail = result;
}
else {
rplacd(tail, consa(sym));
tail = cdr(tail);
}
}
}
}
xlpop();
return(result);
}
static LVAL get_initial_slot_value P2C(LVAL, object, LVAL, slot)
{
LVAL entry = find_slot(object, slot);
return((entry != NIL) ? cdr(entry) : NIL);
}
LOCAL VOID make_prototype P6C(LVAL, object, LVAL, name, LVAL, ivars, LVAL, cvars, LVAL, doc, int, set)
{
LVAL slot;
xlprot1(ivars);
ivars = instance_slots(object, ivars);
add_slot(object, s_instance_slots, ivars);
add_slot(object, s_proto_name, name);
for (; consp(ivars); ivars = cdr(ivars)) {
slot = car(ivars);
add_slot(object, slot, get_initial_slot_value(object, slot));
}
for (; consp(cvars); cvars = cdr(cvars))
add_slot(object, car(cvars), NIL);
if (doc != NIL && stringp(doc))
add_documentation(object, s_proto, doc);
if (set) setvalue(name, object);
xlpop();
}
VOID xsaddinstanceslot P2C(LVAL, x, char *, s)
{
LVAL sym = xlenter(s), ivars = slot_value(x, s_instance_slots);
if (! is_member(sym, ivars)) {
add_slot(x, sym, get_initial_slot_value(x, sym));
set_slot_value(x, s_instance_slots, cons(sym, ivars));
}
}
VOID xssetslotval P3C(LVAL, x, char *, s, LVAL, val)
{
set_slot_value(x, xlenter(s), val);
}
LVAL xsdefproto(V)
{
LVAL object, name, ivars, cvars, parents, doc;
xlstkcheck(5);
xlsave(object);
xlsave(ivars);
xlsave(cvars);
xlsave(parents);
xlsave(doc);
name = xlgasymbol();
ivars = (moreargs()) ? xleval(ivars = xlgetarg()) : NIL;
cvars = (moreargs()) ? xleval(cvars = xlgetarg()) : NIL;
parents = (moreargs()) ? xleval(parents = xlgetarg()) : NIL;
doc = (moreargs()) ? xleval(doc = xlgetarg()) : NIL;
if (! listp(parents)) parents = consa(parents);
object = make_object(parents, NIL);
make_prototype(object, name, ivars, cvars, doc, TRUE);
xlpopn(5);
return(name);
}
LVAL xsmakeproto(V)
{
LVAL object, name, ivars;
object = xlgaobject();
name = xlgasymbol();
ivars = (moreargs()) ? xlgetarg() : NIL;
make_prototype(object, name, ivars, NIL, NIL, FALSE);
return(object);
}
LVAL clanswer (V) { return(NIL); }
LVAL clmethod (V) { return(NIL); }
LVAL clisnew (V) { return(NIL); }
LVAL clnew (V) { return(NIL); }
VOID obsymbols (V) {}
LVAL obclass (V) { return(NIL); }
LVAL obshow (V) { return(NIL); }
LVAL obisnew (V) { return(NIL); }
LVAL xsend (V) { return(NIL); }
int xlobgetvalue P3C(LVAL, a, LVAL, b, LVAL *, c) { return(FALSE); }
int xlobsetvalue P3C(LVAL, a, LVAL, b, LVAL, c) { return(FALSE); }
LVAL xsendsuper (V) { return(NIL); }
VOID xloinit (V) {}
LVAL obprin1(V) { return(NIL); }
syntax highlighted by Code2HTML, v. 0.9.1