klisp

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

kgencapsulations.c (2689B)

      1 /*
      2 ** kgencapsulations.c
      3 ** Encapsulations features for the ground environment
      4 ** See Copyright Notice in klisp.h
      5 */
      6 
      7 #include <assert.h>
      8 #include <stdio.h>
      9 #include <stdlib.h>
     10 #include <stdbool.h>
     11 #include <stdint.h>
     12 
     13 #include "kstate.h"
     14 #include "kobject.h"
     15 #include "kencapsulation.h"
     16 #include "kapplicative.h"
     17 #include "koperative.h"
     18 #include "kerror.h"
     19 
     20 #include "kghelpers.h"
     21 #include "kgencapsulations.h"
     22 
     23 /* Helpers for make-encapsulation-type */
     24 
     25 /* Type predicate for encapsulations */
     26 /* enc_typep(klisp_State *K), in kghelpers */
     27 
     28 /* Constructor for encapsulations */
     29 void enc_wrap(klisp_State *K)
     30 {
     31     TValue *xparams = K->next_xparams;
     32     TValue ptree = K->next_value;
     33     TValue denv = K->next_env;
     34     klisp_assert(ttisenvironment(K->next_env));
     35     bind_1p(K, ptree, obj);
     36     UNUSED(denv);
     37     /*
     38     ** xparams[0]: encapsulation key
     39     */
     40     TValue key = xparams[0];
     41     TValue enc = kmake_encapsulation(K, key, obj);
     42     kapply_cc(K, enc);
     43 }
     44 
     45 /* Accessor for encapsulations */
     46 void enc_unwrap(klisp_State *K)
     47 {
     48     TValue *xparams = K->next_xparams;
     49     TValue ptree = K->next_value;
     50     TValue denv = K->next_env;
     51     klisp_assert(ttisenvironment(K->next_env));
     52     bind_1p(K, ptree, enc);
     53     UNUSED(denv);
     54     /*
     55     ** xparams[0]: encapsulation key
     56     */
     57     TValue key = xparams[0];
     58 
     59     if (!kis_encapsulation_type(enc, key)) {
     60         klispE_throw_simple(K, "object doesn't belong to this "
     61                             "encapsulation type");
     62         return;
     63     }
     64     TValue obj = kget_enc_val(enc);
     65     kapply_cc(K, obj);
     66 }
     67 
     68 /* 8.1.1 make-encapsulation-type */
     69 void make_encapsulation_type(klisp_State *K)
     70 {
     71     TValue *xparams = K->next_xparams;
     72     TValue ptree = K->next_value;
     73     TValue denv = K->next_env;
     74     klisp_assert(ttisenvironment(K->next_env));
     75     check_0p(K, ptree);
     76     UNUSED(denv);
     77     UNUSED(xparams);
     78 
     79     /* GC: root intermediate values & pairs */
     80     TValue key = kmake_encapsulation_key(K);
     81     krooted_tvs_push(K, key);
     82     TValue e = kmake_applicative(K, enc_wrap, 1, key);
     83     krooted_tvs_push(K, e);
     84     TValue p = kmake_applicative(K, enc_typep, 1, key);
     85     krooted_tvs_push(K, p);
     86     TValue d = kmake_applicative(K, enc_unwrap, 1, key);
     87     krooted_tvs_push(K, d);
     88 
     89     TValue ls = klist(K, 3, e, p, d);
     90 
     91     krooted_tvs_pop(K);
     92     krooted_tvs_pop(K);
     93     krooted_tvs_pop(K);
     94     krooted_tvs_pop(K);
     95     kapply_cc(K, ls);
     96 }
     97 
     98 /* init ground */
     99 void kinit_encapsulations_ground_env(klisp_State *K)
    100 {
    101     TValue ground_env = G(K)->ground_env;
    102     TValue symbol, value;
    103 
    104     /* 8.1.1 make-encapsulation-type */
    105     add_applicative(K, ground_env, "make-encapsulation-type", 
    106                     make_encapsulation_type, 0); 
    107 }