klisp

commit 108007f8ea3acd454ff8676b7967e622701ca748
parent 01cb406bffe88b68eea68b495631414f11a56093
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Thu, 24 Nov 2011 20:48:36 -0300

Added get-environment-variable and get-environment-variables to the ground environment.

Diffstat:
M
src/kgsystem.c
 | 
88
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-----

1 file changed, 83 insertions(+), 5 deletions(-)
diff --git a/src/kgsystem.c b/src/kgsystem.c
@@ -5,6 +5,7 @@
 */
 
 #include <assert.h>
+#include <string.h>
 #include <stdlib.h>
 #include <stdbool.h>
 #include <stdio.h>
@@ -175,20 +176,93 @@ void rename_file(klisp_State *K)
     }
 }
 
-/* used for both get_script_arguments and get_interpreter_arguments */
+/* ?.? get-script-arguments, get-interpreter-arguments */
 void get_arguments(klisp_State *K)
 {
     /*
-     * xparams[0]: immutable argument list
+    ** xparams[0]: immutable argument list
      */
     TValue ptree = K->next_value;
     TValue *xparams = K->next_xparams;
-    check_0p(K, ptree);
+    TValue denv = K->next_env;
+    klisp_assert(ttisenvironment(K->next_env));
+    UNUSED(denv);
 
+    check_0p(K, ptree);
     TValue res = xparams[0];
     kapply_cc(K, res);
 }
 
+/* ?.? get-environment-variable, get-environment-variables */
+void get_environment_variable(klisp_State *K)
+{
+    TValue ptree = K->next_value;
+    TValue *xparams = K->next_xparams;
+    TValue denv = K->next_env;
+    klisp_assert(ttisenvironment(K->next_env));
+    UNUSED(xparams);
+    UNUSED(denv);
+
+    bind_1tp(K, ptree, "string", ttisstring, name);
+    char *str = getenv(kstring_buf(name));
+    /* I follow r7rs here, but should probably throw error */
+    TValue res;
+    if (str == NULL) {
+	res = KFALSE;
+    } else {
+	res = kstring_new_b_imm(K, str);
+    }
+    kapply_cc(K, res);
+}
+
+void get_environment_variables(klisp_State *K)
+{
+    /*
+    ** xparams[0]: immutable variable list
+     */
+    TValue ptree = K->next_value;
+    TValue *xparams = K->next_xparams;
+    TValue denv = K->next_env;
+    klisp_assert(ttisenvironment(K->next_env));
+    UNUSED(denv);
+
+    check_0p(K, ptree);
+    kapply_cc(K, xparams[0]);
+}
+
+/* This should work in mingw as well as gcc */
+/* TODO test, if that doesn't work, try to find a way
+   avoiding taking extra params in main */
+/* I think it's defined in unistd, but it needs to have __USE_GNU 
+ defined. The correct way to do that would be to define _GNU_SOURCE
+ before including any system files... That's not good for an 
+ embeddable interpreter... */
+extern char **environ;
+
+/* Helper for get-environment-variables */
+TValue create_env_var_list(klisp_State *K)
+{
+    /* no need for gc guarding in this context */
+    TValue var_name, var_value;
+    TValue tail = KNIL;
+    
+    /* This should work in mingw as well as gcc */
+    /* TODO test, if that doesn't work, try to find a way
+       avoiding taking extra params in main */
+    for(char **env = environ; *env != NULL; ++env) {
+	/* *env is of the form: "<name>=<value>", presumably, name can't have
+	   an equal sign! */
+	char *eq = strchr(*env, '=');
+	int name_len = eq - *env;
+	klisp_assert(eq != NULL); /* shouldn't happen */
+	var_name = kstring_new_bs_imm(K, *env, name_len);
+	var_value = kstring_new_b_imm(K, *env + name_len + 1);
+	TValue new_entry = kimm_cons(K, var_name, var_value);
+	tail = kimm_cons(K, new_entry, tail);
+    }
+    return tail;
+}
+
 /* init ground */
 void kinit_system_ground_env(klisp_State *K)
 {
@@ -210,10 +284,14 @@ void kinit_system_ground_env(klisp_State *K)
     /* ?.? rename-file */
     add_applicative(K, ground_env, "rename-file", rename_file, 0);
     /* The value for these two will get set later by the interpreter */
-    /* ?.? get-script-arguments */
+    /* ?.? get-script-arguments, get-interpreter-arguments */
     add_applicative(K, ground_env, "get-script-arguments", get_arguments, 
 		    1, KNIL);
-    /* ?.? get-interpreter-arguments */
     add_applicative(K, ground_env, "get-interpreter-arguments", get_arguments, 
 		    1, KNIL);
+    /* ?.? get-environment-variable, get-environment-variables */
+    add_applicative(K, ground_env, "get-environment-variable", 
+		    get_environment_variable, 0);
+    add_applicative(K, ground_env, "get-environment-variables", 
+		    get_environment_variables, 1, create_env_var_list(K));
 }