/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/***********\
* *
* KL_STRUCT *
* BODY *
* *
\***********/
#include "EXTERN.h"
#include "klone.h"
#include "kl_number.h"
#include "kl_atom.h"
#include "kl_string.h"
#include "kl_list.h"
#include "kl_hash.h"
#include "kl_stream.h"
#include "INTERN.h"
#include "kl_struct.h"
#ifndef USE_STANDARD_MALLOC
extern char *KlMallocZoneBegin, *KlMallocZoneEnd;
#endif
/*****************************************************************************\
* KlStructClass *
\*****************************************************************************/
KlStructClass
KlStructClassMake(name, size, nslots)
char *name; /* name of class */
int size; /* sizeof of the whole struct */
int nslots; /* room for nslots slots */
{
KlStructClass obj = (KlStructClass) KlOMake(KlStructClassType);
KlHash slots = KlHashAlloc(nslots);
KlOZero(obj, sizeof(struct _KlStructClass));
KlIncRef(obj->name = KlIntern(name));
KlIncRef(obj->slots = slots);
slots->ref_counted = 0;
obj->size = size;
KlSend_setq(obj->name, obj); /* setqs name to structclass */
/* default system methods 0 by default*/
return obj;
}
void
KlDeclareStructClassSlot(structclass, name, func, offset, data)
KlStructClass structclass;
char *name;
KlMethod func;
int offset;
AnyPtr data;
{
KlCAccessor accessor = (KlCAccessor) Malloc(sizeof(struct _KlCAccessor));
accessor->offset = offset;
accessor->access = func;
accessor->data = data;
KlHashPut(structclass->slots, KlIntern(name), accessor);
}
KlO
KlStructClassFree(obj)
KlStructClass obj;
{
KlDecRef(obj->name);
KlDecRef(obj->slots);
Free(obj);
return (KlO) obj;
}
KlO
KlStructClassPrint(obj, stream)
KlStructClass obj;
KlStream stream;
{
KlSPrintf(stream, "{^ StructClass 0x%x ", obj);
KlSPrint(obj->name, stream);
KlSPuts("}", stream);
return (KlO) obj;
}
/* get on a structclass:
* 'name --> the name (atom)
* 'slots --> the list of slot names
* 'size --> ths size (in bytes, not used yet)
*/
KlO
KlStructClassGet(obj, key, def)
KlStructClass obj;
KlAtom key;
KlO def;
{
if (key == KlA_name) {
return (KlO) obj->name;
} else if (key == KlA_slots) {
KlList slotnameslist = KlListNMake(obj->slots->size);
KlListStoreDReset(slotnameslist);
KlHashFORBEGIN(obj->slots, cell) {
KlListStoreAdd(cell->key);
} KlHashFOREND;
return (KlO) slotnameslist;
} else if (key == KlA_size) {
return (KlO) KlNumberMake(obj->size);
} else {
return KlExecuteGetDefault(obj, key, def);
}
}
/* executing a structclass creates a struct. quotes args
*/
KlO
KlStructClassApply(structclass, list)
KlStructClass structclass;
KlList list;
{
int argc = list->size - 1;
KlO *argv = list->list + 1;
if (structclass->parse) {
return (KlO) CFAPPLY((structclass->parse), (structclass, argc, argv));
} else {
return (KlO) KlError(KlE_UNDEFINED_FUNCTION, structclass);
}
}
/*****************************************************************************\
* KlStruct *
\*****************************************************************************/
/* methods
*/
KlStruct
KlStructMake(structclass, Cobject)
KlStructClass structclass;
char * Cobject;
{
if (structclass->make) {
return (KlStruct) CFAPPLY((structclass->make), (Cobject));
} else {
KlStruct obj = (KlStruct) KlOMake(KlStructType);
KlIncRef(obj->structclass = structclass);
obj->ptr = Cobject;
return obj;
}
}
KlO
KlStructFree(obj)
KlStruct obj;
{
KlDecRef(obj->structclass);
if (obj->structclass->free) {
CFAPPLY((obj->structclass->free), (obj));
}
Free(obj);
return (KlO) obj;
}
KlO
KlStructGet(obj, key, def)
KlStruct obj;
KlO key;
KlO def;
{
KlCAccessor accessor;
if ((accessor =
(KlCAccessor) KlHashGet(obj->structclass->slots, key, 0))) {
return CFAPPLY((accessor->access), (obj->ptr + accessor->offset,
0,
accessor->data,
obj));
} else { /* slot not found */
if (obj->structclass->defget) {
return CFAPPLY((obj->structclass->defget), (obj, key, def));
} else {
return KlExecuteGetDefault(obj, key, def);
}
}
}
KlO
KlStructPut(obj, key, val)
KlStruct obj;
KlO key;
KlO val;
{
KlCAccessor accessor;
if ((accessor =
(KlCAccessor) KlHashGet(obj->structclass->slots, key, 0))) {
return CFAPPLY((accessor->access), (obj->ptr + accessor->offset,
val,
accessor->data,
obj));
} else { /* slot not found */
if (obj->structclass->defput) {
return CFAPPLY((obj->structclass->defput), (obj, key, val));
} else {
return KlError2(KlE_NO_ELEMENT, key, obj->structclass->name);
}
}
}
KlO
KlStructPrint(obj, stream)
KlStruct obj;
KlStream stream;
{
if (obj->structclass->print) {
CFAPPLY((obj->structclass->print), (obj, stream));
} else {
KlSPrintf(stream, "{^ Struct 0x%x ", obj);
KlSPrint(obj->structclass->name, stream);
KlSPuts("}", stream);
}
return (KlO) obj;
}
/* functions
*/
/* (struct-of struct [new-structclass])
* gets or sets (cast for unions) the class of the struct
* returns (or take as argument) a structclass object, of which you can get the
* name by (get structclass 'name)
* WARNING: of course, setting the structclass is *EXTREMELY* dangerous,
* and can lead to bus errors
*/
KlO
KlStructOf(argc, argv)
int argc;
KlStruct *argv;
{
KlNumberOfArgumentsCheck(argc < 1, argc);
KlMustBeStruct(argv[0], 0);
switch (argc) {
case 1: /* get the struct name */
return (KlO) argv[0]->structclass;
case 2: /* casts into another struct */
KlMustBeStructClass(argv[1], 1);
KlDecRef(argv[0]->structclass);
KlIncRef(argv[0]->structclass = (KlStructClass) argv[1]);
return (KlO) argv[1];
default:
return KlBadNumberOfArguments((char *) argc);
}
}
/*****************************************************************************\
* default class methods *
\*****************************************************************************/
KlO
KlStructClassFreeDefault(obj)
KlStruct obj;
{
free(obj->ptr);
}
KlO
KlStructClassPrintDefault(obj, stream)
KlStruct obj;
KlStream stream;
{
KlSPutc('{', stream);
if (KlPrintReadably) {
KlCAccessor accessor;
KlO value;
KlSPrint(obj->structclass->name, stream);
KlHashFORBEGIN(((KlHash) obj->structclass->slots), cell) {
KlSPutc(' ', stream);
KlSPrint(cell->key, stream); /* slot name */
KlSPutc(' ', stream);
accessor = (KlCAccessor) cell->object; /* get val */
value = CFAPPLY((accessor->access), (obj->ptr + accessor->offset,
0,
accessor->data,
obj));
KlSPrint(value, stream);
} KlHashFOREND;
} else {
KlSPrintf(stream, "^ Struct 0x%x ", obj);
KlSPrint(obj->structclass->name, stream);
}
KlSPuts("}", stream);
return (KlO) obj;
}
KlO
KlStructClassParseDefault(structclass, argc, argv)
KlStructClass structclass;
int argc;
KlO *argv;
{
KlStruct obj;
int i;
char *ptr = (char *) malloc(structclass->size);
obj = KlStructMake(structclass, ptr);
for (i = 0; i < argc-1; i+= 2) {
KlStructPut(obj, argv[i], argv[i+1]);
}
return (KlO) obj;
}
/*****************************************************************************\
* forcing class *
\*****************************************************************************/
/* routines to access to a C structure knowing whose Structclass it is.
* useful to avoid creating and de-referncing KlStructs on-the-fly ony to
* do get and puts
*/
KlO
KlStructGetWithClass(structclass, ptr, key, def)
KlStructClass structclass;
char * ptr;
KlO key;
KlO def;
{
KlCAccessor accessor;
if ((accessor =
(KlCAccessor) KlHashGet(structclass->slots, key, 0))) {
return CFAPPLY((accessor->access), (ptr + accessor->offset,
0,
accessor->data,
ptr));
} else {
/* slot not found, build a full KlStruct to call default routines */
KlStruct obj = KlStructMake(structclass, ptr);
if (structclass->defget) {
return CFAPPLY((structclass->defget), (obj, key, def));
} else {
return KlExecuteGetDefault(obj, key, def);
}
}
}
KlO
KlStructPutWithClass(structclass, ptr, key, val)
KlStructClass structclass;
char * ptr;
KlO key;
KlO val;
{
KlCAccessor accessor;
if ((accessor =
(KlCAccessor) KlHashGet(structclass->slots, key, 0))) {
return CFAPPLY((accessor->access), (ptr + accessor->offset,
val,
accessor->data,
ptr));
} else {
/* slot not found, build a full KlStruct to call default routines */
KlStruct obj = KlStructMake(structclass, ptr);
if (structclass->defput) {
return CFAPPLY((structclass->defput), (obj, key, val));
} else {
return KlError2(KlE_NO_ELEMENT, key, structclass->name);
}
}
}
/*****************************************************************************\
* KlStructArray *
\*****************************************************************************/
KlStructArray
KlStructArrayMake(array, elt_size, access, max_size, free, data)
char * array;
int elt_size;
KlMethod access;
int max_size;
KlMethod free; /* 0 = no freeing done */
AnyPtr data;
{
KlStructArray obj = (KlStructArray) KlOMake(KlStructArrayType);
obj->ptr = array;
obj->elt_size = elt_size;
obj->access = access;
obj->max_size = max_size;
obj->free = free;
obj->data = data;
return (KlStructArray) obj;
}
KlO
KlStructArrayClone(obj, ptr)
KlStructArray obj;
char * ptr;
{
KlStructArray newobj = (KlStructArray) KlOMake(KlStructArrayType);
bcopy(obj, newobj, sizeof(struct _KlStructArray));
KlZrtPut(newobj);
newobj->ptr = ptr;
return (KlO) newobj;
}
KlO
KlStructArrayFree(obj)
KlStructArray obj;
{
if (obj->free)
CFAPPLY((obj->free), (obj->ptr));
Free(obj);
return (KlO) obj;
}
KlO
KlStructArrayLength(obj)
KlStructArray obj;
{
return (KlO) KlNumberMake(obj->max_size);
}
KlO
KlStructArrayGet(obj, key, def)
KlStructArray obj;
KlNumber key;
KlO def;
{
KlMustBeNumber(key, 1);
if (key->number >= obj->max_size
|| key->number < 0) {
return KlExecuteGetDefault(obj, key, def);
}
return CFAPPLY((obj->access), (obj->ptr + (obj->elt_size * key->number),
0,
obj->data,
obj));
}
KlO
KlStructArrayPut(obj, key, value)
KlStructArray obj;
KlNumber key;
KlO value;
{
KlMustBeNumber(key, 1);
if (key->number >= obj->max_size
|| key->number < 0) {
return KlError2(KlE_NO_ELEMENT, key, obj);
}
return CFAPPLY((obj->access), (obj->ptr + (obj->elt_size * key->number),
value,
obj->data,
obj));
}
KlStructArrayDolist(obj, var, argc, argv)
KlStructArray obj;
KlO var;
int argc;
KlO *argv;
{
char *p = obj->ptr;
char *last = obj->max_size ? (p + (obj->elt_size * obj->max_size)) : p-1;
KlGCMark();
for ( ; p < last; p += obj->elt_size) {
KlSend_setq(var, CFAPPLY((obj->access), (p, 0, obj->data, obj)));
KlProgn(argc, argv);
KlGC();
}
}
/*****************************************************************************\
* standard C accessor functions *
\*****************************************************************************/
/*********************************************************** scalar numerics */
/* very simple.
* data field unused
*/
KlO
KlStructAccessorChar(address, value, data, obj)
unsigned char *address;
KlNumber value;
char *data;
KlStruct obj;
{
if (value) {
KlMustBeNumber(value, 2);
*address = value->number;
return (KlO) value;
} else {
return (KlO) KlNumberMake(*address);
}
}
KlO
KlStructAccessorShort(address, value, data, obj)
short *address;
KlNumber value;
char *data;
KlStruct obj;
{
if (value) {
KlMustBeNumber(value, 2);
*address = value->number;
return (KlO) value;
} else {
return (KlO) KlNumberMake(*address);
}
}
KlO
KlStructAccessorInt(address, value, data, obj)
int *address;
KlNumber value;
char *data;
KlStruct obj;
{
if (value) {
KlMustBeNumber(value, 2);
*address = value->number;
return (KlO) value;
} else {
return (KlO) KlNumberMake(*address);
}
}
KlO
KlStructAccessorLong(address, value, data, obj)
long *address;
KlNumber value;
char *data;
KlStruct obj;
{
if (value) {
KlMustBeNumber(value, 2);
*address = value->number;
return (KlO) value;
} else {
return (KlO) KlNumberMake(*address);
}
}
/****************************************************************** floating */
KlO
KlStructAccessorFloat(address, value, data, obj)
float *address;
KlReal value;
char *data;
KlStruct obj;
{
if (value) {
KlMustBeNumber(value, 2);
*address = KlNumberRealValue(value);
return (KlO) value;
} else {
return (KlO) KlRealMake(((double) (*address)));
}
}
KlO
KlStructAccessorDouble(address, value, data, obj)
double *address;
KlReal value;
char *data;
KlStruct obj;
{
if (value) {
KlMustBeNumber(value, 2);
*address = KlNumberRealValue(value);
return (KlO) value;
} else {
return (KlO) KlRealMake(*address);
}
}
/******************************************************************* pointer */
KlO
KlStructAccessorPtr(address, value, data, obj)
char **address;
KlNumber value;
char *data;
KlStruct obj;
{
if (value) {
KlMustBeNumber(value, 2);
*address = (char *) value->number;
return (KlO) value;
} else {
return (KlO) KlNumberMake(*address);
}
}
/**************************************************************** struct ptr */
/* for structs pointed to, the data field of the accessor is a structclass
* giving the type of the the sub-struct
*/
KlO
KlStructAccessorStructPtr(address, value, data, obj)
char **address;
KlO value;
KlStructClass data;
KlStruct obj;
{
if (value) {
return KlError0(KlE_BAD_ACCESS); /* we do not know what to do,
storage allocation problems */
} else {
return (KlO) KlStructMake(data, (*address));
}
}
/******************************************************* Useful: klone object */
KlO
KlStructAccessorKlone(adress, value, data, obj)
KlO *adress;
KlO value;
char *data;
KlStruct obj;
{
if (value) {
KlDecRefNonNull(*adress) ;
KlIncRef(*adress = value) ;
}
return *adress;
}
/********************************************************************* union */
/* what to provide as a default?
* best way now is just to do a casting by struct-of
*/
/******************************************************************** arrays */
/* for an array, the data field contains the array structure
* that has been created by
* KlStructArrayMake(0, <element-size>, <accessor-for-element>,
* <max-array-size>, 0, 0)
* this for field of type: struct foo { int field[N];};
*/
KlO
KlStructAccessorArray(address, value, data, obj)
char **address;
KlO value;
KlStructArray data;
KlStructArray obj;
{
if (value) {
return KlError0(KlE_BAD_ACCESS);
} else {
return KlStructArrayClone(data, address);
}
}
/* for a pointer to an array, the data field contains the array structure
* that has been created by
* KlStructArrayMake(0, <element-size>, <accessor-for-element>,
* <max-array-size>, 0, 0)
* this for field of type: struct foo { int *field};
*/
KlO
KlStructAccessorArrayPtr(address, value, data, obj)
char **address;
KlO value;
KlStructArray data;
KlStructArray obj;
{
if (value) {
return KlError0(KlE_BAD_ACCESS);
} else {
return KlStructArrayClone(data, *address);
}
}
/******************************************************************* strings */
/* string is not a primitive C type, but it is so common...
* WARNING: this do not do the put, as the problem of freeing the list is not
* solvable in the general case
* a special-purpose function should be made for each case...
*/
KlO
KlStructAccessorString(address, value, data, obj)
char **address;
KlString value;
char *data;
KlStruct obj;
{
if (value) {
return KlError0(KlE_BAD_ACCESS);
} else {
return (KlO) KlStringMake(*address);
}
}
/******************************************************************* scalars */
KlMethod
KlStructAccessorScalarOfAux(size)
int size;
{
if (size > sizeof(long)) {
return (KlMethod) (*KlFatalError)(12, size);
} else {
return KlStructAccessorScalar[size];
}
}
/*****************************************************************************\
* Klone interface *
\*****************************************************************************/
/* C objects:
* pointer 0
* char 1
* short 2
* int 3
* long 4
* float 5
* double 6
* string 7
*/
#define KlStructAccessorsSize 8
static KlMethod KlStructAccessors[KlStructAccessorsSize] = {
KlStructAccessorPtr,
KlStructAccessorChar,
KlStructAccessorShort,
KlStructAccessorInt,
KlStructAccessorLong,
KlStructAccessorFloat,
KlStructAccessorDouble,
KlStructAccessorString
};
/* (*:make-struct structclass address)
* creates a struct at some address to access an element of some type
*/
KlO
KlStructMakeKl(structclass, addr)
KlStructClass structclass;
KlNumber addr;
{
KlMustBeStructClass(structclass, 0);
KlMustBeNumber(addr, 1);
return (KlO) KlStructMake(structclass, addr->number);
}
/* (*:make-structclass name size)
*/
KlO
KlStructClassMakeKl(name, size)
KlString name;
KlNumber size;
{
KlMustBeString(name, 0);
KlMustBeNumber(size, 1);
return (KlO) KlStructClassMake(KlIntern(name->string), size->number, 0);
}
KlO
KlDeclareStructClassSlotKl(structclass, name, what, offset)
KlStructClass structclass;
KlString name;
KlNumber what;
KlNumber offset;
{
KlMethod access;
KlO data = 0;
KlMustBeStructClass(structclass, 0);
KlMustBeString(name, 1);
KlMustBeNumber(offset, 3);
if (KlIsANumber(what)) {
if (what->number >=0 && what->number < KlStructAccessorsSize) {
access = KlStructAccessors[what->number];
} else {
access = KlStructAccessors[0];
}
} else if (KlIsAStructClass(what)) {
access = KlStructAccessorStructPtr;
data = (KlO) what;
} else if (KlIsAList(what)) { /* list type, size */
access = KlStructAccessorArray;
/* data = (KlO) KlStructArrayMake(
... TODO ...
);
*/
}
}
/*****************************************************************************\
* peekpoke *
\*****************************************************************************/
/* obsolete calls */
/* (C:* address)
* returns object at address, otherwise nil
*/
KlO
KlStructCPeek(address)
KlNumber address;
{
KlO obj = (KlO) address->number;
if (KlObjectIsValid(obj)) {
return (KlO) obj;
} else {
return NIL;
}
}
/* (C:*-int address)
* returns value at address as integer
*/
KlO
KlStructCPeekAsInt(address)
KlNumber address;
{
KlO obj = (KlO) address->number;
return (KlO) KlNumberMake(*((Int *) obj));
}
/* (C:*-byte address)
* returns value at address as byte
*/
KlO
KlStructCPeekAsByte(address)
KlNumber address;
{
KlO obj = (KlO) address->number;
return (KlO) KlNumberMake(*((unsigned char *) obj));
}
/* (C:*= address value)
* pokes value at address
*/
KlO
KlStructCPoke(address, value)
KlNumber address;
KlNumber value;
{
Int *obj = (Int *) address->number;
*obj = value->number;
return (KlO) value;
}
/* (C:*=-byte address value)
* pokes value (byte) at address
*/
KlO
KlStructCPokeAsByte(address, value)
KlNumber address;
KlNumber value;
{
unsigned char *obj = (unsigned char *) address->number;
*obj = value->number;
return (KlO) value;
}
/* (C:& object)
* KlStructCAddressOf
* returns address of an object = "peek"
*/
KlO
KlStructCAddressOf(obj)
KlO obj;
{
return (KlO) KlNumberMake(obj);
}
#ifndef USE_STANDARD_MALLOC
/* (C:memory-used address)
* return number of bytes malloced
*/
KlO
KlMallocedSizeKl(adr)
KlNumber adr;
{
KlMustBeNumber(adr, 0);
return (KlO) KlNumberMake(KlMallocedSizeAndCheck(adr->number));
}
#endif /* !USE_STANDARD_MALLOC */
/*****************************************************************************\
* TYPE INIT *
\*****************************************************************************/
KlStructInit()
{
KlDeclareType(&KlStructType, "Struct", sizeof(struct _KlStruct));
KlDeclareMethod1(KlStructType, KlSelPrint, KlStructPrint);
KlDeclareMethod1(KlStructType, KlSelFree, KlStructFree);
KlDeclareMethod1(KlStructType, KlSelGet, KlStructGet);
KlDeclareMethod1(KlStructType, KlSelPut, KlStructPut);
KlDeclareType(&KlStructClassType, "StructClass",
sizeof(struct _KlStructClass));
KlDeclareMethod1(KlStructClassType, KlSelPrint, KlStructClassPrint);
KlDeclareMethod1(KlStructClassType, KlSelGet, KlStructClassGet);
KlDeclareMethod1(KlStructClassType, KlSelExecute, KlStructClassApply);
KlDeclareMethod1(KlStructClassType, KlSelApply, KlStructClassApply);
KlDeclareType(&KlStructArrayType, "StructArray",
sizeof(struct _KlStructArray));
KlDeclareMethod1(KlStructArrayType, KlSelGet, KlStructArrayGet);
KlDeclareMethod1(KlStructArrayType, KlSelPut, KlStructArrayPut);
KlDeclareMethod1(KlStructArrayType, KlSelFree, KlStructArrayFree);
KlDeclareMethod1(KlStructArrayType, KlSelLength, KlStructArrayLength);
KlDeclareMethod1(KlStructArrayType, KlSelDolist,
(KlMethod) KlStructArrayDolist);
/* initialize array of access to number by the value of sizeof */
bzero(KlStructAccessorScalar, sizeof(long) * sizeof(KlMethod));
KlStructAccessorScalar[sizeof(char)] = KlStructAccessorChar;
KlStructAccessorScalar[sizeof(short)] = KlStructAccessorShort;
KlStructAccessorScalar[sizeof(int)] = KlStructAccessorInt;
KlStructAccessorScalar[sizeof(long)] = KlStructAccessorLong;
/* functions */
KlDeclareSubr(KlStructOf, "struct-of", NARY);
/* old calls, should be emulated by something else */
KlConstantMake("C:ptr-size", KlNumberMake(KLSO));
KlDeclareSubr(KlStructCAddressOf, "C:&", 1);
KlDeclareSubr(KlStructCPeek, "C:*", 1);
KlDeclareSubr(KlStructCPeekAsInt, "C:*-int", 1);
KlDeclareSubr(KlStructCPeekAsByte, "C:*-byte", 1);
KlDeclareSubr(KlStructCPoke, "C:*=-int", 2);
KlDeclareSubr(KlStructCPokeAsByte, "C:*=-byte", 2);
#ifndef USE_STANDARD_MALLOC
KlDeclareSubr(KlMallocedSizeKl, "C:memory-used", 1);
#endif /* !USE_STANDARD_MALLOC */
KlDeclareSubr(KlStructMakeKl, "*:make-struct", 2);
}
syntax highlighted by Code2HTML, v. 0.9.1