home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / comutl.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  8KB  |  265 lines
  1. /* -*-C-*-
  2.  
  3. $Id: comutl.c,v 1.31 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1987-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Compiled Code Utilities */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26.  
  27. extern SCHEME_OBJECT
  28.   * EXFUN (compiled_entry_to_block_address, (SCHEME_OBJECT));
  29.  
  30. extern long
  31.   EXFUN (compiled_entry_to_block_offset, (SCHEME_OBJECT)),
  32.   EXFUN (coerce_to_compiled, (SCHEME_OBJECT, long, SCHEME_OBJECT *));
  33.  
  34. extern void EXFUN (compiled_entry_type, (SCHEME_OBJECT, long *));
  35.  
  36. DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->BLOCK", Prim_comp_code_address_block, 1, 1,
  37.   "Given a compiled code address, return its compiled code block.")
  38. {
  39.   PRIMITIVE_HEADER (1);
  40.  
  41.   CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
  42.   PRIMITIVE_RETURN
  43.     (MAKE_POINTER_OBJECT
  44.      (TC_COMPILED_CODE_BLOCK,
  45.       (compiled_entry_to_block_address (ARG_REF (1)))));
  46. }
  47.  
  48. DEFINE_PRIMITIVE ("COMPILED-CODE-ADDRESS->OFFSET", Prim_comp_code_address_offset, 1, 1,
  49.   "Given a compiled code address, return its offset into its block.")
  50. {
  51.   PRIMITIVE_HEADER (1);
  52.   CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
  53.   PRIMITIVE_RETURN
  54.     (LONG_TO_FIXNUM (compiled_entry_to_block_offset (ARG_REF (1))));
  55. }
  56.  
  57. #ifndef USE_STACKLETS
  58.  
  59. DEFINE_PRIMITIVE ("STACK-TOP-ADDRESS", Prim_stack_top_address, 0, 0, 0)
  60. {
  61.   PRIMITIVE_HEADER (0);
  62.   PRIMITIVE_RETURN (long_to_integer ((long) (ADDRESS_TO_DATUM (Stack_Top))));
  63. }
  64.  
  65. DEFINE_PRIMITIVE ("STACK-ADDRESS-OFFSET", Prim_stack_address_offset, 1, 1, 0)
  66. {
  67.   PRIMITIVE_HEADER (1);
  68.  
  69.   CHECK_ARG (1, STACK_ADDRESS_P);
  70.   PRIMITIVE_RETURN
  71.     (long_to_integer
  72.      (STACK_LOCATIVE_DIFFERENCE ((Stack_Top),
  73.                  (OBJECT_ADDRESS (ARG_REF (1))))));
  74. }
  75.  
  76. #endif /* USE_STACKLETS */
  77.  
  78. DEFINE_PRIMITIVE ("COMPILED-ENTRY-KIND", Prim_compiled_entry_type, 1, 1, 0)
  79. {
  80.   PRIMITIVE_HEADER (1);
  81.   CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
  82.   {
  83.     long results [3];
  84.     compiled_entry_type ((ARG_REF (1)), results);
  85.     PRIMITIVE_RETURN
  86.       (hunk3_cons ((LONG_TO_FIXNUM (results [0])),
  87.            (LONG_TO_FIXNUM (results [1])),
  88.            (LONG_TO_FIXNUM (results [2]))));
  89.   }
  90. }
  91.  
  92. DEFINE_PRIMITIVE ("COERCE-TO-COMPILED-PROCEDURE", Prim_coerce_to_closure, 2, 2, 0)
  93. {
  94.   SCHEME_OBJECT temp;
  95.   long result;
  96.   PRIMITIVE_HEADER(2);
  97.   result = (coerce_to_compiled ((ARG_REF (1)), (arg_integer (2)), &temp));
  98.   switch(result)
  99.   {
  100.     case PRIM_DONE:
  101.       PRIMITIVE_RETURN(temp);
  102.  
  103.     case PRIM_INTERRUPT:
  104.       Primitive_GC(10);
  105.       /*NOTREACHED*/
  106.  
  107.     default:
  108.       error_bad_range_arg (2);
  109.       /*NOTREACHED*/
  110.       return (0);
  111.   }
  112. }
  113.  
  114. DEFINE_PRIMITIVE ("COMPILED-CLOSURE->ENTRY", Prim_compiled_closure_to_entry, 1, 1,
  115.   "Given a compiled closure, return the entry point which it invokes.")
  116. {
  117.   long entry_type [3];
  118.   SCHEME_OBJECT closure;
  119.   extern long EXFUN (compiled_entry_closure_p, (SCHEME_OBJECT));
  120.   extern SCHEME_OBJECT EXFUN (compiled_closure_to_entry, (SCHEME_OBJECT));
  121.   PRIMITIVE_HEADER (1);
  122.  
  123.   CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
  124.   closure = (ARG_REF (1));
  125.   compiled_entry_type (closure, (& (entry_type [0])));
  126.   if (! (((entry_type [0]) == 0) && (compiled_entry_closure_p (closure))))
  127.     error_bad_range_arg (1);
  128.   PRIMITIVE_RETURN (compiled_closure_to_entry (closure));
  129. }
  130.  
  131. DEFINE_PRIMITIVE ("UTILITY-INDEX->NAME", Prim_utility_index_to_name, 1, 1,
  132.   "Given an integer, return the name of the corresponding compiled code utility.")
  133. {
  134.   extern char * EXFUN (utility_index_to_name, (int));
  135.   char * result;
  136.   PRIMITIVE_HEADER (1);
  137.  
  138.   result = (utility_index_to_name (arg_integer (1)));
  139.   if (result == ((char *) NULL))
  140.     PRIMITIVE_RETURN (SHARP_F);
  141.   else
  142.     PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) result));
  143. }
  144.  
  145. DEFINE_PRIMITIVE ("BUILTIN-INDEX->NAME", Prim_builtin_index_to_name, 1, 1,
  146.   "Given an integer, return the name of the corresponding compiled code utility.")
  147. {
  148.   extern char * EXFUN (builtin_index_to_name, (int));
  149.   char * result;
  150.   PRIMITIVE_HEADER (1);
  151.  
  152.   result = (builtin_index_to_name (arg_integer (1)));
  153.   if (result == ((char *) NULL))
  154.     PRIMITIVE_RETURN (SHARP_F);
  155.   else
  156.     PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) result));
  157. }
  158.  
  159. /* This is only meaningful for the C back end. */
  160.  
  161. DEFINE_PRIMITIVE ("INITIALIZE-C-COMPILED-BLOCK",
  162.           Prim_initialize_C_compiled_block, 1, 1,
  163.   "Given the tag of a compiled object, return the object.")
  164. {
  165. #ifdef NATIVE_CODE_IS_C
  166.   extern SCHEME_OBJECT * EXFUN (initialize_C_compiled_block, (int, char *));
  167.   SCHEME_OBJECT * block, val;
  168.   
  169.   block = (initialize_C_compiled_block (1, (STRING_ARG (1))));
  170.   val = ((block == ((SCHEME_OBJECT *) NULL))
  171.      ? SHARP_F
  172.      : (MAKE_POINTER_OBJECT (TC_COMPILED_ENTRY, block)));
  173.   PRIMITIVE_RETURN (val);
  174. #else
  175.   PRIMITIVE_RETURN (SHARP_F);
  176. #endif
  177. }
  178.  
  179. DEFINE_PRIMITIVE ("DECLARE-COMPILED-CODE-BLOCK",
  180.           Prim_declare_compiled_code_block, 1, 1,
  181.   "Ensure cache coherence for a compiled-code block newly constructed.")
  182. {
  183.   extern void EXFUN (declare_compiled_code_block, (SCHEME_OBJECT));
  184.   SCHEME_OBJECT new_cc_block;
  185.   PRIMITIVE_HEADER (1);
  186.  
  187.   new_cc_block = (ARG_REF (1));
  188.   if ((OBJECT_TYPE (new_cc_block)) != TC_COMPILED_CODE_BLOCK)
  189.     error_wrong_type_arg (1);
  190.   declare_compiled_code_block (new_cc_block);
  191.   PRIMITIVE_RETURN (SHARP_T);
  192. }
  193.  
  194. extern SCHEME_OBJECT EXFUN (bkpt_install, (PTR));
  195. extern SCHEME_OBJECT EXFUN (bkpt_closure_install, (PTR));
  196. extern Boolean EXFUN (bkpt_p, (PTR));
  197. extern SCHEME_OBJECT EXFUN (bkpt_proceed, (PTR, SCHEME_OBJECT, SCHEME_OBJECT));
  198. extern void EXFUN (bkpt_remove, (PTR, SCHEME_OBJECT));
  199.  
  200. DEFINE_PRIMITIVE ("BKPT/INSTALL", Prim_install_bkpt, 1, 1,
  201.           "(compiled-entry-object)\n\
  202. Install a breakpoint trap in a compiled code object.\n\
  203. Returns false or a handled needed by REMOVE-BKPT and ONE-STEP-PROCEED.")
  204. {
  205.   PRIMITIVE_HEADER (1);
  206.   CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
  207.  
  208.   {
  209.     SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1)));
  210.     SCHEME_OBJECT * block;
  211.  
  212.     if (bkpt_p ((PTR) entry))
  213.       error_bad_range_arg (1);
  214.  
  215.     block = (compiled_entry_to_block_address (ARG_REF (1)));
  216.     if ((OBJECT_TYPE (block[0])) == TC_MANIFEST_CLOSURE)
  217.       PRIMITIVE_RETURN (bkpt_closure_install ((PTR) entry));
  218.     else
  219.       PRIMITIVE_RETURN (bkpt_install ((PTR) entry));
  220.   }
  221. }
  222.  
  223. DEFINE_PRIMITIVE ("BKPT/REMOVE", Prim_remove_bkpt, 2, 2,
  224.           "(compiled-entry-object handle)\n\
  225. Remove a breakpoint trap installed by INSTALL-BKPT.")
  226. {
  227.   PRIMITIVE_HEADER (2);
  228.   CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
  229.   CHECK_ARG (2, NON_MARKED_VECTOR_P);
  230.  
  231.   {
  232.     SCHEME_OBJECT * entry = (OBJECT_ADDRESS (ARG_REF (1)));
  233.     SCHEME_OBJECT handle = (ARG_REF (2));
  234.  
  235.     if (! (bkpt_p ((PTR) entry)))
  236.       error_bad_range_arg (1);
  237.     bkpt_remove (((PTR) entry), handle);
  238.     PRIMITIVE_RETURN (UNSPECIFIC);
  239.   }
  240. }
  241.  
  242. DEFINE_PRIMITIVE ("BKPT?", Prim_bkpt_p, 1, 1,
  243.           "(compiled-entry-object)\n\
  244. True if there is a breakpoint trap in compiled-entry-object.")
  245. {
  246.   PRIMITIVE_HEADER (1);
  247.   CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
  248.  
  249.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT
  250.             (bkpt_p ((PTR) (OBJECT_ADDRESS (ARG_REF (1))))));
  251. }
  252.  
  253. DEFINE_PRIMITIVE ("BKPT/PROCEED", Prim_bkpt_proceed, 3, 3,
  254.           "(compiled-entry-object handle state)\n\
  255. Proceed the computation from the current breakpoint.")
  256. {
  257.   PRIMITIVE_HEADER (3);
  258.   CHECK_ARG (1, COMPILED_CODE_ADDRESS_P);
  259.   CHECK_ARG (2, NON_MARKED_VECTOR_P);
  260.  
  261.   PRIMITIVE_RETURN (bkpt_proceed (((PTR) (OBJECT_ADDRESS (ARG_REF (1)))),
  262.                   (ARG_REF (2)),
  263.                   (ARG_REF (3))));
  264. }
  265.