This is structure.c in view mode; [Download] [Up]
/*
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
This file is part of GNU Common Lisp, herein referred to as GCL
GCL is free software; you can redistribute it and/or modify it under
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
GCL is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
License for more details.
You should have received a copy of the GNU Library General Public License
along with GCL; see the file COPYING. If not, write to the Free Software
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/*
structure.c
structure interface
*/
#include "include.h"
#define COERCE_DEF(x) if (type_of(x)==t_symbol) \
x=getf(x->s.s_plist,sSs_data,Cnil)
#define check_type_structure(x) \
if(type_of((x))!=t_structure) \
FEwrong_type_argument(sLstructure,(x))
bool
structure_subtypep(x, y)
object x, y;
{ if (x==y) return 1;
if (type_of(x)!= t_structure
|| type_of(y)!=t_structure)
FEerror("bad call to structure_subtypep",0);
{if (S_DATA(y)->included == Cnil) return 0;
while ((x=S_DATA(x)->includes) != Cnil)
{ if (x==y) return 1;}
return 0;
}}
static
bad_raw_type()
{ FEerror("Bad raw struct type",0);}
object
structure_ref(x, name, i)
object x, name;
int i;
{unsigned short *s_pos;
COERCE_DEF(name);
if (type_of(x) != t_structure ||
(type_of(name)!=t_structure) ||
!structure_subtypep(x->str.str_def, name))
FEwrong_type_argument((type_of(name)==t_structure ?
S_DATA(name)->name : name),
x);
s_pos = &SLOT_POS(x->str.str_def,0);
switch((SLOT_TYPE(x->str.str_def,i)))
{
case aet_object: return(STREF(object,x,s_pos[i]));
case aet_fix: return(make_fixnum((STREF(int,x,s_pos[i]))));
case aet_ch: return(code_char(STREF(char,x,s_pos[i])));
case aet_bit:
case aet_char: return(make_fixnum(STREF(char,x,s_pos[i])));
case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i])));
case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i])));
case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i])));
case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i])));
case aet_short: return(make_fixnum(STREF(short,x,s_pos[i])));
default:
bad_raw_type();
return 0;
}}
void
siLstructure_ref1()
{object x=vs_base[0];
int n=fix(vs_base[1]);
object def;
check_type_structure(x);
def=x->str.str_def;
if(n>= S_DATA(def)->length)
FEerror("Structure ref out of bounds",0);
vs_base[0]=structure_ref(x,x->str.str_def,n);
vs_top=vs_base+1;
}
object
structure_set(x, name, i, v)
object x, name, v;
int i;
{unsigned short *s_pos;
COERCE_DEF(name);
if (type_of(x) != t_structure ||
type_of(name) != t_structure ||
!structure_subtypep(x->str.str_def, name))
FEwrong_type_argument((type_of(name)==t_structure ?
S_DATA(name)->name : name)
, x);
#ifdef SGC
/* make sure the structure header is on a writable page */
if (x->d.m) FEerror("bad gc field",0); else x->d.m = 0;
#endif
s_pos= & SLOT_POS(x->str.str_def,0);
switch(SLOT_TYPE(x->str.str_def,i)){
case aet_object: STREF(object,x,s_pos[i])=v; break;
case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break;
case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break;
case aet_bit:
case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
default:
bad_raw_type();
}
return(v);
}
void
siLstructure_subtype_p()
{object x,y;
check_arg(2);
x=vs_base[0];
y=vs_base[1];
if (type_of(x)!=t_structure)
{vs_base[0]=Cnil; goto BOTTOM;}
x=x->str.str_def;
COERCE_DEF(y);
if (structure_subtypep(x,y)) vs_base[0]=Ct;
else vs_base[0]=Cnil;
BOTTOM:
vs_top=vs_base+1;
}
object
structure_to_list(x)
object x;
{
object endp_temp;
object *p, s;
struct s_data *def=S_DATA(x->str.str_def);
int i, n;
s = def->slot_descriptions;
vs_push(def->name);
vs_push(Cnil);
p = &vs_head;
for (i=0, n=def->length; !endp(s)&&i<n; s=s->c.c_cdr, i++) {
*p = make_cons(car(s->c.c_car), Cnil);
p = &((*p)->c.c_cdr);
*p = make_cons(structure_ref(x,x->str.str_def,i), Cnil);
p = &((*p)->c.c_cdr);
}
stack_cons();
return(vs_pop);
}
void
siLmake_structure()
{
object x,name,*base;
struct s_data *def;
int narg, i,size;
base=vs_base;
if ((narg = vs_top - base) == 0)
too_few_arguments();
{BEGIN_NO_INTERRUPT;
x = alloc_object(t_structure);
name=base[0];
COERCE_DEF(name);
if (type_of(name)!=t_structure ||
(def=S_DATA(name))->length != --narg)
FEerror("Bad make_structure args for type ~a",1,
base[0]);
x->str.str_def = name;
x->str.str_self = NULL;
size=S_DATA(name)->size;
base[0] = x;
x->str.str_self = (object *)
(def->staticp == Cnil ? alloc_relblock(size)
: alloc_contblock(size));
/* There may be holes in the structure.
We want them zero, so that equal can work better.
*/
if (S_DATA(name)->has_holes != Cnil)
bzero(x->str.str_self,size);
{unsigned char *s_type;
unsigned short *s_pos;
s_pos= (&SLOT_POS(x->str.str_def,0));
s_type = (&(SLOT_TYPE(x->str.str_def,0)));
base=base+1;
for (i = 0; i < narg; i++)
{object v=base[i];
switch(s_type[i]){
case aet_object: STREF(object,x,s_pos[i])=v; break;
case aet_fix: (STREF(int,x,s_pos[i]))=fix(v); break;
case aet_ch: STREF(char,x,s_pos[i])=char_code(v); break;
case aet_bit:
case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
default:
bad_raw_type();
}}
vs_top = base;
vs_base=base-1;
END_NO_INTERRUPT;}
}
}
void
siLcopy_structure()
{
object x, y;
struct s_data *def;
if (vs_top-vs_base < 1) too_few_arguments();
x = vs_base[0];
check_type_structure(x);
{BEGIN_NO_INTERRUPT;
vs_base[0] = y = alloc_object(t_structure);
def=S_DATA(y->str.str_def = x->str.str_def);
y->str.str_self = NULL;
y->str.str_self = (object *)alloc_relblock(def->size);
bcopy(x->str.str_self,y->str.str_self,def->size);
vs_top=vs_base+1;
END_NO_INTERRUPT;}
}
void
siLstructure_name()
{
check_arg(1);
check_type_structure(vs_base[0]);
vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name;
}
void
siLstructure_ref()
{
check_arg(3);
vs_base[0]=structure_ref(vs_base[0],vs_base[1],fix(vs_base[2]));
vs_top=vs_base+1;
}
void
siLstructure_set()
{
check_arg(4);
structure_set(vs_base[0],vs_base[1],fix(vs_base[2]),vs_base[3]);
vs_base = vs_top-1;
}
void
siLstructurep()
{
check_arg(1);
if (type_of(vs_base[0]) == t_structure)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
siLrplaca_nthcdr()
{
object endp_temp;
/*
Used in DEFSETF forms generated by DEFSTRUCT.
(si:rplaca-nthcdr x i v) is equivalent to
(progn (rplaca (nthcdr i x) v) v).
*/
int i;
object l;
check_arg(3);
if (type_of(vs_base[1]) != t_fixnum || fix(vs_base[1]) < 0)
FEerror("~S is not a non-negative fixnum.", 1, vs_base[1]);
if (type_of(vs_base[0]) != t_cons)
FEerror("~S is not a cons.", 1, vs_base[0]);
for (i = fix(vs_base[1]), l = vs_base[0]; i > 0; --i) {
l = l->c.c_cdr;
if (endp(l))
FEerror("The offset ~S is too big.", 1, vs_base[1]);
}
take_care(vs_base[2]);
l->c.c_car = vs_base[2];
vs_base = vs_base + 2;
}
siLlist_nth()
{
object endp_temp;
/*
Used in structure access functions generated by DEFSTRUCT.
si:list-nth is similar to nth except that
(si:list-nth i x) is error if the length of the list x is less than i.
*/
int i;
object l;
check_arg(2);
if (type_of(vs_base[0]) != t_fixnum || fix(vs_base[0]) < 0)
FEerror("~S is not a non-negative fixnum.", 1, vs_base[0]);
if (type_of(vs_base[1]) != t_cons)
FEerror("~S is not a cons.", 1, vs_base[1]);
for (i = fix(vs_base[0]), l = vs_base[1]; i > 0; --i) {
l = l->c.c_cdr;
if (endp(l))
FEerror("The offset ~S is too big.", 1, vs_base[0]);
}
vs_base[0] = l->c.c_car;
vs_pop;
}
void
siLmake_s_data_structure()
{object x,y,raw,*base;
int i;
check_arg(5);
x=vs_base[0];
base=vs_base;
raw=vs_base[1];
y=alloc_object(t_structure);
y->str.str_def=y;
y->str.str_self = (object *)( x->v.v_self);
S_DATA(y)->name =sSs_data;
S_DATA(y)->length=(raw->v.v_dim);
S_DATA(y)->raw =raw;
for(i=3; i<raw->v.v_dim; i++)
y->str.str_self[i]=Cnil;
S_DATA(y)->slot_position=base[2];
S_DATA(y)->slot_descriptions=base[3];
S_DATA(y)->staticp=base[4];
S_DATA(y)->size = (raw->v.v_dim)*sizeof(object);
vs_base[0]=y;
vs_top=vs_base+1;
}
void
siLstructure_def()
{check_arg(1);
check_type_structure(vs_base[0]);
vs_base[0]=vs_base[0]->str.str_def;
}
short aet_sizes [] = {
sizeof(object), /* aet_object t */
sizeof(char), /* aet_ch string-char */
sizeof(char), /* aet_bit bit */
sizeof(fixnum), /* aet_fix fixnum */
sizeof(float), /* aet_sf short-float */
sizeof(double), /* aet_lf long-float */
sizeof(char), /* aet_char signed char */
sizeof(char), /* aet_uchar unsigned char */
sizeof(short), /* aet_short signed short */
sizeof(short) /* aet_ushort unsigned short */
};
void
siLsize_of()
{ object x= vs_base[0];
int i;
i= aet_sizes[fSget_aelttype(x)];
vs_base[0]=make_fixnum(i);
}
void
siLaet_type()
{vs_base[0]=make_fixnum(fSget_aelttype(vs_base[0]));}
/* Return N such that something of type ARG can be aligned on
an address which is a multiple of N */
void
siLalignment()
{struct {double x; int y; double z;
float x1; int y1; float z1;}
joe;
joe.z=3.0;
if (vs_base[0]==sLlong_float)
{vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;}
else
if (vs_base[0]==sLshort_float)
{vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;}
else
{siLsize_of();}
}
DEF_ORDINARY("S-DATA",sSs_data,SI,"");
init_structure_function()
{
make_si_function("MAKE-STRUCTURE", siLmake_structure);
make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure);
make_si_function("COPY-STRUCTURE", siLcopy_structure);
make_si_function("STRUCTURE-NAME", siLstructure_name);
make_si_function("STRUCTURE-REF", siLstructure_ref);
make_si_function("STRUCTURE-DEF", siLstructure_def);
make_si_function("STRUCTURE-REF1", siLstructure_ref1);
make_si_function("STRUCTURE-SET", siLstructure_set);
make_si_function("STRUCTUREP", siLstructurep);
make_si_function("SIZE-OF", siLsize_of);
make_si_function("ALIGNMENT",siLalignment);
make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p);
make_si_function("RPLACA-NTHCDR", siLrplaca_nthcdr);
make_si_function("LIST-NTH", siLlist_nth);
make_si_function("AET-TYPE",siLaet_type);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.