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

Revision 5814, 20.0 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, bool b_cell);
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_symbol_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 make_symbol(const char* str, const char* end);
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        SExp find_symbol(const char* str, const char* end);
161
162        SExp eval_cell(SExp a);                                                 ///< �Z���������car �̊֐��Ɏc�������ČĂяo���j
163        SExp eval_list(SExp a);                                                 ///< list �̊e�v�f������Ă�����X�g�ɂ��ĕԂ�
164        void bind_arg1(SExp symb, SExp val);
165        void bind_arg(SExp arg, SExp param);                    ///< �֐��Ăяo�����́A���o�C���h
166        void unbind_arg(SExp arg);                                              ///< �o�C���h�����ϐ����
167        void push_sexp(SExp s);                                                 ///< �r����^�b�N�ɑޔ�SExp pop_sexp();                                                            ///< ���A
168
169private:
170        int flags[numofMLF];
171
172        Cell g_cell_buf[MAX_CELL];
173        SExp g_free_cell;
174        int free_cell_num;
175
176        Symbol g_symbol_buf[MAX_SYMBOL];
177        int g_symbol_free_p;
178
179        SExp g_stack[MAX_STACK];
180        int g_stack_p;
181
182        BuiltinFuncData builtin_func_buf[MAX_BUILTIN];
183        int g_builtin_p;
184};
185
186
187//=============================================================================
188// helper functions
189
190SExp ml_int2sexp(int x)
191{
192        return (x << 1) | 1;
193}
194
195int ml_sexp2int(SExp a)
196{
197        assert(SEXP_IS_INT(a));
198        return a >> 1;
199}
200
201/// �\��
202static SExp reserved(const char* p, size_t n)
203{
204        struct {
205                const char* str;
206                SExp sexp;
207        } static tbl[] = {
208                {       "\x03nil",      cNil,   },
209                {       "\x01t",        cT,             },
210                {       "\x01.",        cDot,   },
211
212//              {       "quote",        cUndef, },
213        };
214        const int N = sizeof(tbl)/sizeof(*tbl);
215        for (int i=0; i<N; ++i) {
216                const char* s = tbl[i].str;
217                char l = *s++;
218                if (n == l && strncmp(p, s, n) == 0) {
219                        return tbl[i].sexp;
220                }
221        }
222        return cFail;
223}
224
225/// �󔒓ǂݔ��
226static int skip_space(FILE* fp)
227{
228        for (;;) {
229                int c = fgetc(fp);
230                if (c != ' ' && c != '\t') {
231                        return c;
232                }
233        }
234}
235
236/// ��œǂݔ��
237static void skip_line_comment(FILE* fp)
238{
239        for (;;) {
240                int c = fgetc(fp);
241                if (c == EOF || c == '\n')      break;
242        }
243}
244
245
246//=============================================================================
247
248MLContext::MLContext()
249{
250        memset(flags, 0x00, sizeof(flags));
251
252        g_symbol_free_p = 0;
253        g_stack_p = 0;
254        g_builtin_p = 0;
255
256        clear_all_mark();
257                // �Z������‚Ȃ��āA�t���[�Z���Ƃ���        for (int i=0; i<MAX_CELL-1; ++i) {
258                Cell* p = &g_cell_buf[i];
259                p->cdr = MAKE_SEXP(tCell, i+1);
260        }
261        Cell* p = &g_cell_buf[MAX_CELL-1];
262        p->cdr = cNil;
263        g_free_cell = MAKE_SEXP(tCell, 0);
264        free_cell_num = MAX_CELL;
265}
266
267MLContext::~MLContext()
268{
269}
270
271void MLContext::set_flag(ML_FLAG flag, int atom)
272{
273        flags[flag] = atom;
274}
275
276void MLContext::dump()
277{
278        printf("#symbol:%d\n", g_symbol_free_p);
279        for (int i=0; i<g_symbol_free_p; ++i) {
280                printf("%s,", g_symbol_buf[i].str);
281        }
282        printf("\n");
283        printf("#free cell:%d\n", free_cell_num);
284}
285
286void MLContext::syntax_error(const char* msg)
287{
288        FILE* fp = stderr;
289        fprintf(fp, "syntax error:%s\n", msg != NULL ? msg : "??");
290}
291
292void MLContext::runtime_error(SExp a, const char* msg)
293{
294        FILE* fp = stderr;
295        fprintf(fp, "runtime error:%s", msg != NULL ? msg : "??");
296        if (a != cNil) {
297                fprintf(fp, " :");
298                print(fp, a, false);
299        } else {
300                fprintf(fp, "\n");
301        }
302}
303
304void MLContext::clear_all_mark()
305{
306        for (int i=0; i<MAX_CELL; ++i) {
307                Cell* p = &g_cell_buf[i];
308                p->unreach = true;
309        }
310}
311
312void MLContext::mark_cell(SExp sexp)
313{
314        int type = SEXP_TYPE(sexp);
315        if (type == tCell || type == tFunc) {
316                Cell* p = get_cell_ptr(sexp);
317                if (p->unreach) {
318                        p->unreach = false;
319                        mark_cell(p->car);
320                        mark_cell(p->cdr);
321                }
322        }
323}
324
325void MLContext::collect_garbage()
326{
327        assert(!"���r���I");
328
329        clear_all_mark();
330
331                // �‹����炽�ǂ��Z���Ƀ}�[�N�����           // �O���[�o��
332        for (int i=0; i<g_symbol_free_p; ++i) {
333                Symbol* p = &g_symbol_buf[i];
334                mark_cell(p->sexp);
335        }
336                // �X�^�b�N
337        for (int i=0; i<g_stack_p; ++i) {
338                SExp sexp = g_stack[i];
339                mark_cell(sexp);
340        }
341
342                // �}�[�N�̂‚��ĂȂ��Z�����Exp free = cNil;
343        for (int i=0; i<MAX_CELL; ++i) {
344                Cell* p = &g_cell_buf[i];
345                if (p->unreach) {
346                        SExp t = MAKE_SEXP(tCell, i);
347                        Cell* p = get_cell_ptr(t);
348                        p->cdr = free;
349                        free = t;
350                        ++free_cell_num;
351                }
352        }
353        g_free_cell = free;
354}
355
356SExp MLContext::cons(SExp a, SExp d)
357{
358        if (g_free_cell == cNil) {
359                collect_garbage();
360        }
361        SExp res = g_free_cell;
362        assert(SEXP_TYPE(res) == tCell);
363        assert(free_cell_num > 0);
364        g_free_cell = cdr(res);
365        --free_cell_num;
366
367        int idx = SEXP_UVAL(res);
368
369        Cell* p = &g_cell_buf[idx];
370        assert(p->unreach);
371        p->car = a;
372        p->cdr = d;
373        p->unreach = false;
374
375        return MAKE_SEXP(tCell, idx);
376}
377
378Cell* MLContext::get_cell_ptr(SExp a)
379{
380        assert(SEXP_TYPE(a) == tCell || SEXP_TYPE(a) == tFunc);
381        return &g_cell_buf[SEXP_UVAL(a)];
382}
383
384SExp MLContext::car(SExp a)
385{
386        Cell* p = get_cell_ptr(a);
387        return p->car;
388}
389
390SExp MLContext::cdr(SExp a)
391{
392        Cell* p = get_cell_ptr(a);
393        return p->cdr;
394}
395
396void MLContext::rplaca(SExp cs, SExp a)
397{
398        Cell* p = get_cell_ptr(cs);
399        p->car = a;
400}
401
402void MLContext::rplacd(SExp cs, SExp d)
403{
404        Cell* p = get_cell_ptr(cs);
405        p->cdr = d;
406}
407
408void MLContext::setq(SExp symb, SExp a)
409{
410        if (SEXP_TYPE(symb) != tSymb) {
411                runtime_error(symb, ERR_NOT_SYMBOL);
412        } else {
413                Symbol* p = get_symbol_ptr(symb);
414                p->sexp = a;
415        }
416}
417
418const char* MLContext::get_symbol_string(SExp symb)
419{
420        const char* str = NULL;
421        if (SEXP_TYPE(symb) == tSymb) {
422                str = get_symbol_ptr(symb)->str;
423        }
424        return str;
425}
426
427SExp MLContext::alloc_symbol()
428{
429        assert(g_symbol_free_p < MAX_SYMBOL);
430        int idx = g_symbol_free_p++;
431        return MAKE_SEXP(tSymb, idx);
432}
433
434Symbol* MLContext::get_symbol_ptr(SExp a)
435{
436        assert(SEXP_TYPE(a) == tSymb);
437        return &g_symbol_buf[SEXP_UVAL(a)];
438}
439
440SExp MLContext::find_symbol(const char* str, const char* end)
441{
442        int len;
443        if (end == NULL) {
444                len = strlen(str);
445        } else {
446                len = end - str;
447        }
448
449        // @todo�F�������Ă��ƌ��Ȃ��ɂ���  for (int i=0; i<g_symbol_free_p; ++i) {
450                Symbol* p = &g_symbol_buf[i];
451                int l = strlen(p->str);
452                if (l == len && strncmp(str, p->str, l) == 0) {
453                        return MAKE_SEXP(tSymb, i);
454                }
455        }
456        return cFail;
457}
458
459SExp MLContext::make_symbol(const char* str, const char* end)
460{
461        SExp a;
462        a = find_symbol(str, end);
463        if (a == cFail) {
464                a = alloc_symbol();
465                Symbol* p = get_symbol_ptr(a);
466                p->sexp = cUndef;
467                if (end == NULL) {
468                        strncpy(p->str, str, sizeof(p->str)-1);
469                } else {
470                        const int MAX = sizeof(p->str)-1;
471                        int len = end - str;
472                        len = min(len, MAX);
473                        strncpy(p->str, str, len);
474                        p->str[len] = '\0';
475                }
476        }
477        return a;
478}
479
480SExp MLContext::resist_builtin(const char* word, MLBuiltinFunc cfunc, bool b_macro)
481{
482        assert(g_builtin_p < MAX_BUILTIN);
483        int idx = g_builtin_p++;
484        BuiltinFuncData* p = &builtin_func_buf[idx];
485        p->cfunc = cfunc;
486
487        int info;
488        if (b_macro)    info = FuncTypeMacro;
489        else                    info = FuncTypeLambda;
490        info |= FuncCategoryBuiltin;
491        SExp cell = cons(ml_int2sexp(info), ml_int2sexp(idx));
492        SExp fn = MAKE_SEXP(tFunc, SEXP_UVAL(cell));
493
494        SExp symb = make_symbol(word, NULL);
495        setq(symb, fn);
496        return symb;
497}
498
499SExp MLContext::create_lambda(SExp arg_body)
500{
501        int info = FuncTypeLambda | FuncCategoryCell;
502        SExp fn = cons(ml_int2sexp(info), arg_body);
503        return MAKE_SEXP(tFunc, SEXP_UVAL(fn));
504}
505
506void MLContext::defmacro(SExp symb, SExp arg_body)
507{
508        int info = FuncTypeMacro | FuncCategoryCell;
509        SExp fn = cons(ml_int2sexp(info), arg_body);
510        setq(symb, MAKE_SEXP(tFunc, SEXP_UVAL(fn)));
511}
512
513SExp MLContext::read_string(FILE* fp)
514{
515        char str[256];
516        int c;
517        char* q = str;
518        for (; c = fgetc(fp), c != '"'; ) {
519                if (c == EOF) {
520                        syntax_error(ERR_STRING_NOT_TERMINATE);
521                        break;
522                }
523                if (c == '\\') {
524                        c = fgetc(fp);
525                        switch (c) {
526                        default:        break;
527                        case 't':       c = '\t';       break;
528                        case 'n':       c = '\n';       break;
529                        case '0':       c = '\0';       break;
530                        }
531                }
532                *q++ = c;
533        }
534        assert(q - str < sizeof(str));
535        *q = '\0';
536
537        SExp a = make_symbol(str, q);
538        return cons(find_symbol("quote", NULL), cons(a, cNil));
539}
540
541SExp MLContext::read_list(FILE* fp)
542{
543        SExp a;
544        SExp top = cNil, tail = cNil;
545        for (;;) {
546                a = read_rec(fp);
547                if (a == cFail || a == cEOF)    return top;
548                if (a == cNL)   continue;
549                if (a == cDot)  break;
550
551                SExp cd = cons(a, cNil);
552                if (top == cNil) {
553                        top = cd;
554                } else {
555                        rplacd(tail, cd);
556                }
557                tail = cd;
558        }
559
560        // dot appear
561        do {
562                a = read_rec(fp);
563        } while (a == cNL);
564        if (a == cFail || a == cEOF) {
565                // ERR: (x .)
566                syntax_error(ERR_EMPTY_AFTER_DOT);
567        } else {
568                bool err = false;
569                if (top == cNil) {
570                        // ERR: (. x)
571                        syntax_error(ERR_DOT_FIRST);
572                        err = true;
573                } else {
574                        rplacd(tail, a);
575                }
576
577                bool err2 = false;
578                for (; a=read_rec(fp), a != cFail && a != cEOF; ) {
579                        if (a != cNL)   err2 = true;
580                }
581                if (err2 && !err) {
582                        // ERR: (x . y z)
583                        syntax_error(ERR_ILLEGAL_DOT_LIST);
584                }
585        }
586
587        return top;
588}
589
590SExp MLContext::read_rec(FILE* fp)
591{
592        int c;
593
594        for (;;) {
595                c = skip_space(fp);
596                if (c == EOF)   return cEOF;
597                if (c == '\n')  return cNL;
598
599                if (c == ';') {
600                        skip_line_comment(fp);
601                        continue;
602                }
603                break;
604        }
605
606        switch (c) {
607        case '(':
608                {
609                        SExp a = read_list(fp);
610       
611                        // close paren
612                        int c = fgetc(fp);
613                        if (c != ')') {
614                                ungetc(c, fp);
615                                syntax_error(ERR_NO_CLOSE_PAREN);
616                        }
617       
618                        return a;
619                }
620        case '\'':
621                {
622                        SExp a = read_rec(fp);
623                        return cons(make_symbol("quote", NULL), cons(a, cNil));
624                }
625        case '`':
626                {
627                        SExp a = read_rec(fp);
628                        return cons(make_symbol("quasiquote", NULL), cons(a, cNil));
629                }
630        case ',':
631                {
632                        SExp a = read_rec(fp);
633                        return cons(make_symbol("unquote", NULL), cons(a, cNil));
634                }
635        case '"':
636                return read_string(fp);
637        }
638
639        {
640                char symb[256];
641                char* q = symb;
642                // search delimiter
643                int bDigit = TRUE;
644                // scheme �Ŏ��ʎq�Ɏg���镶���F !$%&*+-./:<=>?@^_~
645                for (; c != EOF && strchr(" \t\n()'@,#[]{}|", c) == NULL; *q++ = c, c = fgetc(fp)) {
646                        if (!isdigit(c))        bDigit = FALSE;
647                }
648                assert(q - symb < sizeof(symb));
649                ungetc(c, fp);
650                *q = '\0';
651                if (q == symb) {
652                        return cFail;
653                } else if (bDigit) {
654                        int x = atoi(symb);
655                        return ml_int2sexp(x);
656                } else {
657                        SExp a = reserved(symb, q-symb);
658                        if (a == cFail) {
659                                a = make_symbol(symb, q);
660                        }
661                        return a;
662                }
663        }
664}
665
666SExp MLContext::read(FILE* fp)
667{
668        SExp s = read_rec(fp);
669        if (s == cFail) {
670                int c = fgetc(fp);
671                syntax_error(ERR_ILLEGAL_CHAR);
672        }
673        return s;
674}
675
676SExp MLContext::eval(SExp a)
677{
678        if (SEXP_IS_INT(a)) {
679                return a;
680        }
681
682        switch (SEXP_TYPE(a)) {
683        default:        assert(false);  return cNil;
684        case tCell:
685                {
686                        SExp ca = car(a);
687                        SExp cd = cdr(a);
688                        return apply(ca, cd, true);
689                }
690                break;
691        case tOther:
692        case tFunc:
693                return a;
694        case tSymb:
695                {
696                        Symbol* p = get_symbol_ptr(a);
697                        SExp s = p->sexp;
698                        if (s == cUndef) {
699                                runtime_error(a, ERR_UNDEFINED_SYMBOL);
700                                return cNil;
701                        }
702                        return s;
703                }
704                break;
705        }
706}
707
708SExp MLContext::apply(SExp ca, SExp cd, bool b_eval)
709{
710        SExp fn = eval(ca);
711
712        if (SEXP_TYPE(fn) != tFunc) {
713                runtime_error(ca, ERR_CANT_CALL_FUNCTION);
714                return cNil;
715        }
716
717
718        // apply
719
720        SExp param = cd;
721
722        int info = ml_sexp2int(car(fn));
723        int type = info & FuncTypeMask;
724        int category = info & FuncCategoryMask;
725
726        if (type == FuncTypeLambda && b_eval) {
727                param = eval_list(param);
728        }
729
730        switch (category) {
731        default:        assert(false);  return cNil;
732        case FuncCategoryBuiltin:
733                {
734                        int idx = ml_sexp2int(cdr(fn));
735                        BuiltinFuncData* p = &builtin_func_buf[idx];
736                        return p->cfunc(this, param);
737                }
738                break;
739        case FuncCategoryCell:
740                {
741                        SExp cd = cdr(fn);
742                        SExp arg = car(cd);
743                        SExp body = car(cdr(cd));
744
745                        if (flags[MLF_PRINT_FUNC_ARG]) {
746                                print(stdout, param, false);
747                        }
748                        bind_arg(arg, param);
749
750                        if (type == FuncTypeMacro) {
751                                SExp replace = eval(body);
752                                if (flags[MLF_PRINT_MACRO_REPLACE]) {
753                                        print(stdout, replace, false);
754                                }
755                                body = replace;
756                        }
757
758                        SExp res = eval(body);
759
760                        unbind_arg(arg);
761
762                        return res;
763                }
764                break;
765        }
766}
767
768SExp MLContext::eval_list(SExp a)
769{
770        SExp top = cNil, tail = cNil;
771        SExp p;
772        for (p=a; SEXP_CONSP(p); p=cdr(p)) {
773                SExp ca = car(p);
774                SExp cd = cons(eval(ca), cNil);
775                if (top == cNil) {
776                        top = cd;
777                } else {
778                        rplacd(tail, cd);
779                }
780                tail = cd;
781        }
782        if (p != cNil) {
783                rplacd(tail, eval(p));
784        }
785        return top;
786}
787
788void MLContext::push_sexp(SExp s)
789{
790        assert(g_stack_p < MAX_STACK);
791        g_stack[g_stack_p++] = s;
792}
793
794SExp MLContext::pop_sexp()
795{
796        assert(g_stack_p > 0);
797        return g_stack[--g_stack_p];
798}
799
800void MLContext::bind_arg1(SExp symb, SExp val)
801{
802        Symbol* p = get_symbol_ptr(symb);
803        push_sexp(p->sexp);
804
805        p->sexp = val;
806
807        if (flags[MLF_PRINT_FUNC_ARG]) {
808                printf("bind ");
809                print_rec(stdout, symb);
810                printf(":");
811                print(stdout, val, false);
812        }
813}
814
815void MLContext::bind_arg(SExp arg, SExp param)
816{
817        for (; SEXP_CONSP(arg); arg = cdr(arg)) {
818                SExp symb = car(arg);
819                if (symb == cNil)       continue;
820
821                SExp nxt = cNil;
822                SExp val = param;
823                if (SEXP_CONSP(param)) {
824                        val = car(param);
825                        nxt = cdr(param);
826                }
827                bind_arg1(symb, val);
828
829                param = nxt;
830        }
831
832        if (arg != cNil) {
833                bind_arg1(arg, param);
834        }
835}
836
837void MLContext::unbind_arg(SExp arg)
838{
839        SExp a;
840        if (SEXP_TYPE(arg) == tCell) {
841                unbind_arg(cdr(arg));
842                a = car(arg);
843        } else {
844                a = arg;
845        }
846
847        if (SEXP_TYPE(a) == tSymb) {
848                Symbol* p = get_symbol_ptr(a);
849                p->sexp = pop_sexp();
850        }
851}
852
853void MLContext::print_rec(FILE* fp, SExp a)
854{
855        if (SEXP_IS_INT(a)) {
856                fprintf(fp, "%d", ml_sexp2int(a));
857                return;
858        }
859
860        switch (SEXP_TYPE(a)) {
861        default:        assert(false);  break;
862        case tOther:
863                switch (a) {
864                default:        /*assert(false);*/      break;
865                case cNil:      fprintf(fp, "nil");     break;
866                case cT:        fprintf(fp, "t");       break;
867                }
868                break;
869        case tSymb:
870                {
871                        Symbol* p = get_symbol_ptr(a);
872                        fprintf(fp, "%s", p->str);
873                }
874                break;
875        case tCell:
876                fprintf(fp, "(");
877                print_cell(fp, a);
878                fprintf(fp, ")");
879                break;
880        case tFunc:
881                fprintf(fp, "#<lambda>");
882                break;
883        }
884}
885
886void MLContext::print_cell(FILE* fp, SExp a)
887{
888        for (int idx=0; a != cNil; ++idx) {
889                if (idx != 0)   fprintf(fp, " ");
890
891                SExp ca;
892                if (SEXP_TYPE(a) != tCell) {
893                        fprintf(fp, ". ");
894                        ca = a;
895                        a = cNil;
896                } else {
897                        Cell* p = get_cell_ptr(a);
898                        ca = p->car;
899                        a = p->cdr;
900                }
901                print_rec(fp, ca);
902        }
903}
904
905void MLContext::print(FILE* fp, SExp a, bool b_cell)
906{
907        if (!b_cell) {
908                print_rec(fp, a);
909        } else {
910                print_cell(fp, a);
911        }
912        printf("\n");
913}
914
915
916//=============================================================================
917
918MLContext* ml_new(void)                                                                                         { return new MLContext; }
919void ml_delete(MLContext* ml)                                                                           { delete ml; }
920
921void ml_set_flag(MLContext* ml, ML_FLAG flag, int atom)                         { return ml->set_flag(flag, atom); }
922
923void ml_dump(MLContext* ml)                                                                                     { ml->dump(); }
924
925
926SExp ml_read(MLContext* ml, FILE* fp)                                                           { return ml->read(fp); }
927SExp ml_eval(MLContext* ml, SExp a)                                                                     { return ml->eval(a); }
928void ml_print(MLContext* ml, FILE* fp, SExp a, int b_cell)                      { ml->print(fp, a, b_cell != FALSE); }
929SExp ml_apply(MLContext* ml, SExp ca, SExp cd)                                          { return ml->apply(ca, cd, false); }
930
931SExp ml_resist_builtin(MLContext* ml, const char* word, MLBuiltinFunc cfunc, int b_macro)               { return ml->resist_builtin(word, cfunc, b_macro != FALSE); }
932SExp ml_create_lambda(MLContext* ml, SExp arg_body)     { return ml->create_lambda(arg_body); }
933void ml_defmacro(MLContext* ml, SExp symb, SExp arg_body)                       { ml->defmacro(symb, arg_body); }
934
935void ml_runtime_error(MLContext* ml, SExp a, const char* msg)           { ml->runtime_error(a, msg); }
936
937
938SExp ml_cons(MLContext* ml, SExp a, SExp d)                                                     { return ml->cons(a, d); }
939SExp ml_car(MLContext* ml, SExp a)                                                                      { return ml->car(a); }
940SExp ml_cdr(MLContext* ml, SExp a)                                                                      { return ml->cdr(a); }
941void ml_rplacd(MLContext* ml, SExp a, SExp d)                                           { ml->rplacd(a, d); }
942
943void ml_setq(MLContext* ml, SExp symb, SExp arg_body)                           { ml->setq(symb, arg_body); }
944SExp ml_make_symbol(MLContext* ml, const char* str, const char* end)    { return ml->make_symbol(str, end); }
945
946const char* ml_get_symbol_string(MLContext* ml, SExp symb)                      { return ml->get_symbol_string(symb); }
947
Note: See TracBrowser for help on using the browser.