23 |
#include <string.h> |
#include <string.h> |
24 |
#include "include.h" |
#include "include.h" |
25 |
|
|
26 |
|
static void |
27 |
|
displace(object, object, int); |
28 |
|
|
29 |
|
static enum aelttype |
30 |
|
Iarray_element_type(object); |
31 |
|
|
32 |
|
|
33 |
/* #define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM */ |
/* #define ARRAY_DIMENSION_LIMIT MOST_POSITIVE_FIXNUM */ |
34 |
|
|
63 |
#define N_FIXNUM_ARGS 6 |
#define N_FIXNUM_ARGS 6 |
64 |
|
|
65 |
DEFUNO_NEW("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT, |
DEFUNO_NEW("AREF", object, fLaref, LISP, 1, ARRAY_RANK_LIMIT, |
66 |
NONE, OO, II, II, II,Laref,(object x, int i, ...),"") |
NONE, OO, II, II, II,void,Laref,(object x, int i, ...),"") |
67 |
{ int n = VFUN_NARGS; |
{ int n = VFUN_NARGS; |
68 |
int i1; |
int i1; |
69 |
va_list ap; |
va_list ap; |
106 |
|
|
107 |
} |
} |
108 |
|
|
109 |
void |
static void |
110 |
fScheck_bounds_bounds(object x, int i) |
fScheck_bounds_bounds(object x, int i) |
111 |
{ |
{ |
112 |
switch (type_of(x)) { |
switch (type_of(x)) { |
121 |
} |
} |
122 |
} |
} |
123 |
|
|
124 |
DEFUN_NEW("SVREF", object, fLsvref, LISP, 2, 2, |
DEFUNO_NEW("SVREF", object, fLsvref, LISP, 2, 2, |
125 |
ONE_VAL, OO, IO, OO,OO,(object x, unsigned int i), |
ONE_VAL, OO, IO, OO,OO,void,Lsvref,(object x, unsigned int i), |
126 |
"For array X and index I it returns (aref x i) ") |
"For array X and index I it returns (aref x i) ") |
127 |
{ |
{ |
128 |
if (type_of(x)==t_vector |
if (type_of(x)==t_vector |
134 |
return(Cnil); |
return(Cnil); |
135 |
} |
} |
136 |
|
|
137 |
DEFUNO_NEW("ROW-MAJOR-AREF", object, fLrow_major_aref, LISP, 2, 2, |
DEFUN_NEW("ROW-MAJOR-AREF", object, fLrow_major_aref, LISP, 2, 2, |
138 |
NONE, OO, IO, OO,OO,Lrow_major_aref,(object x, int i), |
NONE, OO, IO, OO,OO,(object x, int i), |
139 |
"For array X and index I it returns (aref x i) as if x were \ |
"For array X and index I it returns (aref x i) as if x were \ |
140 |
1 dimensional, even though its rank may be bigger than 1") |
1 dimensional, even though its rank may be bigger than 1") |
141 |
{ |
{ |
259 |
} |
} |
260 |
|
|
261 |
DEFUNO_NEW("ASET", object, fSaset, SI, 1, ARG_LIMIT, NONE, OO, |
DEFUNO_NEW("ASET", object, fSaset, SI, 1, ARG_LIMIT, NONE, OO, |
262 |
OO, OO, OO,siLaset,(object x,object ii,object y, ...),"") |
OO, OO, OO,void,siLaset,(object x,object ii,object y, ...),"") |
263 |
{ int i1; |
{ int i1; |
264 |
int n = VFUN_NARGS; |
int n = VFUN_NARGS; |
265 |
int i; |
int i; |
315 |
} |
} |
316 |
|
|
317 |
DEFUNO_NEW("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO, |
DEFUNO_NEW("SVSET", object, fSsvset, SI, 3, 3, NONE, OO, IO, OO, |
318 |
OO,siLsvset,(object x,int i,object val),"") |
OO,void,siLsvset,(object x,int i,object val),"") |
319 |
{ if (TYPE_OF(x) != t_vector |
{ if (TYPE_OF(x) != t_vector |
320 |
|| DISPLACED_TO(x) != Cnil) |
|| DISPLACED_TO(x) != Cnil) |
321 |
Wrong_type_error("simple array",0); |
Wrong_type_error("simple array",0); |
333 |
*/ |
*/ |
334 |
|
|
335 |
|
|
336 |
DEFUNO_NEW("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI, |
DEFUN_NEW("MAKE-VECTOR1",object,fSmake_vector1,SI,3,8,NONE,OI, |
337 |
IO,OO,OO,LSmake_vector1,(int n,int elt_type,object staticp,...),"") |
IO,OO,OO,(int n,int elt_type,object staticp,...),"") |
338 |
|
|
339 |
{ |
{ |
340 |
int displaced_index_offset=0; |
int displaced_index_offset=0; |
467 |
static 6 &optional initial-element) |
static 6 &optional initial-element) |
468 |
*/ |
*/ |
469 |
DEFUNO_NEW("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE, |
DEFUNO_NEW("MAKE-VECTOR",object,fSmake_vector,SI,7,8,NONE, |
470 |
OO,OO,OO,OO,siLmake_vector,(object x0,object x1,object x2,object x3,object x4,object x5,object x6,...),"") |
OO,OO,OO,OO,void,siLmake_vector,(object x0,object x1,object x2,object x3,object x4,object x5,object x6,...),"") |
471 |
{int narg=VFUN_NARGS; |
{int narg=VFUN_NARGS; |
472 |
object initial_elt; |
object initial_elt; |
473 |
va_list ap; |
va_list ap; |
539 |
*/ |
*/ |
540 |
|
|
541 |
/* DEFUNO_NEW("ARRAY-DISPLACEMENT1",object,fSarray_displacement,SI,1,1, */ |
/* DEFUNO_NEW("ARRAY-DISPLACEMENT1",object,fSarray_displacement,SI,1,1, */ |
542 |
/* NONE,OO,OO,OO,OO,siLarray_displacement,"") */ |
/* NONE,OO,OO,OO,OO,void,siLarray_displacement,"") */ |
543 |
/* (object array) { */ |
/* (object array) { */ |
544 |
|
|
545 |
/* object a; */ |
/* object a; */ |
562 |
|
|
563 |
/* } */ |
/* } */ |
564 |
|
|
565 |
void |
static void |
566 |
Larray_displacement(void) { |
Larray_displacement(void) { |
567 |
|
|
568 |
object array,a; |
object array,a; |
617 |
(setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) |
(setq z2 (make-array 2 :displaced-to y)) ;; z2->displaced= (y) |
618 |
*/ |
*/ |
619 |
|
|
620 |
void |
static void |
621 |
displace(object from_array, object dest_array, int offset) |
displace(object from_array, object dest_array, int offset) |
622 |
{ |
{ |
623 |
enum aelttype typ; |
enum aelttype typ; |
657 |
|
|
658 |
|
|
659 |
|
|
660 |
enum aelttype |
static enum aelttype |
661 |
Iarray_element_type(object x) |
Iarray_element_type(object x) |
662 |
{enum aelttype t=aet_last; |
{enum aelttype t=aet_last; |
663 |
switch(TYPE_OF(x)) |
switch(TYPE_OF(x)) |
683 |
at the DISPLACED_INDEX_OFFSET |
at the DISPLACED_INDEX_OFFSET |
684 |
*/ |
*/ |
685 |
|
|
686 |
void |
/* static void */ |
687 |
Idisplace_array(object from, object to, int displaced_index_offset) |
/* Idisplace_array(object from, object to, int displaced_index_offset) */ |
688 |
{ |
/* { */ |
689 |
enum aelttype t1,t2; |
/* enum aelttype t1,t2; */ |
690 |
t1 = Iarray_element_type(from); |
/* t1 = Iarray_element_type(from); */ |
691 |
t2 = Iarray_element_type(to); |
/* t2 = Iarray_element_type(to); */ |
692 |
if (t1 != t2) |
/* if (t1 != t2) */ |
693 |
FEerror("Attempt to displace arrays of one type to arrays of another type",0); |
/* FEerror("Attempt to displace arrays of one type to arrays of another type",0); */ |
694 |
if (to->a.a_dim > from->a.a_dim - displaced_index_offset) |
/* if (to->a.a_dim > from->a.a_dim - displaced_index_offset) */ |
695 |
FEerror("To array not large enough for displacement",0); |
/* FEerror("To array not large enough for displacement",0); */ |
696 |
{BEGIN_NO_INTERRUPT; |
/* {BEGIN_NO_INTERRUPT; */ |
697 |
from->a.a_displaced = make_cons(to,Cnil); |
/* from->a.a_displaced = make_cons(to,Cnil); */ |
698 |
if (to->a.a_displaced == Cnil) |
/* if (to->a.a_displaced == Cnil) */ |
699 |
to->a.a_displaced = make_cons(Cnil,Cnil); |
/* to->a.a_displaced = make_cons(Cnil,Cnil); */ |
700 |
DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to)); |
/* DISPLACED_FROM(to) = make_cons(from,DISPLACED_FROM(to)); */ |
701 |
|
|
702 |
if (t1 == aet_bit) { |
/* if (t1 == aet_bit) { */ |
703 |
displaced_index_offset += BV_OFFSET(to); |
/* displaced_index_offset += BV_OFFSET(to); */ |
704 |
from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS; |
/* from->bv.bv_self = to->bv.bv_self + displaced_index_offset/BV_BITS; */ |
705 |
SET_BV_OFFSET(from, displaced_index_offset%BV_BITS); |
/* SET_BV_OFFSET(from, displaced_index_offset%BV_BITS); */ |
706 |
} |
/* } */ |
707 |
else |
/* else */ |
708 |
from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset); |
/* from->st.st_self = ARRAY_BODY_PTR(to,displaced_index_offset); */ |
709 |
END_NO_INTERRUPT; |
/* END_NO_INTERRUPT; */ |
710 |
} |
/* } */ |
711 |
|
|
712 |
} |
/* } */ |
713 |
|
|
714 |
/* add diff to body of x and arrays diisplaced to it */ |
/* add diff to body of x and arrays diisplaced to it */ |
715 |
|
|
731 |
type. |
type. |
732 |
*/ |
*/ |
733 |
|
|
734 |
char * |
static char * |
735 |
raw_aet_ptr(object x, short int typ) |
raw_aet_ptr(object x, short int typ) |
736 |
{ /* doubles are the largest raw type */ |
{ /* doubles are the largest raw type */ |
737 |
static double u; |
static double u; |
891 |
} |
} |
892 |
|
|
893 |
DEFUNO_NEW("FILL-POINTER-SET",object,fSfill_pointer_set,SI,2,2, |
DEFUNO_NEW("FILL-POINTER-SET",object,fSfill_pointer_set,SI,2,2, |
894 |
NONE,OO,IO,OO,OO,siLfill_pointer_set,(object x,int i),"") |
NONE,OO,IO,OO,OO,void,siLfill_pointer_set,(object x,int i),"") |
895 |
{ |
{ |
896 |
|
|
897 |
if (!(TS_MEMBER(type_of(x),TS(t_vector)| |
if (!(TS_MEMBER(type_of(x),TS(t_vector)| |
912 |
} |
} |
913 |
|
|
914 |
DEFUNO_NEW("FILL-POINTER",object,fLfill_pointer,LISP,1,1,NONE,OO, |
DEFUNO_NEW("FILL-POINTER",object,fLfill_pointer,LISP,1,1,NONE,OO, |
915 |
OO,OO,OO,Lfill_pointer,(object x),"") |
OO,OO,OO,void,Lfill_pointer,(object x),"") |
916 |
{ |
{ |
917 |
if (!(TS_MEMBER(type_of(x),TS(t_vector)| |
if (!(TS_MEMBER(type_of(x),TS(t_vector)| |
918 |
TS(t_bitvector)| |
TS(t_bitvector)| |
950 |
*/ |
*/ |
951 |
|
|
952 |
DEFUNO_NEW("ARRAY-ELEMENT-TYPE",object,fLarray_element_type, |
DEFUNO_NEW("ARRAY-ELEMENT-TYPE",object,fLarray_element_type, |
953 |
LISP,1,1,NONE,OO,OO,OO,OO,Larray_element_type,(object x),"") |
LISP,1,1,NONE,OO,OO,OO,OO,void,Larray_element_type,(object x),"") |
954 |
{ enum aelttype t; |
{ enum aelttype t; |
955 |
t = Iarray_element_type(x); |
t = Iarray_element_type(x); |
956 |
return * aet_types[(int)t].namep; |
return * aet_types[(int)t].namep; |
957 |
} |
} |
958 |
|
|
959 |
DEFUNO_NEW("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p, |
DEFUNO_NEW("ADJUSTABLE-ARRAY-P",object,fLadjustable_array_p, |
960 |
LISP,1,1,NONE,OO,OO,OO,OO,Ladjustable_array_p,(object x),"") |
LISP,1,1,NONE,OO,OO,OO,OO,void,Ladjustable_array_p,(object x),"") |
961 |
{ return sLt; |
{ return sLt; |
962 |
} |
} |
963 |
|
|
964 |
DEFUNO_NEW("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1, |
DEFUNO_NEW("DISPLACED-ARRAY-P",object,fSdisplaced_array_p,SI,1, |
965 |
1,NONE,OO,OO,OO,OO,siLdisplaced_array_p,(object x),"") |
1,NONE,OO,OO,OO,OO,void,siLdisplaced_array_p,(object x),"") |
966 |
{ IisArray(x); |
{ IisArray(x); |
967 |
return (x->a.a_displaced == Cnil ? Cnil : sLt); |
return (x->a.a_displaced == Cnil ? Cnil : sLt); |
968 |
} |
} |
969 |
|
|
970 |
DEFUNO_NEW("ARRAY-RANK",object,fLarray_rank,LISP,1,1,NONE,OO,OO,OO, |
DEFUNO_NEW("ARRAY-RANK",object,fLarray_rank,LISP,1,1,NONE,OO,OO,OO, |
971 |
OO,Larray_rank,(object x),"") |
OO,void,Larray_rank,(object x),"") |
972 |
{ if (type_of(x) == t_array) |
{ if (type_of(x) == t_array) |
973 |
return make_fixnum(x->a.a_rank); |
return make_fixnum(x->a.a_rank); |
974 |
IisArray(x); |
IisArray(x); |
976 |
} |
} |
977 |
|
|
978 |
DEFUNO_NEW("ARRAY-DIMENSION",object,fLarray_dimension,LISP,2,2, |
DEFUNO_NEW("ARRAY-DIMENSION",object,fLarray_dimension,LISP,2,2, |
979 |
NONE,OO,IO,OO,OO,Larray_dimension,(object x,int i),"") |
NONE,OO,IO,OO,OO,void,Larray_dimension,(object x,int i),"") |
980 |
{ |
{ |
981 |
if (type_of(x) == t_array) |
if (type_of(x) == t_array) |
982 |
{ if ((unsigned int)i >= x->a.a_rank) |
{ if ((unsigned int)i >= x->a.a_rank) |
987 |
return make_fixnum(x->v.v_dim); |
return make_fixnum(x->v.v_dim); |
988 |
} |
} |
989 |
|
|
990 |
void |
static void |
991 |
Icheck_displaced(object displaced_list, object ar, int dim) |
Icheck_displaced(object displaced_list, object ar, int dim) |
992 |
{ |
{ |
993 |
while (displaced_list!=Cnil) |
while (displaced_list!=Cnil) |
1016 |
Destroy the displacement from AR |
Destroy the displacement from AR |
1017 |
|
|
1018 |
*/ |
*/ |
1019 |
void |
/* static void */ |
1020 |
Iundisplace(object ar) |
/* Iundisplace(object ar) */ |
1021 |
{ object *p,x; |
/* { object *p,x; */ |
1022 |
|
|
1023 |
if ((x = DISPLACED_TO(ar)) == Cnil || |
/* if ((x = DISPLACED_TO(ar)) == Cnil || */ |
1024 |
ar->a.a_displaced->d.m == FREE) |
/* ar->a.a_displaced->d.m == FREE) */ |
1025 |
return; |
/* return; */ |
1026 |
{BEGIN_NO_INTERRUPT; |
/* {BEGIN_NO_INTERRUPT; */ |
1027 |
DISPLACED_TO(ar) = Cnil; |
/* DISPLACED_TO(ar) = Cnil; */ |
1028 |
p = &(DISPLACED_FROM(x)) ; |
/* p = &(DISPLACED_FROM(x)) ; */ |
1029 |
/* walk through the displaced from list and delete AR */ |
/* walk through the displaced from list and delete AR */ |
1030 |
while(1) |
/* while(1) */ |
1031 |
{ if ((*p)->d.m == FREE |
/* { if ((*p)->d.m == FREE */ |
1032 |
|| *p == Cnil) |
/* || *p == Cnil) */ |
1033 |
goto retur; |
/* goto retur; */ |
1034 |
if((Mcar(*p) == ar)) |
/* if((Mcar(*p) == ar)) */ |
1035 |
{ *p = Mcdr(*p); |
/* { *p = Mcdr(*p); */ |
1036 |
goto retur;} |
/* goto retur;} */ |
1037 |
p = &(Mcdr(*p)); |
/* p = &(Mcdr(*p)); */ |
1038 |
} |
/* } */ |
1039 |
retur: |
/* retur: */ |
1040 |
END_NO_INTERRUPT; |
/* END_NO_INTERRUPT; */ |
1041 |
return; |
/* return; */ |
1042 |
} |
/* } */ |
1043 |
} |
/* } */ |
1044 |
|
|
1045 |
DEFUNO_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE, |
DEFUNO_NEW("REPLACE-ARRAY",object,fSreplace_array,SI,2,2,NONE, |
1046 |
OO,OO,OO,OO,siLreplace_array,(object old,object new),"") |
OO,OO,OO,OO,void,siLreplace_array,(object old,object new),"") |
1047 |
{ struct dummy fw ; |
{ struct dummy fw ; |
1048 |
fw = old->d; |
fw = old->d; |
1049 |
|
|
1078 |
return old; |
return old; |
1079 |
} |
} |
1080 |
|
|
1081 |
DEFUNO_NEW("ARRAY-TOTAL-SIZE",object,fLarray_total_size,LISP,1,1, |
DEFUN_NEW("ARRAY-TOTAL-SIZE",object,fLarray_total_size,LISP,1,1, |
1082 |
NONE,OO,OO,OO,OO,Larray_total_size,(object x),"") |
NONE,OO,OO,OO,OO,(object x),"") |
1083 |
{ x = IisArray(x); |
{ x = IisArray(x); |
1084 |
return make_fixnum(x->a.a_dim); |
return make_fixnum(x->a.a_dim); |
1085 |
} |
} |
1086 |
|
|
1087 |
|
|
1088 |
DEFUNO_NEW("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3, |
DEFUN_NEW("ASET-BY-CURSOR",object,fSaset_by_cursor,SI,3,3, |
1089 |
NONE,OO,OO,OO,OO,siLaset_by_cursor,(object array,object val,object cursor),"") |
NONE,OO,OO,OO,OO,(object array,object val,object cursor),"") |
1090 |
{ |
{ |
1091 |
object x; |
object x; |
1092 |
int i; |
int i; |