計算機プログラムの構造と解釈[第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.7(翻訳したコードと評価機のインターフェース)、解釈と翻訳、問題 5.49.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題 5.49.
コード(BBEdit, Emacs)
sample49.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(load "./compmachine.scm")
(start-compile-machine)
compmachine.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(load "./simulator.scm")
(load "./compiler.scm")
(define (initialize-stack)
(eceval 'initialize-stack))
(define operations
(list (list 'self-evaluating? self-evaluating?)
(list 'initialize-stack initialize-stack)
(list 'prompt-for-input prompt-for-input)
(list 'read read)
(list 'list list)
(list 'cons cons)
(list 'false? false?)
(list 'get-global-environment get-global-environment)
(list 'announce-output announce-output)
(list 'user-print user-print)
(list 'variable? variable?)
(list 'quoted? quoted?)
(list 'assignment? assignment?)
(list 'definition? definition?)
(list 'if? if?)
(list 'lambda? lambda?)
(list 'begin? begin?)
(list 'cond? cond?)
(list 'let? let?)
(list 'application? application?)
(list 'lookup-variable-value lookup-variable-value)
(list 'text-of-quotation text-of-quotation)
(list 'lambda-parameters lambda-parameters)
(list 'lambda-body lambda-body)
(list 'make-procedure make-procedure)
(list 'operands operands)
(list 'operator operator)
(list 'empty-arglist empty-arglist)
(list 'no-operands? no-operands?)
(list 'first-operand first-operand)
(list 'last-operand? last-operand?)
(list 'adjoin-arg adjoin-arg)
(list 'rest-operands rest-operands)
(list 'primitive-procedure? primitive-procedure?)
(list 'compound-procedure? compound-procedure?)
(list 'apply-primitive-procedure apply-primitive-procedure)
(list 'procedure-parameters procedure-parameters)
(list 'procedure-environment procedure-environment)
(list 'extend-environment extend-environment)
(list 'procedure-body procedure-body)
(list 'begin-actions begin-actions)
(list 'first-exp first-exp)
(list 'last-exp? last-exp?)
(list 'rest-exps rest-exps)
(list 'if-predicate if-predicate)
(list 'true? true?)
(list 'if-alternative if-alternative)
(list 'if-consequent if-consequent)
(list 'assignment-variable assignment-variable)
(list 'assignment-value assignment-value)
(list 'set-variable-value! set-variable-value!)
(list 'definition-variable definition-variable)
(list 'definition-value definition-value)
(list 'define-variable! define-variable!)
(list 'cond->if cond->if)
(list 'let->combination let->combination)
(list 'make-compiled-procedure make-compiled-procedure)
(list 'compiled-procedure? compiled-procedure?)
(list 'compiled-procedure-entry compiled-procedure-entry)
(list 'compiled-procedure-env compiled-procedure-env)
(list 'make-compile-machine make-compile-machine)
(list 'compile compile)
(list 'statements statements)
(list 'assemble assemble)
))
(define compile-machine
(make-machine
operations
'((assign machine (op make-compile-machine))
read-compile-print-loop
(perform (op initialize-stack))
(perform
(op prompt-for-input) (const ";;; Compile input:"))
(assign exp (op read))
(assign env (op get-global-environment))
(assign continue (label print-result))
(goto (label compile))
print-result
(perform (op print-stack-statisstics))
(perform
(op announce-output) (const ";;; Compile value:"))
(perform (op user-print) (reg val))
(goto (label read-compile-print-loop))
compile
(assign exp (op compile) (reg exp) (const val) (const return))
(assign exp (op statements) (reg exp))
(assign val (op assemble) (reg exp) (reg machine))
(goto (reg val))
)))
(define the-global-environment (setup-environment))
(define (start-compile-machine)
(set! the-global-environment (setup-environment))
(start compile-machine))
operations.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)
(cond ((compound-procedure? object)
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>)))
((compiled-procedure? object)
(display '<compiled-procedure>))
(else (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 (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 (false? x)
(not (true? x)))
(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 the-global-environment (setup-environment))
(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))
(define (make-compile-machine) compile-machine)
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./sample49.scm
;;; Compile input:
(define (factorial n)
(if (= n 1)
1
(* (factorial (- n 1)) n)))
(total-pushes = 0 maximum-depth = 0)
;;; Compile value:
ok
;;; Compile input:
(factorial 5)
(total-pushes = 26 maximum-depth = 14)
;;; Compile value:
120
;;; Compile input:
(exit)
$
0 コメント:
コメントを投稿