計算機プログラムの構造と解釈[第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.43.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題 5.43.
コード(BBEdit, Emacs)
compiler43.scm
;; -*- coding;: utf-8 -*-
(load "./operations43.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))
((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-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))))
operations43.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 (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))
sample43.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(load "./compiler43.scm")
(print (compile '(lambda ()
(define u 5)
'done)
'val
'next
'()))
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./sample43.scm ((env) (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 ()) (reg argl) (reg env)) (assign val (op lookup-variable-value) (const let) (reg env)) (save continue) (save env) (assign proc (op lookup-variable-value) (const u) (reg env)) (assign val (const *unassigned*)) (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch3)) compiled-branch4 (assign continue (label after-call5)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch3 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call5 (restore env) (restore continue) (assign val (const 5)) (perform (op set-variable-value!) (const u) (reg val) (reg env)) (assign val (const ok)) (assign val (const done)) (goto (reg continue)) after-lambda2)) $
見やすくするため、改行を挿入して修正。
レジスタ計算機。
(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 ()) (reg argl) (reg env)) (assign val (op lookup-variable-value) (const let) (reg env)) (save continue) (save env) (assign proc (op lookup-variable-value) (const u) (reg env)) (assign val (const *unassigned*)) (assign argl (op list) (reg val)) (test (op primitive-procedure?) (reg proc)) (branch (label primitive-branch3)) compiled-branch4 (assign continue (label after-call5)) (assign val (op compiled-procedure-entry) (reg proc)) (goto (reg val)) primitive-branch3 (assign val (op apply-primitive-procedure) (reg proc) (reg argl)) after-call5 (restore env) (restore continue) (assign val (const 5)) (perform (op set-variable-value!) (const u) (reg val) (reg env)) (assign val (const ok)) (assign val (const done)) (goto (reg continue)) after-lambda2
0 コメント:
コメントを投稿