Branch data Line data Source code
1 : : #ifdef _P64
2 : : #define NWORDS(sz) (((sz)+7)>>3)
3 : : #else
4 : : #define NWORDS(sz) (((sz)+3)>>2)
5 : : #endif
6 : :
7 : : struct prim_int16{ char a; int16_t i; };
8 : : struct prim_int32{ char a; int32_t i; };
9 : : struct prim_int64{ char a; int64_t i; };
10 : : struct prim_ptr{ char a; void *i; };
11 : :
12 : : // compute struct field alignment required for primitives
13 : : static const int ALIGN2 = sizeof(struct prim_int16) - 2;
14 : : static const int ALIGN4 = sizeof(struct prim_int32) - 4;
15 : : static const int ALIGN8 = sizeof(struct prim_int64) - 8;
16 : : static const int ALIGNPTR = sizeof(struct prim_ptr) - sizeof(void*);
17 : :
18 : : static void cvalue_init(fl_context_t *fl_ctx, fltype_t *type, value_t v, void *dest);
19 : :
20 : : // cvalues-specific builtins
21 : : value_t cvalue_new(fl_context_t *fl_ctx, value_t *args, uint32_t nargs);
22 : : value_t cvalue_sizeof(fl_context_t *fl_ctx, value_t *args, uint32_t nargs);
23 : : value_t cvalue_typeof(fl_context_t *fl_ctx, value_t *args, uint32_t nargs);
24 : :
25 : : // trigger unconditional GC after this many bytes are allocated
26 : : #define ALLOC_LIMIT_TRIGGER 67108864
27 : :
28 : 2193280 : void add_finalizer(fl_context_t *fl_ctx, cvalue_t *cv)
29 : : {
30 [ + + ]: 2193280 : if (fl_ctx->nfinalizers == fl_ctx->maxfinalizers) {
31 [ + + ]: 142 : size_t nn = (fl_ctx->maxfinalizers==0 ? 256 : fl_ctx->maxfinalizers*2);
32 : 142 : cvalue_t **temp = (cvalue_t**)realloc(fl_ctx->Finalizers, nn*sizeof(value_t));
33 [ - + ]: 142 : if (temp == NULL)
34 : 0 : lerror(fl_ctx, fl_ctx->OutOfMemoryError, "out of memory");
35 : 142 : fl_ctx->Finalizers = temp;
36 : 142 : fl_ctx->maxfinalizers = nn;
37 : : }
38 : 2193280 : fl_ctx->Finalizers[fl_ctx->nfinalizers++] = cv;
39 : 2193280 : }
40 : :
41 : : // remove dead objects from finalization list in-place
42 : 4474 : static void sweep_finalizers(fl_context_t *fl_ctx)
43 : : {
44 : 4474 : cvalue_t **lst = fl_ctx->Finalizers;
45 : 4474 : size_t n=0, ndel=0, l=fl_ctx->nfinalizers;
46 : : cvalue_t *tmp;
47 : : #define SWAP_sf(a,b) (tmp=a,a=b,b=tmp,1)
48 [ - + ]: 4474 : if (l == 0)
49 : 0 : return;
50 : : do {
51 : 9562320 : tmp = lst[n];
52 [ + + ]: 9562320 : if (isforwarded((value_t)tmp)) {
53 : : // object is alive
54 : 7422700 : lst[n] = (cvalue_t*)ptr(forwardloc((value_t)tmp));
55 : 7422700 : n++;
56 : : }
57 : : else {
58 : 2139620 : fltype_t *t = cv_class(tmp);
59 [ + + + + ]: 2139620 : if (t->vtable != NULL && t->vtable->finalize != NULL) {
60 : 2077980 : t->vtable->finalize(fl_ctx, tagptr(tmp, TAG_CVALUE));
61 : : }
62 [ + + + - ]: 2139620 : if (!isinlined(tmp) && owned(tmp)) {
63 : : #ifdef DEBUG
64 : : memset(cv_data(tmp), 0xbb, cv_len(tmp));
65 : : #endif
66 : 56674 : free(cv_data(tmp));
67 : : }
68 : 2139620 : ndel++;
69 : : }
70 [ + + ]: 9562320 : } while ((n < l-ndel) && SWAP_sf(lst[n],lst[n+ndel]));
71 : :
72 : 4474 : fl_ctx->nfinalizers -= ndel;
73 : : #ifdef VERBOSEGC
74 : : if (ndel > 0)
75 : : printf("GC: finalized %d objects\n", ndel);
76 : : #endif
77 : :
78 : 4474 : fl_ctx->malloc_pressure = 0;
79 : : }
80 : :
81 : : // compute the size of the metadata object for a cvalue
82 : 9920320 : static size_t cv_nwords(fl_context_t *fl_ctx, cvalue_t *cv)
83 : : {
84 [ + + ]: 9920320 : if (isinlined(cv)) {
85 : 2586240 : size_t n = cv_len(cv);
86 [ + - + + ]: 2586240 : if (n==0 || cv_isstr(fl_ctx, cv))
87 : 2323100 : n++;
88 : 2586240 : return CVALUE_NWORDS - 1 + NWORDS(n);
89 : : }
90 : 7334080 : return CVALUE_NWORDS;
91 : : }
92 : :
93 : 105706 : static void autorelease(fl_context_t *fl_ctx, cvalue_t *cv)
94 : : {
95 : 105706 : cv->type = (fltype_t*)(((uintptr_t)cv->type) | CV_OWNED_BIT);
96 : 105706 : add_finalizer(fl_ctx, cv);
97 : 105706 : }
98 : :
99 : 45632 : void cv_autorelease(fl_context_t *fl_ctx, cvalue_t *cv)
100 : : {
101 : 45632 : autorelease(fl_ctx, cv);
102 : 45632 : }
103 : :
104 : 40843800 : static value_t cprim(fl_context_t *fl_ctx, fltype_t *type, size_t sz)
105 : : {
106 : 40843800 : cprim_t *pcp = (cprim_t*)alloc_words(fl_ctx, CPRIM_NWORDS-1+NWORDS(sz));
107 : 40843800 : pcp->type = type;
108 : 40843800 : return tagptr(pcp, TAG_CPRIM);
109 : : }
110 : :
111 : 10900100 : value_t cvalue(fl_context_t *fl_ctx, fltype_t *type, size_t sz)
112 : : {
113 : : cvalue_t *pcv;
114 : 10900100 : int str=0;
115 : :
116 [ - + ]: 10900100 : if (valid_numtype(type->numtype)) {
117 : 0 : return cprim(fl_ctx, type, sz);
118 : : }
119 [ + + ]: 10900100 : if (type->eltype == fl_ctx->bytetype) {
120 [ + + ]: 1838896 : if (sz == 0)
121 : 36162 : return symbol_value(fl_ctx->emptystringsym);
122 : 1802734 : sz++;
123 : 1802734 : str=1;
124 : : }
125 [ + + ]: 10863940 : if (sz <= MAX_INL_SIZE) {
126 [ - + ]: 10851840 : size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz==0 ? 1 : 0);
127 : 10851840 : pcv = (cvalue_t*)alloc_words(fl_ctx, nw);
128 : 10851840 : pcv->type = type;
129 : 10851840 : pcv->data = &pcv->_space[0];
130 [ + + + + ]: 10851840 : if (type->vtable != NULL && type->vtable->finalize != NULL)
131 : 2042800 : add_finalizer(fl_ctx, pcv);
132 : : }
133 : : else {
134 [ - + ]: 12104 : if (fl_ctx->malloc_pressure > ALLOC_LIMIT_TRIGGER)
135 : 0 : gc(fl_ctx, 0);
136 : 12104 : pcv = (cvalue_t*)alloc_words(fl_ctx, CVALUE_NWORDS);
137 : 12104 : pcv->type = type;
138 : 12104 : pcv->data = malloc(sz);
139 : : // TODO: if pcv->data == NULL
140 : 12104 : autorelease(fl_ctx, pcv);
141 : 12104 : fl_ctx->malloc_pressure += sz;
142 : : }
143 [ + + ]: 10863940 : if (str) {
144 : 1802734 : sz--;
145 : 1802734 : ((char*)pcv->data)[sz] = '\0';
146 : : }
147 : 10863940 : pcv->len = sz;
148 : 10863940 : return tagptr(pcv, TAG_CVALUE);
149 : : }
150 : :
151 : 0 : value_t cvalue_from_data(fl_context_t *fl_ctx, fltype_t *type, void *data, size_t sz)
152 : : {
153 : : value_t cv;
154 : 0 : cv = cvalue(fl_ctx, type, sz);
155 [ # # ]: 0 : memcpy(cptr(cv), data, sz);
156 : 0 : return cv;
157 : : }
158 : :
159 : : // this effectively dereferences a pointer
160 : : // just like *p in C, it only removes a level of indirection from the type,
161 : : // it doesn't copy any data.
162 : : // this method of creating a cvalue only allocates metadata.
163 : : // ptr is user-managed; we don't autorelease it unless the
164 : : // user explicitly calls (autorelease ) on the result of this function.
165 : : // 'parent' is an optional cvalue that this pointer is known to point
166 : : // into; fl_ctx->NIL if none.
167 : 69640 : value_t cvalue_from_ref(fl_context_t *fl_ctx, fltype_t *type, void *ptr, size_t sz, value_t parent)
168 : : {
169 : : cvalue_t *pcv;
170 : : value_t cv;
171 : :
172 : 69640 : pcv = (cvalue_t*)alloc_words(fl_ctx, CVALUE_NWORDS);
173 : 69640 : pcv->data = ptr;
174 : 69640 : pcv->len = sz;
175 : 69640 : pcv->type = type;
176 [ - + ]: 69640 : if (parent != fl_ctx->NIL) {
177 : 0 : pcv->type = (fltype_t*)(((uintptr_t)pcv->type) | CV_PARENT_BIT);
178 : 0 : pcv->parent = parent;
179 : : }
180 : 69640 : cv = tagptr(pcv, TAG_CVALUE);
181 : 69640 : return cv;
182 : : }
183 : :
184 : 1838896 : value_t cvalue_string(fl_context_t *fl_ctx, size_t sz)
185 : : {
186 : 1838896 : return cvalue(fl_ctx, fl_ctx->stringtype, sz);
187 : : }
188 : :
189 : 23918 : value_t cvalue_static_cstrn(fl_context_t *fl_ctx, const char *str, size_t n)
190 : : {
191 : 23918 : return cvalue_from_ref(fl_ctx, fl_ctx->stringtype, (char*)str, n, fl_ctx->NIL);
192 : : }
193 : :
194 : 90 : value_t cvalue_static_cstring(fl_context_t *fl_ctx, const char *str)
195 : : {
196 : 90 : return cvalue_static_cstrn(fl_ctx, str, strlen(str));
197 : : }
198 : :
199 : 0 : value_t string_from_cstrn(fl_context_t *fl_ctx, char *str, size_t n)
200 : : {
201 : 0 : value_t v = cvalue_string(fl_ctx, n);
202 : 0 : memcpy(cvalue_data(v), str, n);
203 : 0 : return v;
204 : : }
205 : :
206 : 0 : value_t string_from_cstr(fl_context_t *fl_ctx, char *str)
207 : : {
208 : 0 : return string_from_cstrn(fl_ctx, str, strlen(str));
209 : : }
210 : :
211 : 39399400 : int fl_isstring(fl_context_t *fl_ctx, value_t v)
212 : : {
213 [ + + + + ]: 39399400 : return (iscvalue(v) && cv_isstr(fl_ctx, (cvalue_t*)ptr(v)));
214 : : }
215 : :
216 : : // convert to malloc representation (fixed address)
217 : 50010 : void cv_pin(fl_context_t *fl_ctx, cvalue_t *cv)
218 : : {
219 [ + + ]: 50010 : if (!isinlined(cv))
220 : 2040 : return;
221 : 47970 : size_t sz = cv_len(cv);
222 [ + - ]: 47970 : if (cv_isstr(fl_ctx, cv)) sz++;
223 : 47970 : void *data = malloc(sz);
224 : : // TODO: if data == NULL
225 : 47970 : memcpy(data, cv_data(cv), sz);
226 : 47970 : cv->data = data;
227 : 47970 : autorelease(fl_ctx, cv);
228 : : }
229 : :
230 : : #define num_init(ctype, cnvt, tag) \
231 : : static int cvalue_##ctype##_init(fl_context_t *fl_ctx, fltype_t *type, \
232 : : value_t arg, void *dest) \
233 : : { \
234 : : fl_##ctype##_t n=0; \
235 : : (void)type; \
236 : : if (isfixnum(arg)) { \
237 : : n = numval(arg); \
238 : : } \
239 : : else if (iscprim(arg)) { \
240 : : cprim_t *cp = (cprim_t*)ptr(arg); \
241 : : void *p = cp_data(cp); \
242 : : n = (fl_##ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \
243 : : } \
244 : : else { \
245 : : return 1; \
246 : : } \
247 : : memcpy(jl_assume_aligned(dest, sizeof(void*)), &n, \
248 : : sizeof(fl_##ctype##_t)); \
249 : : return 0; \
250 : : }
251 [ # # # # ]: 0 : num_init(int8, int32, T_INT8)
252 [ + - - - ]: 1706 : num_init(uint8, uint32, T_UINT8)
253 [ # # # # ]: 0 : num_init(int16, int32, T_INT16)
254 [ + - - - ]: 740 : num_init(uint16, uint32, T_UINT16)
255 [ + - - - ]: 30 : num_init(int32, int32, T_INT32)
256 [ + - - - ]: 1510 : num_init(uint32, uint32, T_UINT32)
257 [ - + + - ]: 60 : num_init(int64, int64, T_INT64)
258 [ + + + - ]: 4864 : num_init(uint64, uint64, T_UINT64)
259 [ - + + - ]: 1368 : num_init(float, double, T_FLOAT)
260 [ - + + - ]: 68 : num_init(double, double, T_DOUBLE)
261 : :
262 : : #define num_ctor_init(typenam, ctype, tag) \
263 : : value_t cvalue_##typenam(fl_context_t *fl_ctx, value_t *args, uint32_t nargs) \
264 : : { \
265 : : if (nargs==0) { PUSH(fl_ctx, fixnum(0)); args = &fl_ctx->Stack[fl_ctx->SP-1]; } \
266 : : value_t cp = cprim(fl_ctx, fl_ctx->typenam##type, sizeof(fl_##ctype##_t)); \
267 : : if (cvalue_##ctype##_init(fl_ctx, fl_ctx->typenam##type, \
268 : : args[0], cp_data((cprim_t*)ptr(cp)))) \
269 : : type_error(fl_ctx, #typenam, "number", args[0]); \
270 : : return cp; \
271 : : }
272 : :
273 : : #define num_ctor_ctor(typenam, ctype, tag) \
274 : : value_t mk_##typenam(fl_context_t *fl_ctx, fl_##ctype##_t n) \
275 : : { \
276 : : value_t cp = cprim(fl_ctx, fl_ctx->typenam##type, sizeof(fl_##ctype##_t)); \
277 : : *(fl_##ctype##_t*)cp_data((cprim_t*)ptr(cp)) = n; \
278 : : return cp; \
279 : : }
280 : :
281 : : #define num_ctor(typenam, ctype, tag) \
282 : : num_ctor_init(typenam, ctype, tag) \
283 : : num_ctor_ctor(typenam, ctype, tag)
284 : :
285 [ # # # # ]: 0 : num_ctor(int8, int8, T_INT8)
286 [ - + - + ]: 1706 : num_ctor(uint8, uint8, T_UINT8)
287 [ # # # # ]: 0 : num_ctor(int16, int16, T_INT16)
288 [ - + - + ]: 740 : num_ctor(uint16, uint16, T_UINT16)
289 [ - + - + ]: 30 : num_ctor(int32, int32, T_INT32)
290 [ - + - + ]: 2846 : num_ctor(uint32, uint32, T_UINT32)
291 [ - + - + ]: 818 : num_ctor(int64, int64, T_INT64)
292 [ - + - + ]: 6510 : num_ctor(uint64, uint64, T_UINT64)
293 [ # # # # ]: 0 : num_ctor(byte, uint8, T_UINT8)
294 [ # # # # ]: 40820200 : num_ctor(wchar, int32, T_INT32)
295 : : #ifdef _P64
296 [ # # # # ]: 0 : num_ctor(ptrdiff, int64, T_INT64)
297 [ # # # # ]: 0 : num_ctor(size, uint64, T_UINT64)
298 : : #else
299 : : num_ctor(ptrdiff, int32, T_INT32)
300 : : num_ctor(size, uint32, T_UINT32)
301 : : #endif
302 [ - + - + ]: 1368 : num_ctor(float, float, T_FLOAT)
303 [ - + - + ]: 9660 : num_ctor(double, double, T_DOUBLE)
304 : :
305 : 4071160 : value_t size_wrap(fl_context_t *fl_ctx, size_t sz)
306 : : {
307 [ - + - - ]: 4071160 : if (fits_fixnum(sz))
308 : 4071160 : return fixnum(sz);
309 : : assert(sizeof(void*) == sizeof(size_t));
310 : 0 : return mk_size(fl_ctx, sz);
311 : : }
312 : :
313 : 1014466 : size_t tosize(fl_context_t *fl_ctx, value_t n, const char *fname)
314 : : {
315 [ + - ]: 1014466 : if (isfixnum(n))
316 : 1014466 : return numval(n);
317 [ # # ]: 0 : if (iscprim(n)) {
318 : 0 : cprim_t *cp = (cprim_t*)ptr(n);
319 : 0 : return conv_to_size(cp_data(cp), cp_numtype(cp));
320 : : }
321 : 0 : type_error(fl_ctx, fname, "number", n);
322 : : return 0;
323 : : }
324 : :
325 : 0 : static int isarray(value_t v)
326 : : {
327 [ # # # # ]: 0 : return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != NULL;
328 : : }
329 : :
330 : 0 : static size_t predict_arraylen(fl_context_t *fl_ctx, value_t arg)
331 : : {
332 [ # # ]: 0 : if (isvector(arg))
333 : 0 : return vector_size(arg);
334 [ # # ]: 0 : else if (iscons(arg))
335 : 0 : return llength(arg);
336 [ # # ]: 0 : else if (arg == fl_ctx->NIL)
337 : 0 : return 0;
338 [ # # ]: 0 : if (isarray(arg))
339 : 0 : return cvalue_arraylen(arg);
340 : 0 : return 1;
341 : : }
342 : :
343 : 0 : static int cvalue_array_init(fl_context_t *fl_ctx, fltype_t *ft, value_t arg, void *dest)
344 : : {
345 : 0 : value_t type = ft->type;
346 : : size_t elsize, i, cnt, sz;
347 : 0 : fltype_t *eltype = ft->eltype;
348 : :
349 : 0 : elsize = ft->elsz;
350 : 0 : cnt = predict_arraylen(fl_ctx, arg);
351 : :
352 [ # # ]: 0 : if (iscons(cdr_(cdr_(type)))) {
353 : 0 : size_t tc = tosize(fl_ctx, car_(cdr_(cdr_(type))), "array");
354 [ # # ]: 0 : if (tc != cnt)
355 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "array: size mismatch");
356 : : }
357 : :
358 : 0 : sz = elsize * cnt;
359 : :
360 [ # # ]: 0 : if (isvector(arg)) {
361 [ # # ]: 0 : for(i=0; i < cnt; i++) {
362 : 0 : cvalue_init(fl_ctx, eltype, vector_elt(arg,i), dest);
363 : 0 : dest = (char *)dest + elsize;
364 : : }
365 : 0 : return 0;
366 : : }
367 [ # # # # ]: 0 : else if (iscons(arg) || arg==fl_ctx->NIL) {
368 : 0 : i = 0;
369 [ # # ]: 0 : while (iscons(arg)) {
370 [ # # ]: 0 : if (i == cnt) { i++; break; } // trigger error
371 : 0 : cvalue_init(fl_ctx, eltype, car_(arg), dest);
372 : 0 : i++;
373 : 0 : dest = (char *)dest + elsize;
374 : 0 : arg = cdr_(arg);
375 : : }
376 [ # # ]: 0 : if (i != cnt)
377 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "array: size mismatch");
378 : 0 : return 0;
379 : : }
380 [ # # ]: 0 : else if (iscvalue(arg)) {
381 : 0 : cvalue_t *cv = (cvalue_t*)ptr(arg);
382 [ # # ]: 0 : if (isarray(arg)) {
383 : 0 : fltype_t *aet = cv_class(cv)->eltype;
384 [ # # ]: 0 : if (aet == eltype) {
385 [ # # ]: 0 : if (cv_len(cv) == sz)
386 : 0 : memcpy(dest, cv_data(cv), sz);
387 : : else
388 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "array: size mismatch");
389 : 0 : return 0;
390 : : }
391 : : else {
392 : : // TODO: initialize array from different type elements
393 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "array: element type mismatch");
394 : : }
395 : : }
396 : : }
397 [ # # ]: 0 : if (cnt == 1)
398 : 0 : cvalue_init(fl_ctx, eltype, arg, dest);
399 : : else
400 : 0 : type_error(fl_ctx, "array", "sequence", arg);
401 : 0 : return 0;
402 : : }
403 : :
404 : 0 : value_t cvalue_array(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
405 : : {
406 : : size_t elsize, cnt, sz, i;
407 : : value_t arg;
408 : :
409 [ # # ]: 0 : if (nargs < 1)
410 : 0 : argcount(fl_ctx, "array", nargs, 1);
411 : :
412 : 0 : cnt = nargs - 1;
413 : 0 : fltype_t *type = get_array_type(fl_ctx, args[0]);
414 : 0 : elsize = type->elsz;
415 : 0 : sz = elsize * cnt;
416 : :
417 : 0 : value_t cv = cvalue(fl_ctx, type, sz);
418 : 0 : char *dest = (char*)cv_data((cvalue_t*)ptr(cv));
419 [ # # ]: 0 : FOR_ARGS(i,1,arg,args) {
420 : 0 : cvalue_init(fl_ctx, type->eltype, arg, dest);
421 : 0 : dest += elsize;
422 : : }
423 : 0 : return cv;
424 : : }
425 : :
426 : : // NOTE: v must be an array
427 : 158040 : size_t cvalue_arraylen(value_t v)
428 : : {
429 : 158040 : cvalue_t *cv = (cvalue_t*)ptr(v);
430 : 158040 : return cv_len(cv)/(cv_class(cv)->elsz);
431 : : }
432 : :
433 : : // *palign is an output argument giving the alignment required by type
434 : 666684 : size_t ctype_sizeof(fl_context_t *fl_ctx, value_t type, int *palign)
435 : : {
436 [ + + + + : 666684 : if (type == fl_ctx->int8sym || type == fl_ctx->uint8sym || type == fl_ctx->bytesym) {
+ + ]
437 : 666354 : *palign = 1;
438 : 666354 : return 1;
439 : : }
440 [ + + + + ]: 330 : if (type == fl_ctx->int16sym || type == fl_ctx->uint16sym) {
441 : 60 : *palign = ALIGN2;
442 : 60 : return 2;
443 : : }
444 [ + + + + : 270 : if (type == fl_ctx->int32sym || type == fl_ctx->uint32sym || type == fl_ctx->wcharsym ||
+ + ]
445 [ + + ]: 180 : type == fl_ctx->floatsym) {
446 : 120 : *palign = ALIGN4;
447 : 120 : return 4;
448 : : }
449 [ + + + + : 150 : if (type == fl_ctx->int64sym || type == fl_ctx->uint64sym || type == fl_ctx->doublesym) {
+ + ]
450 : 90 : *palign = ALIGN8;
451 : 90 : return 8;
452 : : }
453 [ + + + - ]: 60 : if (type == fl_ctx->ptrdiffsym || type == fl_ctx->sizesym) {
454 : : #ifdef _P64
455 : 60 : *palign = ALIGN8;
456 : 60 : return 8;
457 : : #else
458 : : *palign = ALIGN4;
459 : : return 4;
460 : : #endif
461 : : }
462 [ # # ]: 0 : if (iscons(type)) {
463 : 0 : value_t hed = car_(type);
464 [ # # # # ]: 0 : if (hed == fl_ctx->pointersym || hed == fl_ctx->cfunctionsym) {
465 : 0 : *palign = ALIGNPTR;
466 : 0 : return sizeof(void*);
467 : : }
468 [ # # ]: 0 : if (hed == fl_ctx->arraysym) {
469 : 0 : value_t t = car(fl_ctx, cdr_(type));
470 [ # # ]: 0 : if (!iscons(cdr_(cdr_(type))))
471 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "sizeof: incomplete type");
472 : 0 : value_t n = car_(cdr_(cdr_(type)));
473 : 0 : size_t sz = tosize(fl_ctx, n, "sizeof");
474 : 0 : return sz * ctype_sizeof(fl_ctx, t, palign);
475 : : }
476 : : }
477 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "sizeof: invalid c type");
478 : : return 0;
479 : : }
480 : :
481 : : // get pointer and size for any plain-old-data value
482 : 257948 : void to_sized_ptr(fl_context_t *fl_ctx, value_t v, const char *fname, char **pdata, size_t *psz)
483 : : {
484 [ + - ]: 257948 : if (iscvalue(v)) {
485 : 257948 : cvalue_t *pcv = (cvalue_t*)ptr(v);
486 : 257948 : ios_t *x = value2c(ios_t*,v);
487 [ - + - - ]: 257948 : if (cv_class(pcv) == fl_ctx->iostreamtype && (x->bm == bm_mem)) {
488 : 0 : *pdata = x->buf;
489 : 0 : *psz = (size_t)x->size;
490 : 0 : return;
491 : : }
492 [ + - ]: 257948 : else if (cv_isPOD(pcv)) {
493 : 257948 : *pdata = (char*)cv_data(pcv);
494 : 257948 : *psz = cv_len(pcv);
495 : 257948 : return;
496 : : }
497 : : }
498 [ # # ]: 0 : else if (iscprim(v)) {
499 : 0 : cprim_t *pcp = (cprim_t*)ptr(v);
500 : 0 : *pdata = cp_data(pcp);
501 : 0 : *psz = cp_class(pcp)->size;
502 : 0 : return;
503 : : }
504 : 0 : type_error(fl_ctx, fname, "plain-old-data", v);
505 : : }
506 : :
507 : 17994 : value_t cvalue_sizeof(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
508 : : {
509 : 17994 : argcount(fl_ctx, "sizeof", nargs, 1);
510 [ + - - + ]: 17994 : if (issymbol(args[0]) || iscons(args[0])) {
511 : : int a;
512 : 0 : return size_wrap(fl_ctx, ctype_sizeof(fl_ctx, args[0], &a));
513 : : }
514 : : size_t n; char *data;
515 : 17994 : to_sized_ptr(fl_ctx, args[0], "sizeof", &data, &n);
516 : 17994 : return size_wrap(fl_ctx, n);
517 : : }
518 : :
519 : 23089800 : value_t cvalue_typeof(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
520 : : {
521 : 23089800 : argcount(fl_ctx, "typeof", nargs, 1);
522 [ + - + - : 23089800 : switch(tag(args[0])) {
+ + ]
523 : 19638520 : case TAG_CONS: return fl_ctx->pairsym;
524 : 0 : case TAG_NUM1:
525 : 0 : case TAG_NUM: return fl_ctx->fixnumsym;
526 : 2501820 : case TAG_SYM: return fl_ctx->symbolsym;
527 : 0 : case TAG_VECTOR: return fl_ctx->vectorsym;
528 : 64 : case TAG_FUNCTION:
529 [ + - + + ]: 64 : if (args[0] == fl_ctx->T || args[0] == fl_ctx->F)
530 : 48 : return fl_ctx->booleansym;
531 [ - + ]: 16 : if (args[0] == fl_ctx->NIL)
532 : 0 : return fl_ctx->nullsym;
533 [ + - ]: 16 : if (args[0] == fl_ctx->FL_EOF)
534 : 16 : return symbol(fl_ctx, "eof-object");
535 [ # # # # ]: 0 : if (isbuiltin(args[0]))
536 : 0 : return fl_ctx->builtinsym;
537 : 0 : return fl_ctx->FUNCTION;
538 : : }
539 : 949442 : return cv_type((cvalue_t*)ptr(args[0]));
540 : : }
541 : :
542 : 9920320 : static value_t cvalue_relocate(fl_context_t *fl_ctx, value_t v)
543 : : {
544 : : size_t nw;
545 : 9920320 : cvalue_t *cv = (cvalue_t*)ptr(v);
546 : : cvalue_t *nv;
547 : : value_t ncv;
548 : :
549 : 9920320 : nw = cv_nwords(fl_ctx, cv);
550 : 9920320 : nv = (cvalue_t*)alloc_words(fl_ctx, nw);
551 : 9920320 : memcpy(nv, cv, nw*sizeof(value_t));
552 [ + + ]: 9920320 : if (isinlined(cv))
553 : 2586240 : nv->data = &nv->_space[0];
554 : 9920320 : ncv = tagptr(nv, TAG_CVALUE);
555 : 9920320 : fltype_t *t = cv_class(cv);
556 [ + + + - ]: 9920320 : if (t->vtable != NULL && t->vtable->relocate != NULL)
557 : 174032 : t->vtable->relocate(fl_ctx, v, ncv);
558 : 9920320 : forward(v, ncv);
559 : 9920320 : return ncv;
560 : : }
561 : :
562 : 0 : value_t cvalue_copy(fl_context_t *fl_ctx, value_t v)
563 : : {
564 [ # # ]: 0 : assert(iscvalue(v));
565 : 0 : PUSH(fl_ctx, v);
566 : 0 : cvalue_t *cv = (cvalue_t*)ptr(v);
567 : 0 : size_t nw = cv_nwords(fl_ctx, cv);
568 : 0 : cvalue_t *ncv = (cvalue_t*)alloc_words(fl_ctx, nw);
569 : 0 : v = POP(fl_ctx); cv = (cvalue_t*)ptr(v);
570 : 0 : memcpy(ncv, cv, nw * sizeof(value_t));
571 [ # # ]: 0 : if (!isinlined(cv)) {
572 : 0 : size_t len = cv_len(cv);
573 [ # # ]: 0 : if (cv_isstr(fl_ctx, cv)) len++;
574 : 0 : ncv->data = malloc(len);
575 : : // TODO: if ncv->data == NULL
576 : 0 : memcpy(ncv->data, cv_data(cv), len);
577 : 0 : autorelease(fl_ctx, ncv);
578 [ # # ]: 0 : if (hasparent(cv)) {
579 : 0 : ncv->type = (fltype_t*)(((uintptr_t)ncv->type) & ~CV_PARENT_BIT);
580 : 0 : ncv->parent = fl_ctx->NIL;
581 : : }
582 : : }
583 : : else {
584 : 0 : ncv->data = &ncv->_space[0];
585 : : }
586 : :
587 : 0 : return tagptr(ncv, TAG_CVALUE);
588 : : }
589 : :
590 : 0 : value_t fl_copy(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
591 : : {
592 : 0 : argcount(fl_ctx, "copy", nargs, 1);
593 [ # # # # ]: 0 : if (iscons(args[0]) || isvector(args[0]))
594 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "copy: argument must be a leaf atom");
595 [ # # ]: 0 : if (!iscvalue(args[0]))
596 : 0 : return args[0];
597 [ # # ]: 0 : if (!cv_isPOD((cvalue_t*)ptr(args[0])))
598 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "copy: argument must be a plain-old-data type");
599 : 0 : return cvalue_copy(fl_ctx, args[0]);
600 : : }
601 : :
602 : 0 : value_t fl_podp(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
603 : : {
604 : 0 : argcount(fl_ctx, "plain-old-data?", nargs, 1);
605 : 0 : return (iscprim(args[0]) ||
606 [ # # # # ]: 0 : (iscvalue(args[0]) && cv_isPOD((cvalue_t*)ptr(args[0])))) ?
607 [ # # ]: 0 : fl_ctx->T : fl_ctx->F;
608 : : }
609 : :
610 : 0 : static void cvalue_init(fl_context_t *fl_ctx, fltype_t *type, value_t v, void *dest)
611 : : {
612 : 0 : cvinitfunc_t f=type->init;
613 : :
614 [ # # ]: 0 : if (f == NULL)
615 : 0 : lerror(fl_ctx, fl_ctx->ArgError, "c-value: invalid c type");
616 : :
617 : 0 : f(fl_ctx, type, v, dest);
618 : 0 : }
619 : :
620 : 444 : static numerictype_t sym_to_numtype(fl_context_t *fl_ctx, value_t type)
621 : : {
622 [ + + ]: 444 : if (type == fl_ctx->int8sym)
623 : 30 : return T_INT8;
624 [ + + + + ]: 414 : else if (type == fl_ctx->uint8sym || type == fl_ctx->bytesym)
625 : 60 : return T_UINT8;
626 [ + + ]: 354 : else if (type == fl_ctx->int16sym)
627 : 30 : return T_INT16;
628 [ + + ]: 324 : else if (type == fl_ctx->uint16sym)
629 : 30 : return T_UINT16;
630 : : #ifdef _P64
631 [ + + + + ]: 294 : else if (type == fl_ctx->int32sym || type == fl_ctx->wcharsym)
632 : : #else
633 : : else if (type == fl_ctx->int32sym || type == fl_ctx->wcharsym || type == fl_ctx->ptrdiffsym)
634 : : #endif
635 : 60 : return T_INT32;
636 : : #ifdef _P64
637 [ + + ]: 234 : else if (type == fl_ctx->uint32sym)
638 : : #else
639 : : else if (type == fl_ctx->uint32sym || type == fl_ctx->sizesym)
640 : : #endif
641 : 30 : return T_UINT32;
642 : : #ifdef _P64
643 [ + + + + ]: 204 : else if (type == fl_ctx->int64sym || type == fl_ctx->ptrdiffsym)
644 : : #else
645 : : else if (type == fl_ctx->int64sym)
646 : : #endif
647 : 60 : return T_INT64;
648 : : #ifdef _P64
649 [ + + + + ]: 144 : else if (type == fl_ctx->uint64sym || type == fl_ctx->sizesym)
650 : : #else
651 : : else if (type == fl_ctx->uint64sym)
652 : : #endif
653 : 60 : return T_UINT64;
654 [ + + ]: 84 : else if (type == fl_ctx->floatsym)
655 : 30 : return T_FLOAT;
656 [ + + ]: 54 : else if (type == fl_ctx->doublesym)
657 : 30 : return T_DOUBLE;
658 : 24 : return (numerictype_t)N_NUMTYPES;
659 : : }
660 : :
661 : : // (new type . args)
662 : : // this provides (1) a way to allocate values with a shared type for
663 : : // efficiency, (2) a uniform interface for allocating cvalues of any
664 : : // type, including user-defined.
665 : 0 : value_t cvalue_new(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
666 : : {
667 [ # # # # ]: 0 : if (nargs < 1 || nargs > 2)
668 : 0 : argcount(fl_ctx, "c-value", nargs, 2);
669 : 0 : value_t type = args[0];
670 : 0 : fltype_t *ft = get_type(fl_ctx, type);
671 : : value_t cv;
672 [ # # ]: 0 : if (ft->eltype != NULL) {
673 : : // special case to handle incomplete array types bla[]
674 : 0 : size_t elsz = ft->elsz;
675 : : size_t cnt;
676 : :
677 [ # # ]: 0 : if (iscons(cdr_(cdr_(type))))
678 : 0 : cnt = tosize(fl_ctx, car_(cdr_(cdr_(type))), "array");
679 [ # # ]: 0 : else if (nargs == 2)
680 : 0 : cnt = predict_arraylen(fl_ctx, args[1]);
681 : : else
682 : 0 : cnt = 0;
683 : 0 : cv = cvalue(fl_ctx, ft, elsz * cnt);
684 [ # # ]: 0 : if (nargs == 2)
685 : 0 : cvalue_array_init(fl_ctx, ft, args[1], cv_data((cvalue_t*)ptr(cv)));
686 : : }
687 : : else {
688 : 0 : cv = cvalue(fl_ctx, ft, ft->size);
689 [ # # ]: 0 : if (nargs == 2)
690 [ # # ]: 0 : cvalue_init(fl_ctx, ft, args[1], cptr(cv));
691 : : }
692 : 0 : return cv;
693 : : }
694 : :
695 : : // NOTE: this only compares lexicographically; it ignores numeric formats
696 : 235660 : value_t cvalue_compare(value_t a, value_t b)
697 : : {
698 : 235660 : cvalue_t *ca = (cvalue_t*)ptr(a);
699 : 235660 : cvalue_t *cb = (cvalue_t*)ptr(b);
700 : 235660 : char *adata = (char*)cv_data(ca);
701 : 235660 : char *bdata = (char*)cv_data(cb);
702 : 235660 : size_t asz = cv_len(ca);
703 : 235660 : size_t bsz = cv_len(cb);
704 : 235660 : size_t minsz = asz < bsz ? asz : bsz;
705 : 235660 : int diff = memcmp(adata, bdata, minsz);
706 [ + + ]: 235660 : if (diff == 0) {
707 [ + + ]: 235640 : if (asz > bsz)
708 : 235632 : return fixnum(1);
709 [ - + ]: 8 : else if (asz < bsz)
710 : 0 : return fixnum(-1);
711 : : }
712 : 28 : return fixnum(diff);
713 : : }
714 : :
715 : 0 : static void check_addr_args(fl_context_t *fl_ctx, const char *fname, value_t arr,
716 : : value_t ind, char **data, size_t *index)
717 : : {
718 : : size_t numel;
719 : 0 : cvalue_t *cv = (cvalue_t*)ptr(arr);
720 : 0 : *data = (char*)cv_data(cv);
721 : 0 : numel = cv_len(cv)/(cv_class(cv)->elsz);
722 : 0 : *index = tosize(fl_ctx, ind, fname);
723 [ # # ]: 0 : if (*index >= numel)
724 : 0 : bounds_error(fl_ctx, fname, arr, ind);
725 : 0 : }
726 : :
727 : 0 : static value_t cvalue_array_aref(fl_context_t *fl_ctx, value_t *args)
728 : : {
729 : : char *data; size_t index;
730 : 0 : fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
731 : 0 : value_t el = 0;
732 : 0 : numerictype_t nt = eltype->numtype;
733 [ # # ]: 0 : if (nt >= T_INT32)
734 : 0 : el = cvalue(fl_ctx, eltype, eltype->size);
735 : 0 : check_addr_args(fl_ctx, "aref", args[0], args[1], &data, &index);
736 [ # # ]: 0 : if (nt < T_INT32) {
737 [ # # ]: 0 : if (nt == T_INT8)
738 : 0 : return fixnum((int8_t)data[index]);
739 [ # # ]: 0 : else if (nt == T_UINT8)
740 : 0 : return fixnum((uint8_t)data[index]);
741 [ # # ]: 0 : else if (nt == T_INT16)
742 : 0 : return fixnum(((int16_t*)data)[index]);
743 : 0 : return fixnum(((uint16_t*)data)[index]);
744 : : }
745 [ # # ]: 0 : char *dest = (char*)cptr(el);
746 : 0 : size_t sz = eltype->size;
747 [ # # ]: 0 : if (sz == 1)
748 : 0 : *dest = data[index];
749 [ # # ]: 0 : else if (sz == 2)
750 : 0 : *(int16_t*)dest = ((int16_t*)data)[index];
751 [ # # ]: 0 : else if (sz == 4)
752 : 0 : *(int32_t*)dest = ((int32_t*)data)[index];
753 [ # # ]: 0 : else if (sz == 8)
754 : 0 : *(int64_t*)dest = ((int64_t*)data)[index];
755 : : else
756 : 0 : memcpy(dest, data + index*sz, sz);
757 : 0 : return el;
758 : : }
759 : :
760 : 0 : static value_t cvalue_array_aset(fl_context_t *fl_ctx, value_t *args)
761 : : {
762 : : char *data; size_t index;
763 : 0 : fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
764 : 0 : check_addr_args(fl_ctx, "aset!", args[0], args[1], &data, &index);
765 : 0 : char *dest = data + index*eltype->size;
766 : 0 : cvalue_init(fl_ctx, eltype, args[2], dest);
767 : 0 : return args[2];
768 : : }
769 : :
770 : 37500 : value_t fl_builtin(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
771 : : {
772 : 37500 : argcount(fl_ctx, "builtin", nargs, 1);
773 : 37500 : symbol_t *name = tosymbol(fl_ctx, args[0], "builtin");
774 : : cvalue_t *cv;
775 [ - + - - : 37500 : if (ismanaged(fl_ctx, args[0]) || (cv=(cvalue_t*)name->dlcache) == NULL) {
- + ]
776 : 0 : lerrorf(fl_ctx, fl_ctx->ArgError, "builtin: function %s not found", name->name);
777 : : }
778 : 37500 : return tagptr(cv, TAG_CVALUE);
779 : : }
780 : :
781 : 3660 : value_t cbuiltin(fl_context_t *fl_ctx, const char *name, builtin_t f)
782 : : {
783 : 3660 : cvalue_t *cv = (cvalue_t*)malloc(CVALUE_NWORDS * sizeof(value_t));
784 : : // TODO: if cv->data == NULL
785 : 3660 : cv->type = fl_ctx->builtintype;
786 : 3660 : cv->data = &cv->_space[0];
787 : 3660 : cv->len = sizeof(value_t);
788 : 3660 : *(void**)cv->data = (void*)(uintptr_t)f;
789 : :
790 : 3660 : value_t sym = symbol(fl_ctx, name);
791 : 3660 : ((symbol_t*)ptr(sym))->dlcache = cv;
792 : 3660 : ptrhash_put(&fl_ctx->reverse_dlsym_lookup_table, cv, (void*)sym);
793 : :
794 : 3660 : return tagptr(cv, TAG_CVALUE);
795 : : }
796 : :
797 : : static value_t fl_logand(fl_context_t *fl_ctx, value_t *args, uint32_t nargs);
798 : : static value_t fl_logior(fl_context_t *fl_ctx, value_t *args, uint32_t nargs);
799 : : static value_t fl_logxor(fl_context_t *fl_ctx, value_t *args, uint32_t nargs);
800 : : static value_t fl_lognot(fl_context_t *fl_ctx, value_t *args, uint32_t nargs);
801 : : static value_t fl_ash(fl_context_t *fl_ctx, value_t *args, uint32_t nargs);
802 : :
803 : : static const builtinspec_t cvalues_builtin_info[] = {
804 : : { "c-value", cvalue_new },
805 : : { "typeof", cvalue_typeof },
806 : : { "sizeof", cvalue_sizeof },
807 : : { "builtin", fl_builtin },
808 : : { "copy", fl_copy },
809 : : { "plain-old-data?", fl_podp },
810 : :
811 : : { "logand", fl_logand },
812 : : { "logior", fl_logior },
813 : : { "logxor", fl_logxor },
814 : : { "lognot", fl_lognot },
815 : : { "ash", fl_ash },
816 : : // todo: autorelease
817 : : { NULL, NULL }
818 : : };
819 : :
820 : : #define cv_intern(fl_ctx, tok) fl_ctx->tok##sym = symbol(fl_ctx, #tok)
821 : : #define ctor_cv_intern(fl_ctx, tok) \
822 : : cv_intern(fl_ctx, tok); \
823 : : set(fl_ctx->tok##sym, cbuiltin(fl_ctx, #tok, cvalue_##tok))
824 : :
825 : : #define mk_primtype(fl_ctx, name) \
826 : : fl_ctx->name##type = get_type(fl_ctx, fl_ctx->name##sym); \
827 : : fl_ctx->name##type->init = &cvalue_##name##_init
828 : :
829 : : #define mk_primtype_(fl_ctx, name, ctype) \
830 : : fl_ctx->name##type = get_type(fl_ctx, fl_ctx->name##sym); \
831 : : fl_ctx->name##type->init = &cvalue_##ctype##_init
832 : :
833 : 30 : static void cvalues_init(fl_context_t *fl_ctx)
834 : : {
835 : 30 : fl_ctx->malloc_pressure = 0;
836 : 30 : fl_ctx->Finalizers = NULL;
837 : 30 : fl_ctx->nfinalizers = 0;
838 : 30 : fl_ctx->maxfinalizers = 0;
839 : :
840 : 30 : htable_new(&fl_ctx->TypeTable, 256);
841 : 30 : htable_new(&fl_ctx->reverse_dlsym_lookup_table, 256);
842 : :
843 : 30 : fl_ctx->builtintype = define_opaque_type(fl_ctx->builtinsym, sizeof(builtin_t), NULL, NULL);
844 : :
845 : 30 : ctor_cv_intern(fl_ctx, int8);
846 : 30 : ctor_cv_intern(fl_ctx, uint8);
847 : 30 : ctor_cv_intern(fl_ctx, int16);
848 : 30 : ctor_cv_intern(fl_ctx, uint16);
849 : 30 : ctor_cv_intern(fl_ctx, int32);
850 : 30 : ctor_cv_intern(fl_ctx, uint32);
851 : 30 : ctor_cv_intern(fl_ctx, int64);
852 : 30 : ctor_cv_intern(fl_ctx, uint64);
853 : 30 : ctor_cv_intern(fl_ctx, byte);
854 : 30 : ctor_cv_intern(fl_ctx, wchar);
855 : 30 : ctor_cv_intern(fl_ctx, ptrdiff);
856 : 30 : ctor_cv_intern(fl_ctx, size);
857 : 30 : ctor_cv_intern(fl_ctx, float);
858 : 30 : ctor_cv_intern(fl_ctx, double);
859 : :
860 : 30 : ctor_cv_intern(fl_ctx, array);
861 : 30 : cv_intern(fl_ctx, pointer);
862 : 30 : cv_intern(fl_ctx, void);
863 : 30 : fl_ctx->cfunctionsym = symbol(fl_ctx, "c-function");
864 : :
865 : 30 : assign_global_builtins(fl_ctx, cvalues_builtin_info);
866 : :
867 : 30 : fl_ctx->stringtypesym = symbol(fl_ctx, "*string-type*");
868 : 30 : setc(fl_ctx->stringtypesym, fl_list2(fl_ctx, fl_ctx->arraysym, fl_ctx->bytesym));
869 : :
870 : 30 : fl_ctx->wcstringtypesym = symbol(fl_ctx, "*wcstring-type*");
871 : 30 : setc(fl_ctx->wcstringtypesym, fl_list2(fl_ctx, fl_ctx->arraysym, fl_ctx->wcharsym));
872 : :
873 : 30 : mk_primtype(fl_ctx, int8);
874 : 30 : mk_primtype(fl_ctx, uint8);
875 : 30 : mk_primtype(fl_ctx, int16);
876 : 30 : mk_primtype(fl_ctx, uint16);
877 : 30 : mk_primtype(fl_ctx, int32);
878 : 30 : mk_primtype(fl_ctx, uint32);
879 : 30 : mk_primtype(fl_ctx, int64);
880 : 30 : mk_primtype(fl_ctx, uint64);
881 : : #ifdef _P64
882 : 30 : mk_primtype_(fl_ctx, ptrdiff, int64);
883 : 30 : mk_primtype_(fl_ctx, size, uint64);
884 : : #else
885 : : mk_primtype_(fl_ctx, ptrdiff, int32);
886 : : mk_primtype_(fl_ctx, size, uint32);
887 : : #endif
888 : 30 : mk_primtype_(fl_ctx, byte, uint8);
889 : 30 : mk_primtype_(fl_ctx, wchar, int32);
890 : 30 : mk_primtype(fl_ctx, float);
891 : 30 : mk_primtype(fl_ctx, double);
892 : :
893 : 30 : fl_ctx->stringtype = get_type(fl_ctx, symbol_value(fl_ctx->stringtypesym));
894 : 30 : fl_ctx->wcstringtype = get_type(fl_ctx, symbol_value(fl_ctx->wcstringtypesym));
895 : :
896 : 30 : fl_ctx->emptystringsym = symbol(fl_ctx, "*empty-string*");
897 : 30 : setc(fl_ctx->emptystringsym, cvalue_static_cstring(fl_ctx, ""));
898 : 30 : }
899 : :
900 : : #define RETURN_NUM_AS(fl_ctx, var, type) return(mk_##type(fl_ctx, (fl_##type##_t)var))
901 : :
902 : 753424 : value_t return_from_uint64(fl_context_t *fl_ctx, uint64_t Uaccum)
903 : : {
904 [ + + - + ]: 753424 : if (fits_fixnum(Uaccum)) {
905 : 751056 : return fixnum((fixnum_t)Uaccum);
906 : : }
907 [ + + ]: 2368 : if (Uaccum > (uint64_t)S64_MAX) {
908 : 1646 : RETURN_NUM_AS(fl_ctx, Uaccum, uint64);
909 : : }
910 [ + - ]: 722 : else if (Uaccum > (uint64_t)INT_MAX) {
911 : 722 : RETURN_NUM_AS(fl_ctx, Uaccum, int64);
912 : : }
913 : 0 : RETURN_NUM_AS(fl_ctx, Uaccum, int32);
914 : : }
915 : :
916 : 5916 : value_t return_from_int64(fl_context_t *fl_ctx, int64_t Saccum)
917 : : {
918 [ + + + + ]: 5916 : if (fits_fixnum(Saccum)) {
919 : 5880 : return fixnum((fixnum_t)Saccum);
920 : : }
921 [ + - + - ]: 36 : if (Saccum > (int64_t)INT_MAX || Saccum < (int64_t)INT_MIN) {
922 : 36 : RETURN_NUM_AS(fl_ctx, Saccum, int64);
923 : : }
924 : 0 : RETURN_NUM_AS(fl_ctx, Saccum, int32);
925 : : }
926 : :
927 : 0 : static value_t fl_add_any(fl_context_t *fl_ctx, value_t *args, uint32_t nargs, fixnum_t carryIn)
928 : : {
929 : 0 : uint64_t Uaccum=0;
930 : 0 : int64_t Saccum = carryIn;
931 : 0 : double Faccum=0;
932 : : uint32_t i;
933 : 0 : value_t arg=fl_ctx->NIL;
934 : :
935 [ # # ]: 0 : FOR_ARGS(i,0,arg,args) {
936 [ # # ]: 0 : if (isfixnum(arg)) {
937 : 0 : Saccum += numval(arg);
938 : 0 : continue;
939 : : }
940 [ # # ]: 0 : else if (iscprim(arg)) {
941 : 0 : cprim_t *cp = (cprim_t*)ptr(arg);
942 : 0 : void *a = cp_data(cp);
943 : : int64_t i64;
944 [ # # # # : 0 : switch(cp_numtype(cp)) {
# # # # #
# # ]
945 : 0 : case T_INT8: Saccum += *(int8_t*)a; break;
946 : 0 : case T_UINT8: Saccum += *(uint8_t*)a; break;
947 : 0 : case T_INT16: Saccum += *(int16_t*)a; break;
948 : 0 : case T_UINT16: Saccum += *(uint16_t*)a; break;
949 : 0 : case T_INT32: Saccum += *(int32_t*)a; break;
950 : 0 : case T_UINT32: Saccum += *(uint32_t*)a; break;
951 : 0 : case T_INT64:
952 : 0 : i64 = *(int64_t*)a;
953 [ # # ]: 0 : if (i64 > 0)
954 : 0 : Uaccum += (uint64_t)i64;
955 : : else
956 : 0 : Saccum += i64;
957 : 0 : break;
958 : 0 : case T_UINT64: Uaccum += *(uint64_t*)a; break;
959 : 0 : case T_FLOAT: Faccum += *(float*)a; break;
960 : 0 : case T_DOUBLE: Faccum += *(double*)a; break;
961 : 0 : default:
962 : 0 : goto add_type_error;
963 : : }
964 : 0 : continue;
965 : : }
966 : 0 : add_type_error:
967 : 0 : type_error(fl_ctx, "+", "number", arg);
968 : : }
969 [ # # ]: 0 : if (Faccum != 0) {
970 : 0 : Faccum += Uaccum;
971 : 0 : Faccum += Saccum;
972 : 0 : return mk_double(fl_ctx, Faccum);
973 : : }
974 [ # # ]: 0 : else if (Saccum < 0) {
975 : 0 : uint64_t negpart = (uint64_t)(-Saccum);
976 [ # # ]: 0 : if (negpart > Uaccum) {
977 : 0 : Saccum += (int64_t)Uaccum;
978 : : // return value in Saccum
979 [ # # ]: 0 : if (Saccum >= INT_MIN) {
980 [ # # # # ]: 0 : if (fits_fixnum(Saccum)) {
981 : 0 : return fixnum((fixnum_t)Saccum);
982 : : }
983 : 0 : RETURN_NUM_AS(fl_ctx, Saccum, int32);
984 : : }
985 : 0 : RETURN_NUM_AS(fl_ctx, Saccum, int64);
986 : : }
987 : 0 : Uaccum -= negpart;
988 : : }
989 : : else {
990 : 0 : Uaccum += (uint64_t)Saccum;
991 : : }
992 : : // return value in Uaccum
993 : 0 : return return_from_uint64(fl_ctx, Uaccum);
994 : : }
995 : :
996 : 0 : static value_t fl_neg(fl_context_t *fl_ctx, value_t n)
997 : : {
998 [ # # ]: 0 : if (isfixnum(n)) {
999 : 0 : return fixnum(-numval(n));
1000 : : }
1001 [ # # ]: 0 : else if (iscprim(n)) {
1002 : 0 : cprim_t *cp = (cprim_t*)ptr(n);
1003 : 0 : void *a = cp_data(cp);
1004 : : uint32_t ui32;
1005 : : int32_t i32;
1006 : : int64_t i64;
1007 [ # # # # : 0 : switch(cp_numtype(cp)) {
# # # # #
# # ]
1008 : 0 : case T_INT8: return fixnum(-(int32_t)*(int8_t*)a);
1009 : 0 : case T_UINT8: return fixnum(-(int32_t)*(uint8_t*)a);
1010 : 0 : case T_INT16: return fixnum(-(int32_t)*(int16_t*)a);
1011 : 0 : case T_UINT16: return fixnum(-(int32_t)*(uint16_t*)a);
1012 : 0 : case T_INT32:
1013 : 0 : i32 = *(int32_t*)a;
1014 [ # # ]: 0 : if (i32 == (int32_t)BIT31)
1015 : 0 : return mk_uint32(fl_ctx, (uint32_t)BIT31);
1016 : 0 : return mk_int32(fl_ctx, -i32);
1017 : 0 : case T_UINT32:
1018 : 0 : ui32 = *(uint32_t*)a;
1019 [ # # ]: 0 : if (ui32 <= ((uint32_t)INT_MAX)+1) return mk_int32(fl_ctx, -(int32_t)ui32);
1020 : 0 : return mk_int64(fl_ctx, -(int64_t)ui32);
1021 : 0 : case T_INT64:
1022 : 0 : i64 = *(int64_t*)a;
1023 [ # # ]: 0 : if (i64 == (int64_t)BIT63)
1024 : 0 : return mk_uint64(fl_ctx, (uint64_t)BIT63);
1025 : 0 : return mk_int64(fl_ctx, -i64);
1026 : 0 : case T_UINT64: return mk_int64(fl_ctx, -(int64_t)*(uint64_t*)a);
1027 : 0 : case T_FLOAT: return mk_float(fl_ctx, -*(float*)a);
1028 : 0 : case T_DOUBLE: return mk_double(fl_ctx, -*(double*)a);
1029 : : break;
1030 : : }
1031 : : }
1032 : 0 : type_error(fl_ctx, "-", "number", n);
1033 : : }
1034 : :
1035 : 0 : static value_t fl_mul_any(fl_context_t *fl_ctx, value_t *args, uint32_t nargs, int64_t Saccum)
1036 : : {
1037 : 0 : uint64_t Uaccum=1;
1038 : 0 : double Faccum=1;
1039 : : uint32_t i;
1040 : 0 : value_t arg=fl_ctx->NIL;
1041 : :
1042 [ # # ]: 0 : FOR_ARGS(i,0,arg,args) {
1043 [ # # ]: 0 : if (isfixnum(arg)) {
1044 : 0 : Saccum *= numval(arg);
1045 : 0 : continue;
1046 : : }
1047 [ # # ]: 0 : else if (iscprim(arg)) {
1048 : 0 : cprim_t *cp = (cprim_t*)ptr(arg);
1049 : 0 : void *a = cp_data(cp);
1050 : : int64_t i64;
1051 [ # # # # : 0 : switch(cp_numtype(cp)) {
# # # # #
# # ]
1052 : 0 : case T_INT8: Saccum *= *(int8_t*)a; break;
1053 : 0 : case T_UINT8: Saccum *= *(uint8_t*)a; break;
1054 : 0 : case T_INT16: Saccum *= *(int16_t*)a; break;
1055 : 0 : case T_UINT16: Saccum *= *(uint16_t*)a; break;
1056 : 0 : case T_INT32: Saccum *= *(int32_t*)a; break;
1057 : 0 : case T_UINT32: Saccum *= *(uint32_t*)a; break;
1058 : 0 : case T_INT64:
1059 : 0 : i64 = *(int64_t*)a;
1060 [ # # ]: 0 : if (i64 > 0)
1061 : 0 : Uaccum *= (uint64_t)i64;
1062 : : else
1063 : 0 : Saccum *= i64;
1064 : 0 : break;
1065 : 0 : case T_UINT64: Uaccum *= *(uint64_t*)a; break;
1066 : 0 : case T_FLOAT: Faccum *= *(float*)a; break;
1067 : 0 : case T_DOUBLE: Faccum *= *(double*)a; break;
1068 : 0 : default:
1069 : 0 : goto mul_type_error;
1070 : : }
1071 : 0 : continue;
1072 : : }
1073 : 0 : mul_type_error:
1074 : 0 : type_error(fl_ctx, "*", "number", arg);
1075 : : }
1076 [ # # ]: 0 : if (Faccum != 1) {
1077 : 0 : Faccum *= Uaccum;
1078 : 0 : Faccum *= Saccum;
1079 : 0 : return mk_double(fl_ctx, Faccum);
1080 : : }
1081 [ # # ]: 0 : else if (Saccum < 0) {
1082 : 0 : Saccum *= (int64_t)Uaccum;
1083 [ # # ]: 0 : if (Saccum >= INT_MIN) {
1084 [ # # # # ]: 0 : if (fits_fixnum(Saccum)) {
1085 : 0 : return fixnum((fixnum_t)Saccum);
1086 : : }
1087 : 0 : RETURN_NUM_AS(fl_ctx, Saccum, int32);
1088 : : }
1089 : 0 : RETURN_NUM_AS(fl_ctx, Saccum, int64);
1090 : : }
1091 : : else {
1092 : 0 : Uaccum *= (uint64_t)Saccum;
1093 : : }
1094 : 0 : return return_from_uint64(fl_ctx, Uaccum);
1095 : : }
1096 : :
1097 : 299310000 : static int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp)
1098 : : {
1099 : : cprim_t *cp;
1100 [ + + ]: 299310000 : if (isfixnum(a)) {
1101 : 318504 : *pi = numval(a);
1102 : 318504 : *pp = pi;
1103 : 318504 : *pt = T_FIXNUM;
1104 : : }
1105 [ + + ]: 298992000 : else if (iscprim(a)) {
1106 : 298984000 : cp = (cprim_t*)ptr(a);
1107 : 298984000 : *pp = cp_data(cp);
1108 : 298984000 : *pt = cp_numtype(cp);
1109 : : }
1110 : : else {
1111 : 6566 : return 0;
1112 : : }
1113 : 299304000 : return 1;
1114 : : }
1115 : :
1116 : : /*
1117 : : returns -1, 0, or 1 based on ordering of a and b
1118 : : eq: consider equality only, returning 0 or nonzero
1119 : : eqnans: NaNs considered equal to each other
1120 : : -0.0 not considered equal to 0.0
1121 : : inexact not considered equal to exact
1122 : : fname: if not NULL, throws type errors, else returns 2 for type errors
1123 : : */
1124 : 149655000 : int numeric_compare(fl_context_t *fl_ctx, value_t a, value_t b, int eq, int eqnans, char *fname)
1125 : : {
1126 : : int_t ai, bi;
1127 : : numerictype_t ta, tb;
1128 : : void *aptr, *bptr;
1129 : :
1130 [ - + ]: 149655000 : if (bothfixnums(a,b)) {
1131 [ # # ]: 0 : if (a==b) return 0;
1132 [ # # ]: 0 : if (numval(a) < numval(b)) return -1;
1133 : 0 : return 1;
1134 : : }
1135 [ - + ]: 149655000 : if (!num_to_ptr(a, &ai, &ta, &aptr)) {
1136 [ # # ]: 0 : if (fname) type_error(fl_ctx, fname, "number", a); else return 2;
1137 : : }
1138 [ + + ]: 149655000 : if (!num_to_ptr(b, &bi, &tb, &bptr)) {
1139 [ - + ]: 6566 : if (fname) type_error(fl_ctx, fname, "number", b); else return 2;
1140 : : }
1141 [ + + + + : 149648400 : if (eq && eqnans && ((ta >= T_FLOAT) != (tb >= T_FLOAT)))
- + ]
1142 : 0 : return 1;
1143 [ + + ]: 149648400 : if (cmp_eq(aptr, ta, bptr, tb, eqnans))
1144 : 8015320 : return 0;
1145 [ + + ]: 141633200 : if (eq) return 1;
1146 [ + + ]: 172158 : if (cmp_lt(aptr, ta, bptr, tb))
1147 : 52124 : return -1;
1148 : 120034 : return 1;
1149 : : }
1150 : :
1151 : : #if defined(_OS_WINDOWS_)
1152 : : __declspec(noreturn) static void DivideByZeroError(fl_context_t *fl_ctx);
1153 : : #else
1154 : : static void DivideByZeroError(fl_context_t *fl_ctx) __attribute__ ((__noreturn__));
1155 : : #endif
1156 : :
1157 : 0 : static void DivideByZeroError(fl_context_t *fl_ctx)
1158 : : {
1159 : 0 : lerror(fl_ctx, fl_ctx->DivideError, "/: division by zero");
1160 : : }
1161 : :
1162 : 12 : static value_t fl_div2(fl_context_t *fl_ctx, value_t a, value_t b)
1163 : : {
1164 : : double da, db;
1165 : : int_t ai, bi;
1166 : : numerictype_t ta, tb;
1167 : : void *aptr, *bptr;
1168 : :
1169 [ - + ]: 12 : if (!num_to_ptr(a, &ai, &ta, &aptr))
1170 : 0 : type_error(fl_ctx, "/", "number", a);
1171 [ - + ]: 12 : if (!num_to_ptr(b, &bi, &tb, &bptr))
1172 : 0 : type_error(fl_ctx, "/", "number", b);
1173 : :
1174 : 12 : da = conv_to_double(aptr, ta);
1175 : 12 : db = conv_to_double(bptr, tb);
1176 : :
1177 [ - + - - ]: 12 : if (db == 0 && tb < T_FLOAT) // exact 0
1178 : 0 : DivideByZeroError(fl_ctx);
1179 : :
1180 : 12 : da = da/db;
1181 : :
1182 [ + - + - : 12 : if (ta < T_FLOAT && tb < T_FLOAT && (double)(int64_t)da == da)
+ - ]
1183 : 12 : return return_from_int64(fl_ctx, (int64_t)da);
1184 : 0 : return mk_double(fl_ctx, da);
1185 : : }
1186 : :
1187 : 0 : static value_t fl_idiv2(fl_context_t *fl_ctx, value_t a, value_t b)
1188 : : {
1189 : : int_t ai, bi;
1190 : : numerictype_t ta, tb;
1191 : : void *aptr, *bptr;
1192 : : int64_t a64, b64;
1193 : :
1194 [ # # ]: 0 : if (!num_to_ptr(a, &ai, &ta, &aptr))
1195 : 0 : type_error(fl_ctx, "div0", "number", a);
1196 [ # # ]: 0 : if (!num_to_ptr(b, &bi, &tb, &bptr))
1197 : 0 : type_error(fl_ctx, "div0", "number", b);
1198 : :
1199 [ # # ]: 0 : if (ta == T_UINT64) {
1200 [ # # ]: 0 : if (tb == T_UINT64) {
1201 [ # # ]: 0 : if (*(uint64_t*)bptr == 0) goto div_error;
1202 : 0 : return return_from_uint64(fl_ctx, *(uint64_t*)aptr / *(uint64_t*)bptr);
1203 : : }
1204 : 0 : b64 = conv_to_int64(bptr, tb);
1205 [ # # ]: 0 : if (b64 < 0) {
1206 : 0 : return return_from_int64(fl_ctx, -(int64_t)(*(uint64_t*)aptr /
1207 : 0 : (uint64_t)(-b64)));
1208 : : }
1209 [ # # ]: 0 : if (b64 == 0)
1210 : 0 : goto div_error;
1211 : 0 : return return_from_uint64(fl_ctx, *(uint64_t*)aptr / (uint64_t)b64);
1212 : : }
1213 [ # # ]: 0 : if (tb == T_UINT64) {
1214 [ # # ]: 0 : if (*(uint64_t*)bptr == 0) goto div_error;
1215 : 0 : a64 = conv_to_int64(aptr, ta);
1216 [ # # ]: 0 : if (a64 < 0) {
1217 : 0 : return return_from_int64(fl_ctx, -((int64_t)((uint64_t)(-a64) /
1218 : 0 : *(uint64_t*)bptr)));
1219 : : }
1220 : 0 : return return_from_uint64(fl_ctx, (uint64_t)a64 / *(uint64_t*)bptr);
1221 : : }
1222 : :
1223 : 0 : b64 = conv_to_int64(bptr, tb);
1224 [ # # ]: 0 : if (b64 == 0) goto div_error;
1225 : :
1226 : 0 : return return_from_int64(fl_ctx, conv_to_int64(aptr, ta) / b64);
1227 : 0 : div_error:
1228 : 0 : DivideByZeroError(fl_ctx);
1229 : : }
1230 : :
1231 : 0 : static value_t fl_bitwise_op(fl_context_t *fl_ctx, value_t a, value_t b, int opcode, char *fname)
1232 : : {
1233 : : int_t ai, bi;
1234 : : numerictype_t ta, tb, itmp;
1235 : 0 : void *aptr=NULL, *bptr=NULL, *ptmp;
1236 : : int64_t b64;
1237 : :
1238 [ # # # # ]: 0 : if (!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT)
1239 : 0 : type_error(fl_ctx, fname, "integer", a);
1240 [ # # # # ]: 0 : if (!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT)
1241 : 0 : type_error(fl_ctx, fname, "integer", b);
1242 : :
1243 [ # # ]: 0 : if (ta < tb) {
1244 : 0 : itmp = ta; ta = tb; tb = itmp;
1245 : 0 : ptmp = aptr; aptr = bptr; bptr = ptmp;
1246 : : }
1247 : : // now a's type is larger than or same as b's
1248 : 0 : b64 = conv_to_int64(bptr, tb);
1249 [ # # # # ]: 0 : switch (opcode) {
1250 : 0 : case 0:
1251 [ # # # # : 0 : switch (ta) {
# # # # #
# ]
1252 : 0 : case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64);
1253 : 0 : case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64);
1254 : 0 : case T_INT16: return fixnum( *(int16_t*)aptr & (int16_t )b64);
1255 : 0 : case T_UINT16: return fixnum( *(uint16_t*)aptr & (uint16_t)b64);
1256 : 0 : case T_INT32: return mk_int32(fl_ctx, *(int32_t*)aptr & (int32_t )b64);
1257 : 0 : case T_UINT32: return mk_uint32(fl_ctx, *(uint32_t*)aptr & (uint32_t)b64);
1258 : 0 : case T_INT64: return mk_int64(fl_ctx, *(int64_t*)aptr & (int64_t )b64);
1259 : 0 : case T_UINT64: return mk_uint64(fl_ctx, *(uint64_t*)aptr & (uint64_t)b64);
1260 : 0 : case T_FLOAT:
1261 : 0 : case T_DOUBLE: assert(0);
1262 : : }
1263 : 0 : break;
1264 : 0 : case 1:
1265 [ # # # # : 0 : switch (ta) {
# # # # #
# ]
1266 : 0 : case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64);
1267 : 0 : case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64);
1268 : 0 : case T_INT16: return fixnum( *(int16_t*)aptr | (int16_t )b64);
1269 : 0 : case T_UINT16: return fixnum( *(uint16_t*)aptr | (uint16_t)b64);
1270 : 0 : case T_INT32: return mk_int32(fl_ctx, *(int32_t*)aptr | (int32_t )b64);
1271 : 0 : case T_UINT32: return mk_uint32(fl_ctx, *(uint32_t*)aptr | (uint32_t)b64);
1272 : 0 : case T_INT64: return mk_int64(fl_ctx, *(int64_t*)aptr | (int64_t )b64);
1273 : 0 : case T_UINT64: return mk_uint64(fl_ctx, *(uint64_t*)aptr | (uint64_t)b64);
1274 : 0 : case T_FLOAT:
1275 : 0 : case T_DOUBLE: assert(0);
1276 : : }
1277 : 0 : break;
1278 : 0 : case 2:
1279 [ # # # # : 0 : switch (ta) {
# # # # #
# ]
1280 : 0 : case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64);
1281 : 0 : case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64);
1282 : 0 : case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_t )b64);
1283 : 0 : case T_UINT16: return fixnum( *(uint16_t*)aptr ^ (uint16_t)b64);
1284 : 0 : case T_INT32: return mk_int32(fl_ctx, *(int32_t*)aptr ^ (int32_t )b64);
1285 : 0 : case T_UINT32: return mk_uint32(fl_ctx, *(uint32_t*)aptr ^ (uint32_t)b64);
1286 : 0 : case T_INT64: return mk_int64(fl_ctx, *(int64_t*)aptr ^ (int64_t )b64);
1287 : 0 : case T_UINT64: return mk_uint64(fl_ctx, *(uint64_t*)aptr ^ (uint64_t)b64);
1288 : 0 : case T_FLOAT:
1289 : 0 : case T_DOUBLE: assert(0);
1290 : : }
1291 : : }
1292 : 0 : assert(0);
1293 : : return fl_ctx->NIL;
1294 : : }
1295 : :
1296 : 5518740 : static value_t fl_logand(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
1297 : : {
1298 : : value_t v, e;
1299 : : int i;
1300 [ - + ]: 5518740 : if (nargs == 0)
1301 : 0 : return fixnum(-1);
1302 : 5518740 : v = args[0];
1303 [ + + ]: 11037500 : FOR_ARGS(i,1,e,args) {
1304 [ + - ]: 5518740 : if (bothfixnums(v, e))
1305 : 5518740 : v = v & e;
1306 : : else
1307 : 0 : v = fl_bitwise_op(fl_ctx, v, e, 0, "logand");
1308 : : }
1309 : 5518740 : return v;
1310 : : }
1311 : :
1312 : 1710144 : static value_t fl_logior(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
1313 : : {
1314 : : value_t v, e;
1315 : : int i;
1316 [ - + ]: 1710144 : if (nargs == 0)
1317 : 0 : return fixnum(0);
1318 : 1710144 : v = args[0];
1319 [ + + ]: 3420280 : FOR_ARGS(i,1,e,args) {
1320 [ + - ]: 1710144 : if (bothfixnums(v, e))
1321 : 1710144 : v = v | e;
1322 : : else
1323 : 0 : v = fl_bitwise_op(fl_ctx, v, e, 1, "logior");
1324 : : }
1325 : 1710144 : return v;
1326 : : }
1327 : :
1328 : 0 : static value_t fl_logxor(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
1329 : : {
1330 : : value_t v, e;
1331 : : int i;
1332 [ # # ]: 0 : if (nargs == 0)
1333 : 0 : return fixnum(0);
1334 : 0 : v = args[0];
1335 [ # # ]: 0 : FOR_ARGS(i,1,e,args) {
1336 [ # # ]: 0 : if (bothfixnums(v, e))
1337 : 0 : v = fixnum(numval(v) ^ numval(e));
1338 : : else
1339 : 0 : v = fl_bitwise_op(fl_ctx, v, e, 2, "logxor");
1340 : : }
1341 : 0 : return v;
1342 : : }
1343 : :
1344 : 622230 : static value_t fl_lognot(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
1345 : : {
1346 : 622230 : argcount(fl_ctx, "lognot", nargs, 1);
1347 : 622230 : value_t a = args[0];
1348 [ + - ]: 622230 : if (isfixnum(a))
1349 : 622230 : return fixnum(~numval(a));
1350 : : cprim_t *cp;
1351 : : int ta;
1352 : : void *aptr;
1353 : :
1354 [ # # ]: 0 : if (iscprim(a)) {
1355 : 0 : cp = (cprim_t*)ptr(a);
1356 : 0 : ta = cp_numtype(cp);
1357 : 0 : aptr = cp_data(cp);
1358 [ # # # # : 0 : switch (ta) {
# # # #
# ]
1359 : 0 : case T_INT8: return fixnum(~*(int8_t *)aptr);
1360 : 0 : case T_UINT8: return fixnum(~*(uint8_t *)aptr);
1361 : 0 : case T_INT16: return fixnum(~*(int16_t *)aptr);
1362 : 0 : case T_UINT16: return fixnum(~*(uint16_t*)aptr);
1363 : 0 : case T_INT32: return mk_int32(fl_ctx, ~*(int32_t *)aptr);
1364 : 0 : case T_UINT32: return mk_uint32(fl_ctx, ~*(uint32_t*)aptr);
1365 : 0 : case T_INT64: return mk_int64(fl_ctx, ~*(int64_t *)aptr);
1366 : 0 : case T_UINT64: return mk_uint64(fl_ctx, ~*(uint64_t*)aptr);
1367 : : }
1368 : : }
1369 : 0 : type_error(fl_ctx, "lognot", "integer", a);
1370 : : }
1371 : :
1372 : 0 : static value_t fl_ash(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
1373 : : {
1374 : : fixnum_t n;
1375 : : int64_t accum;
1376 : 0 : argcount(fl_ctx, "ash", nargs, 2);
1377 : 0 : value_t a = args[0];
1378 : 0 : n = tofixnum(fl_ctx, args[1], "ash");
1379 [ # # ]: 0 : if (isfixnum(a)) {
1380 [ # # ]: 0 : if (n <= 0)
1381 : 0 : return fixnum(numval(a)>>(-n));
1382 : 0 : accum = ((int64_t)numval(a))<<n;
1383 [ # # # # ]: 0 : if (fits_fixnum(accum))
1384 : 0 : return fixnum(accum);
1385 : : else
1386 : 0 : return return_from_int64(fl_ctx, accum);
1387 : : }
1388 : : cprim_t *cp;
1389 : : int ta;
1390 : : void *aptr;
1391 [ # # ]: 0 : if (iscprim(a)) {
1392 [ # # ]: 0 : if (n == 0) return a;
1393 : 0 : cp = (cprim_t*)ptr(a);
1394 : 0 : ta = cp_numtype(cp);
1395 : 0 : aptr = cp_data(cp);
1396 [ # # ]: 0 : if (n < 0) {
1397 : 0 : n = -n;
1398 [ # # # # : 0 : switch (ta) {
# # # #
# ]
1399 : 0 : case T_INT8: return fixnum((*(int8_t *)aptr) >> n);
1400 : 0 : case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n);
1401 : 0 : case T_INT16: return fixnum((*(int16_t *)aptr) >> n);
1402 : 0 : case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n);
1403 : 0 : case T_INT32: return mk_int32(fl_ctx, (*(int32_t *)aptr) >> n);
1404 : 0 : case T_UINT32: return mk_uint32(fl_ctx, (*(uint32_t*)aptr) >> n);
1405 : 0 : case T_INT64: return mk_int64(fl_ctx, (*(int64_t *)aptr) >> n);
1406 : 0 : case T_UINT64: return mk_uint64(fl_ctx, (*(uint64_t*)aptr) >> n);
1407 : : }
1408 : : }
1409 : : else {
1410 [ # # ]: 0 : if (ta == T_UINT64)
1411 : 0 : return return_from_uint64(fl_ctx, (*(uint64_t*)aptr)<<n);
1412 [ # # ]: 0 : else if (ta < T_FLOAT) {
1413 : 0 : int64_t i64 = conv_to_int64(aptr, (numerictype_t)ta);
1414 : 0 : return return_from_int64(fl_ctx, i64<<n);
1415 : : }
1416 : : }
1417 : : }
1418 : 0 : type_error(fl_ctx, "ash", "integer", a);
1419 : : return fl_ctx->NIL;
1420 : : }
|
