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 /* Un*x primitives for an FFI. */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "bignmint.h"
32 #include "history.h"
33 #include "floenv.h"
34 #include "pruxffi.h"
35 /* Using SCM instead of SCHEME_OBJECT here, hoping to ensure that
36 these types always match. */
37
38 /* Alien Addresses */
39
40 #define HALF_WORD_SHIFT ((sizeof (void *) * CHAR_BIT) / 2UL)
41 #define HALF_WORD_MASK ((1UL << HALF_WORD_SHIFT) - 1UL)
42 #define ARG_RECORD(argument_number) \
43 ((RECORD_P (ARG_REF (argument_number))) \
44 ? (ARG_REF (argument_number)) \
45 : ((error_wrong_type_arg (argument_number)), 0))
46
47 int
is_alien(SCM alien)48 is_alien (SCM alien)
49 {
50 if ((RECORD_P (alien)) && ((VECTOR_LENGTH (alien)) == 4))
51 {
52 SCM high = (VECTOR_REF (alien, 1));
53 SCM low = (VECTOR_REF (alien, 2));
54 if ((UNSIGNED_FIXNUM_P (high)) && (UNSIGNED_FIXNUM_P (low)))
55 return (1);
56 }
57 return (0);
58 }
59
60 void *
alien_address(SCM alien)61 alien_address (SCM alien)
62 {
63 unsigned long high = (FIXNUM_TO_ULONG (VECTOR_REF (alien, 1)));
64 unsigned long low = (FIXNUM_TO_ULONG (VECTOR_REF (alien, 2)));
65 return ((void *) ((high << HALF_WORD_SHIFT) + low));
66 }
67
68 void
set_alien_address(SCM alien,const void * ptr)69 set_alien_address (SCM alien, const void * ptr)
70 {
71 unsigned long addr = ((unsigned long) ptr);
72 VECTOR_SET (alien, 1, (ULONG_TO_FIXNUM (addr >> HALF_WORD_SHIFT)));
73 VECTOR_SET (alien, 2, (ULONG_TO_FIXNUM (addr & HALF_WORD_MASK)));
74 }
75
76 SCM
arg_alien(int argn)77 arg_alien (int argn)
78 {
79 SCM alien = (ARG_REF (argn));
80 if (is_alien (alien))
81 return (alien);
82 error_wrong_type_arg (argn);
83 return (0);
84 }
85
86 void *
arg_address(int argn)87 arg_address (int argn)
88 {
89 SCM alien = ARG_REF (argn);
90 if (is_alien (alien))
91 return (alien_address (alien));
92 error_wrong_type_arg (argn);
93 return (0);
94 }
95
96 #define ALIEN_ADDRESS_LOC(type) \
97 ((type *)(((char *) (arg_address (1))) + (UNSIGNED_FIXNUM_ARG (2))))
98
99 #define ALIEN_ADDRESS_REF(type) (* (ALIEN_ADDRESS_LOC (type)))
100
101 #define ALIEN_ADDRESS_SET(type, value) do \
102 { \
103 (* (ALIEN_ADDRESS_LOC (type))) = (value); \
104 } while (0)
105
106 #define C_PEEKER(type_to_object, type) \
107 { \
108 PRIMITIVE_HEADER (2); \
109 PRIMITIVE_RETURN (type_to_object (ALIEN_ADDRESS_REF (type))); \
110 }
111
112 /* Peek the Basic Types */
113
114 DEFINE_PRIMITIVE ("C-PEEK-CHAR", Prim_peek_char, 2, 2, 0)
C_PEEKER(LONG_TO_FIXNUM,char)115 C_PEEKER (LONG_TO_FIXNUM, char)
116
117 DEFINE_PRIMITIVE ("C-PEEK-UCHAR", Prim_peek_uchar, 2, 2, 0)
118 C_PEEKER (LONG_TO_FIXNUM, unsigned char)
119
120 DEFINE_PRIMITIVE ("C-PEEK-SHORT", Prim_peek_short, 2, 2, 0)
121 C_PEEKER (LONG_TO_FIXNUM, short)
122
123 DEFINE_PRIMITIVE ("C-PEEK-USHORT", Prim_peek_ushort, 2, 2, 0)
124 C_PEEKER (LONG_TO_FIXNUM, unsigned short)
125
126 DEFINE_PRIMITIVE ("C-PEEK-INT", Prim_peek_int, 2, 2, 0)
127 C_PEEKER (long_to_integer, int)
128
129 DEFINE_PRIMITIVE ("C-PEEK-UINT", Prim_peek_uint, 2, 2, 0)
130 C_PEEKER (ulong_to_integer, unsigned int)
131
132 DEFINE_PRIMITIVE ("C-PEEK-LONG", Prim_peek_long, 2, 2, 0)
133 C_PEEKER (long_to_integer, long)
134
135 DEFINE_PRIMITIVE ("C-PEEK-ULONG", Prim_peek_ulong, 2, 2, 0)
136 C_PEEKER (ulong_to_integer, unsigned long)
137
138 DEFINE_PRIMITIVE ("C-PEEK-FLOAT", Prim_peek_float, 2, 2, 0)
139 C_PEEKER (double_to_flonum, float)
140
141 DEFINE_PRIMITIVE ("C-PEEK-DOUBLE", Prim_peek_double, 2, 2, 0)
142 C_PEEKER (double_to_flonum, double)
143
144 DEFINE_PRIMITIVE ("C-PEEK-POINTER", Prim_peek_pointer, 3, 3, 0)
145 {
146 /* Read the pointer at ALIEN+OFFSET and set ALIEN2 (perhaps the
147 same as ALIEN) to point to the same address. */
148
149 PRIMITIVE_HEADER (3);
150 {
151 SCM alien = (ARG_RECORD (3));
152 set_alien_address (alien, (ALIEN_ADDRESS_REF (void *)));
153 PRIMITIVE_RETURN (alien);
154 }
155 }
156
157 DEFINE_PRIMITIVE ("C-PEEK-CSTRING", Prim_peek_cstring, 2, 2, 0)
158 {
159 PRIMITIVE_HEADER (2);
160 PRIMITIVE_RETURN (char_pointer_to_string (ALIEN_ADDRESS_LOC (char)));
161 }
162
163 DEFINE_PRIMITIVE ("C-PEEK-CSTRING!", Prim_peek_cstring_bang, 2, 2, 0)
164 {
165 /* Return a Scheme string containing the characters in a C string
166 that starts at the address ALIEN+OFFSET. Set ALIEN to the
167 address of the C char after the string's null terminator. */
168
169 PRIMITIVE_HEADER (2);
170 {
171 char * ptr = (ALIEN_ADDRESS_LOC (char));
172 SCM string = (char_pointer_to_string (ptr));
173 set_alien_address ((ARG_REF (1)), (ptr + strlen (ptr) + 1));
174 PRIMITIVE_RETURN (string);
175 }
176 }
177
178 DEFINE_PRIMITIVE ("C-PEEK-CSTRINGP", Prim_peek_cstringp, 2, 2, 0)
179 {
180 /* Follow the pointer at the address ALIEN+OFFSET to a C string.
181 Copy the C string into the heap and return the new Scheme
182 string. If the pointer is null, return (). */
183
184 PRIMITIVE_HEADER (2);
185 {
186 char ** ptr = (ALIEN_ADDRESS_LOC (char *));
187 if (*ptr == NULL)
188 {
189 PRIMITIVE_RETURN (EMPTY_LIST);
190 }
191 else
192 {
193 PRIMITIVE_RETURN (char_pointer_to_string (*ptr));
194 }
195 }
196 }
197
198 DEFINE_PRIMITIVE ("C-PEEK-CSTRINGP!", Prim_peek_cstringp_bang, 2, 2, 0)
199 {
200 /* Follow the pointer at the address ALIEN+OFFSET to a C string.
201 Set ALIEN to the address of the char pointer after ALIEN+OFFSET.
202 Copy the C string into the heap and return the new Scheme
203 string. If the pointer is null, return (). */
204
205 PRIMITIVE_HEADER (2);
206 {
207 char ** ptr = (ALIEN_ADDRESS_LOC (char *));
208 if (*ptr == NULL)
209 {
210 PRIMITIVE_RETURN (EMPTY_LIST);
211 }
212 else
213 {
214 SCM string = char_pointer_to_string (*ptr);
215 set_alien_address ((ARG_REF (1)), (ptr + 1)); /* No more aborts! */
216 PRIMITIVE_RETURN (string);
217 }
218 }
219 }
220
221 DEFINE_PRIMITIVE ("C-PEEK-BYTES", Prim_peek_bytes, 5, 5, 0)
222 {
223 /* Copy, from ALIEN+OFFSET, COUNT bytes to STRING[START..]. */
224
225 PRIMITIVE_HEADER (5);
226 CHECK_ARG (4, STRING_P);
227 {
228 const void * src = (ALIEN_ADDRESS_LOC (void *));
229 int count = (UNSIGNED_FIXNUM_ARG (3));
230 SCM string = (ARG_REF (4));
231 int index = arg_index_integer (5, (STRING_LENGTH (string)));
232 void * dest = STRING_LOC (string, index);
233 memcpy (dest, src, count);
234 }
235 PRIMITIVE_RETURN (UNSPECIFIC);
236 }
237
238 #define C_POKER(type, value_arg_ref) \
239 { \
240 PRIMITIVE_HEADER (3); \
241 ALIEN_ADDRESS_SET (type, (value_arg_ref (3))); \
242 PRIMITIVE_RETURN (UNSPECIFIC); \
243 }
244
245 /* Poke the Basic Types */
246
247 DEFINE_PRIMITIVE ("C-POKE-CHAR", Prim_poke_char, 3, 3, 0)
C_POKER(char,arg_integer)248 C_POKER (char, arg_integer)
249
250 DEFINE_PRIMITIVE ("C-POKE-UCHAR", Prim_poke_uchar, 3, 3, 0)
251 C_POKER (unsigned char, arg_integer)
252
253 DEFINE_PRIMITIVE ("C-POKE-SHORT", Prim_poke_short, 3, 3, 0)
254 C_POKER (short, arg_integer)
255
256 DEFINE_PRIMITIVE ("C-POKE-USHORT", Prim_poke_ushort, 3, 3, 0)
257 C_POKER (unsigned short, arg_integer)
258
259 DEFINE_PRIMITIVE ("C-POKE-INT", Prim_poke_int, 3, 3, 0)
260 C_POKER (int, arg_integer)
261
262 DEFINE_PRIMITIVE ("C-POKE-UINT", Prim_poke_uint, 3, 3, 0)
263 C_POKER (unsigned int, arg_integer)
264
265 DEFINE_PRIMITIVE ("C-POKE-LONG", Prim_poke_long, 3, 3, 0)
266 C_POKER (long, arg_integer)
267
268 DEFINE_PRIMITIVE ("C-POKE-ULONG", Prim_poke_ulong, 3, 3, 0)
269 C_POKER (unsigned long, arg_ulong_integer)
270
271 DEFINE_PRIMITIVE ("C-POKE-FLOAT", Prim_poke_float, 3, 3, 0)
272 C_POKER (float, arg_real_number)
273
274 DEFINE_PRIMITIVE ("C-POKE-DOUBLE", Prim_poke_double, 3, 3, 0)
275 C_POKER (double, arg_real_number)
276
277 DEFINE_PRIMITIVE ("C-POKE-POINTER", Prim_poke_pointer, 3, 3, 0)
278 C_POKER (void *, arg_pointer)
279
280 DEFINE_PRIMITIVE ("C-POKE-POINTER!", Prim_poke_pointer_bang, 3, 3, 0)
281 {
282 /* Set the pointer at address ALIEN+OFFSET to ADDRESS (an alien,
283 string, xstring or 0 for NULL). Set ALIEN to the address of the
284 pointer after ALIEN+OFFSET. */
285
286 PRIMITIVE_HEADER (3);
287 {
288 void ** ptr = (ALIEN_ADDRESS_LOC (void *));
289 (*ptr) = (arg_pointer (3));
290 set_alien_address ((ARG_REF (1)), (ptr + 1));
291 }
292 PRIMITIVE_RETURN (UNSPECIFIC);
293 }
294
295 DEFINE_PRIMITIVE ("C-POKE-STRING", Prim_poke_string, 3, 3, 0)
296 {
297 /* Copy into the C string at address ALIEN+OFFSET the Scheme STRING.
298 Assume STRING fits. Null terminate the C string. */
299
300 PRIMITIVE_HEADER (3);
301 CHECK_ARG (3, STRING_P);
302 {
303 SCM string = (ARG_REF (3));
304 strncpy ((ALIEN_ADDRESS_LOC (char)),
305 (STRING_POINTER (string)),
306 ((STRING_LENGTH (string)) + 1));
307 }
308 PRIMITIVE_RETURN (UNSPECIFIC);
309 }
310
311 DEFINE_PRIMITIVE ("C-POKE-STRING!", Prim_poke_string_bang, 3, 3, 0)
312 {
313 /* Copy into the C string at address ALIEN+OFFSET the Scheme STRING.
314 Assume STRING fits. Null terminate the C string. Set ALIEN to
315 the address of the C char following the NULL terminator. */
316
317 PRIMITIVE_HEADER (3);
318 CHECK_ARG (3, STRING_P);
319 {
320 char * ptr = (ALIEN_ADDRESS_LOC (char));
321 SCM string = (ARG_REF (3));
322 unsigned long n_chars = ((STRING_LENGTH (string)) + 1);
323 strncpy (ptr, (STRING_POINTER (string)), n_chars);
324 set_alien_address ((ARG_REF (1)), (ptr + n_chars));
325 }
326 PRIMITIVE_RETURN (UNSPECIFIC);
327 }
328
329 DEFINE_PRIMITIVE ("C-POKE-BYTES", Prim_poke_bytes, 5, 5, 0)
330 {
331 /* Copy to ALIEN+OFFSET COUNT bytes from STRING[START]. */
332
333 PRIMITIVE_HEADER (5);
334 CHECK_ARG (4, STRING_P);
335 {
336 void * dest = (ALIEN_ADDRESS_LOC (void *));
337 int count = (UNSIGNED_FIXNUM_ARG (3));
338 SCM string = (ARG_REF (4));
339 int index = arg_index_integer (5, (STRING_LENGTH (string)));
340 const void * src = STRING_LOC (string, index);
341 memcpy (dest, src, count);
342 }
343 PRIMITIVE_RETURN (UNSPECIFIC);
344 }
345
346 /* Malloc/Free. */
347
348 DEFINE_PRIMITIVE ("C-MALLOC", Prim_c_malloc, 2, 2, 0)
349 {
350 PRIMITIVE_HEADER (2);
351 set_alien_address ((arg_alien (1)), (malloc (arg_ulong_integer (2))));
352 PRIMITIVE_RETURN (UNSPECIFIC);
353 }
354
355 DEFINE_PRIMITIVE ("C-FREE", Prim_c_free, 1, 1, 0)
356 {
357 PRIMITIVE_HEADER (1);
358 {
359 void * addr = (arg_address (1));
360 if (addr != NULL)
361 free (addr);
362 }
363 PRIMITIVE_RETURN (UNSPECIFIC);
364 }
365
366 /* The CStack */
367
368 char *
cstack_top(void)369 cstack_top (void)
370 {
371 return (ffi_obstack.next_free);
372 }
373
374 void
cstack_push(void * addr,int bytes)375 cstack_push (void * addr, int bytes)
376 {
377 obstack_grow ((&ffi_obstack), addr, bytes);
378 }
379
380 char *
cstack_lpop(char * tos,int bytes)381 cstack_lpop (char * tos, int bytes)
382 {
383 tos = tos - bytes;
384 if (tos < ffi_obstack.object_base)
385 {
386 outf_error ("\ninternal error: C stack exhausted\n");
387 outf_error ("\tCould not pop %d bytes.\n", bytes);
388 outf_flush_error ();
389 signal_error_from_primitive (ERR_EXTERNAL_RETURN);
390 }
391 return (tos);
392 }
393
394 void
cstack_pop(char * tos)395 cstack_pop (char * tos)
396 {
397 if (tos < ffi_obstack.object_base)
398 {
399 outf_error ("\ninternal error: C stack over-popped.\n");
400 outf_flush_error ();
401 signal_error_from_primitive (ERR_EXTERNAL_RETURN);
402 }
403 (&ffi_obstack)->next_free = tos;
404 }
405
406 /* Number CStack frames, to detect slips. */
407 int cstack_depth = 0;
408
409 /* Callouts */
410
411 DEFINE_PRIMITIVE ("C-CALL", Prim_c_call, 1, LEXPR, 0)
412 {
413 /* All the smarts are in the trampolines. */
414
415 PRIMITIVE_HEADER (LEXPR);
416 canonicalize_primitive_context ();
417 {
418 CalloutTrampOut tramp;
419
420 tramp = (CalloutTrampOut) arg_alien_entry (1);
421 PRIMITIVE_RETURN (tramp ());
422 }
423 }
424
425 void
alienate_float_environment(void)426 alienate_float_environment (void)
427 {
428 int s;
429
430 #ifdef FE_DFL_ENV
431 s = fesetenv (FE_DFL_ENV);
432 if (s != 0)
433 {
434 outf_error ("Error status from fesetenv: %d\n", s);
435 outf_flush_error ();
436 }
437 #else
438 # ifdef HAVE_FECLEAREXCEPT
439 # ifdef HAVE_FEDISABLEEXCEPT
440 # ifdef HAVE_FESETROUND
441 s = feclearexcept (FE_ALL_EXCEPT);
442 if (s == -1)
443 {
444 outf_error ("Error status from feclearexcept: %d\n", s);
445 outf_flush_error ();
446 }
447 s = fedisableexcept (FE_ALL_EXCEPT);
448 if (s == -1)
449 {
450 outf_error ("Error status from fedisableexcept: %d\n", s);
451 outf_flush_error ();
452 }
453 s = fesetround (FE_TONEAREST);
454 if (s != 0)
455 {
456 outf_error ("Error status from fesetround: %d\n", s);
457 outf_flush_error ();
458 }
459 # endif
460 # endif
461 # endif
462 #endif
463 }
464
465 static SCM c_call_continue = SHARP_F;
466
467 void
callout_seal(CalloutTrampIn tramp)468 callout_seal (CalloutTrampIn tramp)
469 {
470 /* Used in a callout part1 trampoline. Arrange for subsequent
471 aborts to start part2.
472
473 Seal the CStack, substitute the C-CALL-CONTINUE primitive for
474 the C-CALL primitive, and back out. The tramp can then execute
475 the toolkit function safely, even if there is a callback. */
476
477 if (c_call_continue == SHARP_F)
478 {
479 c_call_continue
480 = find_primitive_cname ("C-CALL-CONTINUE",
481 false, false, LEXPR_PRIMITIVE_ARITY);
482 if (c_call_continue == SHARP_F)
483 {
484 outf_error ("\nNo C-CALL-CONTINUE primitive!\n");
485 outf_flush_error ();
486 signal_error_from_primitive (ERR_EXTERNAL_RETURN);
487 }
488 }
489 cstack_depth += 1;
490 CSTACK_PUSH (int, cstack_depth);
491 CSTACK_PUSH (CalloutTrampIn, tramp);
492
493 /* Back out of C-CALL-CONTINUE. */
494 SET_PRIMITIVE (c_call_continue);
495 back_out_of_primitive ();
496 alienate_float_environment ();
497 }
498
499 void
callout_unseal(CalloutTrampIn expected)500 callout_unseal (CalloutTrampIn expected)
501 {
502 /* Used by a callout part1 trampoline to strip the CStack's frame
503 header (tramp, depth) before pushing return values. */
504
505 char * tos;
506 CalloutTrampIn found;
507 int depth;
508
509 tos = cstack_top ();
510 CSTACK_LPOP (CalloutTrampIn, found, tos);
511 CSTACK_LPOP (int, depth, tos);
512 if (found != expected || depth != cstack_depth)
513 {
514 outf_error ("\ninternal error: slipped in 1st part of callout\n");
515 outf_flush_error ();
516 signal_error_from_primitive (ERR_EXTERNAL_RETURN);
517 }
518 cstack_pop (tos);
519 }
520
521 SCM
callout_continue(CalloutTrampIn tramp)522 callout_continue (CalloutTrampIn tramp)
523 {
524 /* Re-seal the CStack frame over the C results (again, pushing the
525 cstack_depth and callout-part2) and abort. Restart as
526 C-CALL-CONTINUE and run callout-part2. */
527 SCM val;
528
529 CSTACK_PUSH (int, cstack_depth);
530 CSTACK_PUSH (CalloutTrampIn, tramp);
531
532 /* Just call; do not actually abort. */
533 /* PRIMITIVE_ABORT (PRIM_POP_RETURN); */
534
535 /* Remove stack sealant created by callout_seal (which used
536 back_out_of_primitive), as if removed by pop_return in Interp()
537 after the abort. */
538 SET_PRIMITIVE (SHARP_F); /* PROCEED_AFTER_PRIMITIVE (); */
539 RESTORE_CONT ();
540 assert (RC_INTERNAL_APPLY == (OBJECT_DATUM(GET_RET)));
541 SET_LEXPR_ACTUALS (APPLY_FRAME_N_ARGS ());
542 stack_pointer = (APPLY_FRAME_ARGS ());
543 SET_EXP (APPLY_FRAME_PROCEDURE ());
544 /* APPLY_PRIMITIVE_FROM_INTERPRETER (Function); */
545 /* Prim_c_call_continue(); */
546 val = tramp ();
547 return (val);
548 }
549
550 DEFINE_PRIMITIVE ("C-CALL-CONTINUE", Prim_c_call_continue, 1, LEXPR, 0)
551 {
552 /* (Re)Run the callout trampoline part 2 (CalloutTrampIn). */
553
554 PRIMITIVE_HEADER (LEXPR);
555 {
556 char * tos;
557 CalloutTrampIn tramp;
558 int depth;
559 SCM val;
560
561 tos = cstack_top ();
562 CSTACK_LPOP (CalloutTrampIn, tramp, tos);
563 CSTACK_LPOP (int, depth, tos);
564 if (depth != cstack_depth)
565 {
566 outf_error ("\ninternal error: slipped in 2nd part of callout\n");
567 outf_flush_error ();
568 signal_error_from_primitive (ERR_EXTERNAL_RETURN);
569 }
570 val = tramp ();
571 PRIMITIVE_RETURN (val);
572 }
573 }
574
575 char *
callout_lunseal(CalloutTrampIn expected)576 callout_lunseal (CalloutTrampIn expected)
577 {
578 /* Used by a callout part2 trampoline to strip the CStack's frame
579 header (tramp, depth) before lpopping return value(s). */
580
581 char * tos;
582 CalloutTrampIn found;
583 int depth;
584
585 tos = cstack_top ();
586 CSTACK_LPOP (CalloutTrampIn, found, tos);
587 CSTACK_LPOP (int, depth, tos);
588 if (depth != cstack_depth || found != expected)
589 {
590 outf_error ("\ninternal error: slipped in 1st part of callout\n");
591 outf_flush_error ();
592 signal_error_from_primitive (ERR_EXTERNAL_RETURN);
593 }
594 return (tos);
595 }
596
597 void
callout_pop(char * tos)598 callout_pop (char * tos)
599 {
600 /* Used by a callout part2 trampoline just before returning. */
601
602 cstack_depth -= 1;
603 cstack_pop (tos);
604 }
605
606 /* Callbacks */
607
608 static SCM run_callback = SHARP_F;
609 static SCM return_to_c = SHARP_F;
610
611 void
callback_run_kernel(long callback_id,CallbackKernel kernel)612 callback_run_kernel (long callback_id, CallbackKernel kernel)
613 {
614 /* Used by callback trampolines.
615
616 Expect the args on the CStack. Push a couple primitive apply
617 frames on the Scheme stack and seal the CStack. Then call
618 Interpret(). Cannot abort. */
619
620 if (run_callback == SHARP_F)
621 {
622 run_callback = find_primitive_cname ("RUN-CALLBACK", false, false, 0);
623 return_to_c = find_primitive_cname ("RETURN-TO-C", false, false, 0);
624 if (run_callback == SHARP_F || return_to_c == SHARP_F)
625 {
626 outf_error
627 ("\nWarning: punted callback #%ld. Missing primitives!\n",
628 callback_id);
629 outf_flush_error ();
630 SET_VAL (FIXNUM_ZERO);
631 return;
632 }
633 }
634
635 /* Need to push 2 each of prim+header+continuation. */
636 if (! CAN_PUSH_P (2 * (1 + 1 + CONTINUATION_SIZE)))
637 {
638 outf_error
639 ("\nWarning: punted callback #%ld. No room on stack!\n", callback_id);
640 outf_flush_error ();
641 SET_VAL (FIXNUM_ZERO);
642 return;
643 }
644
645 cstack_depth += 1;
646 CSTACK_PUSH (int, cstack_depth);
647 CSTACK_PUSH (CallbackKernel, kernel);
648
649 STACK_PUSH (return_to_c);
650 PUSH_APPLY_FRAME_HEADER (0);
651 SET_RC (RC_INTERNAL_APPLY);
652 SAVE_CONT();
653 STACK_PUSH (run_callback);
654 PUSH_APPLY_FRAME_HEADER (0);
655 SAVE_CONT();
656 Interpret (1);
657 alienate_float_environment ();
658 cstack_depth -= 1;
659 }
660
661 DEFINE_PRIMITIVE ("RUN-CALLBACK", Prim_run_callback, 0, 0, 0)
662 {
663 /* All the smarts are in the kernel. */
664
665 PRIMITIVE_HEADER (0);
666 {
667 char * tos;
668 CallbackKernel kernel;
669 int depth;
670
671 tos = cstack_top ();
672 CSTACK_LPOP (CallbackKernel, kernel, tos);
673 CSTACK_LPOP (int, depth, tos);
674 if (depth != cstack_depth)
675 {
676 outf_error ("\nWarning: C data stack slipped in run-callback!\n");
677 outf_flush_error ();
678 signal_error_from_primitive (ERR_EXTERNAL_RETURN);
679 }
680
681 kernel ();
682 /* NOTREACHED */
683 PRIMITIVE_RETURN (UNSPECIFIC);
684 }
685 }
686
687 DEFINE_PRIMITIVE ("RETURN-TO-C", Prim_return_to_c, 0, 0, 0)
688 {
689 /* Callbacks are possible while stopped. The PRIM_RETURN_TO_C abort
690 expects this primitive to clean up its stack frame. */
691
692 PRIMITIVE_HEADER (0);
693 canonicalize_primitive_context ();
694 {
695 SCM primitive;
696 long nargs;
697
698 primitive = GET_PRIMITIVE;
699 assert (PRIMITIVE_P (primitive));
700 nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
701 POP_PRIMITIVE_FRAME (nargs);
702 SET_EXP (SHARP_F);
703 PRIMITIVE_ABORT (PRIM_RETURN_TO_C);
704 /* NOTREACHED */
705 PRIMITIVE_RETURN (UNSPECIFIC);
706 }
707 }
708
709 /* This is mainly for src/gtk/gtkio.c, so it does not need to include
710 prim.h, scheme.h and everything. */
711 void
abort_to_c(void)712 abort_to_c (void)
713 {
714 PRIMITIVE_ABORT (PRIM_RETURN_TO_C);
715 /* NOTREACHED */
716 }
717
718 char *
callback_lunseal(CallbackKernel expected)719 callback_lunseal (CallbackKernel expected)
720 {
721 /* Used by a callback kernel to strip the CStack's frame header
722 (kernel, depth) before lpopping arguments. */
723
724 char * tos;
725 CallbackKernel found;
726 int depth;
727
728 tos = cstack_top ();
729 CSTACK_LPOP (CallbackKernel, found, tos);
730 CSTACK_LPOP (int, depth, tos);
731 if (depth != cstack_depth || found != expected)
732 {
733 outf_error ("\ninternal error: slipped in callback kernel\n");
734 outf_flush_error ();
735 signal_error_from_primitive (ERR_EXTERNAL_RETURN);
736 }
737 return (tos);
738 }
739
740 static SCM valid_callback_handler (void);
741 static SCM valid_callback_id (long id);
742
743 void
callback_run_handler(long callback_id,SCM arglist)744 callback_run_handler (long callback_id, SCM arglist)
745 {
746 /* Used by callback kernels, inside the interpreter. Thus it MAY GC
747 abort.
748
749 Push a Scheme callback handler apply frame. This leaves the
750 interpreter ready to tail-call the Scheme procedure. (The
751 RUN-CALLBACK primitive apply frame is already gone.) The
752 trampoline should abort with PRIM_APPLY. */
753
754 SCM handler, fixnum_id;
755
756 handler = valid_callback_handler ();
757 fixnum_id = valid_callback_id (callback_id);
758
759 stop_history ();
760
761 Will_Push (STACK_ENV_EXTRA_SLOTS + 3);
762 STACK_PUSH (arglist);
763 STACK_PUSH (fixnum_id);
764 STACK_PUSH (handler);
765 PUSH_APPLY_FRAME_HEADER (2);
766 Pushed ();
767 }
768
769 static SCM
valid_callback_handler(void)770 valid_callback_handler (void)
771 {
772 /* Validate the Scheme callback handler procedure. */
773
774 SCM handler;
775
776 handler = (VECTOR_REF (fixed_objects, CALLBACK_HANDLER));
777 if (! interpreter_applicable_p (handler))
778 {
779 outf_error ("\nWarning: bogus callback handler: 0x%x.\n",
780 ((unsigned int) handler));
781 outf_flush_error ();
782 Do_Micro_Error (ERR_INAPPLICABLE_OBJECT, true);
783 abort_to_interpreter (PRIM_APPLY);
784 /* NOTREACHED */
785 }
786 return (handler);
787 }
788
789 static SCM
valid_callback_id(long id)790 valid_callback_id (long id)
791 {
792 /* Validate the callback ID and convert to a fixnum. */
793
794 if (ULONG_TO_FIXNUM_P (id))
795 return (ULONG_TO_FIXNUM (id));
796 signal_error_from_primitive (ERR_ARG_1_BAD_RANGE);
797 /* NOTREACHED */
798 return (FIXNUM_ZERO);
799 }
800
801 void
callback_return(char * tos)802 callback_return (char * tos)
803 {
804 cstack_pop (tos);
805 PRIMITIVE_ABORT (PRIM_APPLY);
806 }
807
808 /* Converters */
809
810 long
arg_long(int argn)811 arg_long (int argn)
812 {
813 return (arg_integer (argn));
814 }
815
816 unsigned long
arg_ulong(int argn)817 arg_ulong (int argn)
818 {
819 return (arg_ulong_integer (argn));
820 }
821
822 double
arg_double(int argn)823 arg_double (int argn)
824 {
825 /* Convert the object to a double. Like arg_real_number. */
826
827 return (arg_real_number (argn));
828 }
829
830 void *
arg_alien_entry(int argn)831 arg_alien_entry (int argn)
832 {
833 /* Expect an alien-function. Return its address. */
834
835 SCM alienf = VECTOR_ARG (argn);
836 int length = VECTOR_LENGTH (alienf);
837 if (length < 3)
838 error_wrong_type_arg (argn);
839 return (alien_address (alienf));
840 }
841
842 void *
arg_pointer(int argn)843 arg_pointer (int argn)
844 {
845 /* Accept an alien, string, flovec, xstring handle (positive
846 integer), or zero (for a NULL pointer). */
847
848 SCM arg = ARG_REF (argn);
849 if ((INTEGER_P (arg)) && (integer_zero_p (arg)))
850 return ((void *)0);
851 if (STRING_P (arg))
852 return ((void *) (STRING_POINTER (arg)));
853 if ((INTEGER_P (arg)) && (integer_to_ulong_p (arg)))
854 {
855 unsigned char * result = lookup_external_string (arg, NULL);
856 if (result == 0)
857 error_wrong_type_arg (argn);
858 return ((void *) result);
859 }
860 if (is_alien (arg))
861 return (alien_address (arg));
862 if (FLONUM_P (arg))
863 return ((void *) (OBJECT_ADDRESS (arg)));
864
865 error_wrong_type_arg (argn);
866 /*NOTREACHED*/
867 return ((void *)0);
868 }
869
870 SCM
long_to_scm(const long i)871 long_to_scm (const long i)
872 {
873 return (long_to_integer (i));
874 }
875
876 SCM
ulong_to_scm(const unsigned long i)877 ulong_to_scm (const unsigned long i)
878 {
879 return (ulong_to_integer (i));
880 }
881
882 SCM
double_to_scm(const double d)883 double_to_scm (const double d)
884 {
885 return (double_to_flonum (d));
886 }
887
888 SCM
pointer_to_scm(const void * p)889 pointer_to_scm (const void * p)
890 {
891 /* Return a pointer from a callout. Expect the first real argument
892 (the 2nd) to be either #F or an alien. */
893
894 SCM arg = ARG_REF (2);
895 if (arg == SHARP_F)
896 return (UNSPECIFIC);
897 if (is_alien (arg))
898 {
899 set_alien_address (arg, p);
900 return (arg);
901 }
902
903 error_wrong_type_arg (2);
904 /* NOTREACHED */
905 return (SHARP_F);
906 }
907
908 SCM
struct_to_scm(const void * p,int size)909 struct_to_scm (const void *p, int size)
910 {
911 /* Return a struct or union from a callout. Expect the first real
912 argument (the 2nd) to be either #F or the alien address to
913 which the struct or union should be copied. */
914
915 SCM arg = ARG_REF (2);
916 if (arg == SHARP_F)
917 return (UNSPECIFIC);
918 if (is_alien (arg))
919 {
920 memcpy(alien_address (arg), p, size);
921 return (arg);
922 }
923
924 error_wrong_type_arg (2);
925 /* NOTREACHED */
926 return (SHARP_F);
927 }
928
929 SCM
cons_alien(const void * addr)930 cons_alien (const void * addr)
931 {
932 /* Construct an alien. Used by callback kernels to construct
933 arguments for the Scheme callback-handler, or part2 of callouts
934 returning a new alien. Note that these should be fixed up on the
935 Scheme side with the record type. */
936
937 SCM alien;
938 Primitive_GC_If_Needed (5);
939 alien = (MAKE_POINTER_OBJECT (TC_RECORD, Free));
940 (*Free++) = MAKE_OBJECT (TC_MANIFEST_VECTOR, 4);
941 (*Free++) = SHARP_F;
942 (*Free++) = FIXNUM_ZERO;
943 (*Free++) = FIXNUM_ZERO;
944 (*Free++) = SHARP_F;
945 set_alien_address (alien, addr);
946 return (alien);
947 }
948
949 long
long_value(void)950 long_value (void)
951 {
952 /* Convert VAL to a long. Accept integers AND characters. Like
953 arg_integer otherwise. */
954
955 SCM value = GET_VAL;
956 if (CHARACTER_P (value))
957 return (CHAR_TO_ASCII (value));
958 if (! (INTEGER_P (value)))
959 {
960 /* error_wrong_type_arg (1); Not inside the interpreter here. */
961 outf_error ("\nWarning: Callback did not return an integer!\n");
962 outf_flush_error ();
963 return (0);
964 }
965 if (! (integer_to_long_p (value)))
966 {
967 /* error_bad_range_arg (1); */
968 outf_error
969 ("\nWarning: Callback returned an integer larger than a C long!\n");
970 outf_flush_error ();
971 return (0);
972 }
973 return (integer_to_long (value));
974 }
975
976 unsigned long
ulong_value(void)977 ulong_value (void)
978 {
979 /* Convert VAL to an unsigned long. Accept integers AND characters.
980 Like arg_integer otherwise. */
981
982 SCM value = GET_VAL;
983 if (CHARACTER_P (value))
984 return (CHAR_TO_ASCII (value));
985 if (! (INTEGER_P (value)))
986 {
987 /* error_wrong_type_arg (1); Not inside the interpreter here. */
988 outf_error ("\nWarning: Callback did not return an integer!\n");
989 outf_flush_error ();
990 return (0);
991 }
992 if (! (integer_to_ulong_p (value)))
993 {
994 /* error_bad_range_arg (1); */
995 outf_error
996 ("\nWarning: "
997 "Callback returned an integer larger than a C unsigned long!\n");
998 outf_flush_error ();
999 return (0);
1000 }
1001 return (integer_to_ulong (value));
1002 }
1003
1004 double
double_value(void)1005 double_value (void)
1006 {
1007 /* Convert VAL to a double. Like arg_real_number. */
1008
1009 SCM value = GET_VAL;
1010
1011 if (! REAL_P (value))
1012 {
1013 /* error_wrong_type_arg (1); Not inside the interpreter here. */
1014 outf_error ("\nWarning: Callback did not return a real.\n");
1015 outf_flush_error ();
1016 return (0.0);
1017 }
1018 if (! (real_number_to_double_p (value)))
1019 {
1020 /* error_bad_range_arg (1); */
1021 outf_error
1022 ("\nWarning: Callback returned a real larger than a C double!\n");
1023 outf_flush_error ();
1024 return (0.0);
1025 }
1026 return (real_number_to_double (value));
1027 }
1028
1029 void *
pointer_value(void)1030 pointer_value (void)
1031 {
1032 SCM value = GET_VAL;
1033
1034 if (integer_zero_p (value))
1035 return (NULL);
1036 /* NOT allowing a Scheme string (heap pointer!) into the toolkit. */
1037 if ((INTEGER_P (value)) && (integer_to_ulong_p (value)))
1038 {
1039 unsigned char * result = lookup_external_string (value, NULL);
1040 if (result == 0)
1041 {
1042 outf_error ("\nWarning: Callback returned a bogus xstring.\n");
1043 outf_flush_error ();
1044 return (NULL);
1045 }
1046 return ((void *) result);
1047 }
1048 if (is_alien (value))
1049 return (alien_address (value));
1050
1051 outf_error ("\nWarning: Callback did not return a pointer.\n");
1052 outf_flush_error ();
1053 return (NULL);
1054 }
1055
1056 /* Utilities */
1057
1058 void
check_number_of_args(int num)1059 check_number_of_args (int num)
1060 {
1061 if (GET_LEXPR_ACTUALS < num)
1062 {
1063 signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
1064 }
1065 }
1066
1067 SCM
unspecific(void)1068 unspecific (void)
1069 {
1070 return (UNSPECIFIC);
1071 }
1072
1073 SCM
empty_list(void)1074 empty_list (void)
1075 {
1076 return (EMPTY_LIST);
1077 }
1078
1079 int
flovec_length(SCM vector)1080 flovec_length (SCM vector)
1081 {
1082 return (FLOATING_VECTOR_LENGTH (vector));
1083 }
1084
1085 double*
flovec_loc(SCM vector)1086 flovec_loc (SCM vector)
1087 {
1088 return (FLOATING_VECTOR_LOC (vector, 0));
1089 }
1090
1091 double
flovec_ref(SCM vector,int index)1092 flovec_ref (SCM vector, int index)
1093 {
1094 int len = FLOATING_VECTOR_LENGTH (vector);
1095 if (0 <= index && index < len)
1096 return (FLOATING_VECTOR_REF (vector, index));
1097 error_external_return ();
1098 }
1099
1100 DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0)
1101 {
1102 /* To avoid the normal i/o system when debugging a callback. */
1103
1104 PRIMITIVE_HEADER (1);
1105 {
1106 SCM arg = ARG_REF (1);
1107 if (STRING_P (arg))
1108 {
1109 char * string = ((char *) STRING_LOC (arg, 0));
1110 outf_error ("%s", string);
1111 outf_flush_error ();
1112 }
1113 else
1114 {
1115 error_wrong_type_arg (1);
1116 }
1117 PRIMITIVE_RETURN (UNSPECIFIC);
1118 }
1119 }
1120