x-prim.h

Go to the documentation of this file.

#ifndef X_PRIM_H
#define X_PRIM_H
 
/*
 *     ., .,
 *     {O,O}
 *     (   )
 *      " "
 */
 
#include "x-obj.h"
#include "x-heap.h"
#include "x-eval.h" /* x_eval_arg: the x_eargs helper below evaluates args */
#include <stdarg.h>
 
 
static void __attribute__((unused)) x_args(x_obj_t *p_base, x_obj_t *p_args,
    int count, ...)
{
    va_list ap;
    int i;
 
    va_start(ap, count);
    for (i = 0; i < count; i++) {
        x_obj_t **slot = va_arg(ap, x_obj_t **);
        if (p_args == NULL) { if (slot) *slot = NULL; continue; }
        x_eval_spine_guard(p_base, p_args);
        if (slot != NULL)
            *slot = x_firstobj(p_args);
        p_args = x_restobj(p_args);
    }
    va_end(ap);
}
 
static void __attribute__((unused)) x_eargs(x_obj_t *p_base, x_obj_t *p_args, int count, ...)
{
    va_list ap;
    int i;
    int held = 0;
    x_obj_t **p_cell = x_heap_root_slot(p_base);
    /* Earlier results may be fresh objects whose only other homes are the
     * caller's out-slots -- bare C stack the collector does not scan under
     * precise rooting -- so each result is parked in a registered slot
     * while the later arguments evaluate.  Two pair cells give four slots:
     * enough for the deepest x_eargs caller (count 5 = four results, of
     * which the last needs no protection here). */
    x_spair_t roots[2] = {
        x_obj_set((x_obj_t *)x_type_pair_obj, X_OBJ_FLAG_NONE,
            { NULL }, { NULL }),
        x_obj_set((x_obj_t *)x_type_pair_obj, X_OBJ_FLAG_NONE,
            { NULL }, { NULL })
    };
 
    x_heap_root_push(p_cell, roots[0]);
    x_heap_root_push(p_cell, roots[1]);
 
    va_start(ap, count);
    for (i = 0; i < count; i++) {
        x_obj_t **slot = va_arg(ap, x_obj_t **);
        if (p_args == NULL) { if (slot) *slot = NULL; continue; }
        /* A proper list ends at nil, handled above; an IMPROPER one ends
         * at an ATOM, which the walk below would have read as a pair
         * (#487).  Raising here is safe with the roots pushed: the
         * handler restores the root chain to its snapshot on the error
         * path, exactly as it does for the C frames a longjmp cuts. */
        x_eval_spine_guard(p_base, p_args);
        if (slot != NULL) {
            *slot = x_eval_arg(p_base, x_firstobj(p_args));
            if (held < 4) {
                x_obj_data_i((x_obj_t *)roots[held >> 1], held & 1).p = *slot;
                held++;
            }
        }
        p_args = x_restobj(p_args);
    }
    va_end(ap);
 
    x_heap_root_pop(p_cell);
    x_heap_root_pop(p_cell);
}
 
 
 
typedef struct {
    x_char_t *name;                        
    x_fn_t fn;                             
} x_callable_entry_t;
 
void x_value_bind(x_obj_t *p_base, x_char_t *name, x_obj_t *p_val);
 
void x_callable_bind(x_obj_t *p_base, x_char_t *name, x_fn_t fn);
 
void x_callable_bind_table(x_obj_t *p_base, const x_callable_entry_t *table, int count);
 
x_obj_t *x_prims(x_obj_t *p_base);
 
typedef struct {
    x_char_t *name;                        
    x_fn_t fn;                             
    x_char_t *ns;                          
    x_char_t *method;                      
} x_prim_entry_t;
 
void x_prims_bind_table(x_obj_t *p_base, const x_prim_entry_t *table, int count);
 
x_obj_t *x_prim_core_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_arith_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_pred_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_string_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_io_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_heap_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_image_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_repl(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_type_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_type_build_struct(x_obj_t *p_base, x_obj_t *p_name_atom,
    x_obj_t *p_handlers);
 
x_obj_t *x_prim_base_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_op1(x_obj_t *p_base, x_obj_t *p_args,
    x_obj_t *(*op)(x_obj_t *, x_obj_t *));
 
x_obj_t *x_prim_buffer_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_iter_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_ffi_register(x_obj_t *p_base, x_obj_t *p_args);
 
x_obj_t *x_prim_callcc_register(x_obj_t *p_base, x_obj_t *p_args);
 
#ifdef X_SIGNAL
x_obj_t *x_prim_signal_register(x_obj_t *p_base, x_obj_t *p_args);
#endif
 
void x_callcc_init(void);
x_obj_t *x_prim_register(x_obj_t *p_base, x_obj_t *p_args);
 
#endif /* X_PRIM_H */