root/lang/c/misc/mlisp/src/mlisp.cpp @ 5979

Revision 5979, 20.7 kB (checked in by mokehehe, 5 years ago)

コメント書き

Line 
1//=============================================================================
2///     minimal lisp
3/**
4        ���e�����F
5                ����                            ���������͂Ȃ�
6                ������`"                ��͒P�Ȃ����{��
7
8        �r���̓��\��     SExp
9                ���ʂP�r�b�g���P         �����i������1bit�A������30bit�j
10                ����YPE_BITS ��
11                        tCell                           �Z��
12                        tSymb                           �V���{��
13                        tOther                          ���̑��it, nil, �j
14                        tFunc                           �֐��i�����_ or �}�N���j
15
16        �Z���F
17                �Z���̏ꍇ�ASExp �̏��r�b�g�ŃZ���o�b�t�@��
18                �C���f�N�X�������
19
20        �֐��F
21                �֐����ʂ̓Z���Ɠ������Z������C���f�N�X�ɂȂ�Ă��āA
22                ���̃Z����car �Ɋ֐��̏��i�����_���}�N�����A
23                C�̑g�ݍ��݊֐����Z�����j�����������œ��
24                cdr �ɂ́AC�̑g�ݍ��݊֐��̏ꍇ�g�ݍ��݊֐��f�[�^�̃C���f�N�X���A
25                �Z���̏ꍇ�֐��̈��֐��{�̂����
26*/
27//=============================================================================
28
29#include "mlisp.h"
30
31#include <stdio.h>
32#include <stdlib.h>
33#include <string.h>
34#include <ctype.h>
35#include <assert.h>
36
37#ifndef FALSE
38#define FALSE           (0)
39#define TRUE            (1)
40#endif
41
42#ifndef min
43#define min(a, b)                       ((a)<(b) ? (a) : (b))
44#endif
45#ifndef max
46#define max(a, b)                       ((a)>(b) ? (a) : (b))
47#endif
48
49/// define
50#define SEXP_BITS                       (sizeof(SExp) * 8)
51#define VAL_BITS                        (SEXP_BITS - TYPE_BITS)
52
53/// macros
54#define SEXP_VAL(a)                     ((a) >> TYPE_BITS)
55#define SEXP_UVAL(a)            ((unsigned int)(a) >> TYPE_BITS)
56
57/// constant value
58#define cFail                           MAKE_SEXP(tOther, -1)
59#define cDot                            MAKE_SEXP(tOther, -2)
60#define cUndef                          MAKE_SEXP(tOther, -3)
61
62// function type
63#define FuncTypeMask            (1<<0)
64#define FuncTypeMacro           (0<<0)                  // macro
65#define FuncTypeLambda          (1<<0)                  // lambda
66
67// function category
68#define FuncCategoryMask        (1<<1)
69#define FuncCategoryBuiltin     (0<<1)                  // builtin function (C)
70#define FuncCategoryCell        (1<<1)                  // user defined (cell)
71
72
73/// cons cell
74typedef struct {
75        SExp car;
76        SExp cdr;
77        bool unreach;                   // �K�x�R���p�F�����B�t���O
78} Cell;
79
80/// builtin-function data
81typedef struct {
82        MLBuiltinFunc cfunc;
83} BuiltinFuncData;
84
85/// symbol
86typedef struct {
87        char str[32];
88        SExp sexp;
89} Symbol;
90
91
92//=============================================================================
93
94const char ERR_ILLEGAL_CHAR[] = "illegal char";
95const char ERR_STRING_NOT_TERMINATE[] = "sting not terminate";
96const char ERR_NO_CLOSE_PAREN[] = "no close paren";
97const char ERR_DOT_FIRST[] = "dot first";
98const char ERR_EMPTY_AFTER_DOT[] = "empty after dot";
99const char ERR_ILLEGAL_DOT_LIST[] = "illegal dot list";
100
101const char ERR_NOT_SYMBOL[] = "not symbol";
102const char ERR_CANT_CALL_FUNCTION[] = "cant' call function";
103const char ERR_UNDEFINED_SYMBOL[] = "undefined symbol";
104const char ERR_NOT_LAMBDA[] = "not lambda";
105
106
107//=============================================================================
108
109#define MAX_CELL                (1024)
110#define MAX_SYMBOL              (1024)
111#define MAX_STACK               (128)
112#define MAX_BUILTIN             (64)
113
114/// �R���e�L�X�g�̎��
115struct MLContext {
116        MLContext();
117        ~MLContext();
118
119        void set_flag(ML_FLAG flag, int atom);                  ///< �������O�ݒ�
120        void dump();                                                                    ///< ���o��
121
122        SExp read(FILE* fp);
123        SExp eval(SExp a);
124        void print(FILE* fp, SExp a);
125        SExp apply(SExp ca, SExp cd, bool b_eval);
126
127        SExp cons(SExp a, SExp d);                                              ///< cons
128        SExp car(SExp a);                                                               ///< car
129        SExp cdr(SExp a);                                                               ///< cdr
130        void rplaca(SExp cs, SExp a);                                   ///< car �v�f�̒u��
131        void rplacd(SExp cs, SExp d);                                   ///< cdr �v�f�̒u��
132
133        void setq(SExp symb, SExp arg_body);
134
135        const char* get_string(SExp symb);
136
137        SExp resist_builtin(const char* word, MLBuiltinFunc cfunc, bool b_macro);
138        SExp create_lambda(SExp arg_body);
139        void defmacro(SExp symb, SExp arg_body);
140
141        void syntax_error(const char* msg);
142        void runtime_error(SExp a, const char* msg);
143
144        SExp find_symbol(const char* str, const char* end, bool b_make);
145
146private:
147        void clear_all_mark();                                                  ///< ���ׂẴZ���𖢓��B�ɐݒ� void mark_cell(SExp sexp);                                              ///< �Z���Ƀ}�[�N������ċA�j
148        void collect_garbage();                                                 ///< �K�x�[�W�R���N�V����
149
150        SExp read_string(FILE* fp);
151        SExp read_list(FILE* fp);
152        SExp read_rec(FILE* fp);
153        void print_rec(FILE* fp, SExp a);
154        void print_cell(FILE* fp, SExp a);
155
156        Cell* get_cell_ptr(SExp a);
157
158        SExp alloc_symbol();
159        Symbol* get_symbol_ptr(SExp a);
160
161        SExp eval_cell(SExp a);                                                 ///< �Z���������car �̊֐��Ɏc�������ČĂяo���j
162        SExp eval_list(SExp a);                                                 ///< list �̊e�v�f������Ă�����X�g�ɂ��ĕԂ�
163        void bind_arg1(SExp symb, SExp val);
164        void bind_arg(SExp arg, SExp param);                    ///< �֐��Ăяo�����́A���o�C���h
165        void unbind_arg(SExp arg);                                              ///< �o�C���h�����ϐ����
166        void push_sexp(SExp s);                                                 ///< �r����^�b�N�ɑޔ�SExp pop_sexp();                                                            ///< ���A
167
168private:
169        int flags[numofMLF];
170
171        Cell g_cell_buf[MAX_CELL];
172        SExp g_free_cell;
173        int free_cell_num;
174
175        Symbol g_symbol_buf[MAX_SYMBOL];
176        int g_symbol_free_p;
177
178        SExp g_stack[MAX_STACK];
179        int g_stack_p;
180
181        BuiltinFuncData builtin_func_buf[MAX_BUILTIN];
182        int g_builtin_p;
183};
184
185
186//=============================================================================
187// helper functions
188
189SExp ml_int2sexp(int x)
190{
191        return (x << 1) | 1;
192}
193
194int ml_sexp2int(SExp a)
195{
196        assert(SEXP_IS_INT(a));
197        return a >> 1;
198}
199
200/// �\��
201static SExp reserved(const char* p, size_t n)
202{
203        struct {
204                const char* str;
205                SExp sexp;
206        } static tbl[] = {
207                {       "\x03nil",      cNil,   },
208                {       "\x01t",        cT,             },
209                {       "\x01.",        cDot,   },
210
211//              {       "quote",        cUndef, },
212        };
213        const int N = sizeof(tbl)/sizeof(*tbl);
214        for (int i=0; i<N; ++i) {
215                const char* s = tbl[i].str;
216                char l = *s++;
217                if (n == l && strncmp(p, s, n) == 0) {
218                        return tbl[i].sexp;
219                }
220        }
221        return cFail;
222}
223
224/// �󔒓ǂݔ��
225static int skip_space(FILE* fp)
226{
227        for (;;) {
228                int c = fgetc(fp);
229                if (c != ' ' && c != '\t') {
230                        return c;
231                }
232        }
233}
234
235/// ��œǂݔ��
236static void skip_line_comment(FILE* fp)
237{
238        for (;;) {
239                int c = fgetc(fp);
240                if (c == EOF || c == '\n')      break;
241        }
242}
243
244
245//=============================================================================
246
247MLContext::MLContext()
248{
249        memset(flags, 0x00, sizeof(flags));
250
251        g_symbol_free_p = 0;
252        g_stack_p = 0;
253        g_builtin_p = 0;
254
255        clear_all_mark();
256                // �Z������‚Ȃ��āA�t���[�Z���Ƃ���        for (int i=0; i<MAX_CELL-1; ++i) {
257                Cell* p = &g_cell_buf[i];
258                p->cdr = MAKE_SEXP(tCell, i+1);
259        }
260        Cell* p = &g_cell_buf[MAX_CELL-1];
261        p->cdr = cNil;
262        g_free_cell = MAKE_SEXP(tCell, 0);
263        free_cell_num = MAX_CELL;
264}
265
266MLContext::~MLContext()
267{
268}
269
270void MLContext::set_flag(ML_FLAG flag, int atom)
271{
272        flags[flag] = atom;
273}
274
275void MLContext::dump()
276{
277        printf("#symbol:%d\n", g_symbol_free_p);
278        for (int i=0; i<g_symbol_free_p; ++i) {
279                printf("%s,", g_symbol_buf[i].str);
280        }
281        printf("\n");
282        printf("#free cell:%d\n", free_cell_num);
283}
284
285void MLContext::syntax_error(const char* msg)
286{
287        FILE* fp = stderr;
288        fprintf(fp, "syntax error:%s\n", msg != NULL ? msg : "??");
289}
290
291void MLContext::runtime_error(SExp a, const char* msg)
292{
293        FILE* fp = stderr;
294        fprintf(fp, "runtime error:%s", msg != NULL ? msg : "??");
295        if (a != cNil) {
296                fprintf(fp, " :");
297                print(fp, a);
298        } else {
299                fprintf(fp, "\n");
300        }
301}
302
303void MLContext::clear_all_mark()
304{
305        for (int i=0; i<MAX_CELL; ++i) {
306                Cell* p = &g_cell_buf[i];
307                p->unreach = true;
308        }
309}
310
311void MLContext::mark_cell(SExp sexp)
312{
313        int type = SEXP_TYPE(sexp);
314        if (type == tCell || type == tFunc) {
315                Cell* p = get_cell_ptr(sexp);
316                if (p->unreach) {
317                        p->unreach = false;
318                        mark_cell(p->car);
319                        mark_cell(p->cdr);
320                }
321        }
322}
323
324void MLContext::collect_garbage()
325{
326        assert(!"���r���I");
327
328        clear_all_mark();
329
330                // �‹����炽�ǂ��Z���Ƀ}�[�N�����           // �O���[�o��
331        for (int i=0; i<g_symbol_free_p; ++i) {
332                Symbol* p = &g_symbol_buf[i];
333                mark_cell(p->sexp);
334        }
335                // �X�^�b�N
336        for (int i=0; i<g_stack_p; ++i) {
337                SExp sexp = g_stack[i];
338                mark_cell(sexp);
339        }
340
341                // �}�[�N�̂‚��ĂȂ��Z�����Exp free = cNil;
342        for (int i=0; i<MAX_CELL; ++i) {
343                Cell* p = &g_cell_buf[i];
344                if (p->unreach) {
345                        SExp t = MAKE_SEXP(tCell, i);
346                        Cell* p = get_cell_ptr(t);
347                        p->cdr = free;
348                        free = t;
349                        ++free_cell_num;
350                }
351        }
352        g_free_cell = free;
353}
354
355SExp MLContext::cons(SExp a, SExp d)
356{
357        if (g_free_cell == cNil) {
358                collect_garbage();
359        }
360        SExp res = g_free_cell;
361        assert(SEXP_TYPE(res) == tCell);
362        assert(free_cell_num > 0);
363        g_free_cell = cdr(res);
364        --free_cell_num;
365
366        int idx = SEXP_UVAL(res);
367
368        Cell* p = &g_cell_buf[idx];
369        assert(p->unreach);
370        p->car = a;
371        p->cdr = d;
372        p->unreach = false;
373
374        return MAKE_SEXP(tCell, idx);
375}
376
377Cell* MLContext::get_cell_ptr(SExp a)
378{
379        assert(SEXP_TYPE(a) == tCell || SEXP_TYPE(a) == tFunc);
380        return &g_cell_buf[SEXP_UVAL(a)];
381}
382
383SExp MLContext::car(SExp a)
384{
385        Cell* p = get_cell_ptr(a);
386        return p->car;
387}
388
389SExp MLContext::cdr(SExp a)
390{
391        Cell* p = get_cell_ptr(a);
392        return p->cdr;
393}
394
395void MLContext::rplaca(SExp cs, SExp a)
396{
397        Cell* p = get_cell_ptr(cs);
398        p->car = a;
399}
400
401void MLContext::rplacd(SExp cs, SExp d)
402{
403        Cell* p = get_cell_ptr(cs);
404        p->cdr = d;
405}
406
407void MLContext::setq(SExp symb, SExp a)
408{
409        if (SEXP_TYPE(symb) != tSymb) {
410                runtime_error(symb, ERR_NOT_SYMBOL);
411        } else {
412                Symbol* p = get_symbol_ptr(symb);
413                p->sexp = a;
414        }
415}
416
417const char* MLContext::get_string(SExp symb)
418{
419        const char* str = NULL;
420        if (SEXP_TYPE(symb) == tSymb || SEXP_TYPE(symb) == tStr) {
421                str = get_symbol_ptr(symb)->str;
422        }
423        return str;
424}
425
426SExp MLContext::alloc_symbol()
427{
428        assert(g_symbol_free_p < MAX_SYMBOL);
429        int idx = g_symbol_free_p++;
430        return MAKE_SEXP(tSymb, idx);
431}
432
433Symbol* MLContext::get_symbol_ptr(SExp a)
434{
435        assert(SEXP_TYPE(a) == tSymb || SEXP_TYPE(a) == tStr);
436        return &g_symbol_buf[SEXP_UVAL(a)];
437}
438
439SExp MLContext::find_symbol(const char* str, const char* end, bool b_make)
440{
441        const int MAXLEN = sizeof(((Symbol*)0)->str)-1;
442        int len;
443        if (end == NULL) {
444                len = strlen(str);
445        } else {
446                len = end - str;
447        }
448        len = min(len, MAXLEN);
449
450        // @todo�F�������Ă��ƌ��Ȃ��ɂ���  for (int i=0; i<g_symbol_free_p; ++i) {
451                Symbol* p = &g_symbol_buf[i];
452                int l = strlen(p->str);
453                if (l == len && strncmp(str, p->str, l) == 0) {
454                        return MAKE_SEXP(tSymb, i);
455                }
456        }
457        // ���‚����������
458
459        if (b_make) {
460                SExp a = alloc_symbol();
461                Symbol* p = get_symbol_ptr(a);
462                p->sexp = cUndef;
463                memcpy(p->str, str, len);
464                p->str[len] = '\0';
465                return a;
466        }
467
468        return cFail;
469}
470
471SExp MLContext::resist_builtin(const char* word, MLBuiltinFunc cfunc, bool b_macro)
472{
473        assert(g_builtin_p < MAX_BUILTIN);
474        int idx = g_builtin_p++;
475        BuiltinFuncData* p = &builtin_func_buf[idx];
476        p->cfunc = cfunc;
477
478        int info;
479        if (b_macro)    info = FuncTypeMacro;
480        else                    info = FuncTypeLambda;
481        info |= FuncCategoryBuiltin;
482        SExp cell = cons(ml_int2sexp(info), ml_int2sexp(idx));
483        SExp fn = MAKE_SEXP(tFunc, SEXP_UVAL(cell));
484
485        SExp symb = find_symbol(word, NULL, true);
486        setq(symb, fn);
487        return symb;
488}
489
490SExp MLContext::create_lambda(SExp arg_body)
491{
492        int info = FuncTypeLambda | FuncCategoryCell;
493        SExp fn = cons(ml_int2sexp(info), arg_body);
494        return MAKE_SEXP(tFunc, SEXP_UVAL(fn));
495}
496
497void MLContext::defmacro(SExp symb, SExp arg_body)
498{
499        int info = FuncTypeMacro | FuncCategoryCell;
500        SExp fn = cons(ml_int2sexp(info), arg_body);
501        setq(symb, MAKE_SEXP(tFunc, SEXP_UVAL(fn)));
502}
503
504/// ������ǂݍ���
505/**
506        "..." ��ݍ��������Ԃ�
507*/
508SExp MLContext::read_string(FILE* fp)
509{
510        char str[256];
511        int c;
512        char* q = str;
513        for (; c = fgetc(fp), c != '"'; ) {
514                if (c == EOF) {
515                        syntax_error(ERR_STRING_NOT_TERMINATE);
516                        break;
517                }
518                if (c == '\\') {
519                        c = fgetc(fp);
520                        switch (c) {
521                        default:        break;
522                        case 't':       c = '\t';       break;
523                        case 'n':       c = '\n';       break;
524                        case '0':       c = '\0';       break;
525                        }
526                }
527                *q++ = c;
528        }
529        assert(q - str < sizeof(str));
530        *q = '\0';
531
532        SExp a = find_symbol(str, q, true);
533        return MAKE_SEXP(tStr, SEXP_UVAL(a));
534}
535
536/// ���X�g�̓ǂݍ���
537/**
538        (...) ��ݍ�����X�g���
539*/
540SExp MLContext::read_list(FILE* fp)
541{
542        SExp a;
543        SExp top = cNil, tail = cNil;
544        for (;;) {
545                a = read_rec(fp);
546                if (a == cFail || a == cEOF)    return top;
547                if (a == cNL)   continue;
548                if (a == cDot)  break;
549
550                SExp cd = cons(a, cNil);
551                if (top == cNil) {
552                        top = cd;
553                } else {
554                        rplacd(tail, cd);
555                }
556                tail = cd;
557        }
558
559        // dot appear
560        do {
561                a = read_rec(fp);
562        } while (a == cNL);
563        if (a == cFail || a == cEOF) {
564                // ERR: (x .)
565                syntax_error(ERR_EMPTY_AFTER_DOT);
566        } else {
567                bool err = false;
568                if (top == cNil) {
569                        // ERR: (. x)
570                        syntax_error(ERR_DOT_FIRST);
571                        err = true;
572                } else {
573                        rplacd(tail, a);
574                }
575
576                bool err2 = false;
577                for (; a=read_rec(fp), a != cFail && a != cEOF; ) {
578                        if (a != cNL)   err2 = true;
579                }
580                if (err2 && !err) {
581                        // ERR: (x . y z)
582                        syntax_error(ERR_ILLEGAL_DOT_LIST);
583                }
584        }
585
586        return top;
587}
588
589/// �ċA�ǂݍ���
590/**
591        �ǂݍ��݂̐擪
592*/
593SExp MLContext::read_rec(FILE* fp)
594{
595        int c;
596
597        for (;;) {
598                c = skip_space(fp);
599                if (c == EOF)   return cEOF;
600                if (c == '\n')  return cNL;
601
602                if (c == ';') {
603                        skip_line_comment(fp);
604                        continue;
605                }
606                break;
607        }
608
609        switch (c) {
610        case '(':
611                {
612                        SExp a = read_list(fp);
613
614                        // close paren
615                        int c = fgetc(fp);
616                        if (c != ')') {
617                                ungetc(c, fp);
618                                syntax_error(ERR_NO_CLOSE_PAREN);
619                        }
620
621                        return a;
622                }
623        case '\'':
624                {
625                        SExp a = read_rec(fp);
626                        return cons(find_symbol("quote", NULL, true), cons(a, cNil));
627                }
628        case '`':
629                {
630                        SExp a = read_rec(fp);
631                        return cons(find_symbol("quasiquote", NULL, true), cons(a, cNil));
632                }
633        case ',':
634                {
635                        SExp fn;
636                        c = fgetc(fp);
637                        if (c != '@') {
638                                ungetc(c, fp);
639                                fn = find_symbol("unquote", NULL, true);
640                        } else {
641                                fn = find_symbol("unquote-splicing", NULL, true);
642                        }
643                        SExp a = read_rec(fp);
644                        return cons(fn, cons(a, cNil));
645                }
646        case '"':
647                return read_string(fp);
648        }
649
650        {
651                char symb[256];
652                char* q = symb;
653                // search delimiter
654                int bDigit = TRUE;
655                // scheme �Ŏ��ʎq�Ɏg���镶���F !$%&*+-./:<=>?@^_~
656                for (; c != EOF && strchr(" \t\n()'@,#[]{}|", c) == NULL; *q++ = c, c = fgetc(fp)) {
657                        if (!isdigit(c))        bDigit = FALSE;
658                }
659                assert(q - symb < sizeof(symb));
660                ungetc(c, fp);
661                *q = '\0';
662                if (q == symb) {
663                        return cFail;
664                } else if (bDigit) {
665                        int x = atoi(symb);
666                        return ml_int2sexp(x);
667                } else {
668                        SExp a = reserved(symb, q-symb);
669                        if (a == cFail) {
670                                a = find_symbol(symb, q, true);
671                        }
672                        return a;
673                }
674        }
675}
676
677SExp MLContext::read(FILE* fp)
678{
679        SExp s = read_rec(fp);
680        if (s == cFail) {
681                int c = fgetc(fp);              // �ǂݍ��ݎ��s�ɂȂ��������ݎ̂Ă�             syntax_error(ERR_ILLEGAL_CHAR);
682        }
683        return s;
684}
685
686/// �l�̕]��
687SExp MLContext::eval(SExp a)
688{
689        if (SEXP_IS_INT(a)) {
690                return a;
691        }
692
693        switch (SEXP_TYPE(a)) {
694        default:        assert(false);  return cNil;
695        case tCell:
696                {
697                        SExp ca = car(a);
698                        SExp cd = cdr(a);
699                        return apply(ca, cd, true);
700                }
701                break;
702        case tOther:
703        case tFunc:
704        case tStr:
705                return a;
706        case tSymb:
707                {
708                        Symbol* p = get_symbol_ptr(a);
709                        SExp s = p->sexp;
710                        if (s == cUndef) {
711                                runtime_error(a, ERR_UNDEFINED_SYMBOL);
712                                return cNil;
713                        }
714                        return s;
715                }
716                break;
717        }
718}
719
720/// �֐��E�}�N���K�p
721SExp MLContext::apply(SExp ca, SExp cd, bool b_eval)
722{
723        SExp fn = eval(ca);
724
725        if (SEXP_TYPE(fn) != tFunc) {
726                runtime_error(ca, ERR_CANT_CALL_FUNCTION);
727                return cNil;
728        }
729
730
731        // apply
732
733        SExp param = cd;
734
735        int info = ml_sexp2int(car(fn));
736        int type = info & FuncTypeMask;
737        int category = info & FuncCategoryMask;
738
739        if (type == FuncTypeLambda && b_eval) {
740                param = eval_list(param);
741        }
742
743        switch (category) {
744        default:        assert(false);  return cNil;
745        case FuncCategoryBuiltin:
746                {
747                        int idx = ml_sexp2int(cdr(fn));
748                        BuiltinFuncData* p = &builtin_func_buf[idx];
749                        return p->cfunc(this, param);
750                }
751                break;
752        case FuncCategoryCell:
753                {
754                        SExp cd = cdr(fn);
755                        SExp arg = car(cd);
756                        SExp body = car(cdr(cd));
757
758                        if (flags[MLF_PRINT_FUNC_ARG]) {
759                                print(stdout, param);
760                        }
761                        bind_arg(arg, param);
762
763                        if (type == FuncTypeMacro) {
764                                SExp replace = eval(body);
765                                if (flags[MLF_PRINT_MACRO_REPLACE]) {
766                                        print(stdout, replace);
767                                }
768                                body = replace;
769                        }
770
771                        SExp res = eval(body);
772
773                        unbind_arg(arg);
774
775                        return res;
776                }
777                break;
778        }
779}
780
781/**
782        ���X�g�̊e�v�f������ĐV�������X�g���*/
783SExp MLContext::eval_list(SExp a)
784{
785        SExp top = cNil, tail = cNil;
786        SExp p;
787        for (p=a; SEXP_CONSP(p); p=cdr(p)) {
788                SExp ca = car(p);
789                SExp cd = cons(eval(ca), cNil);
790                if (top == cNil) {
791                        top = cd;
792                } else {
793                        rplacd(tail, cd);
794                }
795                tail = cd;
796        }
797        if (p != cNil) {
798                rplacd(tail, eval(p));
799        }
800        return top;
801}
802
803void MLContext::push_sexp(SExp s)
804{
805        assert(g_stack_p < MAX_STACK);
806        g_stack[g_stack_p++] = s;
807}
808
809SExp MLContext::pop_sexp()
810{
811        assert(g_stack_p > 0);
812        return g_stack[--g_stack_p];
813}
814
815void MLContext::bind_arg1(SExp symb, SExp val)
816{
817        Symbol* p = get_symbol_ptr(symb);
818        push_sexp(p->sexp);
819
820        p->sexp = val;
821
822        if (flags[MLF_PRINT_FUNC_ARG]) {
823                printf("bind ");
824                print_rec(stdout, symb);
825                printf(":");
826                print(stdout, val);
827        }
828}
829
830void MLContext::bind_arg(SExp arg, SExp param)
831{
832        for (; SEXP_CONSP(arg); arg = cdr(arg)) {
833                SExp symb = car(arg);
834                if (symb == cNil)       continue;
835
836                SExp nxt = cNil;
837                SExp val = param;
838                if (SEXP_CONSP(param)) {
839                        val = car(param);
840                        nxt = cdr(param);
841                }
842                bind_arg1(symb, val);
843
844                param = nxt;
845        }
846
847        if (arg != cNil) {
848                bind_arg1(arg, param);
849        }
850}
851
852void MLContext::unbind_arg(SExp arg)
853{
854        SExp a;
855        if (SEXP_TYPE(arg) == tCell) {
856                unbind_arg(cdr(arg));
857                a = car(arg);
858        } else {
859                a = arg;
860        }
861
862        if (SEXP_TYPE(a) == tSymb) {
863                Symbol* p = get_symbol_ptr(a);
864                p->sexp = pop_sexp();
865        }
866}
867
868/// �o��
869void MLContext::print_rec(FILE* fp, SExp a)
870{
871        if (SEXP_IS_INT(a)) {
872                fprintf(fp, "%d", ml_sexp2int(a));
873                return;
874        }
875
876        switch (SEXP_TYPE(a)) {
877        default:        assert(false);  break;
878        case tOther:
879                switch (a) {
880                default:        /*assert(false);*/      break;
881                case cNil:      fprintf(fp, "nil");     break;
882                case cT:        fprintf(fp, "t");       break;
883                }
884                break;
885        case tSymb:
886                {
887                        Symbol* p = get_symbol_ptr(a);
888                        fprintf(fp, "%s", p->str);
889                }
890                break;
891        case tStr:
892                {
893                        Symbol* p = get_symbol_ptr(a);
894                        fprintf(fp, "\"%s\"", p->str);
895                }
896                break;
897        case tCell:
898                print_cell(fp, a);
899                break;
900        case tFunc:
901                {
902                        SExp fn = a;
903                        int info = ml_sexp2int(car(fn));
904                        int type = info & FuncTypeMask;
905                        int category = info & FuncCategoryMask;
906
907                        switch (type) {
908                        default:        assert(false);  break;
909                        case FuncTypeMacro:             fprintf(fp, "#<macro: >");      break;
910                        case FuncTypeLambda:    fprintf(fp, "#<lambda: >");     break;
911                        }
912                }
913                break;
914        }
915}
916
917/// �Z���̏o��
918/**
919        (a b c . d)
920*/
921void MLContext::print_cell(FILE* fp, SExp a)
922{
923        fprintf(fp, "(");
924        for (int idx=0; a != cNil; ++idx) {
925                if (idx != 0)   fprintf(fp, " ");
926
927                SExp ca;
928                if (SEXP_TYPE(a) != tCell) {
929                        fprintf(fp, ". ");
930                        ca = a;
931                        a = cNil;
932                } else {
933                        Cell* p = get_cell_ptr(a);
934                        ca = p->car;
935                        a = p->cdr;
936                }
937                print_rec(fp, ca);
938        }
939        fprintf(fp, ")");
940}
941
942void MLContext::print(FILE* fp, SExp a)
943{
944        print_rec(fp, a);
945        printf("\n");
946}
947
948
949//=============================================================================
950
951MLContext* ml_new(void)                                                                                         { return new MLContext; }
952void ml_delete(MLContext* ml)                                                                           { delete ml; }
953
954void ml_set_flag(MLContext* ml, ML_FLAG flag, int atom)                         { return ml->set_flag(flag, atom); }
955
956void ml_dump(MLContext* ml)                                                                                     { ml->dump(); }
957
958
959SExp ml_read(MLContext* ml, FILE* fp)                                                           { return ml->read(fp); }
960SExp ml_eval(MLContext* ml, SExp a)                                                                     { return ml->eval(a); }
961void ml_print(MLContext* ml, FILE* fp, SExp a)                                          { ml->print(fp, a); }
962SExp ml_apply(MLContext* ml, SExp ca, SExp cd)                                          { return ml->apply(ca, cd, false); }
963
964SExp ml_resist_builtin(MLContext* ml, const char* word, MLBuiltinFunc cfunc, int b_macro)               { return ml->resist_builtin(word, cfunc, b_macro != FALSE); }
965SExp ml_create_lambda(MLContext* ml, SExp arg_body)     { return ml->create_lambda(arg_body); }
966void ml_defmacro(MLContext* ml, SExp symb, SExp arg_body)                       { ml->defmacro(symb, arg_body); }
967
968void ml_runtime_error(MLContext* ml, SExp a, const char* msg)           { ml->runtime_error(a, msg); }
969
970
971SExp ml_cons(MLContext* ml, SExp a, SExp d)                                                     { return ml->cons(a, d); }
972SExp ml_car(MLContext* ml, SExp a)                                                                      { return ml->car(a); }
973SExp ml_cdr(MLContext* ml, SExp a)                                                                      { return ml->cdr(a); }
974void ml_rplacd(MLContext* ml, SExp a, SExp d)                                           { ml->rplacd(a, d); }
975
976void ml_setq(MLContext* ml, SExp symb, SExp arg_body)                           { ml->setq(symb, arg_body); }
977SExp ml_find_symbol(MLContext* ml, const char* str, const char* end, int b_make)        { return ml->find_symbol(str, end, b_make != FALSE); }
978
979const char* ml_get_string(MLContext* ml, SExp symb)                                     { return ml->get_string(symb); }
980
Note: See TracBrowser for help on using the browser.