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 / sysprim.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  5KB  |  165 lines
  1. /* -*-C-*-
  2.  
  3. $Id: sysprim.c,v 9.47 2000/12/05 21:23:48 cph Exp $
  4.  
  5. Copyright (c) 1987-2000 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. /* Random system primitives.  Most are implemented in terms of
  23.    utilities in os.c */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "ostty.h"
  28. #include "ostop.h"
  29.  
  30. extern long EXFUN (OS_set_trap_state, (long));
  31.  
  32. /* Pretty random primitives */
  33.  
  34. DEFINE_PRIMITIVE ("EXIT", Prim_non_restartable_exit, 0, 0,
  35.   "Exit Scheme with no option to restart.")
  36. {
  37.   PRIMITIVE_HEADER (0);
  38.   termination_normal (0);
  39.   PRIMITIVE_RETURN (UNSPECIFIC);
  40. }
  41.  
  42. DEFINE_PRIMITIVE ("EXIT-WITH-VALUE", 
  43.           Prim_non_restartable_exit_with_value, 1, 1,
  44.   "Exit Scheme with no option to restart, returning integer argument\n\
  45. as exit status.")
  46. {
  47.   PRIMITIVE_HEADER (1);
  48.   termination_normal ((int) arg_integer (1));
  49.   PRIMITIVE_RETURN (UNSPECIFIC);
  50. }
  51.  
  52. DEFINE_PRIMITIVE ("HALT", Prim_restartable_exit, 0, 0,
  53.   "Exit Scheme, suspending it to that it can be restarted.")
  54. {
  55.   PRIMITIVE_HEADER (0);
  56.   OS_restartable_exit ();
  57.   PRIMITIVE_RETURN (UNSPECIFIC);
  58. }
  59.  
  60. DEFINE_PRIMITIVE ("UNDER-EMACS?", Prim_under_emacs_p, 0, 0, 0)
  61. {
  62.   PRIMITIVE_HEADER (0);
  63.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_under_emacs_p ()));
  64. }
  65.  
  66. DEFINE_PRIMITIVE ("SET-TRAP-STATE!", Prim_set_trap_state, 1, 1, 0)
  67. {
  68.   long result;
  69.   PRIMITIVE_HEADER (1);
  70.  
  71.   result = (OS_set_trap_state (arg_nonnegative_integer (1)));
  72.   if (result < 0)
  73.   {
  74.     error_bad_range_arg (1);
  75.     /*NOTREACHED*/
  76.   }
  77.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result));
  78. }
  79.  
  80. DEFINE_PRIMITIVE ("HEAP-AVAILABLE?", Prim_heap_available_p, 1, 1, 
  81.   "(N-WORDS)\n\
  82. Tests to see if there are at least N-WORDS words of heap storage available")
  83. {
  84.   PRIMITIVE_HEADER (1);
  85.   PRIMITIVE_RETURN
  86.     (BOOLEAN_TO_OBJECT ((Free + (arg_nonnegative_integer (1))) < MemTop));
  87. }
  88.  
  89. DEFINE_PRIMITIVE ("PRIMITIVE-GET-FREE", Prim_get_free, 1, 1,
  90.   "(TYPE-CODE)\n\
  91. Return the value of the free pointer tagged with TYPE-CODE")
  92. {
  93.   PRIMITIVE_HEADER (1);
  94.   PRIMITIVE_RETURN
  95.     (MAKE_POINTER_OBJECT ((arg_index_integer (1, (MAX_TYPE_CODE + 1))), Free));
  96. }
  97.  
  98. DEFINE_PRIMITIVE ("PRIMITIVE-INCREMENT-FREE", Prim_increment_free, 1, 1,
  99.   "(N-WORDS)\n\
  100. Advance the free pointer by N-WORDS words")
  101. {
  102.   PRIMITIVE_HEADER (1);
  103.   Free += (arg_nonnegative_integer (1));
  104.   PRIMITIVE_RETURN (UNSPECIFIC);
  105. }
  106.  
  107. #define CONVERT_ADDRESS(address)                    \
  108.   (long_to_integer (ADDRESS_TO_DATUM (address)))
  109.  
  110. DEFINE_PRIMITIVE ("GC-SPACE-STATUS", Prim_gc_space_status, 0, 0, 0)
  111. {
  112.   SCHEME_OBJECT * constant_low;
  113.   SCHEME_OBJECT * constant_free;
  114.   SCHEME_OBJECT * constant_high;
  115.   SCHEME_OBJECT * heap_low;
  116.   SCHEME_OBJECT * heap_free;
  117.   SCHEME_OBJECT * heap_limit;
  118.   SCHEME_OBJECT * heap_high;
  119. #ifndef USE_STACKLETS
  120.   SCHEME_OBJECT * stack_low;
  121.   SCHEME_OBJECT * stack_free;
  122.   SCHEME_OBJECT * stack_limit;
  123.   SCHEME_OBJECT * stack_high;
  124. #endif /* USE_STACKLETS */
  125.   SCHEME_OBJECT result;
  126.   PRIMITIVE_HEADER (0);
  127.  
  128.   constant_low = Constant_Space;
  129.   constant_free = Free_Constant;
  130.   constant_high = Constant_Top;
  131.   heap_low = Heap_Bottom;
  132.   heap_free = Free;
  133.   heap_limit = MemTop;
  134.   heap_high = Heap_Top;
  135. #ifndef USE_STACKLETS
  136.   stack_low = Stack_Bottom;
  137.   stack_free = Stack_Pointer;
  138.   stack_limit = Stack_Guard;
  139.   stack_high = Stack_Top;
  140. #endif /* USE_STACKLETS */
  141.  
  142.   result = (make_vector (12, SHARP_F, true));
  143.   VECTOR_SET (result, 0, (LONG_TO_UNSIGNED_FIXNUM (sizeof (SCHEME_OBJECT))));
  144.   VECTOR_SET (result, 1, (CONVERT_ADDRESS (constant_low)));
  145.   VECTOR_SET (result, 2, (CONVERT_ADDRESS (constant_free)));
  146.   VECTOR_SET (result, 3, (CONVERT_ADDRESS (constant_high)));
  147.   VECTOR_SET (result, 4, (CONVERT_ADDRESS (heap_low)));
  148.   VECTOR_SET (result, 5, (CONVERT_ADDRESS (heap_free)));
  149.   VECTOR_SET (result, 6, (CONVERT_ADDRESS (heap_limit)));
  150.   VECTOR_SET (result, 7, (CONVERT_ADDRESS (heap_high)));
  151. #ifndef USE_STACKLETS
  152.   VECTOR_SET (result, 8, (CONVERT_ADDRESS (stack_low)));
  153.   VECTOR_SET (result, 9, (CONVERT_ADDRESS (stack_free)));
  154.   VECTOR_SET (result, 10, (CONVERT_ADDRESS (stack_limit)));
  155.   VECTOR_SET (result, 11, (CONVERT_ADDRESS (stack_high)));
  156. #endif /* USE_STACKLETS */
  157.   PRIMITIVE_RETURN (result);
  158. }
  159.  
  160. DEFINE_PRIMITIVE ("SCHEME-PROGRAM-NAME", Prim_scheme_program_name, 0, 0, 0)
  161. {
  162.   PRIMITIVE_HEADER (0);
  163.   PRIMITIVE_RETURN (char_pointer_to_string ((char *) (scheme_program_name)));
  164. }
  165.