計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著)ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著)Julie Sussman (原著)
Gerald Jay Sussman (原著)和田 英一 (翻訳)
開発環境
- OS X Yosemite - Apple (OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- Scheme (プログラミング言語)
- Gauche (処理系)
計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の5(レジスタ計算機での計算)、5.5(翻訳系)、5.5.6(文面アドレス)、問題 5.44.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題 5.44.
コード(BBEdit, Emacs)
compiler44.scm
;; -*- coding;: utf-8 -*-
(load "./operations44.scm")
(define (compile exp target linkage compile-time-env)
(cond ((self-evaluating? exp)
(compile-self-evaluating exp target linkage))
((quoted? exp) (compile-quoted exp target linkage))
((variable? exp)
(compile-variable exp target linkage compile-time-env))
((assignment? exp)
(compile-assignment exp target linkage compile-time-env))
((definition? exp)
(compile-definition exp target linkage compile-time-env))
((if? exp) (compile-if exp target linkage compile-time-env))
((lambda? exp) (compile-lambda exp target linkage compile-time-env))
((begin? exp)
(compile-sequence (begin-actions exp)
target
linkage
compile-time-env))
((cond? exp) (compile (cond->if exp) target linkage compile-time-env))
((open-code? exp compile-time-env)
(compile-open-code exp target linkage compile-time-env))
((application? exp)
(compile-application exp target linkage compile-time-env))
(else
(error "Unknown expression type -- COMPILE" exp))))
(define (make-instruction-sequence needs modifies statements)
(list needs modifies statements))
(define (empty-instruction-sequence)
(make-instruction-sequence '() '() '()))
(define (compile-linkage linkage)
(cond ((eq? linkage 'return)
(make-instruction-sequence '(continue) '()
'((goto (reg continue)))))
((eq? linkage 'next)
(empty-instruction-sequence))
(else
(make-instruction-sequence '() '()
`((goto (label ,linkage)))))))
(define (end-with-linkage linkage instruction-sequence)
(preserving '(continue)
instruction-sequence
(compile-linkage linkage)))
(define (compile-self-evaluating exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence
'()
(list target)
`((assign ,target (const ,exp))))))
(define (compile-quoted exp target linkage)
(end-with-linkage linkage
(make-instruction-sequence
'()
(list target)
`((assign ,target (const ,(text-of-quotation exp)))))))
(define (compile-variable exp target linkage compile-time-env)
(let ((lexical-address (find-variable exp compile-time-env)))
(end-with-linkage linkage
(make-instruction-sequence
'(env)
(list target)
(if (eq? lexical-address 'not-found)
`((assign ,target
(op lookup-variable-value)
(const ,exp)
(reg env)))
`((assign ,target
(op lexical-address-lookup)
(const ,lexical-address)
(reg env))))))))
(define (compile-assignment exp target linkage compile-time-env)
(let ((var (assignment-variable exp))
(get-value-code
(compile (assignment-value exp) 'val 'next compile-time-env)))
(let ((lexical-address (find-variable var compile-time-env)))
(end-with-linkage
linkage
(preserving '(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
(if (eq? lexical-address 'not-found)
`((perform (op set-variable-value!)
(const ,var)
(reg val)
(reg env))
(assign ,target (const ok)))
`((perform (op lexical-address-set!)
(const ,lexical-address)
(reg val)
(reg env))
(assign ,target (const ok))))))))))
(define (compile-definition exp target linkage compile-time-env)
(let ((var (definition-variable exp))
(get-value-code
(compile (definition-value exp) 'val 'next compile-time-env)))
(end-with-linkage
linkage
(preserving '(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
`((perform (op define-variable!)
(const ,var)
(reg val)
(reg env))
(assign ,target (const ok))))))))
(define (compile-open-code exp target linkage compile-time-env)
(let ((proc (operator exp))
(operand-codes
(map (lambda (operand) (compile operand 'val 'next compile-time-env))
(operands exp))))
(preserving
'(proc continue)
(spread-arguments operand-codes)
(compile-open-code-call proc target linkage))))
(define (spread-arguments operand-codes)
(let ((operand-codes (reverse operand-codes)))
(if (null? operand-codes)
(make-instruction-sequence
'()
'(argl)
'((assign argl (const ()))))
(let ((code-to-get-last-arg
(append-instruction-sequences
(car operand-codes)
(make-instruction-sequence
'(val)
'(argl)
'((assign argl (op list) (reg val)))))))
(if (null? (cdr operand-codes))
code-to-get-last-arg
(preserving '(env arg1 arg2)
code-to-get-last-arg
(code-to-get-rest-args
(cdr operand-codes))))))))
(define (compile-open-code-call proc target linkage)
(let ((entry (make-label 'entry))
(last-branch (make-label 'last-branch))
(after-call (make-label 'after-call)))
(let ((compiled-linkage
(if (eq? linkage 'next) after-call linkage)))
(append-instruction-sequences
entry
(make-instruction-sequence
'(argl)
(list target)
`((assign ,target (op length) (reg argl))
(test (op =) (reg argl) (const 2))
(branch (label ,last-branch))))
(make-instruction-sequence
'(argl arg1 arg2)
(list 'arg1 'arg2 target 'argl)
`((assign arg1 (op car) (reg argl))
(assign arg2 (op cadr) (reg argl))
(assign ,target (op ,proc) (reg arg1) (reg arg2))
(assign argl (op cdr) (reg argl))
(assign argl (op cons) (reg ,target) (reg argl))
(branch (label ,entry))))
last-branch
(end-with-linkage
linkage
(make-instruction-sequence
'(argl arg1 arg2)
(list target 'arg1 'arg2)
`((assign arg1 (op car) (reg argl))
(assign arg2 (op cadr) (reg argl))
(assign ,target (op ,proc) (reg arg1) (reg arg2)))))
after-call))))
(define (compile-if exp target linkage compile-time-env)
(let ((t-branch (make-label 'true-branch))
(f-branch (make-label 'false-branch))
(after-if (make-label 'after-if)))
(let ((consequent-linkage
(if (eq? linkage 'next) after-if linkage)))
(let ((p-code (compile (if-predicate exp) 'val 'next compile-time-env))
(c-code
(compile
(if-consequent exp) target consequent-linkage))
(a-code
(compile (if-alternative exp) target linkage compile-time-env)))
(preserving
'(env continue)
p-code
(append-instruction-sequences
(make-instruction-sequence
'(val)
'()
`((test (op false?) (reg val))
(branch (label ,f-branch))))
(parallel-instruction-sequences
(append-instruction-sequences t-branch c-code)
(append-instruction-sequences f-branch a-code))
after-if))))))
(define (compile-sequence seq target linkage compile-time-env)
(if (last-exp? seq)
(compile (first-exp seq) target linkage compile-time-env)
(preserving '(env continue)
(compile (first-exp seq) target 'next compile-time-env)
(compile-sequence (rest-exps seq)
target
linkage
compile-time-env))))
(define (compile-lambda exp target linkage compile-time-env)
(let ((proc-entry (make-label 'entry))
(after-lambda (make-label 'after-lambda)))
(let ((lambda-linkage
(if (eq? linkage 'next) after-lambda linkage)))
(append-instruction-sequences
(tack-on-instruction-sequence
(end-with-linkage
lambda-linkage
(make-instruction-sequence
'(env)
(list target)
`((assign ,target
(op make-compiled-procedure)
(label ,proc-entry)
(reg env)))))
(compile-lambda-body exp proc-entry compile-time-env))
after-lambda))))
(define (compile-lambda-body exp proc-entry compile-time-env)
(let ((formals (lambda-parameters exp)))
(append-instruction-sequences
(make-instruction-sequence
'(env proc argl)
'(env)
`(,proc-entry
(assign env (op compiled-procedure-env) (reg proc))
(assign env
(op extend-environment)
(const ,formals)
(reg argl)
(reg env))))
(compile-sequence (scan-out-defines (lambda-body exp))
'val
'return
(extend-compile-time-environment formals
compile-time-env)))))
(define (compile-application exp target linkage compile-time-env)
(let ((proc-code (compile (operator exp) 'proc 'next compile-time-env))
(operand-codes
(map (lambda (operand)
(compile operand 'val 'next compile-time-env))
(operands exp))))
(preserving '(env continue)
proc-code
(preserving '(proc continue)
(construct-arglist operand-codes)
(compile-procedure-call target
linkage
compile-time-env)))))
(define (construct-arglist operand-codes)
(let ((operand-codes (reverse operand-codes)))
(if (null? operand-codes)
(make-instruction-sequence
'()
'(argl)
'((assign argl (const ()))))
(let ((code-to-get-last-arg
(append-instruction-sequences
(car operand-codes)
(make-instruction-sequence
'(val)
'(argl)
'((assign argl (op list) (reg val)))))))
(if (null? (cdr operand-codes))
code-to-get-last-arg
(preserving '(env)
code-to-get-last-arg
(code-to-get-rest-args
(cdr operand-codes))))))))
(define (code-to-get-rest-args operand-codes)
(let ((code-for-next-arg
(preserving '(argl)
(car operand-codes)
(make-instruction-sequence
'(val argl)
'(argl)
'((assign argl (op cons) (reg val) (reg argl)))))))
(if (null? (cdr operand-codes))
code-for-next-arg
(preserving '(env)
code-for-next-arg
(code-to-get-rest-args (cdr operand-codes))))))
(define (compile-procedure-call target linkage compile-time-env)
(let ((primitive-branch (make-label 'primitive-branch))
(compiled-branch (make-label 'compiled-branch))
(after-call (make-label 'after-call)))
(let ((compiled-linkage
(if (eq? linkage 'next) after-call linkage)))
(append-instruction-sequences
(make-instruction-sequence
'(proc)
'()
`((test (op primitive-procedure?) (reg proc))
(branch (label ,primitive-branch))))
(parallel-instruction-sequences
(append-instruction-sequences
compiled-branch
(compile-proc-appl target compiled-linkage compile-time-env))
(append-instruction-sequences
primitive-branch
(end-with-linkage linkage
(make-instruction-sequence
'(proc argl)
(list target)
`((assign ,target
(op apply-primitive-procedure)
(reg proc)
(reg argl)))))))
after-call))))
(define (compile-proc-appl target linkage compile-time-env)
(cond ((and (eq? target 'val) (not (eq? linkage 'return)))
(make-instruction-sequence
'(proc)
all-regs
`((assign continue (label ,linkage))
(assign val
(op compiled-procedure-entry)
(reg proc))
(goto (reg val)))))
((and (not (eq? target 'val))
(not (eq? linkage 'return)))
(let ((proc-return (make-label 'proc-return)))
(make-instruction-sequence
'(proc)
all-regs
`((assign continue (label ,proc-return))
(assign val
(op compiled-procedure-entry)
(reg proc))
(goto (reg val))
,proc-return
(assign ,target (reg val))
(goto (label ,linkage))))))
((and (eq? target 'val) (eq? linkage 'return))
(make-instruction-sequence
'(proc continue)
all-regs
'((assign val
(op compiled-procedure-entry)
(reg proc))
(goto (reg val)))))
((and (not (eq? target 'val)) (eq? linkage 'return))
(error "return linkage, target not val -- COMPILE" target))))
(define (registers-needed s)
(if (symbol? s) '() (car s)))
(define (registers-modified s)
(if (symbol? s) '() (cadr s)))
(define (statements s)
(if (symbol? s) (list s) (caddr s)))
(define (needs-register? seq reg)
(memq reg (registers-needed seq)))
(define (modifies-register? seq reg)
(memq reg (registers-modified seq)))
(define (append-instruction-sequences . seqs)
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(list-difference (registers-needed seq2)
(registers-needed seq1)))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
(define (append-seq-list seqs)
(if (null? seqs)
(empty-instruction-sequence)
(append-2-sequences (car seqs)
(append-seq-list (cdr seqs)))))
(append-seq-list seqs))
(define (list-union s1 s2)
(cond ((null? s1) s2)
((memq (car s1) s2) (list-union (cdr s1) s2))
(else (cons (car s1) (list-union (cdr s1) s2)))))
(define (list-difference s1 s2)
(cond ((null? s1) '())
((memq (car s1) s2) (list-difference (cdr s1) s2))
(else (cons (car s1)
(list-difference (cdr s1) s2)))))
(define (preserving regs seq1 seq2)
(if (null? regs)
(append-instruction-sequences seq1 seq2)
(let ((first-reg (car regs)))
(if (and (needs-register? seq2 first-reg)
(modifies-register? seq1 first-reg))
(preserving (cdr regs)
(make-instruction-sequence
(list-union (list first-reg)
(registers-needed seq1))
(list-difference (registers-modified seq1)
(list first-reg))
(append `((save ,first-reg))
(statements seq1)
`((restore ,first-reg))))
seq2)
(preserving (cdr regs) seq1 seq2)))))
(define (tack-on-instruction-sequence seq body-seq)
(make-instruction-sequence
(registers-needed seq)
(registers-modified seq)
(append (statements seq) (statements body-seq))))
(define (parallel-instruction-sequences seq1 seq2)
(make-instruction-sequence
(list-union (registers-needed seq1)
(registers-needed seq2))
(list-union (registers-modified seq1)
(registers-modified seq2))
(append (statements seq1) (statements seq2))))
operations44.scm
;; -*- coding: utf-8 -*-
(load "./compile_time_environment.scm")
(define (prompt-for-input string)
(newline) (newline) (display string) (newline))
(define (get-global-environment) the-global-environment)
(define (announce-output string)
(newline) (display string) (newline))
(define (user-print object)
(if (compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>))
(display object)))
(define (self-evaluating? exp)
(cond ((number? exp) #t)
((string? exp) #t)
(else #f)))
(define (variable? exp) (symbol? exp))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
#f))
(define (quoted? exp) (tagged-list? exp 'quote))
(define (assignment? exp) (tagged-list? exp 'set!))
(define (definition? exp) (tagged-list? exp 'define))
(define (open-code? exp compile-time-env)
(and (eq? (find-variable (operator exp) compile-time-env)
'not-found)
(or (tagged-list? exp '=)
(tagged-list? exp '*)
(tagged-list? exp '-)
(tagged-list? exp '+))))
(define (if? exp) (tagged-list? exp 'if))
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (begin? exp) (tagged-list? exp 'begin))
(define (cond? exp) (tagged-list? exp 'cond))
(define (let? exp) (tagged-list? exp 'let))
(define (application? exp) (pair? exp))
(define (text-of-quotation exp) (cadr exp))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (scan-out-defines body)
(define (scan-define body)
(cond ((null? body) #f)
((definition? (car body)) #t)
(scan-define (cdr body))))
(define (define-vars body)
(cond ((null? body) '())
((definition? (car body))
(cons (definition-variable (car body))
(define-vars (cdr body))))
(else (define-vars (cdr body)))))
(define (define-vals body)
(cond ((null? body) '())
((definition? (car body))
(cons (definition-value (car body))
(define-vals (cdr body))))
(else (define-vals (cdr body)))))
(define (scan-body body)
(cond ((null? body) '())
((not (pair? (car body)))
(cons (car body) (scan-body (cdr body))))
((definition? (car body)) (scan-body (cdr body)))
(else (cons (car body) (scan-body (cdr body))))))
(if (scan-define body)
(let ((vars (define-vars body))
(vals (define-vals body))
(body (scan-body body)))
(cons 'let (append (map (lambda (var)
(list var ''*unassigned*))
vars)
(map (lambda (var val)
(list 'set! var val))
vars
vals)
body)))
body))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (operands exp) (cdr exp))
(define (operator exp) (car exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (empty-arglist) '())
(define (last-operand? ops) (null? (cdr ops)))
(define (adjoin-arg arg arglist) (append arglist (list arg)))
(define (rest-operands ops) (cdr ops))
(define (primitive-procedure? proc) (tagged-list? proc 'primitive))
(define (compound-procedure? p) (tagged-list? p 'procedure))
(define (primitive-implementation proc) (cadr proc))
(define apply-in-underlying-scheme apply)
(define (apply-primitive-procedure proc args)
(apply-in-underlying-scheme
(primitive-implementation proc) args))
(define (procedure-parameters p) (cadr p))
(define (procedure-environment p) (cadddr p))
(define (procedure-body p) (caddr p))
(define (begin-actions exp) (cdr exp))
(define (first-exp seq) (car seq))
(define (last-exp? seq) (null? (cdr seq)))
(define (rest-exps seq) (cdr seq))
(define (if-predicate exp) (cadr exp))
(define (true? x)
(not (eq? x #f)))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
'false))
(define (if-consequent exp) (caddr exp))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (expand-clauses clauses)
(if (null? clauses)
'false
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF" clauses))
(make-if (cond-predicate first)
(sequence->exp (cond-actions first))
(expand-clauses rest))))))
(define (cond->if exp) (expand-clauses (cond-clauses exp)))
(define (let-vars exp) (map car (cadr exp)))
(define (let-exps exp) (map cadr (cadr exp)))
(define (let-body exp) (cddr exp))
(define (let->combination exp)
(cons (make-lambda (let-vars exp)
(let-boy exp))
(let-exps exp)))
(define primitive-procedures
(list (list 'car car)
(list 'cdr cdr)
(list 'cons cons)
(list 'null? null?)
(list 'list list)
(list 'symbol? symbol?)
(list 'exit exit)
(list '= =)
(list '+ +)
(list '- -)
(list '* *)
(list '/ /)
(list '> >)
(list '< <)
))
(define (primitive-procedure-names)
(map car primitive-procedures))
(define (primitive-procedure-objects)
(map (lambda (proc)
(list 'primitive (cadr proc)))
primitive-procedures))
(define (setup-environment)
(let ((initial-env
(extend-environment (primitive-procedure-names)
(primitive-procedure-objects)
the-empty-environment)))
(define-variable! 'true #t initial-env)
(define-variable! 'false #f initial-env)
initial-env))
(define label-counter 0)
(define (new-label-number)
(set! label-counter (+ 1 label-counter))
label-counter)
(define (make-label name)
(string->symbol
(string-append (symbol->string name)
(number->string (new-label-number)))))
(define (make-compiled-procedure entry env)
(list 'compiled-procedure entry env))
(define (compiled-procedure? proc)
(tagged-list? proc 'compiled-procedure))
(define (compiled-procedure-entry c-proc) (cadr c-proc))
(define (compiled-procedure-env c-proc) (caddr c-proc))
(define all-regs '(env proc val argl continue))
sample44_1.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(load "./compiler44.scm")
(print (compile '((define a (lambda (x y) x))
(+ 5 10))
'val
'next
'()))
sample44_2.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(load "./compiler44.scm")
(print (compile '((define + (lambda (x y) x))
(+ 5 10))
'val
'next
'()))
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./sample44_1.scm ((env val argl arg1 arg2 proc) (arg1 arg2 env proc argl continue val) ((assign val (op make-compiled-procedure) (label entry1) (reg env)) (goto (label after-lambda2)) entry1 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (x y)) (reg argl) (reg env)) (assign val (op lookup-variable-value) (const let) (reg env)) (assign val (op lexical-address-lookup) (const (0 0)) (reg env)) (goto (reg continue)) after-lambda2 (perform (op define-variable!) (const a) (reg val) (reg env)) (assign proc (const ok)) (assign val (const 10)) (assign argl (op list) (reg val)) (assign val (const 5)) (assign argl (op cons) (reg val) (reg argl)) entry3 (assign val (op length) (reg argl)) (test (op =) (reg argl) (const 2)) (branch (label last-branch4)) (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) (assign argl (op cdr) (reg argl)) (assign argl (op cons) (reg val) (reg argl)) (branch (label entry3)) last-branch4 (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) after-call5 (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) compiled-branch7 (assign continue (label after-call8)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call8)) $ ./sample44_2.scm ((env val argl arg1 arg2 proc) (arg1 arg2 env proc argl continue val) ((assign val (op make-compiled-procedure) (label entry1) (reg env)) (goto (label after-lambda2)) entry1 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (x y)) (reg argl) (reg env)) (assign val (op lookup-variable-value) (const let) (reg env)) (assign val (op lexical-address-lookup) (const (0 0)) (reg env)) (goto (reg continue)) after-lambda2 (perform (op define-variable!) (const +) (reg val) (reg env)) (assign proc (const ok)) (assign val (const 10)) (assign argl (op list) (reg val)) (assign val (const 5)) (assign argl (op cons) (reg val) (reg argl)) entry3 (assign val (op length) (reg argl)) (test (op =) (reg argl) (const 2)) (branch (label last-branch4)) (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) (assign argl (op cdr) (reg argl)) (assign argl (op cons) (reg val) (reg argl)) (branch (label entry3)) last-branch4 (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) after-call5 (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) compiled-branch7 (assign continue (label after-call8)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call8)) $
見やすくするため、改行を挿入して修正。
レジスタ計算機。
(assign val (op make-compiled-procedure) (label entry1) (reg env)) (goto (label after-lambda2)) entry1 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (x y)) (reg argl) (reg env)) (assign val (op lookup-variable-value) (const let) (reg env)) (assign val (op lexical-address-lookup) (const (0 0)) (reg env)) (goto (reg continue)) after-lambda2 (perform (op define-variable!) (const a) (reg val) (reg env)) (assign proc (const ok)) (assign val (const 10)) (assign argl (op list) (reg val)) (assign val (const 5)) (assign argl (op cons) (reg val) (reg argl)) entry3 (assign val (op length) (reg argl)) (test (op =) (reg argl) (const 2)) (branch (label last-branch4)) (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) (assign argl (op cdr) (reg argl)) (assign argl (op cons) (reg val) (reg argl)) (branch (label entry3)) last-branch4 (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) after-call5 (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) compiled-branch7 (assign continue (label after-call8)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call8
オープンコード手続きの名前を再束縛した場合。
(assign val (op make-compiled-procedure) (label entry1) (reg env)) (goto (label after-lambda2)) entry1 (assign env (op compiled-procedure-env) (reg proc)) (assign env (op extend-environment) (const (x y)) (reg argl) (reg env)) (assign val (op lookup-variable-value) (const let) (reg env)) (assign val (op lexical-address-lookup) (const (0 0)) (reg env)) (goto (reg continue)) after-lambda2 (perform (op define-variable!) (const +) (reg val) (reg env)) (assign proc (const ok)) (assign val (const 10)) (assign argl (op list) (reg val)) (assign val (const 5)) (assign argl (op cons) (reg val) (reg argl)) entry3 (assign val (op length) (reg argl)) (test (op =) (reg argl) (const 2)) (branch (label last-branch4)) (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) (assign argl (op cdr) (reg argl)) (assign argl (op cons) (reg val) (reg argl)) (branch (label entry3)) last-branch4 (assign arg1 (op car) (reg argl)) (assign arg2 (op cadr) (reg argl)) (assign val (op +) (reg arg1) (reg arg2)) after-call5 (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch6)) compiled-branch7 (assign continue (label after-call8)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch6 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call8
0 コメント:
コメントを投稿