xref: /xsrc/external/mit/xedit/dist/lisp/struct.c

/*
 * 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.22tsi Exp $ */

#include "lisp/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;
    LispObj *list, *cons, *object, *definition, *documentation;

    LispObj *oname, *description;

    description = ARGUMENT(1);
    oname = ARGUMENT(0);

    CHECK_SYMBOL(oname);

    strname = ATOMID(oname)->value;
    length  = ATOMID(oname)->length;

	    /* 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)->value, "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)->value);

	if (!KEYWORDP(object))
	    CAR(cons) = KEYWORD(ATOMID(object)->value);

	/* 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)) {
	Atom_id id;

	if (CONSP(CAR(list)))
	    id = ATOMID(CAR(CAR(list)));
	else
	    id = ATOMID(CAR(list));
	slength = id->length;
	if (length + slength + 2 > size) {
	    size = length + slength + 2;
	    name = LispRealloc(name, size);
	}
	sprintf(name, "%s-%s", strname, id->value);
	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)->value);
	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)->value, STROBJ(CAR(list)),
			    ATOMID(CAR(definition))->value);
	    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)->value, STROBJ(struc), ATOMID(CAR(definition))->value);

    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);
}