=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/array.c,v retrieving revision 1.53 retrieving revision 1.62 diff -u -p -r1.53 -r1.62 --- OpenXM_contrib2/asir2000/builtin/array.c 2006/06/12 11:52:10 1.53 +++ OpenXM_contrib2/asir2000/builtin/array.c 2013/06/14 05:55:24 1.62 @@ -45,7 +45,7 @@ * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. * - * $OpenXM: OpenXM_contrib2/asir2000/builtin/array.c,v 1.52 2006/05/30 07:35:30 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/builtin/array.c,v 1.61 2012/12/17 07:20:44 noro Exp $ */ #include "ca.h" #include "base.h" @@ -54,7 +54,9 @@ #include #include +#if !defined(_MSC_VER) #include +#endif #define F4_INTRAT_PERIOD 8 @@ -95,6 +97,7 @@ void Pmat(); void Pmatc(); void Pnd_det(); void Plu_mat(); +void Pmat_col(); struct ftab array_tab[] = { {"lu_mat",Plu_mat,1}, @@ -140,6 +143,7 @@ struct ftab array_tab[] = { {"nbpoly_up2",Pnbpoly_up2,2}, {"mat_swap_row_destructive",Pmat_swap_row_destructive,3}, {"mat_swap_col_destructive",Pmat_swap_col_destructive,3}, + {"mat_col",Pmat_col,2}, {0,0,0}, }; @@ -150,6 +154,7 @@ int comp_obj(Obj *a,Obj *b) static FUNC generic_comp_obj_func; static NODE generic_comp_obj_arg; +static NODE generic_comp_obj_option; int generic_comp_obj(Obj *a,Obj *b) { @@ -157,7 +162,7 @@ int generic_comp_obj(Obj *a,Obj *b) BDY(generic_comp_obj_arg)=(pointer)(*a); BDY(NEXT(generic_comp_obj_arg))=(pointer)(*b); - r = (Q)bevalf(generic_comp_obj_func,generic_comp_obj_arg); + r = (Q)bevalf_with_opts(generic_comp_obj_func,generic_comp_obj_arg,generic_comp_obj_option); if ( !r ) return 0; else @@ -204,7 +209,8 @@ void Pqsort(NODE arg,LIST *rp) func = (FUNC)v->priv; } generic_comp_obj_func = func; - MKNODE(n,0,0); MKNODE(generic_comp_obj_arg,0,n); + MKNODE(n,0,0); MKNODE(generic_comp_obj_arg,0,n); + generic_comp_obj_option = current_option; qsort(BDY(vect),vect->len,sizeof(Obj),(int (*)(const void *,const void *))generic_comp_obj); } if (OID(t) == O_LIST) { @@ -338,8 +344,8 @@ void Psepmat_destructive(NODE arg,LIST *rp) sgn = SGN(ent); divn(nm,mod,&quo,&rem); /* if ( quo != nm && rem != nm ) */ -/* GC_free(nm); */ -/* GC_free(ent); */ +/* GCFREE(nm); */ +/* GCFREE(ent); */ NTOQ(rem,sgn,a[i][j]); NTOQ(quo,sgn,a1[i][j]); } MKNODE(n1,mat1,0); MKNODE(n0,mat,n1); @@ -391,11 +397,13 @@ void Pnewvect(NODE arg,VECT *rp) if ( argc(arg) == 2 ) { list = (LIST)ARG1(arg); asir_assert(list,O_LIST,"newvect"); +#if 0 for ( r = 0, tn = BDY(list); tn; r++, tn = NEXT(tn) ); if ( r > len ) { *rp = vect; return; } +#endif for ( i = 0, tn = BDY(list), vb = BDY(vect); tn; i++, tn = NEXT(tn) ) vb[i] = (pointer)BDY(tn); } @@ -403,7 +411,7 @@ void Pnewvect(NODE arg,VECT *rp) } void Pvect(NODE arg,VECT *rp) { - int len,i,r; + int len,i; VECT vect; pointer *vb; NODE tn; @@ -457,15 +465,29 @@ void Pnewbytearray(NODE arg,BYTEARRAY *rp) ac = argc(arg); if ( ac == 1 ) { - /* ARG0(arg) must be a filename */ - asir_assert(ARG0(arg),O_STR,"newbytearray"); - fname = BDY((STRING)ARG0(arg)); - fp = fopen(fname,"rb"); - if ( !fp ) error("newbytearray : fopen failed"); - if ( stat(fname,&sbuf) < 0 ) error("newbytearray : stat failed"); - len = sbuf.st_size; - MKBYTEARRAY(array,len); - fread(BDY(array),len,sizeof(char),fp); + if ( !OID((Obj)ARG0(arg)) ) error("newbytearray : invalid argument"); + switch ( OID((Obj)ARG0(arg)) ) { + case O_STR: + fname = BDY((STRING)ARG0(arg)); + fp = fopen(fname,"rb"); + if ( !fp ) error("newbytearray : fopen failed"); + if ( stat(fname,&sbuf) < 0 ) + error("newbytearray : stat failed"); + len = sbuf.st_size; + MKBYTEARRAY(array,len); + fread(BDY(array),len,sizeof(char),fp); + break; + case O_N: + if ( !RATN(ARG0(arg)) ) + error("newbytearray : invalid argument"); + len = QTOS((Q)ARG0(arg)); + if ( len < 0 ) + error("newbytearray : invalid size"); + MKBYTEARRAY(array,len); + break; + default: + error("newbytearray : invalid argument"); + } } else if ( ac == 2 ) { asir_assert(ARG0(arg),O_N,"newbytearray"); len = QTOS((Q)ARG0(arg)); @@ -901,7 +923,7 @@ void Pgeneric_gauss_elim(NODE arg,LIST *rp) int *ri,*ci; VECT rind,cind; Q dn,q; - int i,j,k,l,row,col,t,rank; + int i,row,col,t,rank; int is_hensel = 0; char *key; Obj value; @@ -1542,7 +1564,7 @@ int generic_gauss_elim_hensel(MAT mat,MAT *nmmat,Q *dn } } -int generic_gauss_elim_hensel_dalg(MAT mat,MAT *nmmat,Q *dn,int **rindp,int **cindp) +int generic_gauss_elim_hensel_dalg(MAT mat,DP *mb,MAT *nmmat,Q *dn,int **rindp,int **cindp) { MAT bmat,xmat; Q **a0,**a,**b,**x,**nm; @@ -1566,12 +1588,9 @@ int generic_gauss_elim_hensel_dalg(MAT mat,MAT *nmmat, N wn; Q wq; NumberField nf; - DP *mb; DP m; int col1; - nf = get_numberfield(); - mb = nf->mb; a0 = (Q **)mat->body; row = mat->row; col = mat->col; w = (int **)almat(row,col); @@ -1818,13 +1837,10 @@ int intmtoratm(MAT mat,N md,MAT nm,Q *dn) return 0; row = mat->row; col = mat->col; bshiftn(md,1,&t); - isqrt(t,&b); -#if 0 isqrt(t,&s); bshiftn(s,64,&b); if ( !b ) b = ONEN; -#endif dn0 = ONE; tmat = (N **)mat->body; rmat = (Q **)nm->body; @@ -2066,8 +2082,7 @@ void red_by_compress(int m,unsigned int *p,unsigned in void red_by_vect(int m,unsigned int *p,unsigned int *r,unsigned int hc,int len) { - register unsigned int up,lo; - unsigned int dmy; + unsigned int up,lo,dmy; *p++ = 0; r++; len--; for ( ; len; len--, r++, p++ ) @@ -2948,10 +2963,10 @@ void inner_product_int(Q *a,Q *b,int n,Q *r) t = wma; wma = sum; sum = t; } } - GC_free(wm); - GC_free(wma); + GCFREE(wm); + GCFREE(wma); if ( !sgn ) { - GC_free(sum); + GCFREE(sum); *r = 0; } else NTOQ(sum,sgn,*r); @@ -3006,10 +3021,10 @@ void inner_product_mat_int_mod(Q **a,int **b,int n,int t = wma; wma = sum; sum = t; } } - GC_free(wm); - GC_free(wma); + GCFREE(wm); + GCFREE(wma); if ( !sgn ) { - GC_free(sum); + GCFREE(sum); *r = 0; } else NTOQ(sum,sgn,*r); @@ -3441,4 +3456,25 @@ void Pnd_det(NODE arg,P *rp) nd_det(0,ARG0(arg),rp); else nd_det(QTOS((Q)ARG1(arg)),ARG0(arg),rp); +} + +void Pmat_col(NODE arg,VECT *rp) +{ + int i,j,n; + MAT mat; + VECT vect; + + asir_assert(ARG0(arg),O_MAT,"mat_col"); + asir_assert(ARG1(arg),O_N,"mat_col"); + mat = (MAT)ARG0(arg); + j = QTOS((Q)ARG1(arg)); + if ( j < 0 || j >= mat->col) { + error("mat_col : Out of range"); + } + n = mat->row; + MKVECT(vect,n); + for(i=0; i