kgsystem.c (9082B)
1 /* 2 ** kgsystem.c 3 ** Ports features for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <string.h> 8 #include <stdlib.h> 9 #include <stdbool.h> 10 #include <stdio.h> 11 #include <stdint.h> 12 #include <time.h> 13 14 #include "kstate.h" 15 #include "kobject.h" 16 #include "kpair.h" 17 #include "kerror.h" 18 #include "ksystem.h" 19 #include "kinteger.h" 20 #include "kgc.h" 21 22 #include "kghelpers.h" 23 #include "kgsystem.h" 24 25 /* 26 ** SOURCE NOTE: These are all from the r7rs draft. 27 */ 28 29 /* ??.?.? current-second */ 30 /* XXX current revision of the r7rs draft asks for tai seconds, 31 I am sticking with UTC seconds for now, at least till the report is 32 ratified */ 33 void get_current_second(klisp_State *K) 34 { 35 TValue *xparams = K->next_xparams; 36 TValue ptree = K->next_value; 37 TValue denv = K->next_env; 38 klisp_assert(ttisenvironment(K->next_env)); 39 UNUSED(xparams); 40 UNUSED(denv); 41 42 check_0p(K, ptree); 43 time_t now = time(NULL); 44 if (now == -1) { 45 klispE_throw_simple(K, "couldn't get time"); 46 return; 47 } else { 48 TValue res = kinteger_new_uint64(K, (uint64_t) now); 49 kapply_cc(K, res); 50 } 51 } 52 53 /* ??.?.? current-jiffy */ 54 void get_current_jiffy(klisp_State *K) 55 { 56 TValue ptree = K->next_value; 57 check_0p(K, ptree); 58 kapply_cc(K, ksystem_current_jiffy(K)); 59 } 60 61 /* ??.?.? jiffies-per-second */ 62 void get_jiffies_per_second(klisp_State *K) 63 { 64 TValue ptree = K->next_value; 65 check_0p(K, ptree); 66 kapply_cc(K, ksystem_jiffies_per_second(K)); 67 } 68 69 /* 15.1.? file-exists? */ 70 void file_existsp(klisp_State *K) 71 { 72 TValue *xparams = K->next_xparams; 73 TValue ptree = K->next_value; 74 TValue denv = K->next_env; 75 klisp_assert(ttisenvironment(K->next_env)); 76 UNUSED(xparams); 77 UNUSED(denv); 78 79 bind_1tp(K, ptree, "string", ttisstring, filename); 80 81 /* TEMP: this should probably be done in a operating system specific 82 manner, but this will do for now */ 83 TValue res = KFALSE; 84 FILE *file = fopen(kstring_buf(filename), "r"); 85 if (file) { 86 res = KTRUE; 87 UNUSED(fclose(file)); 88 } 89 kapply_cc(K, res); 90 } 91 92 /* 15.1.? delete-file */ 93 void delete_file(klisp_State *K) 94 { 95 TValue *xparams = K->next_xparams; 96 TValue ptree = K->next_value; 97 TValue denv = K->next_env; 98 klisp_assert(ttisenvironment(K->next_env)); 99 UNUSED(xparams); 100 UNUSED(denv); 101 102 bind_1tp(K, ptree, "string", ttisstring, filename); 103 104 /* TEMP: this should probably be done in a operating system specific 105 manner, but this will do for now */ 106 /* allow other threads to run while the file is being removed */ 107 klisp_unlock(K); 108 if (remove(kstring_buf(filename))) { 109 /* At least in Windows, this could have failed if there's a dead 110 (in the gc sense) port still open, should retry once after 111 doing a complete GC. This isn't ideal but... */ 112 klisp_lock(K); 113 klispC_fullgc(K); 114 klisp_unlock(K); 115 if (remove(kstring_buf(filename))) { 116 klisp_lock(K); 117 klispE_throw_errno_with_irritants(K, "remove", 1, filename); 118 return; 119 } 120 klisp_lock(K); 121 } 122 kapply_cc(K, KINERT); 123 } 124 125 /* 15.1.? rename-file */ 126 void rename_file(klisp_State *K) 127 { 128 TValue *xparams = K->next_xparams; 129 TValue ptree = K->next_value; 130 TValue denv = K->next_env; 131 klisp_assert(ttisenvironment(K->next_env)); 132 UNUSED(xparams); 133 UNUSED(denv); 134 135 bind_2tp(K, ptree, "string", ttisstring, old_filename, 136 "string", ttisstring, new_filename); 137 138 /* TEMP: this should probably be done in a operating system specific 139 manner, but this will do for now */ 140 /* XXX: this could fail if there's a dead (in the gc sense) port still 141 open, should probably retry once after doing a complete GC */ 142 if (rename(kstring_buf(old_filename), kstring_buf(new_filename))) { 143 klispE_throw_errno_with_irritants(K, "rename", 2, old_filename, new_filename); 144 return; 145 } else { 146 kapply_cc(K, KINERT); 147 return; 148 } 149 } 150 151 /* ?.? get-script-arguments, get-interpreter-arguments */ 152 void get_arguments(klisp_State *K) 153 { 154 /* 155 ** xparams[0]: immutable argument list 156 */ 157 TValue ptree = K->next_value; 158 TValue *xparams = K->next_xparams; 159 TValue denv = K->next_env; 160 klisp_assert(ttisenvironment(K->next_env)); 161 UNUSED(denv); 162 163 check_0p(K, ptree); 164 TValue res = xparams[0]; 165 kapply_cc(K, res); 166 } 167 168 /* ?.? defined-environment-variable?, get-environment-variable, 169 get-environment-variables */ 170 void defined_environment_variableP(klisp_State *K) 171 { 172 TValue ptree = K->next_value; 173 TValue *xparams = K->next_xparams; 174 TValue denv = K->next_env; 175 klisp_assert(ttisenvironment(K->next_env)); 176 UNUSED(xparams); 177 UNUSED(denv); 178 179 bind_1tp(K, ptree, "string", ttisstring, name); 180 char *str = getenv(kstring_buf(name)); 181 182 TValue res = (str == NULL)? KFALSE : KTRUE; 183 kapply_cc(K, res); 184 } 185 186 void get_environment_variable(klisp_State *K) 187 { 188 TValue ptree = K->next_value; 189 TValue *xparams = K->next_xparams; 190 TValue denv = K->next_env; 191 klisp_assert(ttisenvironment(K->next_env)); 192 UNUSED(xparams); 193 UNUSED(denv); 194 195 bind_1tp(K, ptree, "string", ttisstring, name); 196 char *str = getenv(kstring_buf(name)); 197 198 TValue res; 199 if (str == NULL) { 200 klispE_throw_simple_with_irritants(K, "undefined env var", 1, name); 201 return; 202 } else { 203 res = kstring_new_b_imm(K, str); 204 } 205 kapply_cc(K, res); 206 } 207 208 void get_environment_variables(klisp_State *K) 209 { 210 /* 211 ** xparams[0]: immutable variable list 212 */ 213 TValue ptree = K->next_value; 214 TValue *xparams = K->next_xparams; 215 TValue denv = K->next_env; 216 klisp_assert(ttisenvironment(K->next_env)); 217 UNUSED(denv); 218 219 check_0p(K, ptree); 220 kapply_cc(K, xparams[0]); 221 } 222 223 /* Redefining environ hides the definition 224 from <stdlib.h> on MinGW. 225 */ 226 #ifndef __MINGW32__ 227 228 /* Note, when building for Windows if there is 229 a link error try commenting out the following 230 declaration. */ 231 /* TODO test, if that doesn't work, try to find a way 232 avoiding taking extra params in main */ 233 /* I think it's defined in unistd, but it needs to have __USE_GNU 234 defined. The correct way to do that would be to define _GNU_SOURCE 235 before including any system files... That's not so good for an 236 embeddable interpreter, but it could be done in the makefile I guess */ 237 extern 238 #ifdef _WIN32 239 __declspec(dllimport) 240 #endif 241 char **environ; 242 243 #endif 244 245 /* Helper for get-environment-variables */ 246 TValue create_env_var_list(klisp_State *K) 247 { 248 /* no need for gc guarding in this context */ 249 TValue var_name, var_value; 250 TValue tail = KNIL; 251 252 /* This should work in mingw as well as gcc */ 253 /* TODO test, if that doesn't work, try to find a way 254 avoiding taking extra params in main */ 255 for(char **env = environ; *env != NULL; ++env) { 256 /* *env is of the form: "<name>=<value>", presumably, name can't have 257 an equal sign! */ 258 char *eq = strchr(*env, '='); 259 int name_len = eq - *env; 260 klisp_assert(eq != NULL); /* shouldn't happen */ 261 var_name = kstring_new_bs_imm(K, *env, name_len); 262 var_value = kstring_new_b_imm(K, *env + name_len + 1); 263 TValue new_entry = kimm_cons(K, var_name, var_value); 264 tail = kimm_cons(K, new_entry, tail); 265 } 266 return tail; 267 } 268 269 /* init ground */ 270 void kinit_system_ground_env(klisp_State *K) 271 { 272 TValue ground_env = G(K)->ground_env; 273 TValue symbol, value; 274 275 /* ??.?.? get-current-second */ 276 add_applicative(K, ground_env, "get-current-second", get_current_second, 0); 277 /* ??.?.? get-current-jiffy */ 278 add_applicative(K, ground_env, "get-current-jiffy", get_current_jiffy, 0); 279 /* ??.?.? get-jiffies-per-second */ 280 add_applicative(K, ground_env, "get-jiffies-per-second", get_jiffies_per_second, 281 0); 282 /* ?.? file-exists? */ 283 add_applicative(K, ground_env, "file-exists?", file_existsp, 0); 284 /* ?.? delete-file */ 285 add_applicative(K, ground_env, "delete-file", delete_file, 0); 286 /* this isn't in r7rs but it's in ansi c and quite easy to implement */ 287 /* ?.? rename-file */ 288 add_applicative(K, ground_env, "rename-file", rename_file, 0); 289 /* The value for these two will get set later by the interpreter */ 290 /* ?.? get-script-arguments, get-interpreter-arguments */ 291 add_applicative(K, ground_env, "get-script-arguments", get_arguments, 292 1, KNIL); 293 add_applicative(K, ground_env, "get-interpreter-arguments", get_arguments, 294 1, KNIL); 295 /* ?.? defined-environment-variable?, get-environment-variable, 296 get-environment-variables */ 297 add_applicative(K, ground_env, "defined-environment-variable?", 298 defined_environment_variableP, 0); 299 add_applicative(K, ground_env, "get-environment-variable", 300 get_environment_variable, 0); 301 add_applicative(K, ground_env, "get-environment-variables", 302 get_environment_variables, 1, create_env_var_list(K)); 303 }