1 /* Allocator functions for the various types.
2
3 -------------------------- Specification ----------------------------
4
5 All these are declared in lispbibl.d. */
6 global maygc object allocate_cons (void);
7 global maygc object make_symbol (object string);
8 global maygc object allocate_vector (uintL len);
9 global maygc object allocate_bit_vector (uintB atype, uintL len);
10 global maygc object allocate_string (uintL len);
11 global maygc object allocate_iarray (uintB flags, uintC rank, tint type);
12 #ifdef TYPECODES
13 global maygc object allocate_lrecord (uintB rectype, uintL reclen, tint type);
14 global maygc object allocate_srecord_ (uintW flags_rectype, uintC reclen, tint type);
15 global maygc object allocate_xrecord_ (uintW flags_rectype, uintC reclen, uintC recxlen, tint type);
16 #else
17 global maygc object allocate_lrecord_ (uintB rectype, uintL reclen);
18 global maygc object allocate_srecord_ (uintW flags_rectype, uintC reclen);
19 global maygc object allocate_xrecord_ (uintW flags_rectype, uintC reclen, uintC recxlen);
20 #endif
21 global maygc object allocate_stream (uintB streamflags, uintB streamtype, uintC reclen, uintC recxlen);
22 #ifdef FOREIGN
23 global maygc object allocate_fpointer (FOREIGN foreign);
24 #endif
25 #ifdef FOREIGN_HANDLE
26 global maygc object allocate_handle (Handle handle);
27 #endif
28 global maygc object allocate_bignum (uintC len, sintB sign);
29 global maygc object allocate_ffloat (ffloat value);
30 #ifdef intQsize
31 global maygc object allocate_dfloat (dfloat value);
32 #else
33 global maygc object allocate_dfloat (uint32 semhi, uint32 mlo);
34 #endif
35 global maygc object allocate_lfloat (uintC len, uintL expo, signean sign);
36 global maygc object make_ratio (object num, object den);
37 global maygc object make_complex (object real, object imag);
38 #ifdef MULTITHREAD
39 global maygc object allocate_thread (gcv_object_t *name_);
40 global maygc object allocate_mutex (gcv_object_t *name_);
41 global maygc object allocate_exemption (gcv_object_t *name_);
42 #endif
43
44 /* -------------------------- Implementation --------------------------- */
45
46 /* UP, provides a cons
47 allocate_cons()
48 < result: pointer to a new CONS, with CAR and CDR =NIL
49 can trigger GC */
allocate_cons(void)50 modexp maygc object allocate_cons (void) {
51 allocate(cons_type,false,sizeof(cons_),Cons,ptr,
52 { ptr->cdr = NIL; ptr->car = NIL; });
53 }
54
55 /* UP: provides a freshly created uninterned symbol with given printname.
56 make_symbol(string)
57 > string: immutable Simple-String
58 < result: new symbol with this name, with home-package=NIL.
59 can trigger GC */
make_symbol(object string)60 modexp maygc object make_symbol (object string) {
61 pushSTACK(string); /* save string */
62 #if !defined(OLD_GC) && defined(MULTITHREAD)
63 #define INIT_TLS_INDEX ptr->tls_index = SYMBOL_TLS_INDEX_NONE
64 #else
65 #define INIT_TLS_INDEX
66 #endif
67 #define FILL \
68 do { ptr->symvalue = unbound; /* empty value cell */ \
69 ptr->symfunction = unbound; /* empty function cell */ \
70 ptr->hashcode = unbound; /* not yet computed */ \
71 ptr->proplist = NIL; /* empty property list */ \
72 ptr->pname = popSTACK(); /* store name */ \
73 ptr->homepackage = NIL; /* no home-package */ \
74 INIT_TLS_INDEX; /* initialize tls index (MT) */\
75 } while(0)
76 #ifdef TYPECODES
77 allocate(symbol_type,true,size_symbol(),Symbol,ptr,
78 { FILL; });
79 #else
80 allocate(symbol_type,true,size_xrecord(6,symbol_xlength),Symbol,ptr,
81 { ptr->tfl = xrecord_tfl(Rectype_Symbol,0,6,symbol_xlength); FILL; });
82 #endif
83 #undef FILL
84 #undef INIT_TLS_INDEX
85 }
86
87 /* initialize elements with NIL */
88 #define NIL_FILL(len,data) if (len > 0) { \
89 gcv_object_t* p = data; \
90 do { *p++ = NIL; } while (--len); \
91 }
92
93 /* UP, provides vector
94 allocate_vector(len)
95 > len: length of the vector
96 < result: new vector (elements are initialized with NIL)
97 can trigger GC */
allocate_vector(uintL len)98 modexp maygc object allocate_vector (uintL len) {
99 var uintM need = size_svector(len); /* needed memory */
100 #ifdef TYPECODES
101 #define SETTFL ptr->length = len
102 #else
103 #define SETTFL ptr->tfl = vrecord_tfl(Rectype_Svector,len)
104 #endif
105 allocate(svector_type,true,need,Svector,ptr,{
106 SETTFL;
107 NIL_FILL(len,ptr->data);
108 });
109 #undef SETTFL
110 }
111
112 /* Function: Allocates a bit/byte vector.
113 allocate_bit_vector(atype,len)
114 > uintB atype: Atype_nBit
115 > uintL len: length (number of n-bit blocks)
116 < result: fresh simple bit/byte-vector of the given length
117 can trigger GC */
allocate_bit_vector(uintB atype,uintL len)118 modexp maygc object allocate_bit_vector (uintB atype, uintL len) {
119 var uintM need = size_sbvector((uintM)len<<atype); /* needed memory in bytes */
120 #ifdef TYPECODES
121 #define SETTFL ptr->length = len
122 #else
123 #define SETTFL ptr->tfl = vrecord_tfl(Rectype_Sbvector+atype,len)
124 #endif
125 allocate(Array_type_simple_bit_vector(atype),true,need,Sbvector,ptr,
126 { SETTFL; }); /* no further initialization */
127 #undef SETTFL
128 }
129
130 #if !defined(ENABLE_UNICODE) || defined(HAVE_SMALL_SSTRING)
131
132 /* UP, provides 8-bit character string
133 allocate_s8string(len)
134 > len: length of the string (in characters), must be <= stringsize_limit_1
135 < result: new 8-bit character simple-string (LISP-object)
136 can trigger GC */
allocate_s8string(uintL len)137 modexp maygc object allocate_s8string (uintL len) {
138 var uintL need = size_s8string(len); /* needed memory in bytes */
139 #ifdef HAVE_SMALL_SSTRING
140 /* Some uprounding, for reallocate_small_string to work. */
141 if (size_s8string(1) < size_sistring(0)
142 && need < size_sistring(0) && len > 0)
143 need = size_sistring(0);
144 #endif
145 #define SETTFL ptr->tfl = sstring_tfl(Sstringtype_8Bit,0,0,len)
146 allocate(sstring_type,true,need,S8string,ptr,
147 { SETTFL; }); /* no further initialization */
148 #undef SETTFL
149 }
150
151 /* UP, provides immutable 8-bit character string
152 allocate_imm_s8string(len)
153 > len: length of the string (in characters), must be <= stringsize_limit_1
154 < result: new immutable 8-bit character simple-string (LISP-object)
155 can trigger GC */
allocate_imm_s8string(uintL len)156 global maygc object allocate_imm_s8string (uintL len) {
157 var uintL need = size_s8string(len); /* needed memory in bytes */
158 #define SETTFL ptr->tfl = sstring_tfl(Sstringtype_8Bit,1,0,len)
159 allocate(sstring_type,true,need,S8string,ptr,
160 { SETTFL; }); /* no further initialization */
161 #undef SETTFL
162 }
163
164 #endif /* !ENABLE_UNICODE || HAVE_SMALL_SSTRING */
165
166 #ifdef HAVE_SMALL_SSTRING
167
168 /* UP, provides 16-bit character string
169 allocate_s16string(len)
170 > len: length of the string (in characters), must be <= stringsize_limit_1
171 < result: new 16-bit character simple-string (LISP-object)
172 can trigger GC */
allocate_s16string(uintL len)173 global maygc object allocate_s16string (uintL len) {
174 var uintL need = size_s16string(len); /* needed memory in bytes */
175 /* Some uprounding, for reallocate_small_string to work. */
176 if (size_s16string(1) < size_sistring(0)
177 && need < size_sistring(0) && len > 0)
178 need = size_sistring(0);
179 #define SETTFL ptr->tfl = sstring_tfl(Sstringtype_16Bit,0,0,len)
180 allocate(sstring_type,true,need,S16string,ptr,
181 { SETTFL; }); /* no further initialization */
182 #undef SETTFL
183 }
184
185 /* UP, provides immutable 16-bit character string
186 allocate_imm_s16string(len)
187 > len: length of the string (in characters), must be <= stringsize_limit_1
188 < result: new immutable 16-bit character simple-string (LISP-object)
189 can trigger GC */
allocate_imm_s16string(uintL len)190 global maygc object allocate_imm_s16string (uintL len) {
191 var uintL need = size_s16string(len); /* needed memory in bytes */
192 #define SETTFL ptr->tfl = sstring_tfl(Sstringtype_16Bit,1,0,len)
193 allocate(sstring_type,true,need,S16string,ptr,
194 { SETTFL; }); /* no further initialization */
195 #undef SETTFL
196 }
197
198 #endif /* HAVE_SMALL_SSTRING */
199
200 #ifdef ENABLE_UNICODE
201
202 /* UP, provides 32-bit character string
203 allocate_s32string(len)
204 > len: length of the string (in characters), must be <= stringsize_limit_1
205 < result: new 32-bit character simple-string (LISP-object)
206 can trigger GC */
allocate_s32string(uintL len)207 modexp maygc object allocate_s32string (uintL len) {
208 var uintL need = size_s32string(len); /* needed memory in bytes */
209 #define SETTFL ptr->tfl = sstring_tfl(Sstringtype_32Bit,0,0,len)
210 allocate(sstring_type,true,need,S32string,ptr,
211 { SETTFL; }); /* no further initialization */
212 #undef SETTFL
213 }
214
215 /* UP, provides immutable 32-bit character string
216 allocate_imm_s32string(len)
217 > len: length of the string (in characters), must be <= stringsize_limit_1
218 < result: new immutable 32-bit character simple-string (LISP-object)
219 can trigger GC */
allocate_imm_s32string(uintL len)220 global maygc object allocate_imm_s32string (uintL len) {
221 var uintL need = size_s32string(len); /* needed memory in bytes */
222 #define SETTFL ptr->tfl = sstring_tfl(Sstringtype_32Bit,1,0,len)
223 allocate(sstring_type,true,need,S32string,ptr,
224 { SETTFL; }); /* no further initialization */
225 #undef SETTFL
226 }
227
228 #endif /* ENABLE_UNICODE */
229
230 #ifdef HAVE_SMALL_SSTRING
231
232 /* UP: Changes the allocation of a Small-String to an Sistring, while
233 copying the contents to a fresh normal string.
234 reallocate_small_string(string)
235 > string: a nonempty Small-String
236 > newtype: new wider string type, Sstringtype_16Bit or Sstringtype_32Bit
237 < result: an Sistring pointing to a wider String
238 can trigger GC */
reallocate_small_string(object string,uintB newtype)239 global maygc object reallocate_small_string (object string, uintB newtype) {
240 var uintL len = Sstring_length(string); /* known to be > 0 */
241 #ifdef DEBUG_SPVW
242 var uintL size = varobject_bytelength(string);
243 #endif
244 pushSTACK(string);
245 var object newstring =
246 (newtype == Sstringtype_32Bit
247 ? allocate_s32string(len)
248 : allocate_s16string(len));
249 string = popSTACK();
250 var uintB oldtype = sstring_eltype(TheSstring(string));
251 if (newtype == Sstringtype_32Bit) {
252 SstringCase(string,
253 { copy_8bit_32bit(&TheS8string(string)->data[0],&TheS32string(newstring)->data[0],len); },
254 { copy_16bit_32bit(&TheS16string(string)->data[0],&TheS32string(newstring)->data[0],len); },
255 abort();,
256 abort();
257 );
258 } else if (newtype == Sstringtype_16Bit) {
259 SstringCase(string,
260 { copy_8bit_16bit(&TheS8string(string)->data[0],&TheS16string(newstring)->data[0],len); },
261 abort();,
262 abort();,
263 abort();
264 );
265 } else
266 abort();
267 set_break_sem_1(); /* forbid interrupts */
268 var Sistring ptr = (Sistring)TheSstring(string);
269 /* Ensure that objsize(string) == objsize(mutated_string) !! */
270 var uintL xlength;
271 if (oldtype == Sstringtype_8Bit) {
272 var uintL size = size_s8string(len);
273 /* Some uprounding, for reallocate_small_string to work. */
274 if (size_s8string(1) < size_sistring(0)
275 && size < size_sistring(0) && len > 0)
276 size = size_sistring(0);
277 xlength = size - size_sistring(0);
278 } else {
279 var uintL size = size_s16string(len);
280 /* Some uprounding, for reallocate_small_string to work. */
281 if (size_s16string(1) < size_sistring(0)
282 && size < size_sistring(0) && len > 0)
283 size = size_sistring(0);
284 xlength = size - size_sistring(0);
285 }
286 #ifdef TYPECODES
287 ptr->tfl = sstring_tfl(newtype,0,sstringflags_forwarded_B,xlength);
288 #else
289 ptr->tfl = sstringrecord_tfl(Rectype_reallocstring,0,xlength);
290 #endif
291 ptr->data = newstring;
292 clr_break_sem_1(); /* permit interrupts again */
293 #ifdef DEBUG_SPVW
294 if (size != varobject_bytelength(string)) abort();
295 #endif
296 return string;
297 }
298
299 #endif
300
301 /* UP, provides indirect array
302 allocate_iarray(flags,rank,type)
303 > uintB flags: flags
304 > uintC (actually uintWC) rank: rank
305 > tint type: typeinfo
306 < result: LISP-Object array
307 can trigger GC */
allocate_iarray(uintB flags,uintC rank,tint type)308 global maygc object allocate_iarray (uintB flags, uintC rank, tint type) {
309 var uintL need = rank;
310 if (flags & bit(arrayflags_fillp_bit))
311 need += 1;
312 if (flags & bit(arrayflags_dispoffset_bit))
313 need += 1;
314 need = size_iarray(need);
315 #ifdef TYPECODES
316 #define SETTFL ptr->flags = flags; ptr->rank = rank
317 #else
318 #define SETTFL ptr->tfl = srecord_tfl(type,flags,rank)
319 #endif
320 allocate(type,true,need,Iarray,ptr,{
321 SETTFL; /* store flags and rank */
322 ptr->data = NIL; /* initialize data vector with NIL */
323 });
324 #undef SETTFL
325 }
326
327 /* UP: allocates Long-Record
328 allocate_lrecord(rectype,reclen,type)
329 > sintB rectype: further type-info
330 > uintL reclen: length
331 > tint type: type-info
332 < result: LISP-object Record (elements are initialized with NIL)
333 can trigger GC */
334 #ifdef TYPECODES
allocate_lrecord(uintB rectype,uintL reclen,tint type)335 global maygc object allocate_lrecord (uintB rectype, uintL reclen, tint type)
336 {
337 ASSERT((sintB)rectype >= rectype_longlimit);
338 var uintL need = size_lrecord(reclen);
339 allocate(type,true,need,Lrecord,ptr,{
340 ptr->tfl = lrecord_tfl(rectype,reclen); /* store type and length */
341 NIL_FILL(reclen,ptr->recdata);
342 });
343 }
344 #else
allocate_lrecord_(uintB rectype,uintL reclen)345 global maygc object allocate_lrecord_ (uintB rectype, uintL reclen)
346 {
347 ASSERT((sintB)rectype >= rectype_longlimit);
348 var uintL need = size_lrecord(reclen);
349 allocate(type,true,need,Lrecord,ptr,{
350 ptr->tfl = lrecord_tfl(rectype,reclen); /* store type and length */
351 NIL_FILL(reclen,ptr->recdata);
352 });
353 }
354 #endif
355
356 /* UP, provides simple-record
357 allocate_srecord_(flags_rectype,reclen,type)
358 > uintW flags_rectype: flags, further typeinfo
359 > uintC reclen: length
360 > tint type: typeinfo
361 < result: LISP-Object record (elements are initialized with NIL)
362 can trigger GC */
363 #ifdef TYPECODES
allocate_srecord_(uintW flags_rectype,uintC reclen,tint type)364 global maygc object allocate_srecord_ (uintW flags_rectype, uintC reclen, tint type)
365 {
366 ASSERT((sintB)(flags_rectype >> (BIG_ENDIAN_P ? 8 : 0)) < rectype_limit);
367 var uintL need = size_srecord(reclen);
368 allocate(type,true,need,Srecord,ptr,{
369 /* store flags, type: */
370 *(uintW*)pointerplus(ptr,offsetof(record_,rectype)) = flags_rectype;
371 ptr->reclength = reclen; /* store length */
372 NIL_FILL(reclen,ptr->recdata);
373 });
374 }
375 #else
allocate_srecord_(uintW flags_rectype,uintC reclen)376 global maygc object allocate_srecord_ (uintW flags_rectype, uintC reclen) {
377 var uintL need = size_srecord(reclen);
378 allocate(type,true,need,Srecord,ptr,{
379 ptr->tfl = (uintL)flags_rectype + ((uintL)reclen << 16);
380 NIL_FILL(reclen,ptr->recdata);
381 });
382 }
383 #endif
384
385 /* UP, provides extended-record
386 allocate_xrecord_(flags_rectype,reclen,recxlen,type)
387 > uintW flags_rectype: flags, further typeinfo
388 > uintC reclen: length
389 > uintC recxlen: extra-length
390 > tint type: typeinfo
391 < result: LISP-Object Record (elements are initialized with NIL resp. 0)
392 can trigger GC */
393 #ifdef TYPECODES
allocate_xrecord_(uintW flags_rectype,uintC reclen,uintC recxlen,tint type)394 global maygc object allocate_xrecord_ (uintW flags_rectype, uintC reclen,
395 uintC recxlen, tint type) {
396 ASSERT((sintB)(flags_rectype >> (BIG_ENDIAN_P ? 8 : 0)) >= rectype_limit
397 && (sintB)(flags_rectype >> (BIG_ENDIAN_P ? 8 : 0)) < rectype_longlimit);
398 var uintL need = size_xrecord(reclen,recxlen);
399 allocate(type,true,need,Xrecord,ptr,{
400 /* store flags, type: */
401 *(uintW*)pointerplus(ptr,offsetof(record_,rectype)) = flags_rectype;
402 ptr->reclength = reclen; ptr->recxlength = recxlen; /* store lengths */
403 var gcv_object_t* p = &ptr->recdata[0];
404 dotimesC(reclen,reclen, { *p++ = NIL; } ); /*initialize elements with NIL*/
405 if (recxlen > 0) {
406 var uintB* q = (uintB*)p;
407 /* initialize extra-elements with 0: */
408 dotimespC(recxlen,recxlen, { *q++ = 0; } );
409 }
410 });
411 }
412 #else
allocate_xrecord_(uintW flags_rectype,uintC reclen,uintC recxlen)413 global maygc object allocate_xrecord_ (uintW flags_rectype, uintC reclen,
414 uintC recxlen) {
415 var uintL need = size_xrecord(reclen,recxlen);
416 allocate(type,true,need,Xrecord,ptr,{
417 ptr->tfl = /* store flags, type, lengths */
418 (uintL)flags_rectype + ((uintL)reclen << 16) + ((uintL)recxlen << 24);
419 var gcv_object_t* p = &ptr->recdata[0];
420 dotimesC(reclen,reclen, { *p++ = NIL; } ); /*initialize elements with NIL*/
421 if (recxlen > 0) {
422 var uintB* q = (uintB*)p;
423 /* initialize extra-elements with 0: */
424 dotimespC(recxlen,recxlen, { *q++ = 0; } );
425 }
426 });
427 }
428 #endif
429
430 /* UP, provides stream
431 allocate_stream(streamflags,streamtype,reclen)
432 > uintB streamflags: flags
433 > uintB streamtype: further typeinfo
434 > uintC reclen: length in objects
435 > uintC recxlen: extra-length in bytes
436 < result: LISP-object stream (Elements are initialized with NIL)
437 can trigger GC */
allocate_stream(uintB streamflags,uintB streamtype,uintC reclen,uintC recxlen)438 global maygc object allocate_stream (uintB streamflags, uintB streamtype,
439 uintC reclen, uintC recxlen) {
440 var object obj =
441 #ifdef case_stream
442 allocate_xrecord(0,Rectype_Stream,reclen,recxlen,stream_type);
443 #else
444 allocate_xrecord(0,Rectype_Stream,reclen,recxlen,orecord_type);
445 #endif
446 /* Fixnum as place for streamflags and streamtype: */
447 TheRecord(obj)->recdata[0] = Fixnum_0;
448 TheStream(obj)->strmflags = streamflags | strmflags_open_B;
449 TheStream(obj)->strmtype = streamtype;
450 return obj;
451 }
452
453 #ifdef FOREIGN
454
455 /* UP, provides foreign-pointer-wrapping
456 allocate_fpointer(foreign)
457 > foreign: of type FOREIGN
458 < result: LISP-object, that contains the foreign pointer
459 can trigger GC */
allocate_fpointer(FOREIGN foreign)460 modexp maygc object allocate_fpointer (FOREIGN foreign) {
461 var object result = allocate_xrecord(0,Rectype_Fpointer,fpointer_length,
462 fpointer_xlength,orecord_type);
463 TheFpointer(result)->fp_pointer = foreign;
464 return result;
465 }
466
467 #endif
468
469 #ifdef FOREIGN_HANDLE
470
471 /* UP, provides handle-wrapping
472 allocate_handle(handle)
473 < result: LISP-object, that contains the handle
474 can trigger GC */
allocate_handle(Handle handle)475 modexp maygc object allocate_handle (Handle handle) {
476 var object result = allocate_bit_vector(Atype_Bit,sizeof(Handle)*8);
477 TheHandle(result) = handle;
478 return result;
479 }
480
481 #endif
482
483 /* UP, provides bignum
484 allocate_bignum(len,sign)
485 > uintC (actually uintWC) len: length of the number (in digits)
486 > sintB sign: flag for the sign (0 = +, -1 = -)
487 < result: new bignum (LISP-object)
488 can trigger GC */
allocate_bignum(uintC len,sintB sign)489 global maygc object allocate_bignum (uintC len, sintB sign) {
490 var uintL need = size_bignum(len); /* needed memory in bytes */
491 #ifdef TYPECODES
492 #define SETTFL ptr->length = len
493 #else
494 #define SETTFL ptr->tfl = srecord_tfl(Rectype_Bignum,(uintB)sign,len)
495 #endif
496 allocate(bignum_type | (sign & bit(sign_bit_t)),true,need,Bignum,ptr,
497 { SETTFL; }); /* no further initialization */
498 #undef SETTFL
499 }
500
501 /* UP, provides single-float
502 allocate_ffloat(value)
503 > ffloat value: number value (bit 31 = sign)
504 < result: new single-float (LISP-object)
505 can trigger GC */
allocate_ffloat(ffloat value)506 global maygc object allocate_ffloat (ffloat value) {
507 #if !defined(IMMEDIATE_FFLOAT)
508 #ifdef TYPECODES
509 #define SETTFL
510 #else
511 #define SETTFL ptr->tfl = xrecord_tfl(Rectype_Ffloat,((sint32)value<0 ? 0xFF : 0),0,sizeof(ffloat))
512 #endif
513 /* sign bit from value: */
514 allocate(ffloat_type | ((sint32)value<0 ? bit(sign_bit_t) : 0),
515 true,size_ffloat(),Ffloat,ptr,
516 { SETTFL; ptr->float_value = value; });
517 #undef SETTFL
518 #else
519 return /* sign bit from value */
520 type_data_object(ffloat_type | ((sint32)value<0 ? bit(sign_bit_t) : 0),
521 value);
522 #endif
523 }
524
525 /* UP, provides double-float */
526 #ifdef intQsize
527 /* allocate_dfloat(value)
528 > dfloat value: number value (bit 63 = sign)
529 < result: new double-float (LISP-object)
530 can trigger GC */
allocate_dfloat(dfloat value)531 global maygc object allocate_dfloat (dfloat value) {
532 #ifdef TYPECODES
533 #define SETTFL
534 #else
535 #define SETTFL ptr->tfl = xrecord_tfl(Rectype_Dfloat,((sint64)value<0 ? 0xFF : 0),0,sizeof(dfloat))
536 #endif
537 /* sign bit from value */
538 allocate(dfloat_type | ((sint64)value<0 ? bit(sign_bit_t) : 0),
539 true,size_dfloat(),Dfloat,ptr,
540 { SETTFL; ptr->float_value = value; });
541 #undef SETTFL
542 }
543 #else
544 /* allocate_dfloat(semhi,mlo)
545 > semhi,mlo: number value (bit 31 from semhi = sign)
546 < result: new double-float (LISP-object)
547 can trigger GC */
allocate_dfloat(uint32 semhi,uint32 mlo)548 global maygc object allocate_dfloat (uint32 semhi, uint32 mlo) {
549 #ifdef TYPECODES
550 #define SETTFL
551 #else
552 #define SETTFL ptr->tfl = xrecord_tfl(Rectype_Dfloat,((sint32)semhi<0 ? 0xFF : 0),0,sizeof(dfloat))
553 #endif
554 /* sign bit from value */
555 allocate(dfloat_type | ((sint32)semhi<0 ? bit(sign_bit_t) : 0),
556 true,size_dfloat(),Dfloat,ptr,
557 { SETTFL; ptr->float_value.semhi = semhi; ptr->float_value.mlo = mlo; });
558 #undef SETTFL
559 }
560 #endif /* intQsize */
561
562 /* UP, provides long-float
563 allocate_lfloat(len,expo,sign)
564 > uintC (actually uintWC) len: length of the mantissa (in digits)
565 > uintL expo: exponent
566 > signean sign: sign (0 = +, -1 = -)
567 < result: new long-float, still without mantissa
568 A LISP-object is there, only if the mantissa is stored!
569 can trigger GC */
allocate_lfloat(uintC len,uintL expo,signean sign)570 global maygc object allocate_lfloat (uintC len, uintL expo, signean sign) {
571 var uintL need = size_lfloat(len); /* needed memory in bytes */
572 #ifdef TYPECODES
573 #define SETTFL ptr->len = len
574 #else
575 #define SETTFL ptr->tfl = srecord_tfl(Rectype_Lfloat,(uintB)sign,len)
576 #endif
577 allocate(lfloat_type | ((tint)sign & bit(sign_bit_t)),true,need,Lfloat,ptr,
578 { SETTFL; ptr->expo = expo; }); /* no further initialization */
579 #undef SETTFL
580 }
581
582 /* UP, provides ratio
583 make_ratio(num,den)
584 > object num: numerator (must be integer /= 0 , relatively prime to 'den')
585 > object den: denominator (must be integer > 1 )
586 < result: ratio
587 can trigger GC */
make_ratio(object num,object den)588 global maygc object make_ratio (object num, object den) {
589 pushSTACK(den); pushSTACK(num); /* save arguments */
590 #ifdef TYPECODES
591 var tint type = /* take over sign from num */
592 #ifdef fast_mtypecode
593 ratio_type | (mtypecode(STACK_0) & bit(sign_bit_t))
594 #else
595 ratio_type | (typecode(num) & bit(sign_bit_t))
596 #endif
597 ;
598 #endif
599 #define FILL \
600 ptr->rt_num = popSTACK(); /* store numerator */ \
601 ptr->rt_den = popSTACK() /* store denominator */
602 #ifdef SPVW_MIXED
603 /* see allocate_xrecord */
604 #ifdef TYPECODES
605 #define SETTFL \
606 *(uintW*)pointerplus(ptr,offsetof(record_,rectype)) = \
607 ((uintW)Rectype_Ratio << (BIG_ENDIAN_P ? 8 : 0)); \
608 ptr->reclength = 2; ptr->recxlength = 0
609 #else
610 var uintL tfl = xrecord_tfl(Rectype_Ratio,(positivep(num) ? 0 : 0xFF),2,0);
611 #define SETTFL ptr->tfl = tfl
612 #endif /* TYPECODES */
613 allocate(type,true,size_xrecord(2,0),Ratio,ptr,{ SETTFL; FILL; });
614 #undef SETTFL
615 #else
616 allocate(type,false,sizeof(ratio_),Ratio,ptr,{ FILL; });
617 #endif /* SPVW_MIXED */
618 #undef FILL
619 }
620
621 /* UP, provides complex number
622 make_complex(real,imag)
623 > real: real part (must be a real number)
624 > imag: imaginary part (must be a real number /= Fixnum 0)
625 < result: complex number
626 can trigger GC */
make_complex(object real,object imag)627 global maygc object make_complex (object real, object imag) {
628 pushSTACK(imag); pushSTACK(real);
629 #define FILL \
630 ptr->c_real = popSTACK(); /* store real part */ \
631 ptr->c_imag = popSTACK() /* store imaginary part */
632 #ifdef SPVW_MIXED
633 /* see allocate_xrecord */
634 #ifdef TYPECODES
635 #define SETTFL \
636 *(uintW*)pointerplus(ptr,offsetof(record_,rectype)) = \
637 ((uintW)Rectype_Complex << (BIG_ENDIAN_P ? 8 : 0)); \
638 ptr->reclength = 2; ptr->recxlength = 0
639 #else
640 #define SETTFL ptr->tfl = xrecord_tfl(Rectype_Complex,0,2,0)
641 #endif /* TYPECODES */
642 allocate(complex_type,true,size_xrecord(2,0),Complex,ptr,{ SETTFL; FILL; });
643 #undef SETTFL
644 #else
645 allocate(complex_type,false,sizeof(complex_),Complex,ptr,{ FILL; });
646 #endif /* SPVW_MIXED */
647 #undef FILL
648 }
649
650 #ifdef MULTITHREAD
651 /* allocate a thread object
652 allocate_thread()
653 > name : thread name (usually a symbol)
654 < result : new thread object (not started)
655 can trigger GC */
allocate_thread(gcv_object_t * name_)656 global maygc object allocate_thread (gcv_object_t *name_) {
657 /* allocate join mutex and exemption with the same name as thread */
658 pushSTACK(allocate_mutex(name_));
659 pushSTACK(allocate_exemption(name_));
660 var object result = allocate_xrecord(0,Rectype_Thread,thread_length,
661 thread_xlength,orecord_type);
662 TheThread(result)->xth_name = *name_;
663 TheThread(result)->xth_values = unbound; /* no values */
664 TheThread(result)->xth_join_exemption = popSTACK();
665 TheThread(result)->xth_join_lock = popSTACK();
666 return result;
667 }
668
669 /* allocate a mutex object and inserts it in O(all_mutexes)
670 allocate_mutex()
671 > name : mutex name (usually a symbol)
672 < result : new mutex object (initialized)
673 can trigger GC */
allocate_mutex(gcv_object_t * name_)674 global maygc object allocate_mutex (gcv_object_t *name_) {
675 pushSTACK(allocate_xrecord(0,Rectype_Mutex,mutex_length,
676 mutex_xlength,orecord_type));
677 pushSTACK(allocate_cons());
678 var gcv_object_t *mx_ = &STACK_1;
679 var gcv_object_t *cons_ = &STACK_0;
680 WITH_OS_MUTEX_LOCK(0,&all_mutexes_lock, {
681 TheMutex(*mx_)->xmu_name = *name_;
682 begin_system_call();
683 var xmutex_t *p = (xmutex_t *)malloc(sizeof(xmutex_t));
684 end_system_call();
685 if (p && !xmutex_init(p)) {
686 TheMutex(*mx_)->xmu_system = p;
687 /* add to O(all_mutexes) */
688 Car(*cons_) = *mx_;
689 Cdr(*cons_) = O(all_mutexes);
690 O(all_mutexes) = *cons_;
691 } else {
692 if (p) free(p);
693 *mx_ = NIL;
694 }
695 });
696 skipSTACK(1); /* cons */
697 return popSTACK();
698 }
699
700 /* allocate an exemption object and inserts it in O(all_exemptions)
701 allocate_exemption()
702 > name : exemption name (usually a symbol)
703 < result : new exemption object (initialized)
704 can trigger GC */
allocate_exemption(gcv_object_t * name_)705 global maygc object allocate_exemption (gcv_object_t *name_) {
706 pushSTACK(allocate_xrecord(0,Rectype_Exemption,exemption_length,
707 exemption_xlength,orecord_type));
708 pushSTACK(allocate_cons());
709 var gcv_object_t *ex_ = &STACK_1;
710 var gcv_object_t *cons_ = &STACK_0;
711 WITH_OS_MUTEX_LOCK(0,&all_exemptions_lock, {
712 TheExemption(*ex_)->xco_name = *name_;
713 begin_system_call();
714 var xcondition_t *p = (xcondition_t *)malloc(sizeof(xcondition_t));
715 end_system_call();
716 if (p && !xcondition_init(p)) {
717 TheExemption(*ex_)->xco_system = p;
718 /* add to O(all_exemptions) */
719 Car(*cons_) = *ex_;
720 Cdr(*cons_) = O(all_exemptions);
721 O(all_exemptions) = *cons_;
722 } else {
723 if (p) free(p);
724 *ex_ = NIL;
725 }
726 });
727 skipSTACK(1); /* cons */
728 return popSTACK();
729 }
730 #endif
731