![(please configure the [header_logo] section in trac.ini)](/share/chrome/site/your_project_logo.png){kind=logo}
Changeset 31151
- Timestamp:
- 03/13/09 22:20:29 (4 years ago)
- Files:
-
- 1 modified
-
lang/scheme/3imp/4.7.scm (modified) (15 diffs)
Legend:
- Unmodified
- Added
- Removed
-
lang/scheme/3imp/4.7.scm
r31147 r31151 51 51 (compile-refer x e 52 52 (if (set-member? x s) 53 (list INDIRECT next)53 (list* INDIRECT next) 54 54 next))) 55 55 ((pair? x) 56 56 (record-case x 57 (quote (obj) (list CONSTANT obj next))57 (quote (obj) (list* CONSTANT obj next)) 58 58 (lambda (vars . bodies) 59 59 (compile-lambda vars bodies e s next)) … … 64 64 (let ((thenc (compile then e s next)) 65 65 (elsec (compile else e s next))) 66 (compile test e s (list TEST thenc elsec)))))66 (compile test e s (list* TEST thenc elsec))))) 67 67 (set! (var x) 68 68 (compile-lookup var e 69 (lambda (n) (compile x e s (list ASSIGN-LOCAL n next)))70 (lambda (n) (compile x e s (list ASSIGN-FREE n next)))71 (lambda (sym) (compile x e s (list ASSIGN-GLOBAL sym next)))))69 (lambda (n) (compile x e s (list* ASSIGN-LOCAL n next))) 70 (lambda (n) (compile x e s (list* ASSIGN-FREE n next))) 71 (lambda (sym) (compile x e s (list* ASSIGN-GLOBAL sym next))))) 72 72 (call/cc (x) 73 (let ((c (list CONTI (tail? next)74 (list ARGUMENT73 (let ((c (list* CONTI (tail? next) 74 (list* ARGUMENT 75 75 (compile x e s 76 76 (if (tail? next) 77 (list SHIFT77 (list* SHIFT 78 78 1 79 79 (list APPLY 1)) … … 81 81 (if (tail? next) 82 82 c 83 (list FRAME c next))))83 (list* FRAME c next)))) 84 84 (else 85 85 (let ((func (car x)) 86 86 (args (cdr x))) 87 87 (compile-apply func args e s next))))) 88 (else (list CONSTANT x next))))88 (else (list* CONSTANT x next)))) 89 89 90 90 (define (compile-apply func args e s next) … … 94 94 (let ((c (compile func e s 95 95 (if (tail? next) 96 (list SHIFT96 (list* SHIFT 97 97 argnum 98 98 (list APPLY argnum)) … … 101 101 (if (tail? next) 102 102 bc 103 (list FRAME bc next)))))))103 (list* FRAME bc next))))))) 104 104 105 105 (define (compile-apply-args ap c e s) … … 110 110 (loop (cdr ap) 111 111 (compile (car ap) e s 112 (list ARGUMENT c))))))112 (list* ARGUMENT c)))))) 113 113 114 114 (define (direct-invoke? func) … … 151 151 (compile-lambda-bodies (car e) bodies (cdr e) sets s 152 152 next)) 153 (let ((c (list DIRECT-INVOKE (length args2)153 (let ((c (list* DIRECT-INVOKE (length args2) 154 154 (make-boxes sets proper-vars 155 155 (compile-lambda-bodies ext-vars bodies (cdr e) sets s … … 157 157 ((eq? (car next) RETURN-DIRECT) 158 158 (let ((argnum2 (cadr next)) 159 (nnext (c addr next)))160 (list RETURN-DIRECT159 (nnext (cddr next))) 160 (list* RETURN-DIRECT 161 161 (+ (length args2) argnum2) 162 162 nnext))) 163 163 (else 164 (list RETURN-DIRECT (length args2)164 (list* RETURN-DIRECT (length args2) 165 165 next)))))))) 166 166 (compile-apply-args args2 c e s)))))))) … … 177 177 -1)))) 178 178 (collect-free free e 179 (list CLOSE179 (list* CLOSE 180 180 varnum 181 181 (length free) … … 221 221 (collect-free (cdr vars) e 222 222 (compile-refer (car vars) e 223 (list ARGUMENT next)))))223 (list* ARGUMENT next))))) 224 224 225 225 (define (find-setses xs v) … … 250 250 next 251 251 (if (set-member? (car vars) sets) 252 (list BOX n (f (cdr vars) (+ n 1)))252 (list* BOX n (f (cdr vars) (+ n 1))) 253 253 (f (cdr vars) (+ n 1)))))) 254 254 255 255 (define (compile-refer x e next) 256 256 (compile-lookup x e 257 (lambda (n) (list REFER-LOCAL n next))258 (lambda (n) (list REFER-FREE n next))259 (lambda (sym) (list REFER-GLOBAL sym next))))257 (lambda (n) (list* REFER-LOCAL n next)) 258 (lambda (n) (list* REFER-FREE n next)) 259 (lambda (sym) (list* REFER-GLOBAL sym next)))) 260 260 261 261 (define (find-index x ls) … … 332 332 ; (error "stack error")) 333 333 a) 334 (REFER-LOCAL (n x)334 (REFER-LOCAL (n . x) 335 335 (VM (index f n) x f c s)) 336 (REFER-FREE (n x)336 (REFER-FREE (n . x) 337 337 (VM (index-closure c n) x f c s)) 338 (REFER-GLOBAL (sym x)338 (REFER-GLOBAL (sym . x) 339 339 (VM (refer-global sym (lambda () (error "unbound variable:" sym))) x f c s)) 340 (INDIRECT (x)340 (INDIRECT x 341 341 (VM (unbox a) x f c s)) 342 (CONSTANT (obj x)342 (CONSTANT (obj . x) 343 343 (VM obj x f c s)) 344 (CLOSE (argnum n body x)344 (CLOSE (argnum n body . x) 345 345 (VM (closure argnum body n s) x f c (- s n))) 346 (BOX (n x)346 (BOX (n . x) 347 347 (index-set! f n (box (index f n))) 348 348 (VM a x f c s)) 349 (TEST (then else)349 (TEST (then . else) 350 350 (VM a (if a then else) f c s)) 351 (ASSIGN-LOCAL (n x)351 (ASSIGN-LOCAL (n . x) 352 352 (set-box! (index f n) a) 353 353 (VM a x f c s)) 354 (ASSIGN-FREE (n x)354 (ASSIGN-FREE (n . x) 355 355 (set-box! (index-closure c n) a) 356 356 (VM a x f c s)) 357 (ASSIGN-GLOBAL (sym x)357 (ASSIGN-GLOBAL (sym . x) 358 358 (assign-global! sym a) 359 359 (VM a x f c s)) 360 (CONTI (tail? x)360 (CONTI (tail? . x) 361 361 (VM (continuation s tail?) x f c s)) 362 (NUATE (stack x)362 (NUATE (stack . x) 363 363 (VM a x f c (restore-stack stack))) 364 (FRAME (x ret)364 (FRAME (x . ret) 365 365 (VM a x f c (push ret (push f (push c s))))) 366 (ARGUMENT (x)366 (ARGUMENT x 367 367 (VM a x f c (push a s))) 368 (SHIFT (n x)368 (SHIFT (n . x) 369 369 (let ((m (index s (- n 1)))) ; 一つ前の呼び出しの引数の数 370 370 (VM a x f c (shift-args n m s)))) … … 379 379 (let ((s (- s argnum))) 380 380 (VM a (index s 0) (index s 1) (index s 2) (- s 4))))) 381 (DIRECT-INVOKE (argnum x)381 (DIRECT-INVOKE (argnum . x) 382 382 (expand-frame argnum f s) 383 383 (VM a x (+ f argnum) c s)) 384 (RETURN-DIRECT (n x)384 (RETURN-DIRECT (n . x) 385 385 (shrink-frame n f s) 386 386 (VM a x (- f n) c (- s n))) … … 479 479 (closure 480 480 '(1 . 1) ; argnum 481 (list REFER-LOCAL 0482 (list NUATE (save-stack ss)481 (list* REFER-LOCAL 0 482 (list* NUATE (save-stack ss) 483 483 (list RETURN))) 484 484 0 … … 577 577 (vrecord-case x 578 578 (HALT () (my-write `(HALT))) 579 (REFER-LOCAL (n x) (my-write `(REFER-LOCAL ,n : ,(index f n))))580 (REFER-FREE (n x) (my-write `(REFER-FREE ,n : ,(index-closure c n))))581 (REFER-GLOBAL (sym x) (my-write `(REFER-GLOBAL ,sym : ,(refer-global sym error))))582 (INDIRECT (x)(my-write `(INDIRECT : ,(unbox a))))583 (CONSTANT (obj x) (my-write `(CONSTANT ,obj)))584 (CLOSE (argnum n body x) (my-write `(CLOSE ,argnum ,n)))585 (BOX (n x) (my-write `(BOX ,n : ,(index f n))))586 (TEST (then else) (my-write `(TEST : ,a)))587 (ASSIGN-LOCAL (n x) (my-write `(ASSIGN-LOCAL ,n : ,a)))588 (ASSIGN-FREE (n x) (my-write `(ASSIGN-FREE ,n : ,a)))589 (ASSIGN-GLOBAL (sym x) (my-write `(ASSIGN-GLOBAL ,sym : ,a)))590 (CONTI (tail? x) (my-write `(CONTI ,tail?)))591 (NUATE (stack x) (my-write `(NUATE)))592 (FRAME (x ret) (my-write `(FRAME)))593 (ARGUMENT (x)(my-write `(ARGUMENT)))594 (SHIFT (n x) (my-write `(SHIFT ,n)))579 (REFER-LOCAL (n . x) (my-write `(REFER-LOCAL ,n : ,(index f n)))) 580 (REFER-FREE (n . x) (my-write `(REFER-FREE ,n : ,(index-closure c n)))) 581 (REFER-GLOBAL (sym . x) (my-write `(REFER-GLOBAL ,sym : ,(refer-global sym error)))) 582 (INDIRECT x (my-write `(INDIRECT : ,(unbox a)))) 583 (CONSTANT (obj . x) (my-write `(CONSTANT ,obj))) 584 (CLOSE (argnum n body . x) (my-write `(CLOSE ,argnum ,n))) 585 (BOX (n . x) (my-write `(BOX ,n : ,(index f n)))) 586 (TEST (then . else) (my-write `(TEST : ,a))) 587 (ASSIGN-LOCAL (n . x) (my-write `(ASSIGN-LOCAL ,n : ,a))) 588 (ASSIGN-FREE (n . x) (my-write `(ASSIGN-FREE ,n : ,a))) 589 (ASSIGN-GLOBAL (sym . x) (my-write `(ASSIGN-GLOBAL ,sym : ,a))) 590 (CONTI (tail? . x) (my-write `(CONTI ,tail?))) 591 (NUATE (stack . x) (my-write `(NUATE))) 592 (FRAME (x . ret) (my-write `(FRAME))) 593 (ARGUMENT x (my-write `(ARGUMENT))) 594 (SHIFT (n . x) (my-write `(SHIFT ,n))) 595 595 (APPLY (argnum) (my-write `(APPLY ,argnum))) 596 596 (RETURN () (my-write `(RETURN))) 597 (DIRECT-INVOKE (argnum x) (my-write `(DIRECT-INVOKE ,argnum)))598 (RETURN-DIRECT (n x) (my-write `(RETURN-DIRECT ,n)))597 (DIRECT-INVOKE (argnum . x) (my-write `(DIRECT-INVOKE ,argnum))) 598 (RETURN-DIRECT (n . x) (my-write `(RETURN-DIRECT ,n))) 599 599 (else 600 600 (error "unknown opcode" (car x))))
