sync code with last improvements from OpenBSD
This commit is contained in:
commit
88965415ff
GPG key ID:
F42C07F07E2E35B7
26235 changed files with 29195616 additions and 0 deletions
373
app/xedit/lisp/struct.c
Normal file
373
app/xedit/lisp/struct.c
Normal file
|
|
@ -0,0 +1,373 @@
|
|||
/*
|
||||
* 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);
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue