root/lang/c/misc/mlisp/core/sexp.cpp @ 11750

//=============================================================================
///     S ������/**
        mallloc �Ŋm�ۂ����A�h���X�͂S�̔{���Ɖ���*/
//=============================================================================

#include "sexp.h"
#include "s_hash.h"
#include "inner.h"
#include <stdio.h>
#include <string.h>
#include <stdarg.h>

/// �G���[
static const char* errmsg[] = {
        "illegal char: %c",
        "string not terminate",
        "no close paren",
        "dot first",
        "empty after dot",
        "illegal dot list",

        "type required: %s",
        "undefined symbol",
        "unexpected",
};

/// �^���������tatic const char* TypeStrTbl[] = {
        "integer",
        "cons",
        "symbol",
        "string",
        "procedure",
};


/// �A���P�[�^
typedef void* (*SGCAllocFunc)(size_t, int);
class SAllocator {
        SGCAllocFunc allocator;
public:
        void set(SGCAllocFunc f) { allocator = f; }
        void* alloc(size_t size, bool b_atomic) { return allocator(size, b_atomic); }
};


template <int N>
struct SizedSymbol : public Symbol {
        char buf[N];            // Symbol �ŁAchar [1] ���̗̈悪���Ă����ŁA'\0'�̕��͊܂߂�����������������ł悢�B
};

SizedSymbol<3> symNil;
SizedSymbol<1> symT;

const SExp nil = {
        (sint)&symNil,
};

const SExp t = {
        (sint)&symT,
};

static void init_const(void) {
        symNil.type = tSymb;
        strcpy(symNil.str, "nil");
        symT.type = tSymb;
        strcpy(symT.str, "t");
}

SType type_of(SExp s) {
        switch (s.i & 3) {
        case 1: case 3:                 // �ʼn��ʃr�b�g���P�F����
                return tInt;
        case 2:                                 // �Q�F�萔
                break;
        case 0:                                 // �S�̔{���F�|�C���^
//              return s.ptr->type;
                return s.ptr->base.type;
        }
        return tUnknown;
}

const char* s2str(SExp s) {
        type_check(s, tStr);
        String* str = (String*)s.ptr;
        return str->str;
}


//=============================================================================

/// �V���{���e�[�u��
class SymbolTable {
        struct StrCmp {
                bool operator()(const char* a, const char* b) const { return strcmp(a, b) < 0; }
        };
        typedef SHash<const char*, SExp, StrCmp> Container;
        Container buf;

public:
        /// �T��
        const SExp* find(const char* str) {
                Container::iterator it = buf.find(str);
                if (it != buf.end()) {
                        return &(it->second);
                } else {
                        return NULL;
                }
        }

        /// �lj�
        void add(SExp symbol) {
                assert(type_of(symbol) == tSymb);
                Symbol* p = (Symbol*)symbol.ptr;
                buf[p->str] = symbol;
        }

        /// �N���A
        void clear() {
                buf.clear();
        }
};


//=============================================================================

static const SVTable* vtbl;
static SAllocator s_allocator;
static SymbolTable symbol_table;


void* salloc(size_t size, int b_atomic) {
        return s_allocator.alloc(size, b_atomic != FALSE);
}


static void close(void) {
        symbol_table.clear();
}

static void init(const SVTable* vtbl_) {
        close();

        vtbl = vtbl_;
        s_allocator.set(vtbl_->gcmalloc);

        init_const();

        symbol_table.add(nil);
        symbol_table.add(t);
}

void error(int errid, ...) {
        va_list ap;
        va_start(ap, errid);
        char buf[256];
        vsprintf(buf, errmsg[errid-1], ap);
        va_end(ap);

        if (vtbl->error != NULL) {
                (*vtbl->error)(buf);
        } else {
                exit(errid);
        }
}

void reset_error(void) {
}

int type_check(SExp s, SType type) {
        if (type_of(s) != type) {
                error(ERR_TYPE_REQUIRED, TypeStrTbl[type]);
                return FALSE;
        } else {
                return TRUE;
        }
}


SExp cons(SExp a, SExp d) {
        Cell* p = (Cell*)salloc(sizeof(Cell), FALSE);
        p->type = tCell;
        p->car = a;
        p->cdr = d;

        SExp s;
        s.ptr = (SExpExtU*)p;
        return s;
}

SExp car(SExp s) {
        if (!type_check(s, tCell))      return s;

        Cell* cell = (Cell*)s.ptr;
        return cell->car;
}

SExp cdr(SExp s) {
        if (!type_check(s, tCell))      return s;

        Cell* cell = (Cell*)s.ptr;
        return cell->cdr;
}

void rplaca(SExp s, SExp a) {
        if (!type_check(s, tCell))      return;

        Cell* cell = (Cell*)s.ptr;
        cell->car = a;
}

void rplacd(SExp s, SExp d) {
        if (!type_check(s, tCell))      return;

        Cell* cell = (Cell*)s.ptr;
        cell->cdr = d;
}

SExp intern(const char* str) {
        const SExp* ps = symbol_table.find(str);
        if (ps != NULL) {
                return *ps;
        } else {
                int l = strlen(str);
                Symbol* p = (Symbol*)salloc(sizeof(Symbol) + l, TRUE);
                p->type = tSymb;
                memcpy(p->str, str, l);
                p->str[l] = '\0';

                SExp s;
                s.ptr = (SExpExtU*)p;
                symbol_table.add(s);
                return s;
        }
}

SExp gen_str(const char* str) {
        String* p = (String*)salloc(sizeof(String), FALSE);
        p->type = tStr;
        int l = strlen(str);
        p->str = (char*)salloc(l + 1, TRUE);
        memcpy(p->str, str, l);
        p->str[l] = '\0';

        SExp s;
        s.ptr = (SExpExtU*)p;
        return s;
}


SExp gen_cfunc(SCFunc cfunc, int minnarg, int maxnarg) {
        const bool b_macro = false;
        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
        p->type = tProc;
        p->flag = Procedure::Builtin | (b_macro ? Procedure::Macro : Procedure::Lambda);
        p->u.cfunc = cfunc;
        p->minnarg = minnarg;
        p->maxnarg = maxnarg;

        SExp s;
        s.ptr = (SExpExtU*)p;

        return s;
}

SExp gen_cmacro(SCFuncM mfunc, int minnarg, int maxnarg) {
        const bool b_macro = true;
        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
        p->type = tProc;
        p->flag = Procedure::Builtin | (b_macro ? Procedure::Macro : Procedure::Lambda);
        p->u.mfunc = mfunc;
        p->minnarg = minnarg;
        p->maxnarg = maxnarg;

        SExp s;
        s.ptr = (SExpExtU*)p;

        return s;
}


SExp gen_closure(SExp body, SExp env, int minnarg, int maxnarg) {
        const bool b_macro = false;
        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
        p->type = tProc;
        p->flag = Procedure::Cell | (b_macro ? Procedure::Macro : Procedure::Lambda);
        p->u.cell.s = body;
        p->u.cell.e = env;
        p->minnarg = minnarg;
        p->maxnarg = maxnarg;

        SExp s;
        s.ptr = (SExpExtU*)p;

        return s;
}


SExp gen_macro(SExp body, int minnarg, int maxnarg) {
        const bool b_macro = true;
        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
        p->type = tProc;
        p->flag = Procedure::Cell | (b_macro ? Procedure::Macro : Procedure::Lambda);
        p->u.cell.s = body;
        p->u.cell.e = nil;
        p->minnarg = minnarg;
        p->maxnarg = maxnarg;

        SExp s;
        s.ptr = (SExpExtU*)p;

        return s;
}

//=============================================================================

void sexp_new(const SVTable* vtbl) {
        init(vtbl);
}

void sexp_delete(void) {
        close();
}