summaryrefslogtreecommitdiff
path: root/lisp/struct.c
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/struct.c')
-rw-r--r--lisp/struct.c371
1 files changed, 371 insertions, 0 deletions
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);
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-25 14:12:09 +0000