klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

kenvironment.c (10756B)


      1 /*
      2 ** kenvironment.c
      3 ** Kernel Environments
      4 ** See Copyright Notice in klisp.h
      5 */
      6 
      7 #include <string.h>
      8 
      9 #include "kenvironment.h"
     10 #include "kpair.h"
     11 #include "ksymbol.h"
     12 #include "kobject.h"
     13 #include "kerror.h"
     14 #include "kstate.h"
     15 #include "kmem.h"
     16 #include "ktable.h"
     17 #include "kgc.h"
     18 #include "kapplicative.h"
     19 
     20 /* keyed dynamic vars */
     21 #define env_keyed_parents(env_) (tv2env(env_)->keyed_parents)
     22 #define env_keyed_node(env_) (tv2env(env_)->keyed_node)
     23 #define env_keyed_key(env_) (kcar(env_keyed_node(env_)))
     24 #define env_keyed_val(env_) (kcdr(env_keyed_node(env_)))
     25 #define env_is_keyed(env_) (!ttisnil(env_keyed_node(env_)))
     26 /* env_ should be keyed! */
     27 #define env_has_key(env_, k_) (tv_equal(env_keyed_key(env_), (k_)))
     28 
     29 /* GC: Assumes that parents is rooted */
     30 TValue kmake_environment(klisp_State *K, TValue parents)
     31 {
     32     Environment *new_env = klispM_new(K, Environment);
     33 
     34     /* header + gc_fields */
     35     klispC_link(K, (GCObject *) new_env, K_TENVIRONMENT, 
     36                 K_FLAG_CAN_HAVE_NAME);
     37 
     38     /* environment specific fields */
     39     new_env->mark = KFALSE;    
     40     new_env->parents = parents; /* save them here */
     41     /* TEMP: for now the bindings are an alist */
     42     new_env->bindings = KNIL;
     43 
     44     /* set these here to avoid problems if gc gets called */
     45     new_env->keyed_parents = KNIL;
     46     new_env->keyed_node = KNIL;
     47 
     48     /* keep the lock, to avoid problems if the list of parents is mutated */
     49 
     50     /* Contruct the list of keyed parents */
     51     /* MAYBE: this could be optimized to avoid repetition of parents */
     52     TValue kparents;
     53     if (ttisnil(parents)) {
     54         kparents = KNIL;
     55     } else if (ttisenvironment(parents)) {
     56         kparents = env_is_keyed(parents)? parents : env_keyed_parents(parents);
     57     } else {
     58         /* list of parents, for now, just append them */
     59         krooted_tvs_push(K, gc2env(new_env)); /* keep the new env rooted */
     60         TValue plist = kcons(K, KNIL, KNIL); /* keep the list rooted */
     61         krooted_vars_push(K, &plist);
     62         TValue tail = plist;
     63         while(!ttisnil(parents)) {
     64             TValue parent = kcar(parents);
     65             TValue pkparents = env_keyed_parents(parent);
     66             while(!ttisnil(pkparents)) {
     67                 TValue next;
     68                 if (ttisenvironment(pkparents)) {
     69                     next = pkparents;
     70                     pkparents = KNIL;
     71                 } else {
     72                     next = kcar(pkparents);
     73                     pkparents = kcdr(pkparents);
     74                 }
     75                 TValue new_pair = kcons(K, next, KNIL);
     76                 kset_cdr(tail, new_pair);
     77                 tail = new_pair;
     78             }
     79             parents = kcdr(parents);
     80         }
     81         /* all alocation done */
     82         kparents = kcdr(plist); 
     83         krooted_vars_pop(K);
     84         krooted_tvs_pop(K); 
     85         /* if it's just one env switch from (env) to env. */
     86         if (ttispair(kparents) && ttisnil(kcdr(kparents)))
     87             kparents = kcar(kparents);
     88     }
     89     new_env->keyed_parents = kparents; /* overwrite with the proper value */
     90     return gc2env(new_env);
     91 }
     92 
     93 /* 
     94 ** Helper function for kadd_binding and kget_binding,
     95 ** Only for list environments, table environments are handled elsewhere
     96 ** returns KNIL or a pair with sym as car.
     97 */
     98 
     99 /* LOCK: GIL should be acquired */
    100 TValue kfind_local_binding(klisp_State *K, TValue bindings, TValue sym)
    101 {
    102     UNUSED(K);
    103 
    104     while(!ttisnil(bindings)) {
    105         TValue first = kcar(bindings);
    106         TValue first_sym = kcar(first);
    107         /* symbols can't be compared with tv_equal! */
    108         if (tv_sym_equal(sym, first_sym))
    109             return first;
    110         bindings = kcdr(bindings);
    111     }
    112     return KNIL;
    113 }
    114 
    115 /*
    116 ** Some helper macros
    117 */
    118 #define kenv_parents(kst_, env_) (tv2env(env_)->parents)
    119 #define kenv_bindings(kst_, env_) (tv2env(env_)->bindings)
    120 
    121 #if KTRACK_NAMES
    122 /* GC: Assumes that obj & sym are rooted. */
    123 void ktry_set_name(klisp_State *K, TValue obj, TValue sym)
    124 {
    125     if (kcan_have_name(obj) && !khas_name(obj)) {
    126         /* TODO: maybe we could have some kind of inheritance so
    127            that if this object receives a name it can pass on that
    128            name to other objs, like applicatives to operatives & 
    129            some applicatives to objects */
    130         gcvalue(obj)->gch.kflags |= K_FLAG_HAS_NAME;
    131         TValue *node = klispH_set(K, tv2table(G(K)->name_table), obj);
    132         *node = sym;
    133 
    134         /* TEMP: use this until we have a general mechanism to add
    135            objects to be named after some other obj */
    136         if (ttisapplicative(obj)) {
    137             /* underlying is rooted by means of obj */
    138             TValue underlying = kunwrap(obj);
    139             while (kcan_have_name(underlying) && !khas_name(underlying)) {
    140                 gcvalue(underlying)->gch.kflags |= K_FLAG_HAS_NAME;
    141                 node = klispH_set(K, tv2table(G(K)->name_table), underlying);
    142                 *node = sym;
    143                 if (ttisapplicative(underlying)) 
    144                     underlying = kunwrap(underlying);
    145                 else 
    146                     break;
    147             }
    148         }
    149     }
    150 }
    151 
    152 /* Assumes obj has a name */
    153 TValue kget_name(klisp_State *K, TValue obj)
    154 {
    155     /* LOCK: klispH_get will acquire the GIL */
    156     const TValue *node = klispH_get(tv2table(G(K)->name_table),
    157                                     obj);
    158     klisp_assert(node != &kfree);
    159     return *node;
    160 }
    161 #endif
    162 
    163 /* GC: Assumes that env, sym & val are rooted. */
    164 void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val)
    165 {
    166     klisp_assert(ttisenvironment(env));
    167     klisp_assert(ttissymbol(sym));
    168 
    169 #if KTRACK_NAMES
    170     ktry_set_name(K, val, sym);
    171 #endif
    172 
    173     /* lock early because it is possible that even the environment
    174        type changes (from list to table) */
    175     TValue bindings = kenv_bindings(K, env);
    176     if (ttistable(bindings)) {
    177         TValue *cell = klispH_setsym(K, tv2table(bindings), tv2sym(sym));
    178         *cell = val;
    179     } else {
    180         TValue oldb = kfind_local_binding(K, bindings, sym);
    181 
    182         if (ttisnil(oldb)) {
    183             TValue new_pair = kcons(K, sym, val);
    184             krooted_tvs_push(K, new_pair);
    185             kenv_bindings(K, env) = kcons(K, new_pair, bindings);
    186             krooted_tvs_pop(K);
    187         } else {
    188             kset_cdr(oldb, val);
    189         }
    190     }
    191 }
    192 
    193 /* This works no matter if parents is a list or a single environment */
    194 /* GC: assumes env & sym are rooted */
    195 static inline bool try_get_binding(klisp_State *K, TValue env, TValue sym, 
    196                             TValue *value)
    197 {
    198     /* assume the stack may be in use, keep track of pushed objs */
    199     int pushed = 1;
    200     ks_spush(K, env);
    201 
    202     while(pushed) {
    203         TValue obj = ks_spop(K);
    204         --pushed;
    205         if (ttisnil(obj)) {
    206             continue;
    207         } else if (ttisenvironment(obj)) {
    208             TValue bindings = kenv_bindings(K, obj);
    209             if (ttistable(bindings)) {
    210                 const TValue *cell = klispH_getsym(tv2table(bindings), 
    211                                                    tv2sym(sym));
    212                 if (cell != &kfree) {
    213                     /* remember to leave the stack as it was */
    214                     ks_sdiscardn(K, pushed);
    215                     *value = *cell;
    216                     return true;
    217                 }
    218             } else {
    219                 TValue oldb = kfind_local_binding(K, bindings, sym);
    220                 if (!ttisnil(oldb)) {
    221                     /* remember to leave the stack as it was */
    222                     ks_sdiscardn(K, pushed);
    223                     *value = kcdr(oldb);
    224                     return true;
    225                 }
    226             }
    227             TValue parents = kenv_parents(K, obj);
    228             ks_spush(K, parents);
    229             ++pushed;
    230         } else { /* parent list */
    231             ks_spush(K, kcdr(obj));
    232             ks_spush(K, kcar(obj));
    233             pushed += 2;
    234         }
    235     }
    236 
    237     *value = KINERT;
    238 
    239     return false;
    240 }
    241 
    242 TValue kget_binding(klisp_State *K, TValue env, TValue sym)
    243 {
    244     klisp_assert(ttisenvironment(env));
    245     klisp_assert(ttissymbol(sym));
    246     TValue value;
    247     if (try_get_binding(K, env, sym, &value)) {
    248         return value;
    249     } else {
    250         klispE_throw_simple_with_irritants(K, "Unbound symbol", 1, sym);
    251         /* avoid warning */
    252         return KINERT;
    253     }
    254 }
    255 
    256 bool kbinds(klisp_State *K, TValue env, TValue sym)
    257 {
    258     TValue value;
    259     return try_get_binding(K, env, sym, &value);
    260 }
    261 
    262 /* keyed dynamic vars */
    263 
    264 /* MAYBE: This could be combined with the default constructor */
    265 /* GC: assumes parent, key & val are rooted */
    266 TValue kmake_keyed_static_env(klisp_State *K, TValue parent, TValue key, 
    267                               TValue val)
    268 {
    269     TValue new_env = kmake_environment(K, parent);
    270     krooted_tvs_push(K, new_env); /* keep the env rooted */
    271     env_keyed_node(new_env) = kcons(K, key, val);
    272     krooted_tvs_pop(K);
    273     return new_env;
    274 }
    275 
    276 /* GC: assumes parent, key & env are rooted */
    277 static inline bool try_get_keyed(klisp_State *K, TValue env, TValue key, 
    278                           TValue *value)
    279 {
    280     /* MAYBE: this could be optimized to mark environments to avoid
    281        repetition */
    282     /* assume the stack may be in use, keep track of pushed objs */
    283 
    284     int pushed = 1;
    285     if (!env_is_keyed(env))
    286         env = env_keyed_parents(env);
    287     ks_spush(K, env);
    288 
    289     while(pushed) {
    290         TValue obj = ks_spop(K);
    291         --pushed;
    292         if (ttisnil(obj)) {
    293             continue;
    294         } else if (ttisenvironment(obj)) {
    295             /* obj is guaranteed to be a keyed env */
    296             if (env_has_key(obj, key)) {
    297                 /* remember to leave the stack as it was */
    298                 ks_sdiscardn(K, pushed);
    299                 *value = env_keyed_val(obj);
    300                 return true;
    301             } else {
    302                 TValue parents = env_keyed_parents(obj);
    303                 ks_spush(K, parents);
    304                 ++pushed;
    305             }
    306         } else { /* parent list */
    307             ks_spush(K, kcdr(obj));
    308             ks_spush(K, kcar(obj));
    309             pushed += 2;
    310         }
    311     }
    312     *value = KINERT;
    313     return false;
    314 }
    315 
    316 TValue kget_keyed_static_var(klisp_State *K, TValue env, TValue key)
    317 {
    318     TValue value;
    319     if (try_get_keyed(K, env, key, &value)) {
    320         return value;
    321     } else {
    322         klispE_throw_simple(K, "Unbound keyed static variable");
    323         /* avoid warning */
    324         return KINERT;
    325     }
    326 }
    327 
    328 /* environments with hashtable bindings */
    329 /* TEMP: for now only for ground & std environments */
    330 TValue kmake_table_environment(klisp_State *K, TValue parents)
    331 {
    332     TValue new_env = kmake_environment(K, parents);
    333     krooted_tvs_push(K, new_env);
    334     TValue new_table = klispH_new(K, 0, ENVTABSIZE, K_FLAG_WEAK_NOTHING);
    335     tv2env(new_env)->bindings = new_table;
    336     krooted_tvs_pop(K);
    337     return new_env;
    338 }