elk/lib/misc/record.c

175 lines
5.2 KiB
C

/* record.c
*
* $Id$
*
* Copyright 1990, 1991, 1992, 1993, 1994, 1995, Oliver Laumann, Berlin
* Copyright 2002, 2003 Sam Hocevar <sam@zoy.org>, Paris
*
* This software was derived from Elk 1.2, which was Copyright 1987, 1988,
* 1989, Nixdorf Computer AG and TELES GmbH, Berlin (Elk 1.2 has been written
* by Oliver Laumann for TELES Telematic Services, Berlin, in a joint project
* between TELES and Nixdorf Microprocessor Engineering, Berlin).
*
* Oliver Laumann, TELES GmbH, Nixdorf Computer AG and Sam Hocevar, as co-
* owners or individual owners of copyright in this software, grant to any
* person or company a worldwide, royalty free, license to
*
* i) copy this software,
* ii) prepare derivative works based on this software,
* iii) distribute copies of this software or derivative works,
* iv) perform this software, or
* v) display this software,
*
* provided that this notice is not removed and that neither Oliver Laumann
* nor Teles nor Nixdorf are deemed to have made any representations as to
* the suitability of this software for any purpose nor are held responsible
* for any defects of this software.
*
* THERE IS ABSOLUTELY NO WARRANTY FOR THIS SOFTWARE.
*/
#include "config.h"
#include "scheme.h"
#define RTD(x) ((struct S_Rtd *)POINTER(x))
#define RECORD(x) ((struct S_Record *)POINTER(x))
struct S_Rtd {
Object name;
Object fields;
};
struct S_Record {
Object rtd;
Object values;
};
int T_Rtd, T_Record;
static Object P_Rtdp (Object x) {
return TYPE(x) == T_Rtd ? True : False;
}
static Object P_Recordp (Object x) {
return TYPE(x) == T_Record ? True : False;
}
static Object P_Rtd_Name (Object x) {
Check_Type (x, T_Rtd);
return RTD(x)->name;
}
static Object P_Rtd_Field_Names (Object x) {
Check_Type (x, T_Rtd);
return RTD(x)->fields;
}
static Object P_Make_Record_Type (Object name, Object fields) {
Object s, ismem;
GC_Node2;
if (TYPE(name) == T_Symbol)
name = SYMBOL(name)->name;
else if (TYPE(name) != T_String)
Wrong_Type_Combination (name, "string or symbol");
Check_List (fields);
for (s = fields; !Nullp (s); s = Cdr (s)) {
Check_Type (Car (s), T_Symbol);
ismem = P_Memq (Car (s), Cdr (s));
if (Truep (ismem))
Primitive_Error ("duplicate field name");
}
GC_Link2 (name, fields);
s = Alloc_Object (sizeof (struct S_Rtd), T_Rtd, 0);
RTD(s)->name = name;
RTD(s)->fields = fields;
GC_Unlink;
return s;
}
static Object P_Record_Type (Object x) {
Check_Type (x, T_Record);
return RECORD(x)->rtd;
}
static Object P_Record_Values (Object x) {
Check_Type (x, T_Record);
return RECORD(x)->values;
}
static Object P_Make_Record (Object rtd, Object values) {
Object s;
GC_Node2;
Check_Type (rtd, T_Rtd);
Check_Type (values, T_Vector);
if (VECTOR(values)->size != Fast_Length (RTD(rtd)->fields))
Primitive_Error ("wrong number of fields for record type");
GC_Link2 (rtd, values);
s = Alloc_Object (sizeof (struct S_Record), T_Record, 0);
RECORD(s)->rtd = rtd;
RECORD(s)->values = values;
GC_Unlink;
return s;
}
static int Rtd_Eqv (Object a, Object b) {
return EQ(a,b);
}
#define Record_Eqv Rtd_Eqv
static int Rtd_Equal (Object a, Object b) {
return EQ(RTD(a)->name, RTD(b)->name) &&
Equal (RTD(a)->fields, RTD(b)->fields);
}
static int Record_Equal (Object a, Object b) {
return EQ(RECORD(a)->rtd, RECORD(b)->rtd) &&
Equal (RECORD(a)->values, RECORD(b)->values);
}
static int Rtd_Print (Object x, Object port, int raw, int depth, int length) {
struct S_String *s = STRING(RTD(x)->name);
Printf (port, "#[%.*s-record-type %lu]", s->size, s->data, POINTER(x));
return 0;
}
static int Record_Print (Object x, Object port,
int raw, int depth, int length) {
struct S_String *s = STRING(RTD(RECORD(x)->rtd)->name);
Printf (port, "#[%.*s-record-type %lu]", s->size, s->data, POINTER(x));
return 0;
}
static int Rtd_Visit (register Object *sp, register int (*f)()) {
(*f)(&RTD(*sp)->name);
(*f)(&RTD(*sp)->fields);
return 0;
}
static int Record_Visit (register Object *sp, register int (*f)()) {
(*f)(&RECORD(*sp)->rtd);
(*f)(&RECORD(*sp)->values);
return 0;
}
#define Def_Prim Define_Primitive
void elk_init_lib_record () {
T_Rtd = Define_Type (0, "record-type", NOFUNC, sizeof (struct S_Rtd),
Rtd_Eqv, Rtd_Equal, Rtd_Print, Rtd_Visit);
Def_Prim (P_Rtdp, "record-type?", 1, 1, EVAL);
Def_Prim (P_Rtd_Name, "record-type-name", 1, 1, EVAL);
Def_Prim (P_Rtd_Field_Names, "record-type-field-names", 1, 1, EVAL);
Def_Prim (P_Make_Record_Type, "make-record-type", 2, 2, EVAL);
T_Record = Define_Type (0, "record", NOFUNC, sizeof (struct S_Record),
Record_Eqv, Record_Equal, Record_Print, Record_Visit);
Def_Prim (P_Recordp, "record?", 1, 1, EVAL);
Def_Prim (P_Record_Type, "record-type-descriptor", 1, 1, EVAL);
Def_Prim (P_Record_Values, "record-values", 1, 1, EVAL);
Def_Prim (P_Make_Record, "make-record", 2, 2, EVAL);
P_Provide (Intern ("record.la"));
}