shithub: femtolisp

ref: ea47856f32ee8063d5fe7eb3b1fe5b6094320db2
dir: /types.c/

#include "llt.h"
#include "flisp.h"
#include "cvalues.h"
#include "equalhash.h"
#include "types.h"

fltype_t *
get_type(value_t t)
{
	fltype_t *ft;
	if(issymbol(t)){
		ft = ((symbol_t*)ptr(t))->type;
		if(ft != nil)
			return ft;
	}
	void **bp = equalhash_bp(&FL(TypeTable), (void*)t);
	if(*bp != HT_NOTFOUND)
		return *bp;

	int align, isarray = iscons(t) && car_(t) == FL(arraysym) && iscons(cdr_(t));
	size_t sz;
	if(isarray && !iscons(cdr_(cdr_(t)))){
		// special case: incomplete array type
		sz = 0;
	}else{
		sz = ctype_sizeof(t, &align);
	}

	ft = calloc(1, sizeof(fltype_t));
	ft->type = t;
	ft->numtype = NONNUMERIC;
	if(issymbol(t)){
		ft->numtype = sym_to_numtype(t);
		assert(valid_numtype(ft->numtype));
		((symbol_t*)ptr(t))->type = ft;
	}
	ft->size = sz;
	ft->marked = 1;
	if(iscons(t)){
		if(isarray){
			fltype_t *eltype = get_type(car_(cdr_(t)));
			if(eltype->size == 0){
				LLT_FREE(ft);
				lerrorf(FL(ArgError), "invalid array element type");
			}
			ft->elsz = eltype->size;
			ft->eltype = eltype;
			ft->init = cvalue_array_init;
			//eltype->artype = ft; -- this is a bad idea since some types carry array sizes
		}else if(car_(t) == FL(enumsym)){
			ft->numtype = T_INT32;
			ft->init = cvalue_enum_init;
		}
	}
	*bp = ft;
	return ft;
}

fltype_t *
get_array_type(value_t eltype)
{
	fltype_t *et = get_type(eltype);
	if(et->artype == nil)
		et->artype = get_type(fl_list2(FL(arraysym), eltype));
	return et->artype;
}

fltype_t *
define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init)
{
	fltype_t *ft = calloc(1, sizeof(fltype_t));
	ft->type = sym;
	ft->numtype = NONNUMERIC;
	ft->size = sz;
	ft->vtable = vtab;
	ft->marked = 1;
	ft->init = init;
	return ft;
}

void
relocate_typetable(void)
{
	htable_t *h = &FL(TypeTable);
	size_t i;
	void *nv;
	for(i = 0; i < h->size; i += 2){
		if(h->table[i] != HT_NOTFOUND){
			nv = (void*)relocate((value_t)h->table[i]);
			h->table[i] = nv;
			if(h->table[i+1] != HT_NOTFOUND)
				((fltype_t*)h->table[i+1])->type = (value_t)nv;
		}
	}
}