00001
00002
00003
00004
00005 #include "eus.h"
00006 #if (WORD_SIZE == 64)
00007 extern pointer makefvector();
00008
00009
00010
00011
00012
00013
00014 static pointer FSTRING2DV(ctx,n,argv)
00015 context *ctx;
00016 int n;
00017 pointer argv[];
00018 { pointer f=argv[0],d;
00019 double *fp;
00020 float *src=NULL;
00021 register int i,len=-1;
00022
00023 ckarg2(1,2);
00024 if (isint (f)) {
00025 src = (float *)(intval(f));
00026 } else {
00027 if (!isstring(f)) error(E_NOSTRING);
00028 len = strlength(f)/4;
00029 src = (float *)f->c.str.chars;
00030 }
00031
00032 if (n == 1) {
00033 if(len < 0) error(E_FLOATVECTOR);
00034 d = makefvector(len);
00035 vpush(d);
00036 } else {
00037 d = argv[1];
00038 if (len < 0) len = vecsize(d);
00039 if (!isfltvector(d)) error(E_FLOATVECTOR);
00040 if (vecsize(d)<len) error(E_ARRAYINDEX);
00041 }
00042
00043 fp = d->c.fvec.fv;
00044 for (i=0; i<len; i++) {
00045 *fp++ = (double)src[i];
00046 }
00047 if(n != 1) return (d);
00048 return (vpop());
00049 }
00050
00051
00052
00053
00054
00055
00056 static pointer DV2FSTRING(ctx,n,argv)
00057 context *ctx;
00058 int n;
00059 pointer argv[];
00060 { pointer d=argv[0],f;
00061 double *fp;
00062 char *buf=NULL;
00063 register int i,len;
00064 union doublefloat {
00065 struct {char a,b,c,d;} cval;
00066 float fval;
00067 } f2d;
00068
00069 ckarg2(1,2);
00070 if (!isfltvector(d)) error(E_FLOATVECTOR);
00071 len=vecsize(d)*4;
00072 fp = d->c.fvec.fv;
00073
00074 if (n != 1) {
00075 f=argv[1];
00076 if (isint(f)) {
00077 buf = (char *)intval(f);
00078 } else {
00079 if (!isstring(f)) error(E_NOSTRING);
00080 if (strlength(f)<len) error(E_ARRAYINDEX);
00081 }
00082 } else {
00083
00084 f=alloc((len+2*sizeof(eusinteger_t))>>WORDSHIFT, ELM_CHAR,
00085 stringcp.cix, (len+2*sizeof(eusinteger_t))>>WORDSHIFT );
00086 vpush(f);
00087 f->c.str.length=makeint(len);
00088 f->c.ivec.iv[len/sizeof(eusinteger_t)] = 0;
00089
00090 }
00091
00092 if(buf == NULL) buf = f->c.str.chars;
00093 for (i=0; i<len/4; i++) {
00094 f2d.fval = (float)*fp++;
00095 *buf++ = f2d.cval.a;
00096 *buf++ = f2d.cval.b;
00097 *buf++ = f2d.cval.c;
00098 *buf++ = f2d.cval.d;
00099 }
00100 if(n != 1) return(f);
00101 return(vpop());
00102 }
00103
00104
00105
00106
00107
00108
00109 static pointer ISTRING2LV(ctx,n,argv)
00110 context *ctx;
00111 int n;
00112 pointer argv[];
00113 { pointer f=argv[0],d;
00114 long *fp;
00115 int *src=NULL;
00116 register int i,len=-1;
00117
00118 ckarg2(1,2);
00119 if (isint (f)) {
00120 src = (int *)(intval(f));
00121 } else {
00122 if (!isstring(f)) error(E_NOSTRING);
00123 len = strlength(f)/4;
00124 src = (int *)f->c.str.chars;
00125 }
00126
00127 if (n == 1) {
00128 if(len < 0) error(E_NOINTVECTOR);
00129 d = makevector(C_INTVECTOR,len);
00130 vpush(d);
00131 } else {
00132 d = argv[1];
00133 if (len < 0) len = vecsize(d);
00134 if (!isintvector(d)) error(E_NOINTVECTOR);
00135 if (vecsize(d)<len) error(E_ARRAYINDEX);
00136 }
00137
00138 fp = d->c.ivec.iv;
00139 for (i=0; i<len; i++) {
00140 *fp++ = (long)src[i];
00141 }
00142 if(n != 1) return d;
00143 return(vpop());
00144 }
00145
00146
00147
00148
00149
00150
00151 static pointer LV2ISTRING(ctx,n,argv)
00152 context *ctx;
00153 int n;
00154 pointer argv[];
00155 { pointer d=argv[0],f;
00156 long *fp;
00157 char *buf = NULL;
00158 register int i,len;
00159 union intchar {
00160 struct {char a,b,c,d;} cval;
00161 int ival;
00162 } i2l;
00163
00164 ckarg2(1,2);
00165 if (!isintvector(d)) error(E_NOINTVECTOR);
00166 len=vecsize(d)*4;
00167 fp = d->c.ivec.iv;
00168
00169 if (n != 1) {
00170 f=argv[1];
00171 if (isint(f)) {
00172 buf = (char *)intval(f);
00173 } else {
00174 if (!isstring(f)) error(E_NOSTRING);
00175 if (strlength(f)<len) error(E_ARRAYINDEX);
00176 }
00177 } else {
00178
00179 f=alloc((len+2*sizeof(eusinteger_t))>>WORDSHIFT, ELM_CHAR,
00180 stringcp.cix, (len+2*sizeof(eusinteger_t))>>WORDSHIFT );
00181 vpush(f);
00182 f->c.str.length=makeint(len);
00183 f->c.ivec.iv[len/sizeof(eusinteger_t)] = 0;
00184
00185 }
00186 if(buf == NULL) buf = f->c.str.chars;
00187 for (i=0; i<len/4; i++) {
00188 i2l.ival = (int)*fp++;
00189 *buf++ = i2l.cval.a;
00190 *buf++ = i2l.cval.b;
00191 *buf++ = i2l.cval.c;
00192 *buf++ = i2l.cval.d;
00193 }
00194 if(n != 1) return f;
00195 return(vpop());
00196 }
00197 #endif
00198 #ifdef i386
00199 extern pointer makefvector();
00200
00201
00202
00203
00204
00205
00206 static pointer DSTRING2FV(ctx,n,argv)
00207 context *ctx;
00208 int n;
00209 pointer argv[];
00210 { pointer f=argv[0], d;
00211 float *fp;
00212 double *src=NULL;
00213 register int i, len=-1;
00214
00215 ckarg2(1,2);
00216 if (isint (f)) {
00217 src = (double *)(intval(f));
00218 } else {
00219 if (!isstring(f)) error(E_NOSTRING);
00220 len = strlength(f)/8;
00221 src = (double *)f->c.str.chars;
00222 }
00223
00224 if (n == 1) {
00225 if(len < 0) error(E_FLOATVECTOR);
00226 d = makefvector(len);
00227 vpush (d);
00228 } else {
00229 d = argv[1];
00230 if (len < 0) len = vecsize(d);
00231 if (!isfltvector(d)) error(E_FLOATVECTOR);
00232 if (vecsize(d)<len) error(E_ARRAYINDEX);
00233 }
00234
00235 fp = d->c.fvec.fv;
00236 for (i = 0; i < len; i++) {
00237 *fp++ = (float)src[i];
00238 }
00239 if(n != 1) return (d);
00240 return (vpop());
00241 }
00242
00243
00244
00245
00246
00247
00248 static pointer FV2DSTRING(ctx,n,argv)
00249 context *ctx;
00250 int n;
00251 pointer argv[];
00252 { pointer d=argv[0], f;
00253 float *fp;
00254 char *buf = NULL;
00255 register int i, len;
00256 union doublefloat {
00257 struct {char a,b,c,d,e,f,g,h;} cval;
00258 double fval;
00259 } f2d;
00260
00261 ckarg2(1,2);
00262 if (!isfltvector(d)) error(E_FLOATVECTOR);
00263 len = vecsize(d) * 8;
00264 fp = d->c.fvec.fv;
00265
00266 if (n != 1) {
00267 f=argv[1];
00268 if (isint(f)) {
00269 buf = (char *)intval(f);
00270 } else {
00271 if (!isstring(f)) error(E_NOSTRING);
00272 if (strlength(f)<len) error(E_ARRAYINDEX);
00273 }
00274 } else {
00275 f=alloc((len+2*sizeof(eusinteger_t))>>WORDSHIFT, ELM_CHAR,
00276 stringcp.cix, (len+2*sizeof(eusinteger_t))>>WORDSHIFT);
00277 vpush(f);
00278 f->c.str.length = makeint(len);
00279 f->c.ivec.iv[len/sizeof(eusinteger_t)] = 0;
00280
00281 }
00282
00283 if(buf == NULL) buf = f->c.str.chars;
00284 for (i=0; i < len/8; i++) {
00285 f2d.fval = (double)*fp++;
00286 *buf++ = f2d.cval.a;
00287 *buf++ = f2d.cval.b;
00288 *buf++ = f2d.cval.c;
00289 *buf++ = f2d.cval.d;
00290 *buf++ = f2d.cval.e;
00291 *buf++ = f2d.cval.f;
00292 *buf++ = f2d.cval.g;
00293 *buf++ = f2d.cval.h;
00294 }
00295 if(n != 1) return(f);
00296 return(vpop());
00297 }
00298
00299
00300
00301
00302
00303
00304 static pointer LSTRING2IV(ctx,n,argv)
00305 context *ctx;
00306 int n;
00307 pointer argv[];
00308 { pointer f=argv[0],d;
00309 int *fp;
00310 long long *src=NULL;
00311 register int i, len=-1;
00312
00313 ckarg2(1,2);
00314 if (isint (f)) {
00315 src = (long long *)(intval(f));
00316 } else {
00317 if (!isstring(f)) error(E_NOSTRING);
00318 len = strlength(f) / 8;
00319 src = (long long *)f->c.str.chars;
00320 }
00321
00322 if (n == 1) {
00323 if(len < 0) error(E_NOINTVECTOR);
00324 d = makevector(C_INTVECTOR, len);
00325 vpush(d);
00326 } else {
00327 d = argv[1];
00328 if (len < 0) len = vecsize(d);
00329 if (!isintvector(d)) error(E_NOINTVECTOR);
00330 if (vecsize(d)<len) error(E_ARRAYINDEX);
00331 }
00332 fp = d->c.ivec.iv;
00333 for (i = 0; i < len; i++) {
00334 *fp++ = (int)src[i];
00335 }
00336 if(n != 1) return d;
00337 return (vpop());
00338 }
00339
00340
00341
00342
00343
00344
00345 static pointer IV2LSTRING(ctx,n,argv)
00346 context *ctx;
00347 int n;
00348 pointer argv[];
00349 { pointer d = argv[0],f;
00350 int *fp;
00351 char *buf = NULL;
00352 register int i, len;
00353 union intchar {
00354 struct {char a,b,c,d,e,f,g,h;} cval;
00355 long long ival;
00356 } i2l;
00357
00358 ckarg2(1,2);
00359 if (!isintvector(d)) error(E_NOINTVECTOR);
00360 len = vecsize(d) * 8;
00361 fp = d->c.ivec.iv;
00362
00363 if (n != 1) {
00364 f = argv[1];
00365 if (isint(f)) {
00366 buf = (char *)intval(f);
00367 } else {
00368 if (!isstring(f)) error(E_NOSTRING);
00369 if (strlength(f)<len) error(E_ARRAYINDEX);
00370 }
00371 } else {
00372
00373 f=alloc((len+2*sizeof(eusinteger_t))>>WORDSHIFT, ELM_CHAR,
00374 stringcp.cix, (len+2*sizeof(eusinteger_t))>>WORDSHIFT);
00375 vpush(f);
00376 f->c.str.length = makeint(len);
00377 f->c.ivec.iv[len/sizeof(eusinteger_t)] = 0;
00378
00379 }
00380 if(buf == NULL) buf = f->c.str.chars;
00381 for (i=0; i<len/4; i++) {
00382 i2l.ival = (int)*fp++;
00383 *buf++ = i2l.cval.a;
00384 *buf++ = i2l.cval.b;
00385 *buf++ = i2l.cval.c;
00386 *buf++ = i2l.cval.d;
00387 *buf++ = i2l.cval.e;
00388 *buf++ = i2l.cval.f;
00389 *buf++ = i2l.cval.g;
00390 *buf++ = i2l.cval.h;
00391 }
00392 if(n != 1) return f;
00393 return (vpop());
00394 }
00395 #endif
00396 int fstringdouble(ctx,n,argv)
00397 context *ctx;
00398 int n;
00399 pointer argv[];
00400 { pointer mod=argv[0];
00401 #if (WORD_SIZE == 64)
00402 defun(ctx,"FLOAT-BYTESTRING2DVECTOR",mod,FSTRING2DV,NULL);
00403 defun(ctx,"DVECTOR2FLOAT-BYTESTRING",mod,DV2FSTRING,NULL);
00404 defun(ctx,"INTEGER-BYTESTRING2LVECTOR",mod,ISTRING2LV,NULL);
00405 defun(ctx,"LVECTOR2INTEGER-BYTESTRING",mod,LV2ISTRING,NULL);
00406 #endif
00407 #ifdef i386
00408 defun(ctx,"DOUBLE-BYTESTRING2FVECTOR",mod,DSTRING2FV,NULL);
00409 defun(ctx,"FVECTOR2DOUBLE-BYTESTRING",mod,FV2DSTRING,NULL);
00410 defun(ctx,"LONG-LONG-BYTESTRING2IVECTOR",mod,LSTRING2IV,NULL);
00411 defun(ctx,"IVECTOR2LONG-LONG-BYTESTRING",mod,IV2LSTRING,NULL);
00412 #endif
00413 }