Changeset 11756 for lang/c

Show
Ignore:
Timestamp:
05/17/08 17:54:48 (5 years ago)
Author:
mokehehe
Message:

use global stack pointer

Location:
lang/c/misc/mlisp
Files:
10 modified

Legend:

Unmodified
Added
Removed
  • lang/c/misc/mlisp/core/c_compiler.cpp

    r11750 r11756  
    357357        SExp fn = car(x); 
    358358        SExp args = cdr(x); 
    359         SExp gval = symbolp(fn) ? refer_global(fn) : nil; 
     359        SExp gval = (symbolp(fn) && exist_global(fn)) ? refer_global(fn) : nil; 
    360360        if (macrop(gval)) { 
    361361                return compile(transform_macro(gval, args), e, s, next); 
  • lang/c/misc/mlisp/core/inner.h

    r11750 r11756  
    109109 
    110110/// ��s���F�X�^�b�N�Q�� 
    111 sint get_arg_num(int s); 
    112 SExp get_arg(int s, int idx); 
     111sint get_arg_num(void); 
     112SExp get_arg(int idx); 
  • lang/c/misc/mlisp/core/m_basic.cpp

    r11750 r11756  
    1111 
    1212//============================================================================= 
    13 static SExp builtin_cons(int s) { 
    14         SExp a = get_arg(s, 0); 
    15         SExp d = get_arg(s, 1); 
     13static SExp builtin_cons() { 
     14        SExp a = get_arg(0); 
     15        SExp d = get_arg(1); 
    1616        return cons(a, d); 
    1717} 
    1818 
    19 static SExp builtin_car(int s) { 
    20         SExp a = get_arg(s, 0); 
     19static SExp builtin_car() { 
     20        SExp a = get_arg(0); 
    2121        return car(a); 
    2222} 
    2323 
    24 static SExp builtin_cdr(int s) { 
    25         SExp a = get_arg(s, 0); 
     24static SExp builtin_cdr() { 
     25        SExp a = get_arg(0); 
    2626        return cdr(a); 
    2727} 
    2828 
    29 static SExp builtin_consp(int s) { 
    30         SExp v = get_arg(s, 0); 
     29static SExp builtin_consp() { 
     30        SExp v = get_arg(0); 
    3131        return consp(v) ? t : nil; 
    3232} 
    3333 
    34 static SExp builtin_eq(int s) { 
    35         SExp a = get_arg(s, 0); 
    36         SExp d = get_arg(s, 1); 
     34static SExp builtin_eq() { 
     35        SExp a = get_arg(0); 
     36        SExp d = get_arg(1); 
    3737        return eq(a, d) ? t : nil; 
    3838} 
    3939 
    40 static SExp builtin_rplaca(int s) { 
    41         SExp a = get_arg(s, 0); 
    42         SExp d = get_arg(s, 1); 
     40static SExp builtin_rplaca() { 
     41        SExp a = get_arg(0); 
     42        SExp d = get_arg(1); 
    4343        rplaca(a, d); 
    4444        return nil; 
    4545} 
    4646 
    47 static SExp builtin_rplacd(int s) { 
    48         SExp a = get_arg(s, 0); 
    49         SExp d = get_arg(s, 1); 
     47static SExp builtin_rplacd() { 
     48        SExp a = get_arg(0); 
     49        SExp d = get_arg(1); 
    5050        rplacd(a, d); 
    5151        return nil; 
    5252} 
    5353 
    54 static SExp builtin_list(int s) { 
    55         sint n = get_arg_num(s); 
     54static SExp builtin_list() { 
     55        sint n = get_arg_num(); 
    5656        SExp ls = nil; 
    5757        for (int i=n; --i>=0; ) { 
    58                 SExp a = get_arg(s, i); 
     58                SExp a = get_arg(i); 
    5959                ls = cons(a, ls); 
    6060        } 
     
    6262} 
    6363 
    64 static SExp builtin_plus(int s) { 
    65         sint n = get_arg_num(s); 
     64static SExp builtin_plus() { 
     65        sint n = get_arg_num(); 
    6666        sint x = 0; 
    6767        for (int i=0; i<n; ++i) { 
    68                 SExp a = get_arg(s, i); 
     68                SExp a = get_arg(i); 
    6969                type_check(a, tInt); 
    7070                x += s2int(a); 
     
    7373} 
    7474 
    75 static SExp builtin_difference(int s) { 
    76         sint n = get_arg_num(s); 
    77         SExp a = get_arg(s, 0); 
     75static SExp builtin_difference() { 
     76        sint n = get_arg_num(); 
     77        SExp a = get_arg(0); 
    7878        type_check(a, tInt); 
    7979        sint x = s2int(a); 
     
    8282        } else { 
    8383                for (int i=1; i<n; ++i) { 
    84                         SExp a = get_arg(s, i); 
     84                        SExp a = get_arg(i); 
    8585                        type_check(a, tInt); 
    8686                        x -= s2int(a); 
     
    9090} 
    9191 
    92 static SExp builtin_times(int s) { 
    93         sint n = get_arg_num(s); 
     92static SExp builtin_times() { 
     93        sint n = get_arg_num(); 
    9494        sint x = 1; 
    95         for (int i=1; i<n; ++i) { 
    96                 SExp a = get_arg(s, i); 
     95        for (int i=0; i<n; ++i) { 
     96                SExp a = get_arg(i); 
    9797                type_check(a, tInt); 
    9898                x *= s2int(a); 
     
    101101} 
    102102 
    103 static SExp builtin_quotient(int s) { 
    104         sint n = get_arg_num(s); 
    105         SExp a = get_arg(s, 0); 
     103static SExp builtin_quotient() { 
     104        sint n = get_arg_num(); 
     105        SExp a = get_arg(0); 
    106106        type_check(a, tInt); 
    107107        sint x = s2int(a); 
     
    110110        } else { 
    111111                for (int i=1; i<n; ++i) { 
    112                         SExp a = get_arg(s, i); 
     112                        SExp a = get_arg(i); 
    113113                        type_check(a, tInt); 
    114114                        sint d = s2int(a); 
     
    124124} 
    125125 
    126 static SExp num_predicate(int s, int n, bool (*p)(sint, sint)) { 
    127         SExp a = get_arg(s, 0); 
     126static SExp num_predicate(int n, bool (*p)(sint, sint)) { 
     127        SExp a = get_arg(0); 
    128128        type_check(a, tInt); 
    129129        sint x = s2int(a); 
    130130 
    131131        for (int i=1; i<n; ++i) { 
    132                 SExp b = get_arg(s, i); 
     132                SExp b = get_arg(i); 
    133133                type_check(b, tInt); 
    134134                sint y = s2int(b); 
     
    140140 
    141141static bool numeq(sint a, sint b)       { return a == b; } 
    142 static SExp builtin_numeq(int s) { 
    143         sint n = get_arg_num(s); 
    144         return num_predicate(s, n, numeq); 
     142static SExp builtin_numeq() { 
     143        sint n = get_arg_num(); 
     144        return num_predicate(n, numeq); 
    145145} 
    146146 
    147147static bool numlt(sint a, sint b)       { return a < b; } 
    148 static SExp builtin_lt(int s) { 
    149         sint n = get_arg_num(s); 
    150         return num_predicate(s, n, numlt); 
     148static SExp builtin_lt() { 
     149        sint n = get_arg_num(); 
     150        return num_predicate(n, numlt); 
    151151} 
    152152 
    153153static bool numgt(sint a, sint b)       { return a > b; } 
    154 static SExp builtin_gt(int s) { 
    155         sint n = get_arg_num(s); 
    156         return num_predicate(s, n, numgt); 
     154static SExp builtin_gt() { 
     155        sint n = get_arg_num(); 
     156        return num_predicate(n, numgt); 
    157157} 
    158158 
    159159static bool numle(sint a, sint b)       { return a <= b; } 
    160 static SExp builtin_le(int s) { 
    161         sint n = get_arg_num(s); 
    162         return num_predicate(s, n, numle); 
     160static SExp builtin_le() { 
     161        sint n = get_arg_num(); 
     162        return num_predicate(n, numle); 
    163163} 
    164164 
    165165static bool numge(sint a, sint b)       { return a >= b; } 
    166 static SExp builtin_ge(int s) { 
    167         sint n = get_arg_num(s); 
    168         return num_predicate(s, n, numge); 
    169 } 
    170  
    171  
    172 static SExp builtin_read(int s) { 
     166static SExp builtin_ge() { 
     167        sint n = get_arg_num(); 
     168        return num_predicate(n, numge); 
     169} 
     170 
     171 
     172static SExp builtin_read() { 
    173173        return read_from_file(stdin); 
    174174} 
    175175 
    176 static SExp builtin_print(int s) { 
    177         SExp a = get_arg(s, 0); 
     176static SExp builtin_print() { 
     177        SExp a = get_arg(0); 
    178178        print(a); 
    179179        return nil; 
    180180} 
    181181 
    182 static SExp builtin_eval(int s) { 
    183         SExp code = get_arg(s, 0); 
     182static SExp builtin_eval() { 
     183        SExp code = get_arg(0); 
    184184 
    185185        return evaluate(code); 
    186186} 
    187187 
    188 static SExp builtin_load(int s) { 
    189         SExp a = get_arg(s, 0); 
     188static SExp builtin_load() { 
     189        SExp a = get_arg(0); 
    190190        const char* fn = s2str(a); 
    191191        if (fn != NULL) { 
     
    196196} 
    197197 
    198 static SExp builtin_compile(int s) { 
    199         SExp code = get_arg(s, 0); 
     198static SExp builtin_compile() { 
     199        SExp code = get_arg(0); 
    200200        return compile_ontop(code); 
    201201} 
  • lang/c/misc/mlisp/core/mlisp.cpp

    r11617 r11756  
    1313/// ��s 
    1414SExp run(SExp c) { 
    15         return vm(nil, c, 0, nil, 0); 
     15        return vm(nil, c, 0, nil); 
    1616} 
    1717 
  • lang/c/misc/mlisp/core/v_vm.cpp

    r11750 r11756  
    2222#define STACK_SIZE              (1000) 
    2323static SExp g_stack[STACK_SIZE]; 
     24static int g_sp; 
     25 
     26static void clear_stack(void) { 
     27        g_sp = 0; 
     28} 
     29 
     30static void init_stack(void) { 
     31        clear_stack(); 
     32} 
    2433 
    2534inline static SExp stack_ref(int idx) { 
     
    3746} 
    3847 
    39 static int push(SExp x, int s) { 
    40         assert(s >= 0); 
    41         if (s >= STACK_SIZE) { 
     48static void push(SExp x) { 
     49        if (g_sp >= STACK_SIZE) { 
    4250                runtime_error("stack overflow"); 
    43                 return s; 
    44         } 
    45         g_stack[s] = x; 
    46         return s + 1; 
     51                return; 
     52        } 
     53        g_stack[g_sp++] = x; 
     54} 
     55 
     56static SExp pop() { 
     57        if (g_sp <= 0) { 
     58                runtime_error("stack underflow"); 
     59                return nil; 
     60        } 
     61        return g_stack[--g_sp]; 
     62} 
     63 
     64static void unlink(int n) { 
     65        g_sp -= n; 
     66        if (g_sp < 0) { 
     67                runtime_error("stack underflow"); 
     68        } 
    4769} 
    4870 
     
    5880 
    5981 
    60 sint get_arg_num(int s) { 
    61         return s2int(index(s, 0)); 
    62 } 
    63  
    64 SExp get_arg(int s, int i) { 
    65         return index(s, i + 1); 
     82sint get_arg_num(void) { 
     83        return s2int(index(g_sp, 0)); 
     84} 
     85 
     86SExp get_arg(int i) { 
     87        return index(g_sp, i + 1); 
    6688} 
    6789 
     
    90112void define_global(SExp sym, SExp val) { 
    91113        g_global_env[sym] = val; 
     114} 
     115 
     116int exist_global(SExp sym) { 
     117        std::map<SExp, SExp>::iterator it = g_global_env.find(sym); 
     118        return it != g_global_env.end(); 
    92119} 
    93120 
     
    171198static int restore_stack(SExp v) { 
    172199        int s = vector_length(v); 
     200        clear_stack(); 
    173201        for (int i=0; i<s; ) { 
    174                 i = push(vector_ref(v, i), i); 
     202                push(vector_ref(v, i)); 
    175203        } 
    176204        return s; 
     
    201229//============================================================================= 
    202230 
    203 static int vm_return(SExp* px, sint* pf, SExp* pc, int s) { 
    204         int n = s2int(index(s, 0)); 
    205         int ss = s - n - 1; 
    206         *px = index(ss, 0);     *pf = s2int(index(ss, 1));      *pc = index(ss, 2); 
    207         return ss - 3; 
    208 } 
    209  
    210  
    211 static int apply(SExp fn, SExp argnum, int s, SExp* pa, SExp* px, sint* pf, SExp* pc, int* ps) { 
     231static void vm_return(SExp* px, sint* pf, SExp* pc) { 
     232        int n = s2int(pop()); 
     233        unlink(n); 
     234        *px = pop(); 
     235        *pf = s2int(pop()); 
     236        *pc = pop(); 
     237} 
     238 
     239 
     240static int apply(SExp fn, SExp argnum, SExp* pa, SExp* px, sint* pf, SExp* pc) { 
    212241        int r = 0; 
    213242        if (type_of(fn) == tProc) { 
     
    215244                Procedure* proc = (Procedure*)fn.ptr; 
    216245                if (check_arg_num(proc, n)) { 
    217                         int ss = push(argnum, s); 
     246                        push(argnum); 
     247                        int ss = g_sp; 
    218248                        switch (proc->get_func_type()) { 
    219249                        case Procedure::Builtin: 
    220250                                { 
    221251                                        SCFunc cfunc = proc->u.cfunc; 
    222                                         SExp res = (*cfunc)(ss); 
     252                                        SExp res = (*cfunc)(); 
    223253                                        *pa = res; 
    224                                         *ps = vm_return(px, pf, pc, ss); 
     254                                        vm_return(px, pf, pc); 
    225255                                } 
    226256                                break; 
    227257                        case Procedure::Cell: 
    228258                                { 
    229                                         modify_args(proc, n, s); 
    230                                         *px = closure_body(fn); *pf = ss;       *pc = fn;       *ps = ss; 
     259                                        modify_args(proc, n, g_sp); 
     260                                        *px = closure_body(fn); *pf = ss;       *pc = fn; 
    231261                                } 
    232262                                r = 1; 
     
    247277#include <stdarg.h> 
    248278SExp vm_apply(SExp fn, int narg, ...) { 
    249         int s = 0; 
    250279        SExp c = nil; 
    251280        sint f = 0; 
     
    253282 
    254283        // FRAME 
    255         s = push(ret, push(int2s(f), push(c, s))); 
     284        push(c); 
     285        push(int2s(f)); 
     286        push(ret); 
    256287 
    257288        // argments 
     
    264295        va_end(ap); 
    265296        for (int i=narg; --i>=0; ) { 
    266                 s = push(buf[i], s); 
     297                push(buf[i]); 
    267298        } 
    268299 
    269300        SExp a, x; 
    270         if (apply(fn, int2s(narg), s, &a, &x, &f, &c, &s) == 1) { 
    271                 a = vm(a, x, f, c, s); 
     301        if (apply(fn, int2s(narg), &a, &x, &f, &c) == 1) { 
     302                a = vm(a, x, f, c); 
    272303        } 
    273304        return a; 
     
    279310void init_vm(void) { 
    280311        init_global(); 
    281 } 
    282  
    283  
    284 SExp vm(SExp a, SExp x, sint f, SExp c, int s) { 
     312        init_stack(); 
     313} 
     314 
     315 
     316SExp vm(SExp a, SExp x, sint f, SExp c) { 
    285317        for (;;) { 
    286318                SExp op = car(x); 
    287319 
    288                 dump_stack(s); 
     320                dump_stack(g_sp); 
    289321                print(op); 
    290322 
     
    297329                } else if (op == ARGUMENT) { 
    298330                        SExp xx = cadr(x); 
    299                         x = xx; s = push(a, s); 
     331                        push(a); 
     332                        x = xx; 
    300333                } else if (op == TEST) { 
    301334                        SExp then = cadr(x); 
     
    313346                        SExp xx = cadr(x); 
    314347                        SExp ret = caddr(x); 
    315                         x = xx; s = push(ret, push(int2s(f), push(c, s))); 
     348                        push(c); 
     349                        push(int2s(f)); 
     350                        push(ret); 
     351                        x = xx; 
    316352                } else if (op == CLOSE) { 
    317353                        sint n = s2int(cadr(x)); 
     
    322358                        int minarg = s2int(car(var_min_max)); 
    323359                        int maxarg = s2int(cdr(var_min_max)); 
    324                         a = closure(minarg, maxarg, body, n, s);        x = xx; s -= n; 
     360                        SExp aa = closure(minarg, maxarg, body, n, g_sp); 
     361                        unlink(n); 
     362                        a = aa; x = xx; 
    325363                } else if (op == BOX) { 
    326364                        sint n = s2int(cadr(x)); 
    327365                        SExp xx = caddr(x); 
    328                         index_set(s, n + 1, box(index(s, n + 1))); 
     366                        index_set(g_sp, n + 1, box(index(g_sp, n + 1))); 
    329367                        x = xx; 
    330368                } else if (op == ASSIGN_LOCAL) { 
     
    340378                } else if (op == APPLY) { 
    341379                        SExp argnum = cadr(x); 
    342                         apply(a, argnum, s, &a, &x, &f, &c, &s); 
     380                        apply(a, argnum, &a, &x, &f, &c); 
    343381                } else if (op == RETURN) { 
    344                         s = vm_return(&x, &f, &c, s); 
     382                        vm_return(&x, &f, &c); 
    345383                } else if (op == SHIFT) { 
    346384                        sint n = s2int(cadr(x)); 
    347                         sint m = s2int(index(s, n)); 
    348                         SExp xx = caddr(x); 
    349                         x = xx; s = shift_args(n, m, s); 
     385                        SExp xx = caddr(x); 
     386                        sint m = s2int(index(g_sp, n)); 
     387                        shift_args(n, m, g_sp); 
     388                        unlink(m + 1); 
     389                        x = xx; 
    350390                } else if (op == CONTI) { 
    351391                        SExp xx = cadr(x); 
    352                         a = continuation(s);    x = xx; 
     392                        a = continuation(g_sp); x = xx; 
    353393                } else if (op == NUATE) { 
    354394                        SExp stack = cadr(x); 
    355395                        SExp xx = caddr(x); 
    356                         x = xx; s = push(int2s(0), restore_stack(stack)); 
     396 
     397                        restore_stack(stack); 
     398                        push(int2s(0)); 
     399                        x = xx; 
    357400                } else if (op == DEFINE) { 
    358401                        SExp var = cadr(x); 
  • lang/c/misc/mlisp/core/v_vm.h

    r11715 r11756  
    1212 
    1313void init_vm(void); 
    14 SExp vm(SExp a, SExp x, sint f, SExp c, int s); 
     14SExp vm(SExp a, SExp x, sint f, SExp c); 
    1515 
    1616#ifdef __cplusplus 
  • lang/c/misc/mlisp/inc/mlisp.h

    r11715 r11756  
    3131void define_global(SExp sym, SExp val); 
    3232SExp refer_global(SExp sym); 
     33int exist_global(SExp sym); 
    3334 
    3435SExp vm_apply(SExp fn, int narg, ...); 
  • lang/c/misc/mlisp/inc/sexp.h

    r11750 r11756  
    4747 
    4848/// �g���݊֐��̌^ 
    49 typedef SExp (*SCFunc)(int stack); 
     49typedef SExp (*SCFunc)(void); 
    5050typedef SExp (*SCFuncM)(SExp args); 
    5151 
  • lang/c/misc/mlisp/proto/stackbased.scm

    r11744 r11756  
    1616(use gauche.collection)  ; filter 
    1717(use gauche.sequence)    ; subseq 
    18  
    19  
    20  
    21 (define stack (make-vector 1000)) 
    22  
    23 (define push 
    24   (lambda (x s) 
    25     (vector-set! stack s x) 
    26     (+ s 1))) 
    27  
    28 (define index 
    29   (lambda (s i) 
    30     (vector-ref stack (- s i 1)))) 
    31  
    32 (define index-set! 
    33   (lambda (s i v) 
    34     (vector-set! stack (- s i 1) v))) 
    35  
    36  
    3718 
    3819 
     
    10889 
    10990(define (transform-macro m args) 
    110   #?=(evaluate #?=(compile-macroexpand-1 m args))) 
     91  (evaluate (compile-macroexpand-1 m args))) 
    11192 
    11293 
     
    323304 
    324305 
     306 
     307 
     308 
     309 
     310;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
     311;; スタック 
     312 
     313(define *stack* (make-vector 1000)) 
     314(define *sp* 0) 
     315 
     316(define (init-stack) 
     317  (set! *stack* (make-vector 1000)) 
     318  (set! *sp* 0)) 
     319 
     320(define push 
     321  (lambda (x) 
     322    (vector-set! *stack* *sp* x) 
     323    (inc! *sp*))) 
     324 
     325(define pop 
     326  (lambda () 
     327    (if (<= *sp* 0) 
     328        (error "stack underflow") 
     329      (vector-ref *stack* (dec! *sp*))))) 
     330 
     331(define unlink 
     332  (lambda (n) 
     333    (dec! *sp* n))) 
     334 
     335(define index 
     336  (lambda (s i) 
     337    (vector-ref *stack* (- s i 1)))) 
     338 
     339(define index-set! 
     340  (lambda (s i v) 
     341    (vector-set! *stack* (- s i 1) v))) 
     342 
     343 
    325344;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
    326345;; Evaluation 
    327346 
    328347(define VM 
    329   (lambda (a x f c s) 
    330 ;    (write/ss (list (car x) a (dump-stack s))) 
     348  (lambda (a x f c) 
     349;    (write/ss (list (car x) a (dump-stack *sp*))) 
    331350;    (newline) 
    332351    (record-case x 
    333352                 (HALT () a) 
    334353                 (REFER-LOCAL (n x) 
    335                               (VM (index f (+ n 1)) x f c s)) 
     354                              (VM (index f (+ n 1)) x f c)) 
    336355                 (REFER-FREE (n x) 
    337                              (VM (index-closure c n) x f c s)) 
     356                             (VM (index-closure c n) x f c)) 
    338357                 (INDIRECT (x) 
    339                            (VM (unbox a) x f c s)) 
     358                           (VM (unbox a) x f c)) 
    340359                 (CONSTANT (obj x) 
    341                            (VM obj x f c s)) 
     360                           (VM obj x f c)) 
    342361                 (CLOSE (n var-min-max body x) 
    343                         (VM (closure var-min-max body n s) x f c (- s n))) 
     362                        (let ((aa (closure var-min-max body n *sp*))) 
     363                          (unlink n) 
     364                          (VM aa x f c))) 
    344365                 (BOX (n x) 
    345                       (index-set! s (+ n 1) (box (index s (+ n 1)))) 
    346                       (VM a x f c s)) 
     366                      (index-set! *sp* (+ n 1) (box (index *sp* (+ n 1)))) 
     367                      (VM a x f c)) 
    347368                 (TEST (then else) 
    348                        (VM a (if a then else) f c s)) 
     369                       (VM a (if a then else) f c)) 
    349370                 (ASSIGN-LOCAL (n x) 
    350371                               (set-box! (index f (+ n 1)) a) 
    351                                (VM a x f c s)) 
     372                               (VM a x f c)) 
    352373                 (ASSIGN-FREE (n x) 
    353374                              (set-box! (index-closure c n) a) 
    354                               (VM a x f c s)) 
     375                              (VM a x f c)) 
    355376                 (CONTI (x) 
    356                         (VM (continuation s) x f c s)) 
     377                        (VM (continuation *sp*) x f c)) 
    357378                 (NUATE (stack x) 
    358                         (VM a x f c (push 0 (restore-stack stack)))) 
     379                        (begin 
     380                          (restore-stack stack) 
     381                          (push 0) 
     382                          (VM a x f c))) 
    359383                 (FRAME (x ret) 
    360                         (VM a x f c (push ret (push f (push c s))))) 
     384                        (begin 
     385                          (push c) 
     386                          (push f) 
     387                          (push ret) 
     388                          (VM a x f c))) 
    361389                 (ARGUMENT (x) 
    362                            (VM a x f c (push a s))) 
     390                           (begin 
     391                             (push a) 
     392                             (VM a x f c))) 
    363393                 (SHIFT (n x) 
    364                         (let ((m (index s n)))  ; ひとつ上の引数の個数 
    365                           (VM a x f c (shift-args n m s)))) 
     394                        (let ((m (index *sp* n)))  ; ひとつ上の引数の個数 
     395                          (shift-args n m *sp*) 
     396                          (unlink (+ m 1)) 
     397                          (VM a x f c))) 
    366398                 (APPLY (n) 
    367399                        (if (is-a? a <functional>) 
    368400                            (if (check-arg-num a n) 
    369                                 (let ((ss (push n s)) 
     401                                (let ((ss (push n)) 
    370402                                      (body (closure-body a))) 
    371403                                  (if (procedure? body) 
    372                                       (let* ((res (body ss)) 
     404                                      (let* ((res (body)) 
    373405                                             (ret '(RETURN))) 
    374                                         (VM res ret f c ss)) 
     406                                        (VM res ret f c)) 
    375407                                    (begin 
    376                                       (modify-args a n s) 
    377                                       (VM a body ss a ss)))) 
     408                                      (modify-args a n *sp*) 
     409                                      (VM a body ss a)))) 
    378410                              (error "wrong number of argument")) 
    379411                          (error "can't apply"))) 
    380412                 (RETURN () 
    381                          (let ((n (index s 0))) 
    382                            (let ((s (- s n 1))) 
    383                              (VM a (index s 0) (index s 1) (index s 2) (- s 3))))) 
     413                         (let ((n (pop))) 
     414                           (unlink n) 
     415                           (let* ((xx (pop)) 
     416                                  (ff (pop)) 
     417                                  (cc (pop))) 
     418                             (VM a xx ff cc)))) 
    384419                 (REFER-GLOBAL (var x) 
    385                          (VM (refer-global var) x f c s)) 
     420                         (VM (refer-global var) x f c)) 
    386421                 (DEFINE (var x) 
    387422                         (define-global var a) 
    388                          (VM var x f c s)) 
     423                         (VM var x f c)) 
    389424                 (ASSIGN-GLOBAL (var x) 
    390425                                (if (exist-global? var) 
    391                                     (VM (define-global var a) x f c s) 
     426                                    (VM (define-global var a) x f c) 
    392427                                  (error "assign to undefined symbol:" var))) 
    393428                 (else 
     
    406441(define evaluate 
    407442  (lambda (x) 
    408     (set! stack (make-vector 1000)) 
    409     (VM '() (compile-top x) 0 '() 0))) 
     443    (VM '() (compile-top x) 0 '()))) 
    410444 
    411445 
     
    425459      (recur copy ((i 0)) 
    426460             (unless (= i s) 
    427                (vector-set! v i (vector-ref stack i)) 
     461               (vector-set! v i (vector-ref *stack* i)) 
    428462               (copy (+ i 1)))) 
    429463      v))) 
     
    434468      (recur copy ((i 0)) 
    435469             (unless (= i s) 
    436                (vector-set! stack i (vector-ref v i)) 
     470               (vector-set! *stack* i (vector-ref v i)) 
    437471               (copy (+ i 1)))) 
    438472      s))) 
     
    443477    (let ((v '())) 
    444478      (when (> n 0) 
    445         (make-vector n) 
     479        (set! v (make-vector n)) 
    446480        (recur f ((i 0)) 
    447481               (unless (= i n) 
     
    467501(define index-closure 
    468502  (lambda (c n) 
    469     (vector-ref #?=(slot-ref c 'buffer) n))) 
     503    (vector-ref (slot-ref c 'buffer) n))) 
    470504 
    471505;; 引数の数をチェック 
     
    556590 
    557591 
    558 (define (get-arg-num s) 
    559   (index s 0)) 
    560  
    561 (define (get-arg s i) 
    562   (index s (1+ i))) 
     592(define (get-arg-num) 
     593  (index *sp* 0)) 
     594 
     595(define (get-arg i) 
     596  (index *sp* (1+ i))) 
    563597 
    564598 
     
    567601 
    568602(define (dump-stack s) 
    569   (subseq stack 0 s)) 
     603  (subseq *stack* 0 s)) 
    570604 
    571605 
     
    584618 
    585619 
    586 (define (stack-fold f init s a b) 
     620(define (stack-fold f init a b) 
    587621  (recur loop ((acc init) 
    588622               (i a)) 
    589623         (if (>= i b) 
    590624             acc 
    591            (loop (f (get-arg s i) acc) (+ i 1))))) 
     625           (loop (f (get-arg i) acc) (+ i 1))))) 
    592626 
    593627 
     
    597631                    (gen-builtin 
    598632                     'proc 2 2 
    599                      (lambda (s) (cons (get-arg s 0) (get-arg s 1))))) 
     633                     (lambda () (cons (get-arg 0) (get-arg 1))))) 
    600634              (cons 'car 
    601635                    (gen-builtin 
    602636                     'proc 1 1 
    603                      (lambda (s) (car (get-arg s 0))))) 
     637                     (lambda () (car (get-arg 0))))) 
    604638              (cons 'cdr 
    605639                    (gen-builtin 
    606640                     'proc 1 1 
    607                      (lambda (s) (cdr (get-arg s 0))))) 
     641                     (lambda () (cdr (get-arg 0))))) 
    608642              (cons 'pair? 
    609643                    (gen-builtin 
    610644                     'proc 1 1 
    611                      (lambda (s) (pair? (get-arg s 0))))) 
     645                     (lambda () (pair? (get-arg 0))))) 
    612646              (cons 'eq? 
    613647                    (gen-builtin 
    614648                     'proc 2 2 
    615                      (lambda (s) (eq? (get-arg s 0) (get-arg s 1))))) 
     649                     (lambda () (eq? (get-arg 0) (get-arg 1))))) 
    616650              (cons 'list 
    617651                    (gen-builtin 
    618652                     'proc 0 -1 
    619                      (lambda (s) 
    620                        (let ((n (get-arg-num s))) 
     653                     (lambda () 
     654                       (let ((n (get-arg-num))) 
    621655                         (recur loop ((ls '()) 
    622656                                      (i (-1+ n))) 
    623657                                (if (< i 0) 
    624658                                    ls 
    625                                   (loop (cons (get-arg s i) ls) (-1+ i)))))))) 
     659                                  (loop (cons (get-arg i) ls) (-1+ i)))))))) 
    626660              (cons 'append 
    627661                    (gen-builtin 
    628662                     'proc 0 -1 
    629                      (lambda (s) 
    630                        (let ((n (get-arg-num s))) 
     663                     (lambda () 
     664                       (let ((n (get-arg-num))) 
    631665                         (if (zero? n) 
    632666                             '() 
    633                            (recur loop ((ls (get-arg s (-1+ n))) 
     667                           (recur loop ((ls (get-arg (-1+ n))) 
    634668                                        (i (- n 2))) 
    635669                                  (if (< i 0) 
    636670                                      ls 
    637                                     (loop (append (get-arg s i) ls) (-1+ i))))))))) 
     671                                    (loop (append (get-arg i) ls) (-1+ i))))))))) 
    638672               
    639673               
     
    642676                    (gen-builtin 
    643677                     'proc 0 -1 
    644                      (lambda (s) 
    645                        (let ((n (get-arg-num s))) 
    646                          (stack-fold + 0 s 0 n))))) 
     678                     (lambda () 
     679                       (let ((n (get-arg-num))) 
     680                         (stack-fold + 0 0 n))))) 
    647681              (cons '- 
    648682                    (gen-builtin 
    649683                     'proc 1 -1 
    650                      (lambda (s) 
    651                        (let ((n (get-arg-num s)) 
    652                              (x0 (get-arg s 0))) 
     684                     (lambda () 
     685                       (let ((n (get-arg-num)) 
     686                             (x0 (get-arg 0))) 
    653687                         (if (= n 1) 
    654688                             (- x0) 
    655                            (stack-fold (lambda (x r) (- r x)) x0 s 1 n)))))) 
     689                           (stack-fold (lambda (x r) (- r x)) x0 1 n)))))) 
    656690              (cons '* 
    657691                    (gen-builtin 
    658692                     'proc 0 -1 
    659                      (lambda (s) 
    660                        (let ((n (get-arg-num s))) 
    661                          (stack-fold * 1 s 0 n))))) 
     693                     (lambda () 
     694                       (let ((n (get-arg-num))) 
     695                         (stack-fold * 1 0 n))))) 
    662696              (cons '/ 
    663697                    (gen-builtin 
    664698                     'proc 1 -1 
    665                      (lambda (s) 
    666                        (let ((n (get-arg-num s)) 
    667                              (x0 (get-arg s 0))) 
     699                     (lambda () 
     700                       (let ((n (get-arg-num)) 
     701                             (x0 (get-arg 0))) 
    668702                         (if (= n 1) 
    669703                             (/ x0) 
    670                            (stack-fold (lambda (x r) (/ r x)) x0 s 1 n)))))) 
     704                           (stack-fold (lambda (x r) (/ r x)) x0 1 n)))))) 
    671705              (cons '< 
    672706                    (gen-builtin 
    673707                     'proc 2 2 
    674                      (lambda (s) (< (get-arg s 0) (get-arg s 1))))) 
     708                     (lambda () (< (get-arg 0) (get-arg 1))))) 
    675709              (cons 'read 
    676710                    (gen-builtin 
    677711                     'proc 0 0 
    678                      (lambda (s) (read)))) 
     712                     (lambda () (read)))) 
    679713              (cons 'eval 
    680714                    (gen-builtin 
    681715                     'proc 1 1 
    682                      (lambda (s) (evaluate (get-arg s 0))))) 
     716                     (lambda () (evaluate (get-arg 0))))) 
    683717              (cons 'print 
    684718                    (gen-builtin 
    685719                     'proc 1 1 
    686                      (lambda (s) (print (get-arg s 0))))) 
     720                     (lambda () (print (get-arg 0))))) 
    687721              (cons 'compile 
    688722                    (gen-builtin 
    689723                     'proc 1 1 
    690                      (lambda (s) (compile-top (get-arg s 0))))) 
     724                     (lambda () (compile-top (get-arg 0))))) 
    691725              (cons 'load 
    692726                    (gen-builtin 
    693727                     'proc 1 1 
    694                      (lambda (s) (load-file (get-arg s 0))))) 
     728                     (lambda () (load-file (get-arg 0))))) 
    695729               
    696730               
  • lang/c/misc/mlisp/readme.txt

    r11715 r11756  
    4545* ToDo 
    4646-[v] �X�^�b�N�x�[�X�ɒu��������-[v] �C�ӌ‚̈��󂯎� 
    47 -[x] �}�N����� 
     47-[v] �}�N����� 
    4848--[x] macroexpand ��-[v] C �������[�o���̊֐���яo�������ɂ���- �unil�v�ut�v���V���{���Ȃ̂ŁA�R���p�C�������V���{���Q�ƂɂȂ�Ă��܂� 
    4949- ��s���ɕϐ�������������Ƃ��̎����� 
     
    5555-- �֐��Ăяo���`�F�b�N 
    5656--- �֐����ǂ����H 
    57 --- ����������Ă邩�H�i��s���� 
     57---[v] ����������Ă邩�H�i��s���� 
    5858 
    5959- �n�b�V����� 
     
    6464 
    6565* �o�O 
    66 - eval ����ƃX�^�b�N���󂳂��A�l�����������Ȃ� 
     66-[v] eval ����ƃX�^�b�N���󂳂��A�l�����������Ȃ� 
    6767 
    6868