![(please configure the [header_logo] section in trac.ini)](/share/chrome/site/your_project_logo.png){kind=logo}
- Timestamp:
- 05/17/08 17:54:48 (6 months ago)
- Location:
- lang/c/misc/mlisp
- Files:
-
- 10 modified
-
core/c_compiler.cpp (modified) (1 diff)
-
core/inner.h (modified) (1 diff)
-
core/m_basic.cpp (modified) (10 diffs)
-
core/mlisp.cpp (modified) (1 diff)
-
core/v_vm.cpp (modified) (15 diffs)
-
core/v_vm.h (modified) (1 diff)
-
inc/mlisp.h (modified) (1 diff)
-
inc/sexp.h (modified) (1 diff)
-
proto/stackbased.scm (modified) (13 diffs)
-
readme.txt (modified) (3 diffs)
Legend:
- Unmodified
- Added
- Removed
-
lang/c/misc/mlisp/core/c_compiler.cpp
r11750 r11756 357 357 SExp fn = car(x); 358 358 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; 360 360 if (macrop(gval)) { 361 361 return compile(transform_macro(gval, args), e, s, next); -
lang/c/misc/mlisp/core/inner.h
r11750 r11756 109 109 110 110 /// ��s���F�X�^�b�N�Q�� 111 sint get_arg_num( int s);112 SExp get_arg(int s, intidx);111 sint get_arg_num(void); 112 SExp get_arg(int idx); -
lang/c/misc/mlisp/core/m_basic.cpp
r11750 r11756 11 11 12 12 //============================================================================= 13 static SExp builtin_cons( int s) {14 SExp a = get_arg( s,0);15 SExp d = get_arg( s,1);13 static SExp builtin_cons() { 14 SExp a = get_arg(0); 15 SExp d = get_arg(1); 16 16 return cons(a, d); 17 17 } 18 18 19 static SExp builtin_car( int s) {20 SExp a = get_arg( s,0);19 static SExp builtin_car() { 20 SExp a = get_arg(0); 21 21 return car(a); 22 22 } 23 23 24 static SExp builtin_cdr( int s) {25 SExp a = get_arg( s,0);24 static SExp builtin_cdr() { 25 SExp a = get_arg(0); 26 26 return cdr(a); 27 27 } 28 28 29 static SExp builtin_consp( int s) {30 SExp v = get_arg( s,0);29 static SExp builtin_consp() { 30 SExp v = get_arg(0); 31 31 return consp(v) ? t : nil; 32 32 } 33 33 34 static SExp builtin_eq( int s) {35 SExp a = get_arg( s,0);36 SExp d = get_arg( s,1);34 static SExp builtin_eq() { 35 SExp a = get_arg(0); 36 SExp d = get_arg(1); 37 37 return eq(a, d) ? t : nil; 38 38 } 39 39 40 static SExp builtin_rplaca( int s) {41 SExp a = get_arg( s,0);42 SExp d = get_arg( s,1);40 static SExp builtin_rplaca() { 41 SExp a = get_arg(0); 42 SExp d = get_arg(1); 43 43 rplaca(a, d); 44 44 return nil; 45 45 } 46 46 47 static SExp builtin_rplacd( int s) {48 SExp a = get_arg( s,0);49 SExp d = get_arg( s,1);47 static SExp builtin_rplacd() { 48 SExp a = get_arg(0); 49 SExp d = get_arg(1); 50 50 rplacd(a, d); 51 51 return nil; 52 52 } 53 53 54 static SExp builtin_list( int s) {55 sint n = get_arg_num( s);54 static SExp builtin_list() { 55 sint n = get_arg_num(); 56 56 SExp ls = nil; 57 57 for (int i=n; --i>=0; ) { 58 SExp a = get_arg( s,i);58 SExp a = get_arg(i); 59 59 ls = cons(a, ls); 60 60 } … … 62 62 } 63 63 64 static SExp builtin_plus( int s) {65 sint n = get_arg_num( s);64 static SExp builtin_plus() { 65 sint n = get_arg_num(); 66 66 sint x = 0; 67 67 for (int i=0; i<n; ++i) { 68 SExp a = get_arg( s,i);68 SExp a = get_arg(i); 69 69 type_check(a, tInt); 70 70 x += s2int(a); … … 73 73 } 74 74 75 static SExp builtin_difference( int s) {76 sint n = get_arg_num( s);77 SExp a = get_arg( s,0);75 static SExp builtin_difference() { 76 sint n = get_arg_num(); 77 SExp a = get_arg(0); 78 78 type_check(a, tInt); 79 79 sint x = s2int(a); … … 82 82 } else { 83 83 for (int i=1; i<n; ++i) { 84 SExp a = get_arg( s,i);84 SExp a = get_arg(i); 85 85 type_check(a, tInt); 86 86 x -= s2int(a); … … 90 90 } 91 91 92 static SExp builtin_times( int s) {93 sint n = get_arg_num( s);92 static SExp builtin_times() { 93 sint n = get_arg_num(); 94 94 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); 97 97 type_check(a, tInt); 98 98 x *= s2int(a); … … 101 101 } 102 102 103 static SExp builtin_quotient( int s) {104 sint n = get_arg_num( s);105 SExp a = get_arg( s,0);103 static SExp builtin_quotient() { 104 sint n = get_arg_num(); 105 SExp a = get_arg(0); 106 106 type_check(a, tInt); 107 107 sint x = s2int(a); … … 110 110 } else { 111 111 for (int i=1; i<n; ++i) { 112 SExp a = get_arg( s,i);112 SExp a = get_arg(i); 113 113 type_check(a, tInt); 114 114 sint d = s2int(a); … … 124 124 } 125 125 126 static SExp num_predicate(int s, intn, bool (*p)(sint, sint)) {127 SExp a = get_arg( s,0);126 static SExp num_predicate(int n, bool (*p)(sint, sint)) { 127 SExp a = get_arg(0); 128 128 type_check(a, tInt); 129 129 sint x = s2int(a); 130 130 131 131 for (int i=1; i<n; ++i) { 132 SExp b = get_arg( s,i);132 SExp b = get_arg(i); 133 133 type_check(b, tInt); 134 134 sint y = s2int(b); … … 140 140 141 141 static 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);142 static SExp builtin_numeq() { 143 sint n = get_arg_num(); 144 return num_predicate(n, numeq); 145 145 } 146 146 147 147 static 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);148 static SExp builtin_lt() { 149 sint n = get_arg_num(); 150 return num_predicate(n, numlt); 151 151 } 152 152 153 153 static 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);154 static SExp builtin_gt() { 155 sint n = get_arg_num(); 156 return num_predicate(n, numgt); 157 157 } 158 158 159 159 static 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);160 static SExp builtin_le() { 161 sint n = get_arg_num(); 162 return num_predicate(n, numle); 163 163 } 164 164 165 165 static 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) {166 static SExp builtin_ge() { 167 sint n = get_arg_num(); 168 return num_predicate(n, numge); 169 } 170 171 172 static SExp builtin_read() { 173 173 return read_from_file(stdin); 174 174 } 175 175 176 static SExp builtin_print( int s) {177 SExp a = get_arg( s,0);176 static SExp builtin_print() { 177 SExp a = get_arg(0); 178 178 print(a); 179 179 return nil; 180 180 } 181 181 182 static SExp builtin_eval( int s) {183 SExp code = get_arg( s,0);182 static SExp builtin_eval() { 183 SExp code = get_arg(0); 184 184 185 185 return evaluate(code); 186 186 } 187 187 188 static SExp builtin_load( int s) {189 SExp a = get_arg( s,0);188 static SExp builtin_load() { 189 SExp a = get_arg(0); 190 190 const char* fn = s2str(a); 191 191 if (fn != NULL) { … … 196 196 } 197 197 198 static SExp builtin_compile( int s) {199 SExp code = get_arg( s,0);198 static SExp builtin_compile() { 199 SExp code = get_arg(0); 200 200 return compile_ontop(code); 201 201 } -
lang/c/misc/mlisp/core/mlisp.cpp
r11617 r11756 13 13 /// ��s 14 14 SExp run(SExp c) { 15 return vm(nil, c, 0, nil , 0);15 return vm(nil, c, 0, nil); 16 16 } 17 17 -
lang/c/misc/mlisp/core/v_vm.cpp
r11750 r11756 22 22 #define STACK_SIZE (1000) 23 23 static SExp g_stack[STACK_SIZE]; 24 static int g_sp; 25 26 static void clear_stack(void) { 27 g_sp = 0; 28 } 29 30 static void init_stack(void) { 31 clear_stack(); 32 } 24 33 25 34 inline static SExp stack_ref(int idx) { … … 37 46 } 38 47 39 static int push(SExp x, int s) { 40 assert(s >= 0); 41 if (s >= STACK_SIZE) { 48 static void push(SExp x) { 49 if (g_sp >= STACK_SIZE) { 42 50 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 56 static SExp pop() { 57 if (g_sp <= 0) { 58 runtime_error("stack underflow"); 59 return nil; 60 } 61 return g_stack[--g_sp]; 62 } 63 64 static void unlink(int n) { 65 g_sp -= n; 66 if (g_sp < 0) { 67 runtime_error("stack underflow"); 68 } 47 69 } 48 70 … … 58 80 59 81 60 sint get_arg_num( int s) {61 return s2int(index( s, 0));62 } 63 64 SExp get_arg(int s, inti) {65 return index( s, i + 1);82 sint get_arg_num(void) { 83 return s2int(index(g_sp, 0)); 84 } 85 86 SExp get_arg(int i) { 87 return index(g_sp, i + 1); 66 88 } 67 89 … … 90 112 void define_global(SExp sym, SExp val) { 91 113 g_global_env[sym] = val; 114 } 115 116 int exist_global(SExp sym) { 117 std::map<SExp, SExp>::iterator it = g_global_env.find(sym); 118 return it != g_global_env.end(); 92 119 } 93 120 … … 171 198 static int restore_stack(SExp v) { 172 199 int s = vector_length(v); 200 clear_stack(); 173 201 for (int i=0; i<s; ) { 174 i = push(vector_ref(v, i), i);202 push(vector_ref(v, i)); 175 203 } 176 204 return s; … … 201 229 //============================================================================= 202 230 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) { 231 static 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 240 static int apply(SExp fn, SExp argnum, SExp* pa, SExp* px, sint* pf, SExp* pc) { 212 241 int r = 0; 213 242 if (type_of(fn) == tProc) { … … 215 244 Procedure* proc = (Procedure*)fn.ptr; 216 245 if (check_arg_num(proc, n)) { 217 int ss = push(argnum, s); 246 push(argnum); 247 int ss = g_sp; 218 248 switch (proc->get_func_type()) { 219 249 case Procedure::Builtin: 220 250 { 221 251 SCFunc cfunc = proc->u.cfunc; 222 SExp res = (*cfunc)( ss);252 SExp res = (*cfunc)(); 223 253 *pa = res; 224 *ps = vm_return(px, pf, pc, ss);254 vm_return(px, pf, pc); 225 255 } 226 256 break; 227 257 case Procedure::Cell: 228 258 { 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; 231 261 } 232 262 r = 1; … … 247 277 #include <stdarg.h> 248 278 SExp vm_apply(SExp fn, int narg, ...) { 249 int s = 0;250 279 SExp c = nil; 251 280 sint f = 0; … … 253 282 254 283 // FRAME 255 s = push(ret, push(int2s(f), push(c, s))); 284 push(c); 285 push(int2s(f)); 286 push(ret); 256 287 257 288 // argments … … 264 295 va_end(ap); 265 296 for (int i=narg; --i>=0; ) { 266 s = push(buf[i], s);297 push(buf[i]); 267 298 } 268 299 269 300 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); 272 303 } 273 304 return a; … … 279 310 void init_vm(void) { 280 311 init_global(); 281 } 282 283 284 SExp vm(SExp a, SExp x, sint f, SExp c, int s) { 312 init_stack(); 313 } 314 315 316 SExp vm(SExp a, SExp x, sint f, SExp c) { 285 317 for (;;) { 286 318 SExp op = car(x); 287 319 288 dump_stack( s);320 dump_stack(g_sp); 289 321 print(op); 290 322 … … 297 329 } else if (op == ARGUMENT) { 298 330 SExp xx = cadr(x); 299 x = xx; s = push(a, s); 331 push(a); 332 x = xx; 300 333 } else if (op == TEST) { 301 334 SExp then = cadr(x); … … 313 346 SExp xx = cadr(x); 314 347 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; 316 352 } else if (op == CLOSE) { 317 353 sint n = s2int(cadr(x)); … … 322 358 int minarg = s2int(car(var_min_max)); 323 359 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; 325 363 } else if (op == BOX) { 326 364 sint n = s2int(cadr(x)); 327 365 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))); 329 367 x = xx; 330 368 } else if (op == ASSIGN_LOCAL) { … … 340 378 } else if (op == APPLY) { 341 379 SExp argnum = cadr(x); 342 apply(a, argnum, s, &a, &x, &f, &c, &s);380 apply(a, argnum, &a, &x, &f, &c); 343 381 } else if (op == RETURN) { 344 s = vm_return(&x, &f, &c, s);382 vm_return(&x, &f, &c); 345 383 } else if (op == SHIFT) { 346 384 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; 350 390 } else if (op == CONTI) { 351 391 SExp xx = cadr(x); 352 a = continuation( s); x = xx;392 a = continuation(g_sp); x = xx; 353 393 } else if (op == NUATE) { 354 394 SExp stack = cadr(x); 355 395 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; 357 400 } else if (op == DEFINE) { 358 401 SExp var = cadr(x); -
lang/c/misc/mlisp/core/v_vm.h
r11715 r11756 12 12 13 13 void init_vm(void); 14 SExp vm(SExp a, SExp x, sint f, SExp c , int s);14 SExp vm(SExp a, SExp x, sint f, SExp c); 15 15 16 16 #ifdef __cplusplus -
lang/c/misc/mlisp/inc/mlisp.h
r11715 r11756 31 31 void define_global(SExp sym, SExp val); 32 32 SExp refer_global(SExp sym); 33 int exist_global(SExp sym); 33 34 34 35 SExp vm_apply(SExp fn, int narg, ...); -
lang/c/misc/mlisp/inc/sexp.h
r11750 r11756 47 47 48 48 /// �g���݊��̌^ 49 typedef SExp (*SCFunc)( int stack);49 typedef SExp (*SCFunc)(void); 50 50 typedef SExp (*SCFuncM)(SExp args); 51 51 -
lang/c/misc/mlisp/proto/stackbased.scm
r11744 r11756 16 16 (use gauche.collection) ; filter 17 17 (use gauche.sequence) ; subseq 18 19 20 21 (define stack (make-vector 1000))22 23 (define push24 (lambda (x s)25 (vector-set! stack s x)26 (+ s 1)))27 28 (define index29 (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 37 18 38 19 … … 108 89 109 90 (define (transform-macro m args) 110 #?=(evaluate #?=(compile-macroexpand-1 m args)))91 (evaluate (compile-macroexpand-1 m args))) 111 92 112 93 … … 323 304 324 305 306 307 308 309 310 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 311 ;; スタック 312 313 (define *stack* (make-vector 1000)) 314 (define *sp* 0) 315