1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 #define LIARC_IN_MICROCODE
28 #include "liarc.h"
29 #include "prims.h"
30 #include "bignum.h"
31 #include "bitstr.h"
32 #include "avltree.h"
33 #include "os.h"
34
35 extern int initialize_compiled_code_blocks (void);
36 extern const char * liarc_object_file_prefix (void);
37
38 #ifdef BUG_GCC_LONG_CALLS
39
40 extern SCHEME_OBJECT memory_to_string (unsigned long, const void *);
41 extern SCHEME_OBJECT memory_to_symbol (long, const void *);
42 extern SCHEME_OBJECT make_vector (long, SCHEME_OBJECT, bool);
43 extern SCHEME_OBJECT cons (SCHEME_OBJECT, SCHEME_OBJECT);
44 extern SCHEME_OBJECT double_to_flonum (double);
45 extern SCHEME_OBJECT long_to_integer (long);
46 extern SCHEME_OBJECT digit_string_to_integer
47 (bool, unsigned long, const char *);
48 extern SCHEME_OBJECT digit_string_to_bit_string
49 (unsigned long, unsigned long, const char *);
50 extern SCHEME_OBJECT make_primitive (char *, int);
51 extern SCHEME_OBJECT memory_to_uninterned_symbol (unsigned long, const void *);
52
53 SCHEME_OBJECT (* (constructor_kludge [11])) () =
54 {
55 ((SCHEME_OBJECT (*) ()) memory_to_string),
56 ((SCHEME_OBJECT (*) ()) memory_to_symbol),
57 ((SCHEME_OBJECT (*) ()) make_vector),
58 ((SCHEME_OBJECT (*) ()) cons),
59 ((SCHEME_OBJECT (*) ()) rconsm),
60 ((SCHEME_OBJECT (*) ()) double_to_flonum),
61 ((SCHEME_OBJECT (*) ()) long_to_integer),
62 ((SCHEME_OBJECT (*) ()) digit_string_to_integer),
63 ((SCHEME_OBJECT (*) ()) digit_string_to_bit_string),
64 ((SCHEME_OBJECT (*) ()) make_primitive),
65 ((SCHEME_OBJECT (*) ()) memory_to_uninterned_symbol),
66 };
67
68 #endif /* BUG_GCC_LONG_CALLS */
69
70 static SCHEME_OBJECT dummy_entry = ((SCHEME_OBJECT) -1L);
71 utility_result_t interface_to_C_hook = ((utility_result_t) (&dummy_entry));
72
73 #define TRAMPOLINE_FUDGE 20
74
75 typedef struct
76 {
77 const char * name;
78 liarc_code_proc_t * code_proc; /* C handler for this entry point */
79 void * data_proc; /* Data handler for this compiled block */
80 entry_count_t first_entry; /* Base of dispatch for this block */
81 entry_count_t n_entries; /* Number of entry points in this block */
82 unsigned int flags;
83 } compiled_block_t;
84
85 static entry_count_t n_compiled_blocks = 0;
86 static entry_count_t compiled_blocks_table_size = 0;
87 static compiled_block_t * compiled_blocks = 0;
88 static tree_node compiled_blocks_tree = 0;
89
90 static long initial_entry_number = (-1);
91 static entry_count_t n_compiled_entries = 0;
92 static entry_count_t compiled_entries_size = 0;
93 static compiled_block_t ** compiled_entries = 0;
94
95 #define COMPILED_BLOCK_NAME(block) ((block) -> name)
96 #define COMPILED_BLOCK_CODE_PROC(block) ((block) -> code_proc)
97 #define _COMPILED_BLOCK_DATA_PROC(block) ((block) -> data_proc)
98 #define COMPILED_BLOCK_FIRST_ENTRY(block) ((block) -> first_entry)
99 #define COMPILED_BLOCK_N_ENTRIES(block) ((block) -> n_entries)
100 #define COMPILED_BLOCK_FLAGS(block) ((block) -> flags)
101
102 #define COMPILED_BLOCK_DATA_PROC(block) \
103 ((liarc_data_proc_t *) (_COMPILED_BLOCK_DATA_PROC (block)))
104
105 #define SET_COMPILED_BLOCK_DATA_PROC(block, proc) do \
106 { \
107 _CBFS (block, _CBF_DATA_INIT); \
108 _CBFC (block, _CBF_DATA_ONLY); \
109 (_COMPILED_BLOCK_DATA_PROC (block)) = (proc); \
110 } while (false)
111
112 #define COMPILED_BLOCK_OBJECT_PROC(block) \
113 ((liarc_object_proc_t *) (_COMPILED_BLOCK_DATA_PROC (block)))
114
115 #define SET_COMPILED_BLOCK_OBJECT_PROC(block, proc) do \
116 { \
117 _CBFS (block, (_CBF_DATA_INIT | _CBF_DATA_ONLY)); \
118 (_COMPILED_BLOCK_DATA_PROC (block)) = (proc); \
119 } while (false)
120
121 #define _CBFT(block, flag) (((COMPILED_BLOCK_FLAGS (block)) & (flag)) != 0)
122 #define _CBFS(block, flag) ((COMPILED_BLOCK_FLAGS (block)) |= (flag))
123 #define _CBFC(block, flag) ((COMPILED_BLOCK_FLAGS (block)) &=~ (flag))
124
125 #define _CBF_DATA_ONLY 0x01
126 #define _CBF_DATA_INIT 0x02
127
128 #define COMPILED_BLOCK_DATA_ONLY_P(block) (_CBFT (block, _CBF_DATA_ONLY))
129 #define COMPILED_BLOCK_DATA_INIT_P(block) (_CBFT (block, _CBF_DATA_INIT))
130
131 static int declare_compiled_code_ns_1
132 (const char *, entry_count_t, liarc_code_proc_t *);
133 static bool grow_compiled_blocks (void);
134 static bool grow_compiled_entries (entry_count_t);
135 static int declare_trampoline_block (entry_count_t);
136 static SCHEME_OBJECT * trampoline_procedure (SCHEME_OBJECT *, entry_count_t);
137 static compiled_block_t * find_compiled_block (const char *);
138 static SCHEME_OBJECT * unspecified_code (SCHEME_OBJECT *, entry_count_t);
139 static void * lrealloc (void *, size_t);
140 static unsigned int digit_string_producer (void *);
141 static unsigned int hex_digit_to_int (char);
142
143 long C_return_value;
144
145 long
C_to_interface(SCHEME_OBJECT * entry)146 C_to_interface (SCHEME_OBJECT * entry)
147 {
148 while (entry != 0)
149 {
150 entry_count_t index = ((entry_count_t) (*entry));
151 compiled_block_t * block;
152
153 if (index >= n_compiled_entries)
154 {
155 SET_EXP ((SCHEME_OBJECT) entry);
156 return (ERR_EXECUTE_MANIFEST_VECTOR);
157 }
158 block = (compiled_entries[index]);
159 entry = ((* (COMPILED_BLOCK_CODE_PROC (block)))
160 (entry, (COMPILED_BLOCK_FIRST_ENTRY (block))));
161 }
162 return (C_return_value);
163 }
164
165 SCHEME_OBJECT *
invoke_utility(unsigned int code,unsigned long arg1,unsigned long arg2,unsigned long arg3,unsigned long arg4)166 invoke_utility (unsigned int code,
167 unsigned long arg1, unsigned long arg2,
168 unsigned long arg3, unsigned long arg4)
169 {
170 SCHEME_OBJECT * res;
171 (* (utility_table[code])) ((&res), arg1, arg2, arg3, arg4);
172 return (res);
173 }
174
175 void
initialize_C_interface(void)176 initialize_C_interface (void)
177 {
178 if (initial_entry_number == (-1))
179 /* TRAMPOLINE_FUDGE allows for future growth of max_trampoline. */
180 initial_entry_number = (max_trampoline + TRAMPOLINE_FUDGE);
181
182 if (! (((declare_trampoline_block (initial_entry_number)) == 0)
183 && ((initialize_compiled_code_blocks ()) == 0)))
184 {
185 if (GET_PRIMITIVE != SHARP_F)
186 signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
187 outf_fatal ("error initializing compiled code.\n");
188 Microcode_Termination (TERM_EXIT);
189 }
190 }
191
192 SCHEME_OBJECT
initialize_C_compiled_block(const char * name)193 initialize_C_compiled_block (const char * name)
194 {
195 compiled_block_t * block = (find_compiled_block (name));
196 return
197 ((block == 0)
198 ? SHARP_F
199 : (COMPILED_BLOCK_DATA_ONLY_P (block))
200 ? ((* (COMPILED_BLOCK_OBJECT_PROC (block))) ())
201 : (MAKE_CC_ENTRY ((* (COMPILED_BLOCK_DATA_PROC (block)))
202 (COMPILED_BLOCK_FIRST_ENTRY (block)))));
203 }
204
205 SCHEME_OBJECT
initialize_subblock(const char * name)206 initialize_subblock (const char * name)
207 {
208 compiled_block_t * block = (find_compiled_block (name));
209 if ((block == 0) || (COMPILED_BLOCK_DATA_ONLY_P (block)))
210 error_external_return ();
211
212 return
213 (MAKE_CC_BLOCK
214 (cc_entry_address_to_block_address
215 ((* (COMPILED_BLOCK_DATA_PROC (block)))
216 (COMPILED_BLOCK_FIRST_ENTRY (block)))));
217 }
218
219 unsigned long
c_code_table_export_length(unsigned long * n_blocks_r)220 c_code_table_export_length (unsigned long * n_blocks_r)
221 {
222 compiled_block_t * block = compiled_blocks;
223 compiled_block_t * end = (block + n_compiled_blocks);
224 unsigned long n = 1;
225
226 while (block < end)
227 {
228 n += (1 + (BYTES_TO_WORDS ((strlen (COMPILED_BLOCK_NAME (block))) + 1)));
229 block += 1;
230 }
231 (*n_blocks_r) = n_compiled_blocks;
232 return (n);
233 }
234
235 void
export_c_code_table(SCHEME_OBJECT * start)236 export_c_code_table (SCHEME_OBJECT * start)
237 {
238 compiled_block_t * block = compiled_blocks;
239 compiled_block_t * end = (block + n_compiled_blocks);
240
241 (*start++) = (LONG_TO_FIXNUM (initial_entry_number));
242 while (block < end)
243 {
244 (*start++) = (LONG_TO_UNSIGNED_FIXNUM (COMPILED_BLOCK_N_ENTRIES (block)));
245 strcpy (((char *) start), (COMPILED_BLOCK_NAME (block)));
246 start += (BYTES_TO_WORDS ((strlen (COMPILED_BLOCK_NAME (block))) + 1));
247 block += 1;
248 }
249 }
250
251 void
reset_c_code_table(void)252 reset_c_code_table (void)
253 {
254 if (compiled_entries != 0)
255 free (compiled_entries);
256 if (compiled_blocks != 0)
257 free (compiled_blocks);
258 if (compiled_blocks_tree != 0)
259 tree_free (compiled_blocks_tree);
260
261 n_compiled_blocks = 0;
262 compiled_blocks_table_size = 0;
263 compiled_blocks = 0;
264 compiled_blocks_tree = 0;
265
266 n_compiled_entries = 0;
267 compiled_entries_size = 0;
268 compiled_entries = 0;
269 }
270
271 bool
import_c_code_table(SCHEME_OBJECT * table,unsigned long n_blocks)272 import_c_code_table (SCHEME_OBJECT * table, unsigned long n_blocks)
273 {
274 long dumped_initial_entry_number = (FIXNUM_TO_LONG (*table++));
275 unsigned long count;
276
277 if (dumped_initial_entry_number < max_trampoline)
278 return (false);
279 initial_entry_number = dumped_initial_entry_number;
280
281 if ((declare_trampoline_block (initial_entry_number)) != 0)
282 return (false);
283
284 for (count = 0; (count < n_blocks); count += 1)
285 {
286 unsigned long n_entries = (FIXNUM_TO_ULONG (*table++));
287 size_t nb = ((strlen ((const char *) table)) + 1);
288 char * ncopy = (malloc (nb));
289
290 if (ncopy == 0)
291 return (false);
292 strcpy (ncopy, ((const char *) table));
293 if ((declare_compiled_code_ns (ncopy, n_entries, unspecified_code)) != 0)
294 return (false);
295 table += (BYTES_TO_WORDS (nb));
296 }
297
298 return (true);
299 }
300
301 int
declare_compiled_code(const char * name,entry_count_t n_block_entries,liarc_decl_code_t * decl_code,liarc_code_proc_t * code_proc)302 declare_compiled_code (const char * name,
303 entry_count_t n_block_entries,
304 liarc_decl_code_t * decl_code,
305 liarc_code_proc_t * code_proc)
306 {
307 int rc = (declare_compiled_code_ns (name, n_block_entries, code_proc));
308 return ((rc == 0) ? ((*decl_code) ()) : rc);
309 }
310
311 int
declare_compiled_code_ns(const char * name,entry_count_t n_block_entries,liarc_code_proc_t * code_proc)312 declare_compiled_code_ns (const char * name,
313 entry_count_t n_block_entries,
314 liarc_code_proc_t * code_proc)
315 {
316 void * p = dstack_position;
317 int rc
318 = (declare_compiled_code_ns_1 ((liarc_object_file_name (name)),
319 n_block_entries,
320 code_proc));
321 dstack_set_position (p);
322 return (rc);
323 }
324
325 static int
declare_compiled_code_ns_1(const char * name,entry_count_t n_block_entries,liarc_code_proc_t * code_proc)326 declare_compiled_code_ns_1 (const char * name,
327 entry_count_t n_block_entries,
328 liarc_code_proc_t * code_proc)
329 {
330 compiled_block_t * block = (find_compiled_block (name));
331 if (block == 0)
332 {
333 entry_count_t entries_start = n_compiled_entries;
334 entry_count_t entries_end = (entries_start + n_block_entries);
335 char * cname;
336 tree_node new_tree;
337
338 if (! ((entries_start <= entries_end)
339 && ((n_compiled_blocks < compiled_blocks_table_size)
340 || (grow_compiled_blocks ()))
341 && ((entries_end < compiled_entries_size)
342 || (grow_compiled_entries (entries_end)))))
343 return (-1);
344
345 tree_error_message = 0;
346 cname = (OS_malloc ((strlen (name)) + 1));
347 strcpy (cname, name);
348 new_tree
349 = (tree_insert (compiled_blocks_tree, cname, n_compiled_blocks));
350 if (tree_error_message != 0)
351 {
352 OS_free ((void *) cname);
353 return (-1);
354 }
355 compiled_blocks_tree = new_tree;
356
357 block = (compiled_blocks + (n_compiled_blocks++));
358 (COMPILED_BLOCK_NAME (block)) = cname;
359 (COMPILED_BLOCK_CODE_PROC (block)) = code_proc;
360 (_COMPILED_BLOCK_DATA_PROC (block)) = 0;
361 (COMPILED_BLOCK_FIRST_ENTRY (block)) = entries_start;
362 (COMPILED_BLOCK_N_ENTRIES (block)) = n_block_entries;
363 (COMPILED_BLOCK_FLAGS (block)) = 0;
364
365 while (n_compiled_entries < entries_end)
366 (compiled_entries[n_compiled_entries++]) = block;
367 return (0);
368 }
369 else if ((((COMPILED_BLOCK_CODE_PROC (block)) == unspecified_code)
370 || ((COMPILED_BLOCK_CODE_PROC (block)) == code_proc)
371 || (code_proc == unspecified_code))
372 && ((COMPILED_BLOCK_N_ENTRIES (block)) == n_block_entries))
373 {
374 (COMPILED_BLOCK_CODE_PROC (block)) = code_proc;
375 return (0);
376 }
377 else
378 return (-1);
379 }
380
381 const char *
liarc_object_file_name(const char * name)382 liarc_object_file_name (const char * name)
383 {
384 const char * prefix;
385 char * full;
386
387 prefix = (liarc_object_file_prefix ());
388 if (prefix == 0)
389 return (name);
390 full = (dstack_alloc ((strlen (prefix)) + (strlen (name)) + 1));
391 strcpy (full, prefix);
392 strcat (full, name);
393 return (full);
394 }
395
396 static bool
grow_compiled_blocks(void)397 grow_compiled_blocks (void)
398 {
399 entry_count_t new_blocks_size
400 = ((compiled_blocks_table_size == 0)
401 ? 16
402 : (compiled_blocks_table_size * 2));
403 compiled_block_t * new_blocks
404 = (lrealloc (compiled_blocks,
405 (new_blocks_size * (sizeof (compiled_block_t)))));
406 if (new_blocks == 0)
407 return (false);
408 if (new_blocks != compiled_blocks)
409 {
410 compiled_block_t ** scan = compiled_entries;
411 compiled_block_t ** end = (scan + n_compiled_entries);
412 while (scan < end)
413 {
414 (*scan) = (((*scan) - compiled_blocks) + new_blocks);
415 scan += 1;
416 }
417 }
418 compiled_blocks_table_size = new_blocks_size;
419 compiled_blocks = new_blocks;
420 return (true);
421 }
422
423 static bool
grow_compiled_entries(entry_count_t entries_end)424 grow_compiled_entries (entry_count_t entries_end)
425 {
426 entry_count_t new_entries_size
427 = ((compiled_entries_size == 0)
428 ? 128
429 : compiled_entries_size);
430 compiled_block_t ** new_entries;
431
432 while (new_entries_size <= entries_end)
433 new_entries_size *= 2;
434 new_entries
435 = (lrealloc (compiled_entries,
436 (new_entries_size * (sizeof (compiled_block_t *)))));
437 if (new_entries == 0)
438 return (false);
439 compiled_entries_size = new_entries_size;
440 compiled_entries = new_entries;
441 return (true);
442 }
443
444 int
declare_compiled_data(const char * name,liarc_decl_data_t * decl_data,liarc_data_proc_t * data_proc)445 declare_compiled_data (const char * name,
446 liarc_decl_data_t * decl_data,
447 liarc_data_proc_t * data_proc)
448 {
449 int rc = (declare_compiled_data_ns (name, data_proc));
450 return ((rc == 0) ? ((*decl_data) ()) : rc);
451 }
452
453 int
declare_compiled_data_ns(const char * name,liarc_data_proc_t * data_proc)454 declare_compiled_data_ns (const char * name, liarc_data_proc_t * data_proc)
455 {
456 void * p = dstack_position;
457 const char * full = (liarc_object_file_name (name));
458 compiled_block_t * block = (find_compiled_block (full));
459 dstack_set_position (p);
460 if (! ((block != 0)
461 && ((!COMPILED_BLOCK_DATA_INIT_P (block))
462 || ((COMPILED_BLOCK_DATA_PROC (block)) == data_proc))))
463 return (-1);
464 SET_COMPILED_BLOCK_DATA_PROC (block, data_proc);
465 return (0);
466 }
467
468 int
declare_data_object(const char * name,liarc_object_proc_t * object_proc)469 declare_data_object (const char * name, liarc_object_proc_t * object_proc)
470 {
471 void * p = dstack_position;
472 const char * full = (liarc_object_file_name (name));
473 compiled_block_t * block = (find_compiled_block (full));
474 if (block == 0)
475 {
476 declare_compiled_code_ns_1 (full, 0, unspecified_code);
477 block = (find_compiled_block (full));
478 if (block == 0)
479 {
480 dstack_set_position (p);
481 return (-1);
482 }
483 }
484
485 dstack_set_position (p);
486 if (! ((!COMPILED_BLOCK_DATA_INIT_P (block))
487 || ((COMPILED_BLOCK_OBJECT_PROC (block)) == object_proc)))
488 return (-1);
489 SET_COMPILED_BLOCK_OBJECT_PROC (block, object_proc);
490 return (0);
491 }
492
493 int
declare_compiled_code_mult(unsigned int nslots,const struct liarc_code_S * slots)494 declare_compiled_code_mult (unsigned int nslots,
495 const struct liarc_code_S * slots)
496 {
497 unsigned int i = 0;
498 while (i < nslots)
499 {
500 int res = (declare_compiled_code_ns (((char *) ((slots[i]) . name)),
501 ((slots[i]) . nentries),
502 ((slots[i]) . code)));
503 if (res != 0)
504 return (res);
505 i += 1;
506 }
507 return (0);
508 }
509
510 int
declare_compiled_data_mult(unsigned int nslots,const struct liarc_data_S * slots)511 declare_compiled_data_mult (unsigned int nslots,
512 const struct liarc_data_S * slots)
513 {
514 unsigned int i = 0;
515 while (i < nslots)
516 {
517 int res = (declare_compiled_data_ns (((char *) ((slots[i]) . name)),
518 ((slots[i]) . data)));
519 if (res != 0)
520 return (res);
521 i += 1;
522 }
523 return (0);
524 }
525
526 static int
declare_trampoline_block(entry_count_t n_block_entries)527 declare_trampoline_block (entry_count_t n_block_entries)
528 {
529 return (declare_compiled_code_ns_1 ("#trampoline_code_block",
530 n_block_entries,
531 trampoline_procedure));
532 }
533
534 bool
store_trampoline_insns(insn_t * entry,byte_t code)535 store_trampoline_insns (insn_t * entry, byte_t code)
536 {
537 /* Trampoline entries are stored in the lowest part of the
538 compiled_entries table. That's why we reserve those above. */
539 (*entry) = code;
540 return (false);
541 }
542
543 static SCHEME_OBJECT *
trampoline_procedure(SCHEME_OBJECT * trampoline,entry_count_t dispatch)544 trampoline_procedure (SCHEME_OBJECT * trampoline, entry_count_t dispatch)
545 {
546 return (invoke_utility (((unsigned int) (* ((insn_t *) trampoline))),
547 ((unsigned long)
548 (trampoline_storage
549 (cc_entry_address_to_block_address
550 ((insn_t *) trampoline)))),
551 0, 0, 0));
552 }
553
554 static compiled_block_t *
find_compiled_block(const char * name)555 find_compiled_block (const char * name)
556 {
557 tree_node node = (tree_lookup (compiled_blocks_tree, name));
558 return ((node == 0) ? 0 : (compiled_blocks + (node->value)));
559 }
560
561 static SCHEME_OBJECT *
unspecified_code(SCHEME_OBJECT * entry,entry_count_t dispatch)562 unspecified_code (SCHEME_OBJECT * entry, entry_count_t dispatch)
563 {
564 SET_EXP ((SCHEME_OBJECT) entry);
565 C_return_value = ERR_EXECUTE_MANIFEST_VECTOR;
566 return (0);
567 }
568
569 static void *
lrealloc(void * ptr,size_t size)570 lrealloc (void * ptr, size_t size)
571 {
572 return ((ptr == 0) ? (malloc (size)) : (realloc (ptr, size)));
573 }
574
575 unsigned long
liarc_n_compiled_blocks(void)576 liarc_n_compiled_blocks (void)
577 {
578 return (n_compiled_blocks);
579 }
580
581 void
get_liarc_compiled_block_data(unsigned long index,const char ** name_r,void ** code_proc_r,void ** data_proc_r,void ** object_proc_r)582 get_liarc_compiled_block_data (unsigned long index,
583 const char ** name_r,
584 void ** code_proc_r,
585 void ** data_proc_r,
586 void ** object_proc_r)
587 {
588 compiled_block_t * block;
589
590 assert (index < n_compiled_blocks);
591 block = (& (compiled_blocks[index]));
592 (*name_r) = (COMPILED_BLOCK_NAME (block));
593 if (COMPILED_BLOCK_DATA_ONLY_P (block))
594 {
595 (*code_proc_r) = 0;
596 (*data_proc_r) = 0;
597 (*object_proc_r) = (COMPILED_BLOCK_OBJECT_PROC (block));
598 }
599 else
600 {
601 (*code_proc_r) = (COMPILED_BLOCK_CODE_PROC (block));
602 (*data_proc_r)
603 = ((COMPILED_BLOCK_DATA_INIT_P (block))
604 ? (COMPILED_BLOCK_DATA_PROC (block))
605 : 0);
606 (*object_proc_r) = 0;
607 }
608 }
609
610 int
multiply_with_overflow(long x,long y,long * res)611 multiply_with_overflow (long x, long y, long * res)
612 {
613 SCHEME_OBJECT ans = (Mul ((LONG_TO_FIXNUM (x)), (LONG_TO_FIXNUM (y))));
614 if (ans == SHARP_F)
615 {
616 /* Bogus... */
617 (*res) = (x * y);
618 return (1);
619 }
620 else
621 {
622 (*res) = (FIXNUM_TO_LONG (ans));
623 return (0);
624 }
625 }
626
627 SCHEME_OBJECT
memory_to_uninterned_symbol(unsigned long length,const void * string)628 memory_to_uninterned_symbol (unsigned long length, const void * string)
629 {
630 SCHEME_OBJECT name = (memory_to_string (length, string));
631 SCHEME_OBJECT res = (CONS (name, UNBOUND_OBJECT));
632 return (OBJECT_NEW_TYPE (TC_UNINTERNED_SYMBOL, res));
633 }
634
635 SCHEME_OBJECT
rconsm(unsigned int nargs,SCHEME_OBJECT tail,...)636 rconsm (unsigned int nargs, SCHEME_OBJECT tail, ...)
637 {
638 SCHEME_OBJECT result;
639 unsigned int i;
640 va_list arg_ptr;
641 va_start (arg_ptr, tail);
642
643 result = tail;
644 for (i = 1; (i < nargs); i += 1)
645 result
646 = (cons ((va_arg (arg_ptr, SCHEME_OBJECT)),
647 result));
648
649 va_end (arg_ptr);
650 return (result);
651 }
652
653 SCHEME_OBJECT
digit_string_to_bit_string(unsigned long n_bits,unsigned long n_digits,const char * digits)654 digit_string_to_bit_string (unsigned long n_bits,
655 unsigned long n_digits,
656 const char * digits)
657 {
658 SCHEME_OBJECT result = (allocate_bit_string (n_bits));
659 unsigned long posn = 0;
660 unsigned long i;
661
662 clear_bit_string (result);
663 for (i = 0; (i < n_digits); i += 1)
664 {
665 unsigned int digit = (hex_digit_to_int (*digits++));
666 unsigned int j = 0;
667 unsigned int mask = 1;
668 while (j < 4)
669 {
670 if ((digit & mask) != 0)
671 bit_string_set (result, posn, 1);
672 j += 1;
673 mask <<= 1;
674 posn += 1;
675 }
676 }
677 return (result);
678 }
679
680 SCHEME_OBJECT
digit_string_to_integer(bool negative_p,unsigned long n_digits,const char * digits)681 digit_string_to_integer (bool negative_p,
682 unsigned long n_digits,
683 const char * digits)
684 {
685 SCHEME_OBJECT bignum
686 = (digit_stream_to_bignum (((int) n_digits),
687 digit_string_producer,
688 ((void *) (&digits)),
689 16,
690 ((int) negative_p)));
691
692 return (bignum_to_integer (bignum));
693 }
694
695 static unsigned int
digit_string_producer(void * v_digit_ptr)696 digit_string_producer (void * v_digit_ptr)
697 {
698 const char ** digit_ptr = v_digit_ptr;
699 char digit = (**digit_ptr);
700 (*digit_ptr) = ((*digit_ptr) + 1);
701 return (hex_digit_to_int (digit));
702 }
703
704 static unsigned int
hex_digit_to_int(char h_digit)705 hex_digit_to_int (char h_digit)
706 {
707 unsigned int digit = ((unsigned int) h_digit);
708 return (((digit >= '0') && (digit <= '9'))
709 ? (digit - '0')
710 : (((digit >= 'A') && (digit <= 'F'))
711 ? ((digit - 'A') + 10)
712 : ((digit - 'a') + 10)));
713 }
714