From 0a193e032ba1ecf3f003e027e833dc9d274cb740 Mon Sep 17 00:00:00 2001 From: Kaleb Keithley Date: Fri, 14 Nov 2003 16:49:22 +0000 Subject: Initial revision --- lisp/struct.c | 371 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 371 insertions(+) create mode 100644 lisp/struct.c (limited to 'lisp/struct.c') diff --git a/lisp/struct.c b/lisp/struct.c new file mode 100644 index 0000000..0d2a768 --- /dev/null +++ b/lisp/struct.c @@ -0,0 +1,371 @@ +/* + * Copyright (c) 2001 by The XFree86 Project, Inc. + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF + * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + * + * Except as contained in this notice, the name of the XFree86 Project shall + * not be used in advertising or otherwise to promote the sale, use or other + * dealings in this Software without prior written authorization from the + * XFree86 Project. + * + * Author: Paulo César Pereira de Andrade + */ + +/* $XFree86: xc/programs/xedit/lisp/struct.c,v 1.22 2002/11/23 08:26:50 paulo Exp $ */ + +#include "struct.h" + +/* + * Prototypes + */ +static LispObj *LispStructAccessOrStore(LispBuiltin*, int); + +/* + * Initialization + */ +LispObj *Omake_struct, *Ostruct_access, *Ostruct_store, *Ostruct_type; + +Atom_id Smake_struct, Sstruct_access, Sstruct_store, Sstruct_type; + +/* + * Implementation + */ +LispObj * +Lisp_Defstruct(LispBuiltin *builtin) +/* + defstruct name &rest description + */ +{ + int intern; + LispAtom *atom; + int i, size, length, slength; + char *name, *strname, *sname; + LispObj *list, *cons, *object, *definition, *documentation; + + LispObj *oname, *description; + + description = ARGUMENT(1); + oname = ARGUMENT(0); + + CHECK_SYMBOL(oname); + + strname = ATOMID(oname); + length = strlen(strname); + + /* MAKE- */ + size = length + 6; + name = LispMalloc(size); + + sprintf(name, "MAKE-%s", strname); + atom = (object = ATOM(name))->data.atom; + + if (atom->a_builtin) + LispDestroy("%s: %s cannot be a structure name", + STRFUN(builtin), STROBJ(oname)); + + intern = !atom->ext; + + if (CONSP(description) && STRINGP(CAR(description))) { + documentation = CAR(description); + description = CDR(description); + } + else + documentation = NIL; + + /* get structure fields and default values */ + for (list = description; CONSP(list); list = CDR(list)) { + object = CAR(list); + + cons = list; + if (CONSP(object)) { + if ((CONSP(CDR(object)) && CDR(CDR(object)) != NIL) || + (!CONSP(CDR(object)) && CDR(object) != NIL)) + LispDestroy("%s: bad initialization %s", + STRFUN(builtin), STROBJ(object)); + cons = object; + object = CAR(object); + } + if (!SYMBOLP(object) || strcmp(ATOMID(object), "P") == 0) + /* p is invalid as a field name due to `type'-p */ + LispDestroy("%s: %s cannot be a field for %s", + STRFUN(builtin), STROBJ(object), ATOMID(oname)); + + if (!KEYWORDP(object)) + CAR(cons) = KEYWORD(ATOMID(object)); + + /* check for repeated field names */ + for (object = description; object != list; object = CDR(object)) { + LispObj *left = CAR(object), *right = CAR(list); + + if (CONSP(left)) + left = CAR(left); + if (CONSP(right)) + right = CAR(right); + + if (ATOMID(left) == ATOMID(right)) + LispDestroy("%s: only one slot named %s allowed", + STRFUN(builtin), STROBJ(left)); + } + } + + /* atom should not have been modified */ + definition = CONS(oname, description); + LispSetAtomStructProperty(atom, definition, STRUCT_CONSTRUCTOR); + if (!intern) + LispExportSymbol(object); + + atom = oname->data.atom; + if (atom->a_defstruct) + LispWarning("%s: structure %s is being redefined", + STRFUN(builtin), strname); + LispSetAtomStructProperty(atom, definition, STRUCT_NAME); + + sprintf(name, "%s-P", strname); + atom = (object = ATOM(name))->data.atom; + LispSetAtomStructProperty(atom, definition, STRUCT_CHECK); + if (!intern) + LispExportSymbol(object); + + for (i = 0, list = description; CONSP(list); i++, list = CDR(list)) { + if (CONSP(CAR(list))) + sname = ATOMID(CAR(CAR(list))); + else + sname = ATOMID(CAR(list)); + slength = strlen(sname); + if (length + slength + 2 > size) { + size = length + slength + 2; + name = LispRealloc(name, size); + } + sprintf(name, "%s-%s", strname, sname); + atom = (object = ATOM(name))->data.atom; + LispSetAtomStructProperty(atom, definition, i); + if (!intern) + LispExportSymbol(object); + } + + LispFree(name); + + if (documentation != NIL) + LispAddDocumentation(oname, documentation, LispDocStructure); + + return (oname); +} + +/* helper functions + * DONT explicitly call them. Non standard functions. + */ +LispObj * +Lisp_XeditMakeStruct(LispBuiltin *builtin) +/* + lisp::make-struct atom &rest init + */ +{ + int nfld, ncvt, length = lisp__data.protect.length; + LispAtom *atom = NULL; + + LispObj *definition, *object, *field, *fields, *value = NIL, *cons, *list; + LispObj *struc, *init; + + init = ARGUMENT(1); + struc = ARGUMENT(0); + + field = cons = NIL; + if (!POINTERP(struc) || + !(XSYMBOLP(struc) || XFUNCTIONP(struc)) || + (atom = struc->data.atom)->a_defstruct == 0 || + atom->property->structure.function != STRUCT_CONSTRUCTOR) + LispDestroy("%s: invalid constructor %s", + STRFUN(builtin), STROBJ(struc)); + definition = atom->property->structure.definition; + + ncvt = nfld = 0; + fields = NIL; + + /* check for errors in argument list */ + for (list = init, nfld = 0; CONSP(list); list = CDR(list)) { + CHECK_KEYWORD(CAR(list)); + if (!CONSP(CDR(list))) + LispDestroy("%s: values must be provided as pairs", + ATOMID(struc)); + nfld++; + list = CDR(list); + } + + /* create structure, CAR(definition) is structure name */ + for (list = CDR(definition); CONSP(list); list = CDR(list)) { + Atom_id id; + LispObj *defvalue = NIL; + + ++nfld; + field = CAR(list); + if (CONSP(field)) { + /* if default value provided */ + if (CONSP(CDR(field))) + defvalue = CAR(CDR(field)); + field = CAR(field); + } + id = ATOMID(field); + + for (object = init; CONSP(object); object = CDR(object)) { + /* field is a keyword, test above checked it */ + field = CAR(object); + if (id == ATOMID(field)) { + /* value provided */ + value = CAR(CDR(object)); + ncvt++; + break; + } + object = CDR(object); + } + + /* if no initialization given */ + if (!CONSP(object)) { + /* if default value in structure definition */ + if (defvalue != NIL) + value = EVAL(defvalue); + else + value = NIL; + } + + if (fields == NIL) { + fields = cons = CONS(value, NIL); + if (length + 1 >= lisp__data.protect.space) + LispMoreProtects(); + lisp__data.protect.objects[lisp__data.protect.length++] = fields; + } + else { + RPLACD(cons, CONS(value, NIL)); + cons = CDR(cons); + } + } + + /* if not enough arguments were converted, need to check because + * it is acceptable to set a field more than once, but in that case, + * only the first value will be used. */ + if (nfld > ncvt) { + for (list = init; CONSP(list); list = CDR(list)) { + Atom_id id = ATOMID(CAR(list)); + + for (object = CDR(definition); CONSP(object); + object = CDR(object)) { + field = CAR(object); + if (CONSP(field)) + field = CAR(field); + if (ATOMID(field) == id) + break; + } + if (!CONSP(object)) + LispDestroy("%s: %s is not a field for %s", + ATOMID(struc), STROBJ(CAR(list)), + ATOMID(CAR(definition))); + list = CDR(list); + } + } + + lisp__data.protect.length = length; + + return (STRUCT(fields, definition)); +} + +static LispObj * +LispStructAccessOrStore(LispBuiltin *builtin, int store) +/* + lisp::struct-access atom struct + lisp::struct-store atom struct value + */ +{ + long offset; + LispAtom *atom; + LispObj *definition, *list; + + LispObj *name, *struc, *value = NIL; + + if (store) + value = ARGUMENT(2); + struc = ARGUMENT(1); + name = ARGUMENT(0); + + if (!POINTERP(name) || + !(XSYMBOLP(name) || XFUNCTIONP(name)) || + (atom = name->data.atom)->a_defstruct == 0 || + (offset = atom->property->structure.function) < 0) { + LispDestroy("%s: invalid argument %s", + STRFUN(builtin), STROBJ(name)); + /*NOTREACHED*/ + offset = 0; + atom = NULL; + } + definition = atom->property->structure.definition; + + /* check if the object is of the required type */ + if (!STRUCTP(struc) || struc->data.struc.def != definition) + LispDestroy("%s: %s is not a %s", + ATOMID(name), STROBJ(struc), ATOMID(CAR(definition))); + + for (list = struc->data.struc.fields; offset; list = CDR(list), offset--) + ; + + return (store ? RPLACA(list, value) : CAR(list)); +} + +LispObj * +Lisp_XeditStructAccess(LispBuiltin *builtin) +/* + lisp::struct-access atom struct + */ +{ + return (LispStructAccessOrStore(builtin, 0)); +} + +LispObj * +Lisp_XeditStructStore(LispBuiltin *builtin) +/* + lisp::struct-store atom struct value + */ +{ + return (LispStructAccessOrStore(builtin, 1)); +} + +LispObj * +Lisp_XeditStructType(LispBuiltin *builtin) +/* + lisp::struct-type atom struct + */ +{ + LispAtom *atom = NULL; + + LispObj *definition, *struc, *name; + + struc = ARGUMENT(1); + name = ARGUMENT(0); + + if (!POINTERP(name) || + !(XSYMBOLP(name) || XFUNCTIONP(name)) || + (atom = name->data.atom)->a_defstruct == 0 || + (atom->property->structure.function != STRUCT_CHECK)) + LispDestroy("%s: invalid argument %s", + STRFUN(builtin), STROBJ(name)); + definition = atom->property->structure.definition; + + /* check if the object is of the required type */ + if (STRUCTP(struc) && struc->data.struc.def == definition) + return (T); + + return (NIL); +} -- cgit v1.2.3