![(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 (5 years 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 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 325 344 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 326 345 ;; Evaluation 327 346 328 347 (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*))) 331 350 ; (newline) 332 351 (record-case x 333 352 (HALT () a) 334 353 (REFER-LOCAL (n x) 335 (VM (index f (+ n 1)) x f c s))354 (VM (index f (+ n 1)) x f c)) 336 355 (REFER-FREE (n x) 337 (VM (index-closure c n) x f c s))356 (VM (index-closure c n) x f c)) 338 357 (INDIRECT (x) 339 (VM (unbox a) x f c s))358 (VM (unbox a) x f c)) 340 359 (CONSTANT (obj x) 341 (VM obj x f c s))360 (VM obj x f c)) 342 361 (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))) 344 365 (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)) 347 368 (TEST (then else) 348 (VM a (if a then else) f c s))369 (VM a (if a then else) f c)) 349 370 (ASSIGN-LOCAL (n x) 350 371 (set-box! (index f (+ n 1)) a) 351 (VM a x f c s))372 (VM a x f c)) 352 373 (ASSIGN-FREE (n x) 353 374 (set-box! (index-closure c n) a) 354 (VM a x f c s))375 (VM a x f c)) 355 376 (CONTI (x) 356 (VM (continuation s) x f c s))377 (VM (continuation *sp*) x f c)) 357 378 (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))) 359 383 (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))) 361 389 (ARGUMENT (x) 362 (VM a x f c (push a s))) 390 (begin 391 (push a) 392 (VM a x f c))) 363 393 (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))) 366 398 (APPLY (n) 367 399 (if (is-a? a <functional>) 368 400 (if (check-arg-num a n) 369 (let ((ss (push n s))401 (let ((ss (push n)) 370 402 (body (closure-body a))) 371 403 (if (procedure? body) 372 (let* ((res (body ss))404 (let* ((res (body)) 373 405 (ret '(RETURN))) 374 (VM res ret f c ss))406 (VM res ret f c)) 375 407 (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)))) 378 410 (error "wrong number of argument")) 379 411 (error "can't apply"))) 380 412 (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)))) 384 419 (REFER-GLOBAL (var x) 385 (VM (refer-global var) x f c s))420 (VM (refer-global var) x f c)) 386 421 (DEFINE (var x) 387 422 (define-global var a) 388 (VM var x f c s))423 (VM var x f c)) 389 424 (ASSIGN-GLOBAL (var x) 390 425 (if (exist-global? var) 391 (VM (define-global var a) x f c s)426 (VM (define-global var a) x f c) 392 427 (error "assign to undefined symbol:" var))) 393 428 (else … … 406 441 (define evaluate 407 442 (lambda (x) 408 (set! stack (make-vector 1000)) 409 (VM '() (compile-top x) 0 '() 0))) 443 (VM '() (compile-top x) 0 '()))) 410 444 411 445 … … 425 459 (recur copy ((i 0)) 426 460 (unless (= i s) 427 (vector-set! v i (vector-ref stacki))461 (vector-set! v i (vector-ref *stack* i)) 428 462 (copy (+ i 1)))) 429 463 v))) … … 434 468 (recur copy ((i 0)) 435 469 (unless (= i s) 436 (vector-set! stacki (vector-ref v i))470 (vector-set! *stack* i (vector-ref v i)) 437 471 (copy (+ i 1)))) 438 472 s))) … … 443 477 (let ((v '())) 444 478 (when (> n 0) 445 ( make-vector n)479 (set! v (make-vector n)) 446 480 (recur f ((i 0)) 447 481 (unless (= i n) … … 467 501 (define index-closure 468 502 (lambda (c n) 469 (vector-ref #?=(slot-ref c 'buffer) n)))503 (vector-ref (slot-ref c 'buffer) n))) 470 504 471 505 ;; 引数の数をチェック … … 556 590 557 591 558 (define (get-arg-num s)559 (index s0))560 561 (define (get-arg si)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))) 563 597 564 598 … … 567 601 568 602 (define (dump-stack s) 569 (subseq stack0 s))603 (subseq *stack* 0 s)) 570 604 571 605 … … 584 618 585 619 586 (define (stack-fold f init sa b)620 (define (stack-fold f init a b) 587 621 (recur loop ((acc init) 588 622 (i a)) 589 623 (if (>= i b) 590 624 acc 591 (loop (f (get-arg si) acc) (+ i 1)))))625 (loop (f (get-arg i) acc) (+ i 1))))) 592 626 593 627 … … 597 631 (gen-builtin 598 632 'proc 2 2 599 (lambda ( s) (cons (get-arg s 0) (get-arg s1)))))633 (lambda () (cons (get-arg 0) (get-arg 1))))) 600 634 (cons 'car 601 635 (gen-builtin 602 636 'proc 1 1 603 (lambda ( s) (car (get-arg s0)))))637 (lambda () (car (get-arg 0))))) 604 638 (cons 'cdr 605 639 (gen-builtin 606 640 'proc 1 1 607 (lambda ( s) (cdr (get-arg s0)))))641 (lambda () (cdr (get-arg 0))))) 608 642 (cons 'pair? 609 643 (gen-builtin 610 644 'proc 1 1 611 (lambda ( s) (pair? (get-arg s0)))))645 (lambda () (pair? (get-arg 0))))) 612 646 (cons 'eq? 613 647 (gen-builtin 614 648 'proc 2 2 615 (lambda ( s) (eq? (get-arg s 0) (get-arg s1)))))649 (lambda () (eq? (get-arg 0) (get-arg 1))))) 616 650 (cons 'list 617 651 (gen-builtin 618 652 'proc 0 -1 619 (lambda ( s)620 (let ((n (get-arg-num s)))653 (lambda () 654 (let ((n (get-arg-num))) 621 655 (recur loop ((ls '()) 622 656 (i (-1+ n))) 623 657 (if (< i 0) 624 658 ls 625 (loop (cons (get-arg si) ls) (-1+ i))))))))659 (loop (cons (get-arg i) ls) (-1+ i)))))))) 626 660 (cons 'append 627 661 (gen-builtin 628 662 'proc 0 -1 629 (lambda ( s)630 (let ((n (get-arg-num s)))663 (lambda () 664 (let ((n (get-arg-num))) 631 665 (if (zero? n) 632 666 '() 633 (recur loop ((ls (get-arg s(-1+ n)))667 (recur loop ((ls (get-arg (-1+ n))) 634 668 (i (- n 2))) 635 669 (if (< i 0) 636 670 ls 637 (loop (append (get-arg si) ls) (-1+ i)))))))))671 (loop (append (get-arg i) ls) (-1+ i))))))))) 638 672 639 673 … … 642 676 (gen-builtin 643 677 'proc 0 -1 644 (lambda ( s)645 (let ((n (get-arg-num s)))646 (stack-fold + 0 s0 n)))))678 (lambda () 679 (let ((n (get-arg-num))) 680 (stack-fold + 0 0 n))))) 647 681 (cons '- 648 682 (gen-builtin 649 683 'proc 1 -1 650 (lambda ( s)651 (let ((n (get-arg-num s))652 (x0 (get-arg s0)))684 (lambda () 685 (let ((n (get-arg-num)) 686 (x0 (get-arg 0))) 653 687 (if (= n 1) 654 688 (- x0) 655 (stack-fold (lambda (x r) (- r x)) x0 s1 n))))))689 (stack-fold (lambda (x r) (- r x)) x0 1 n)))))) 656 690 (cons '* 657 691 (gen-builtin 658 692 'proc 0 -1 659 (lambda ( s)660 (let ((n (get-arg-num s)))661 (stack-fold * 1 s0 n)))))693 (lambda () 694 (let ((n (get-arg-num))) 695 (stack-fold * 1 0 n))))) 662 696 (cons '/ 663 697 (gen-builtin 664 698 'proc 1 -1 665 (lambda ( s)666 (let ((n (get-arg-num s))667 (x0 (get-arg s0)))699 (lambda () 700 (let ((n (get-arg-num)) 701 (x0 (get-arg 0))) 668 702 (if (= n 1) 669 703 (/ x0) 670 (stack-fold (lambda (x r) (/ r x)) x0 s1 n))))))704 (stack-fold (lambda (x r) (/ r x)) x0 1 n)))))) 671 705 (cons '< 672 706 (gen-builtin 673 707 'proc 2 2 674 (lambda ( s) (< (get-arg s 0) (get-arg s1)))))708 (lambda () (< (get-arg 0) (get-arg 1))))) 675 709 (cons 'read 676 710 (gen-builtin 677 711 'proc 0 0 678 (lambda ( s) (read))))712 (lambda () (read)))) 679 713 (cons 'eval 680 714 (gen-builtin 681 715 'proc 1 1 682 (lambda ( s) (evaluate (get-arg s0)))))716 (lambda () (evaluate (get-arg 0))))) 683 717 (cons 'print 684 718 (gen-builtin 685 719 'proc 1 1 686 (lambda ( s) (print (get-arg s0)))))720 (lambda () (print (get-arg 0))))) 687 721 (cons 'compile 688 722 (gen-builtin 689 723 'proc 1 1 690 (lambda ( s) (compile-top (get-arg s0)))))724 (lambda () (compile-top (get-arg 0))))) 691 725 (cons 'load 692 726 (gen-builtin 693 727 'proc 1 1 694 (lambda ( s) (load-file (get-arg s0)))))728 (lambda () (load-file (get-arg 0))))) 695 729 696 730 -
lang/c/misc/mlisp/readme.txt
r11715 r11756 45 45 * ToDo 46 46 -[v] �X�^�b�N�x�[�X�ɒu��������-[v] �C�ӌ̈��� 47 -[ x] �}�N�����47 -[v] �}�N����� 48 48 --[x] macroexpand ��-[v] C �������[�o���̊���яo�������ɂ���- �unil�v�ut�v���V���{���Ȃ̂ŁA�R���p�C�������V���{���Q�ƂɂȂ�Ă��܂� 49 49 - ��s���ɕϐ�������������Ƃ��̎����� … … 55 55 -- ���Ăяo���`�F�b�N 56 56 --- �����ǂ����H 57 --- ����������Ă邩�H�i��s����57 ---[v] ����������Ă邩�H�i��s���� 58 58 59 59 - �n�b�V����� … … 64 64 65 65 * �o�O 66 - eval ����ƃX�^�b�N�����A�l�����������Ȃ�66 -[v] eval ����ƃX�^�b�N�����A�l�����������Ȃ� 67 67 68 68
