![(please configure the [header_logo] section in trac.ini)](/share/chrome/site/your_project_logo.png){kind=logo}
Changeset 31324 for lang/scheme
- Timestamp:
- 03/17/09 23:33:05 (4 years ago)
- Location:
- lang/scheme/3imp
- Files:
-
- 3 added
- 2 modified
Legend:
- Unmodified
- Added
- Removed
-
lang/scheme/3imp/4.7.scm
r31243 r31324 22 22 23 23 (defops HALT 24 REFER-LOCAL25 REFER-FREE26 REFER-GLOBAL27 INDIRECT28 CONST ANT24 LREF 25 FREF 26 GREF 27 UNBOX 28 CONST 29 29 CLOSE 30 30 BOX 31 31 TEST 32 ASSIGN-LOCAL33 ASSIGN-FREE34 ASSIGN-GLOBAL32 LSET 33 FSET 34 GSET 35 35 CONTI 36 36 NUATE 37 37 FRAME 38 ARG UMENT38 ARG 39 39 SHIFT 40 40 APPLY 41 RET URN41 RET 42 42 43 DIRECT-INVOKE44 RETURN-DIRECT43 EXPAND 44 SHRINK 45 45 ) 46 46 … … 51 51 (compile-refer x e 52 52 (if (set-member? x s) 53 (list* INDIRECTnext)53 (list* UNBOX next) 54 54 next))) 55 55 ((pair? x) 56 56 (record-case x 57 (quote (obj) (list* CONST ANTobj next))57 (quote (obj) (list* CONST obj next)) 58 58 (lambda (vars . bodies) 59 59 (compile-lambda vars bodies e s next)) … … 67 67 (set! (var x) 68 68 (compile-lookup var e 69 (lambda (n) (compile x e s (list* ASSIGN-LOCALn next)))70 (lambda (n) (compile x e s (list* ASSIGN-FREEn next)))71 (lambda (sym) (compile x e s (list* ASSIGN-GLOBALsym next)))))69 (lambda (n) (compile x e s (list* LSET n next))) 70 (lambda (n) (compile x e s (list* FSET n next))) 71 (lambda (sym) (compile x e s (list* GSET sym next))))) 72 72 (call/cc (x) 73 73 (let ((c (list* CONTI (tail? next) 74 (list* ARG UMENT74 (list* ARG 75 75 (compile x e s 76 76 (if (tail? next) … … 86 86 (args (cdr x))) 87 87 (compile-apply func args e s next))))) 88 (else (list* CONST ANTx next))))88 (else (list* CONST x next)))) 89 89 90 90 (define (compile-apply func args e s next) … … 110 110 (loop (cdr ap) 111 111 (compile (car ap) e s 112 (list* ARG UMENTc))))))112 (list* ARG c)))))) 113 113 114 114 (define (direct-invoke? func) … … 147 147 (let ((args2 (check-argnum varnum args))) 148 148 (if (null? proper-vars) 149 ;; 変数なし(lambda () ...)： DIRECT-INVOKE～RETURN-DIRECT自体必要ない149 ;; 変数なし(lambda () ...)：EXPAND～SHRINK 自体必要ない 150 150 (make-boxes sets proper-vars 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* EXPAND (length args2) 154 154 (make-boxes sets proper-vars 155 155 (compile-lambda-bodies ext-vars bodies (cdr e) sets s 156 156 (cond ((tail? next) next) 157 ((eq? (car next) RETURN-DIRECT)157 ((eq? (car next) SHRINK) 158 158 (let ((argnum2 (cadr next)) 159 159 (nnext (cddr next))) 160 (list* RETURN-DIRECT160 (list* SHRINK 161 161 (+ (length args2) argnum2) 162 162 nnext))) 163 163 (else 164 (list* RETURN-DIRECT(length args2)164 (list* SHRINK (length args2) 165 165 next)))))))) 166 166 (compile-apply-args args2 c e s)))))))) … … 181 181 (length free) 182 182 (make-boxes sets proper-vars 183 (compile-lambda-bodies proper-vars bodies free sets s (list RET URN)))183 (compile-lambda-bodies proper-vars bodies free sets s (list RET))) 184 184 next))))) 185 185 … … 221 221 (collect-free (cdr vars) e 222 222 (compile-refer (car vars) e 223 (list* ARG UMENTnext)))))223 (list* ARG next))))) 224 224 225 225 (define (find-setses xs v) … … 255 255 (define (compile-refer x e next) 256 256 (compile-lookup x e 257 (lambda (n) (list* REFER-LOCALn next))258 (lambda (n) (list* REFER-FREEn next))259 (lambda (sym) (list* REFER-GLOBALsym next))))257 (lambda (n) (list* LREF n next)) 258 (lambda (n) (list* FREF n next)) 259 (lambda (sym) (list* GREF sym next)))) 260 260 261 261 (define (find-index x ls) … … 274 274 275 275 (define (tail? next) 276 (eq? (car next) RET URN))276 (eq? (car next) RET)) 277 277 278 278 … … 332 332 ; (error "stack error")) 333 333 a) 334 ( REFER-LOCAL(n . x)334 (LREF (n . x) 335 335 (VM (index f n) x f c s)) 336 ( REFER-FREE(n . x)336 (FREF (n . x) 337 337 (VM (index-closure c n) x f c s)) 338 ( REFER-GLOBAL(sym . x)338 (GREF (sym . x) 339 339 (VM (refer-global sym (lambda () (error "unbound variable:" sym))) x f c s)) 340 ( INDIRECTx340 (UNBOX x 341 341 (VM (unbox a) x f c s)) 342 (CONST ANT(obj . x)342 (CONST (obj . x) 343 343 (VM obj x f c s)) 344 344 (CLOSE (argnum n body . x) … … 349 349 (TEST (then . else) 350 350 (VM a (if a then else) f c s)) 351 ( ASSIGN-LOCAL(n . x)351 (LSET (n . x) 352 352 (set-box! (index f n) a) 353 353 (VM a x f c s)) 354 ( ASSIGN-FREE(n . x)354 (FSET (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 (GSET (sym . x) 358 358 (assign-global! sym a) 359 359 (VM a x f c s)) … … 364 364 (FRAME (x . ret) 365 365 (VM a x f c (push ret (push f (push c s))))) 366 (ARG UMENTx366 (ARG x 367 367 (VM a x f c (push a s))) 368 368 (SHIFT (n . x) … … 370 370 (VM a x f c (shift-args n m s)))) 371 371 (APPLY (argnum) 372 373 (RET URN()372 (do-apply argnum a s)) 373 (RET () 374 374 (do-return a s)) 375 ( DIRECT-INVOKE(argnum . x)375 (EXPAND (argnum . x) 376 376 (expand-frame argnum f s) 377 377 (VM a x (+ f argnum) c s)) 378 ( RETURN-DIRECT(n . x)378 (SHRINK (n . x) 379 379 (shrink-frame n f s) 380 380 (VM a x (- f n) c (- s n))) … … 489 489 (closure 490 490 '(1 . 1) ; argnum 491 (list* REFER-LOCAL0491 (list* LREF 0 492 492 (list* NUATE (save-stack ss) 493 (list RET URN)))493 (list RET))) 494 494 0 495 495 0))) … … 587 587 (vrecord-case x 588 588 (HALT () (my-write `(HALT))) 589 ( REFER-LOCAL (n . x) (my-write `(REFER-LOCAL,n : ,(index f n))))590 ( REFER-FREE (n . x) (my-write `(REFER-FREE,n : ,(index-closure c n))))591 ( REFER-GLOBAL (sym . x) (my-write `(REFER-GLOBAL,sym : ,(refer-global sym error))))592 ( INDIRECT x (my-write `(INDIRECT: ,(unbox a))))593 (CONST ANT (obj . x) (my-write `(CONSTANT ,obj)))589 (LREF (n . x) (my-write `(LREF ,n : ,(index f n)))) 590 (FREF (n . x) (my-write `(FREF ,n : ,(index-closure c n)))) 591 (GREF (sym . x) (my-write `(GREF ,sym : ,(refer-global sym error)))) 592 (UNBOX x (my-write `(UNBOX : ,(unbox a)))) 593 (CONST (obj . x) (my-write `(CONST ,obj))) 594 594 (CLOSE (argnum n body . x) (my-write `(CLOSE ,argnum ,n))) 595 595 (BOX (n . x) (my-write `(BOX ,n : ,(index f n)))) 596 596 (TEST (then . else) (my-write `(TEST : ,a))) 597 ( ASSIGN-LOCAL (n . x) (my-write `(ASSIGN-LOCAL,n : ,a)))598 ( ASSIGN-FREE (n . x) (my-write `(ASSIGN-FREE,n : ,a)))599 ( ASSIGN-GLOBAL (sym . x) (my-write `(ASSIGN-GLOBAL,sym : ,a)))597 (LSET (n . x) (my-write `(LSET ,n : ,a))) 598 (FSET (n . x) (my-write `(FSET ,n : ,a))) 599 (GSET (sym . x) (my-write `(GSET ,sym : ,a))) 600 600 (CONTI (tail? . x) (my-write `(CONTI ,tail?))) 601 601 (NUATE (stack . x) (my-write `(NUATE))) 602 602 (FRAME (x . ret) (my-write `(FRAME))) 603 (ARG UMENT x (my-write `(ARGUMENT)))603 (ARG x (my-write `(ARG))) 604 604 (SHIFT (n . x) (my-write `(SHIFT ,n))) 605 605 (APPLY (argnum) (my-write `(APPLY ,argnum))) 606 (RET URN () (my-write `(RETURN)))607 ( DIRECT-INVOKE (argnum . x) (my-write `(DIRECT-INVOKE,argnum)))608 ( RETURN-DIRECT (n . x) (my-write `(RETURN-DIRECT,n)))606 (RET () (my-write `(RET))) 607 (EXPAND (argnum . x) (my-write `(EXPAND ,argnum))) 608 (SHRINK (n . x) (my-write `(SHRINK ,n))) 609 609 (else 610 610 (error "unknown opcode" (car x)))) … … 639 639 640 640 (define (my-write s) 641 (define (abbrev? s sym) 642 (and (eq? (car s) sym) 643 (not (null? (cdr s))) 644 (null? (cddr s)))) 641 645 (cond ((my-procedure? s) 642 646 (display "#<proc>")) 643 647 ((pair? s) 644 (display "(") 645 (let loop ((first #t) 646 (ls s)) 647 (if (pair? ls) 648 (begin 649 (unless first (display " ")) 650 (my-write (car ls)) 651 (loop #f (cdr ls))) 652 (when (not (null? ls)) 653 (display " . ") 654 (my-write ls)))) 655 (display ")")) 648 (cond ((abbrev? s 'quote) (display #\') (my-write (cadr s))) 649 ((abbrev? s 'quasiquote) (display #\`) (my-write (cadr s))) 650 (else 651 (display "(") 652 (let loop ((first #t) 653 (ls s)) 654 (if (pair? ls) 655 (begin 656 (unless first (display " ")) 657 (my-write (car ls)) 658 (loop #f (cdr ls))) 659 (when (not (null? ls)) 660 (display " . ") 661 (my-write ls)))) 662 (display ")")))) 656 663 (else 657 664 (write s)))) 658 665 659 666 (define (comp x s) 660 (compile (comp-macroexpand-from-stack x s) '(()) '() (list RET URN)))667 (compile (comp-macroexpand-from-stack x s) '(()) '() (list RET))) 661 668 662 669 (define (run code s) … … 787 794 (define-primitive-function2 (vm-apply args s) 788 795 (apply vm-apply s (cadr args) (cddr args))) 796 797 (define-primitive-function2 (macroexpand args s) 798 (comp-macroexpand-from-stack (car args) s)) 799 (define-primitive-function2 (macroexpand-1 args s) 800 (comp-macroexpand-1-from-stack (car args) s)) 801 (define-primitive-function2 (disasm args s) 802 (let ((f (car args))) 803 (if (and (not (primitive-function? f)) 804 (my-procedure? f)) 805 (closure-body f) 806 #f))) 789 807 ) 790 808 … … 806 824 (define-special-form (quote . all) 807 825 `(quote ,@all)) 826 827 (define-special-form (lambda vars . bodies) 828 `(lambda ,vars ,@(map comp-macroexpand-1 bodies))) 808 829 809 830 (define-special-form (if . all) … … 904 925 (error "illegal case exp" clause)) 905 926 ((pair? (car clause)) 906 `(((eq? ,g ',(caar clause)) ,@(cdr clause)) 927 `((,(let loop ((p (car clause))) 928 (cond ((not (pair? p)) #f) 929 ((null? (cdr p)) `(eq? ,g ',(car p))) 930 (else `(if (eq? ,g ',(car p)) 931 #t 932 ,(loop (cdr p)))))) 933 ,@(cdr clause)) 907 934 ,@(loop (cdr clauses)))) 908 935 ;; else -
lang/scheme/3imp/opsym2code.scm
r31243 r31324 3 3 (define optbl 4 4 '((HALT ()) 5 ( REFER-LOCAL(n . $x))6 ( REFER-FREE(n . $x))7 ( REFER-GLOBAL(sym . $x))8 ( INDIRECT$x)9 (CONST ANT(obj . $x))5 (LREF (n . $x)) 6 (FREF (n . $x)) 7 (GREF (sym . $x)) 8 (UNBOX $x) 9 (CONST (obj . $x)) 10 10 (CLOSE (argnum n $body . $x)) 11 11 (BOX (n . $x)) 12 12 (TEST ($then . $else)) 13 ( ASSIGN-LOCAL(n . $x))14 ( ASSIGN-FREE(n . $x))15 ( ASSIGN-GLOBAL(sym . $x))13 (LSET (n . $x)) 14 (FSET (n . $x)) 15 (GSET (sym . $x)) 16 16 (CONTI (tail$ . $x)) 17 17 (NUATE (stack . $x)) 18 18 (FRAME ($x . $ret)) 19 (ARG UMENT$x)19 (ARG $x) 20 20 (SHIFT (n . $x)) 21 21 (APPLY (argnum)) 22 (RETURN ()) 23 (DIRECT-INVOKE (argnum . $x)) 24 (RETURN-DIRECT (n . $x)) 22 (RET ()) 23 (EXPAND (argnum . $x)) 24 (SHRINK (n . $x)) 25 26 (GREF-APPLY (sym n)) 27 (GREF-SHIFT-APPLY (sym n)) 28 (SHIFT-APPLY (n)) 29 (CONST-ARG (obj . $x)) 25 30 )) 26 31
