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 /* Random system primitives. Most are implemented in terms of 28 utilities in os.c */ 29 30 #include "scheme.h" 31 #include "prims.h" 32 #include "osscheme.h" 33 #include "ostty.h" 34 #include "ostop.h" 35 36 extern long OS_set_trap_state (long); 37 extern double arg_flonum (int); 38 39 /* Pretty random primitives */ 40 41 DEFINE_PRIMITIVE ("EXIT", Prim_non_restartable_exit, 0, 0, 42 "Exit Scheme with no option to restart.") 43 { 44 PRIMITIVE_HEADER (0); 45 termination_normal (0); 46 PRIMITIVE_RETURN (UNSPECIFIC); 47 } 48 49 DEFINE_PRIMITIVE ("EXIT-WITH-VALUE", 50 Prim_non_restartable_exit_with_value, 1, 1, 51 "Exit Scheme with no option to restart, returning integer argument\n\ 52 as exit status.") 53 { 54 PRIMITIVE_HEADER (1); 55 termination_normal ((int) arg_integer (1)); 56 PRIMITIVE_RETURN (UNSPECIFIC); 57 } 58 59 DEFINE_PRIMITIVE ("HALT", Prim_restartable_exit, 0, 0, 60 "Exit Scheme, suspending it to that it can be restarted.") 61 { 62 PRIMITIVE_HEADER (0); 63 OS_restartable_exit (); 64 PRIMITIVE_RETURN (UNSPECIFIC); 65 } 66 67 DEFINE_PRIMITIVE ("UNDER-EMACS?", Prim_under_emacs_p, 0, 0, 0) 68 { 69 PRIMITIVE_HEADER (0); 70 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_under_emacs_p ())); 71 } 72 73 DEFINE_PRIMITIVE ("SET-TRAP-STATE!", Prim_set_trap_state, 1, 1, 0) 74 { 75 long result; 76 PRIMITIVE_HEADER (1); 77 78 result = (OS_set_trap_state (arg_nonnegative_integer (1))); 79 if (result < 0) 80 { 81 error_bad_range_arg (1); 82 /*NOTREACHED*/ 83 } 84 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result)); 85 } 86 87 DEFINE_PRIMITIVE ("HEAP-AVAILABLE?", Prim_heap_available_p, 1, 1, 88 "(N-WORDS)\n\ 89 Tests to see if there are at least N-WORDS words of heap storage available") 90 { 91 PRIMITIVE_HEADER (1); 92 PRIMITIVE_RETURN 93 (BOOLEAN_TO_OBJECT (HEAP_AVAILABLE_P (arg_ulong_integer (1)))); 94 } 95 96 DEFINE_PRIMITIVE ("PRIMITIVE-GET-FREE", Prim_get_free, 1, 1, 97 "(TYPE-CODE)\n\ 98 Return the value of the free pointer tagged with TYPE-CODE") 99 { 100 PRIMITIVE_HEADER (1); 101 PRIMITIVE_RETURN 102 (MAKE_POINTER_OBJECT ((arg_ulong_index_integer (1, N_TYPE_CODES)), Free)); 103 } 104 105 DEFINE_PRIMITIVE ("PRIMITIVE-INCREMENT-FREE", Prim_increment_free, 1, 1, 106 "(N-WORDS)\n\ 107 Advance the free pointer by N-WORDS words.") 108 { 109 PRIMITIVE_HEADER (1); 110 Free += (arg_ulong_integer (1)); 111 PRIMITIVE_RETURN (UNSPECIFIC); 112 } 113 114 #define CONVERT_ADDRESS(address) \ 115 (ulong_to_integer (ADDRESS_TO_DATUM (address))) 116 117 DEFINE_PRIMITIVE ("GC-SPACE-STATUS", Prim_gc_space_status, 0, 0, 0) 118 { 119 PRIMITIVE_HEADER (0); 120 { 121 SCHEME_OBJECT v = (make_vector (12, SHARP_F, true)); 122 VECTOR_SET (v, 0, (ULONG_TO_FIXNUM (sizeof (SCHEME_OBJECT)))); 123 VECTOR_SET (v, 1, (CONVERT_ADDRESS (constant_start))); 124 VECTOR_SET (v, 2, (CONVERT_ADDRESS (constant_alloc_next))); 125 VECTOR_SET (v, 3, (CONVERT_ADDRESS (constant_end))); 126 VECTOR_SET (v, 4, (CONVERT_ADDRESS (heap_start))); 127 VECTOR_SET (v, 5, (CONVERT_ADDRESS (Free))); 128 VECTOR_SET (v, 6, (CONVERT_ADDRESS (heap_alloc_limit))); 129 VECTOR_SET (v, 7, (CONVERT_ADDRESS (heap_end))); 130 VECTOR_SET (v, 8, (CONVERT_ADDRESS (stack_start))); 131 VECTOR_SET (v, 9, (CONVERT_ADDRESS (stack_pointer))); 132 VECTOR_SET (v, 10, (CONVERT_ADDRESS (stack_guard))); 133 VECTOR_SET (v, 11, (CONVERT_ADDRESS (stack_end))); 134 PRIMITIVE_RETURN (v); 135 } 136 } 137 138 DEFINE_PRIMITIVE ("SCHEME-PROGRAM-NAME", Prim_scheme_program_name, 0, 0, 0) 139 { 140 PRIMITIVE_HEADER (0); 141 PRIMITIVE_RETURN (char_pointer_to_string (scheme_program_name)); 142 } 143 144 DEFINE_PRIMITIVE ("READ-BYTE-FROM-MEMORY", Prim_read_byte_from_memory, 1, 1, 145 "(ADDRESS)\n\ 146 Read a byte from memory at ADDRESS and return it as an unsigned integer.") 147 { 148 PRIMITIVE_HEADER (1); 149 PRIMITIVE_RETURN 150 (ulong_to_integer (* ((unsigned char *) (arg_ulong_integer (1))))); 151 } 152 153 DEFINE_PRIMITIVE ("READ-WORD-FROM-MEMORY", Prim_read_word_from_memory, 1, 1, 154 "(ADDRESS)\n\ 155 Read a word from memory at ADDRESS and return it as an unsigned integer.") 156 { 157 PRIMITIVE_HEADER (1); 158 PRIMITIVE_RETURN 159 (ulong_to_integer (* ((unsigned long *) (arg_ulong_integer (1))))); 160 } 161 162 DEFINE_PRIMITIVE ("READ-FLOAT-FROM-MEMORY", Prim_read_float_from_memory, 1, 1, 163 "(ADDRESS)\n\ 164 Read a float from memory at ADDRESS and return it as a flonum.") 165 { 166 PRIMITIVE_HEADER (1); 167 PRIMITIVE_RETURN (double_to_flonum (* ((double *) (arg_ulong_integer (1))))); 168 } 169 170 DEFINE_PRIMITIVE ("WRITE-BYTE-TO-MEMORY", Prim_write_byte_to_memory, 2, 2, 171 "(BYTE ADDRESS)\n\ 172 Write BYTE to memory at ADDRESS.") 173 { 174 PRIMITIVE_HEADER (2); 175 (* ((unsigned char *) (arg_ulong_integer (2)))) 176 = (arg_index_integer (1, 0x100)); 177 PRIMITIVE_RETURN (UNSPECIFIC); 178 } 179 180 DEFINE_PRIMITIVE ("WRITE-WORD-TO-MEMORY", Prim_write_word_to_memory, 2, 2, 181 "(WORD ADDRESS)\n\ 182 Write WORD to memory at ADDRESS.") 183 { 184 PRIMITIVE_HEADER (2); 185 (* ((unsigned long *) (arg_ulong_integer (2)))) = (arg_ulong_integer (1)); 186 PRIMITIVE_RETURN (UNSPECIFIC); 187 } 188 189 DEFINE_PRIMITIVE ("WRITE-FLOAT-TO-MEMORY", Prim_write_float_to_memory, 2, 2, 190 "(FLOAT ADDRESS)\n\ 191 Write FLOAT to memory at ADDRESS.") 192 { 193 PRIMITIVE_HEADER (2); 194 (* ((double *) (arg_ulong_integer (2)))) = (arg_flonum (1)); 195 PRIMITIVE_RETURN (UNSPECIFIC); 196 } 197 198 DEFINE_PRIMITIVE ("CC-BLOCK-LINKAGE-INFO", Prim_cc_block_linkage_info, 1, 1, 0) 199 { 200 PRIMITIVE_HEADER (1); 201 CHECK_ARG (1, CC_BLOCK_P); 202 PRIMITIVE_RETURN (cc_block_linkage_info (ARG_REF (1))); 203 } 204