- Guileを使う
- rlwrapも使う
$ rlwrap -r -c guile
こんな感じで使う> ,q
で終了する> (load "foo.scm")
でソースコード読み込む> ,trace (f 3)
で関数の適用をトレースする
1~3章はこちら
;; 述語 | |
(define (true? x) (not (eq? x #f))) | |
(define (false? x) (eq? x #f)) | |
;; 手続きの表現 | |
(define (make-procedure parameters body env) | |
(list 'procedure parameters (scan-out-defines body) env)) | |
(define (compound-procedure? p) | |
(tagged-list? p 'procedure)) | |
(define (procedure-parameters p) (cadr p)) | |
(define (procedure-body p) (caddr p)) | |
(define (procedure-environment p) (cadddr p)) | |
;; 環境に対する演算 | |
(define (enclosing-environment env) (cdr env)) | |
(define (first-frame env) (car env)) | |
(define the-empty-environment `()) | |
(define (make-frame variables values) | |
(cons variables values)) | |
(define (frame-variables frame) (car frame)) | |
(define (frame-values frame) (cdr frame)) | |
(define (add-binding-to-frame! var val frame) | |
(set-car! frame (cons var (car frame))) | |
(set-cdr! frame (cons val (cdr frame)))) | |
(define (extend-environment vars vals base-env) | |
(if (= (length vars) (length vals)) | |
(cons (make-frame vars vals) base-env) | |
(if (< (length vars) (length vals)) | |
(error "Too many arguments supplied" vars vals) | |
(error "Too few arguments supplied" vars vals)))) | |
(define (lookup-variable-value var env) | |
(define (env-loop env) | |
(define (scan vars vals) | |
(cond ((null? vars) (env-loop (enclosing-environment env))) | |
((eq? var (car vars)) | |
(if (eq? (car vals) '*unassigned*) | |
(error "Unassigned variable" var) | |
(car vals))) | |
(else (scan (cdr vars) (cdr vals))))) | |
(if (eq? env the-empty-environment) | |
(error "Unbound variable" var) | |
(let ((frame (first-frame env))) | |
(scan (frame-variables frame) | |
(frame-values frame))))) | |
(env-loop env)) | |
(define (set-variable-value! var val env) | |
(define (env-loop env) | |
(define (scan vars vals) | |
(cond ((null? vars) (env-loop (enclosing-environment env))) | |
((eq? var (car vars)) (set-car! vals val)) | |
(else (scan (cdr vars) (cdr vals))))) | |
(if (eq? env the-empty-environment) | |
(error "Unbound variable: SET!" var) | |
(let ((frame (first-frame env))) | |
(scan (frame-variables frame) | |
(frame-values frame))))) | |
(env-loop env)) | |
(define (define-variable! var val env) | |
(let ((frame (first-frame env))) | |
(define (scan vars vals) | |
(cond ((null? vars) (add-binding-to-frame! var val frame)) | |
((eq? var (car vars)) (set-car! vals val)) | |
(else (scan (cdr vars) (cdr vals))))) | |
(scan (frame-variables frame) (frame-values frame)))) | |
;; 基本手続き | |
(define apply-in-underlying-scheme apply) ; guileのapplyを退避させる | |
(define (primitive-procedure? proc) | |
(tagged-list? proc 'primitive)) | |
(define (primitive-implementation proc) (cadr proc)) | |
(define (apply-primitive-procedure proc args) | |
(apply-in-underlying-scheme (primitive-implementation proc) args)) | |
(define primitive-procedures | |
(list (list 'car car) | |
(list 'cdr cdr) | |
(list 'cadr cadr) | |
(list 'cddr cddr) | |
(list 'cons cons) | |
(list 'null? null?) | |
(list 'assoc assoc) | |
(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 (tagged-list? exp tag) | |
(if (pair? exp) | |
(eq? (car exp) tag) | |
#f)) | |
;; 自己評価式 | |
;; e.g. 1, "Hello World" | |
(define (self-evaluating? exp) | |
(cond ((number? exp) #t) | |
((string? exp) #t) | |
(else #f))) | |
;; 変数 | |
;; e.g. x, y | |
(define (variable? exp) (symbol? exp)) | |
;; クォート式 | |
;; e.g. (quote foo) | |
(define (quoted? exp) (tagged-list? exp 'quote)) | |
(define (text-of-quotation exp) (cadr exp)) | |
;; 代入 | |
;; e.g. (set! x 10) | |
(define (assignment? exp) (tagged-list? exp 'set!)) | |
(define (assignment-variable exp) (cadr exp)) | |
(define (assignment-value exp) (caddr exp)) | |
;; 定義 | |
;; e.g. (define x 11), (define (double x) (* x x)) | |
(define (definition? exp) (tagged-list? exp 'define)) | |
(define (definition-variable exp) | |
(if (symbol? (cadr exp)) | |
(cadr exp) | |
(caadr exp))) | |
(define (definition-value exp) | |
(if (symbol? (cadr exp)) | |
(caddr exp) | |
(make-lambda (cdadr exp) | |
(cddr exp)))) | |
;; lambda式 | |
;; e.g. (lambda (x) (* x x)) | |
(define (lambda? exp) (tagged-list? exp 'lambda)) | |
(define (lambda-parameters exp) (cadr exp)) | |
(define (lambda-body exp) (cddr exp)) | |
(define (make-lambda parameters body) | |
(cons 'lambda (cons parameters body))) | |
;; and | |
(define (and? exp) (tagged-list? exp 'and)) | |
(define (and-exps exp) (cdr exp)) | |
;; or | |
(define (or? exp) (tagged-list? exp 'or)) | |
(define (or-exps exp) (cdr exp)) | |
;; if式 | |
(define (if? exp) (tagged-list? exp 'if)) | |
(define (if-predicate exp) (cadr exp)) | |
(define (if-consequent exp) (caddr exp)) | |
(define (if-alternative exp) | |
(if (not (null? (cddr exp))) | |
(cadddr exp) | |
#f)) | |
(define (make-if predicate consequent alternative) | |
(list 'if predicate consequent alternative)) | |
;; begin | |
(define (begin? exp) (tagged-list? exp 'begin)) | |
(define (begin-actions exp) (cdr exp)) | |
(define (last-exp? seq) (null? (cdr seq))) | |
(define (first-exp seq) (car seq)) | |
(define (rest-exps seq) (cdr seq)) | |
(define (sequence->exp seq) | |
(cond ((null? seq) seq) | |
((last-exp? seq) (first-exp seq)) | |
(else (make-begin seq)))) | |
(define (make-begin seq) (cons 'begin seq)) | |
;; その他 | |
(define (application? exp) (pair? exp)) | |
(define (operator exp) (car exp)) | |
(define (operands exp) (cdr exp)) | |
(define (no-operands? ops) (null? ops)) | |
(define (first-operand ops) (car ops)) | |
(define (rest-operands ops) (cdr ops)) | |
;;; 派生式 | |
;; cond | |
(define (cond? exp) (tagged-list? exp 'cond)) | |
(define (cond-clauses exp) (cdr exp)) | |
(define (cond-else-clause? clause) | |
(eq? (cond-predicate clause) 'else)) | |
(define (cond-predicate clause) (car clause)) | |
(define (cond-actions clause) (cdr clause)) | |
(define (cond->if exp) (expand-clauses (cond-clauses exp))) | |
(define (expand-clauses clauses) | |
(if (null? clauses) | |
#f | |
(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) | |
(if (eq? (car (cond-actions first)) '=>) | |
(list (cadr (cond-actions first)) (cond-predicate first)) | |
(sequence->exp (cond-actions first))) | |
(expand-clauses rest)))))) | |
;; let | |
(define (let? exp) (tagged-list? exp 'let)) | |
(define (let-args exp) | |
(let ((bindings (cadr exp))) | |
(map car bindings))) | |
(define (let-exps exp) | |
(let ((bindings (cadr exp))) | |
(map cadr bindings))) | |
(define (let-body exp) (cddr exp)) | |
(define (named-let-args exp) | |
(let ((bindings (caddr exp))) | |
(map car bindings))) | |
(define (named-let-exps exp) | |
(let ((bindings (caddr exp))) | |
(map cdr bindings))) | |
(define (named-let-body exp) (cadddr exp)) | |
(define (let->combination exp) | |
(if (symbol? (cadr exp)) | |
(let ((f-name (cadr exp))) | |
(make-begin | |
(list | |
(list 'define (cons f-name (named-let-args exp)) | |
(named-let-body exp)) | |
(cons f-name (named-let-exps exp))))) | |
(cons (make-lambda (let-args exp) (let-body exp)) | |
(let-exps exp)))) | |
;; let* | |
(define (let*? exp) (tagged-list? exp 'let*)) | |
(define (let*-body exp) (cddr exp)) | |
(define (let*->nested-lets exp) | |
(define (iter varexps) | |
(if (null? varexps) | |
(let*-body exp) | |
(list 'let (list (car varexps)) (iter (cdr varexps))))) | |
(iter (cadr exp))) | |
;; 内部定義 | |
(define (scan-out-defines exp) | |
(define (has-define? exp) | |
(if (null? exp) | |
#f | |
(if (definition? (car exp)) | |
#t | |
(has-define? (cdr exp))))) | |
(define (body exp) | |
(if (tagged-list? (car exp) 'define) | |
(body (cdr exp)) | |
exp)) | |
(define (iter exp acc) | |
(if (tagged-list? (car exp) 'define) | |
(iter (cdr exp) | |
(cons (cons (cons (definition-variable (car exp)) (cons ''*unassigned* `())) (car acc)) | |
(cons (list 'set! (definition-variable (car exp)) (definition-value (car exp))) (cdr acc)))) | |
(cons (reverse (car acc)) (reverse (cdr acc))))) | |
(if (has-define? exp) | |
(let ((varexps-sets (iter exp (cons `() `())))) | |
(list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp)))))) | |
exp)) | |
;;;;;;;;;; | |
;;; サンクの表現 | |
(define (delay-it exp env) | |
(list 'thunk exp env)) | |
(define (thunk? obj) | |
(tagged-list? obj 'thunk)) | |
(define (thunk-exp thunk) (cadr thunk)) | |
(define (thunk-env thunk) (caddr thunk)) | |
(define (evaluated-thunk? obj) | |
(tagged-list? obj 'evaluated-thunk)) | |
(define (thunk-value evaluated-thunk) | |
(cadr evaluated-thunk)) | |
(define (force-it obj) | |
(cond ((thunk? obj) | |
(let ((result (actual-value (thunk-exp obj) | |
(thunk-env obj)))) | |
(set-car! obj 'evaluated-thunk) | |
(set-car! (cdr obj) result) ; expを計算後の値で置き換える | |
(set-cdr! (cdr obj) `()) ; 計算後で不要になったenvを忘れる | |
result)) | |
((evaluated-thunk? obj) (thunk-value obj)) | |
(else obj))) | |
(define (actual-value exp env) | |
(force-it (eval exp env))) | |
(define (list-of-arg-values exps env) | |
(if (no-operands? exps) | |
`() | |
(cons (actual-value (first-operand exps) env) | |
(list-of-arg-values (rest-operands exps) env)))) | |
(define (list-of-delayed-args exps env) | |
(if (no-operands? exps) | |
`() | |
(cons (delay-it (first-operand exps) env) | |
(list-of-delayed-args (rest-operands exps) env)))) | |
;;;;;;;;;; | |
;;; 評価手続き | |
(define (list-of-values exps env) | |
(define (first-operand exps) (car exps)) | |
(if (no-operands? exps) | |
`() | |
(let ((first (eval (first-operand exps) env))) | |
(cons first (list-of-values (rest-operands exps) env))))) | |
(define (eval-and exps env) | |
(if (false? (actual-value (first-exp exps) env)) | |
#f | |
(if (last-exp? exps) | |
#t | |
(eval-and (rest-exps exps) env)))) | |
(define (eval-or exps env) | |
(if (true? (actual-value (first-exp exps) env)) | |
#t | |
(if (last-exp? exps) | |
#f | |
(eval-or (rest-exps exps) env)))) | |
(define (eval-if exp env) | |
(if (true? (actual-value (if-predicate exp) env)) | |
(eval (if-consequent exp) env) | |
(eval (if-alternative exp) env))) | |
(define (eval-sequence exps env) | |
(cond ((last-exp? exps) (eval (first-exp exps) env)) | |
(else | |
(eval (first-exp exps) env) | |
(eval-sequence (rest-exps exps) env)))) | |
(define (eval-assignment exp env) | |
(set-variable-value! (assignment-variable exp) | |
(eval (assignment-value exp) env) | |
env) | |
'ok) | |
(define (eval-definition exp env) | |
(define-variable! (definition-variable exp) | |
(eval (definition-value exp) env) | |
env) | |
'ok) | |
(define (apply procedure arguments env) | |
(cond ((primitive-procedure? procedure) | |
(apply-primitive-procedure procedure | |
(list-of-arg-values arguments env))) | |
((compound-procedure? procedure) | |
(eval-sequence (procedure-body procedure) | |
(extend-environment (procedure-parameters procedure) | |
(list-of-delayed-args arguments env) | |
(procedure-environment procedure)))) | |
(else (error "Unknown procedure type: APPLY" procedure)))) | |
;; eval | |
(define (eval exp env) | |
;; ここで場合わけしているので、新たな式の型が増えた場合に追加する必要がある | |
(cond ((self-evaluating? exp) exp) | |
((variable? exp) (lookup-variable-value exp env)) | |
((quoted? exp) (text-of-quotation exp)) | |
((assignment? exp) (eval-assignment exp env)) | |
((definition? exp) (eval-definition exp env)) | |
((and? exp) (eval-and (and-exps exp) env)) | |
((or? exp) (eval-or (or-exps exp) env)) | |
((if? exp) (eval-if exp env)) | |
((lambda? exp) (make-procedure (lambda-parameters exp) | |
(lambda-body exp) | |
env)) | |
((begin? exp) (eval-sequence (begin-actions exp) env)) | |
((cond? exp) (eval (cond->if exp) env)) | |
((let? exp) (eval (let->combination exp) env)) | |
((let*? exp) (eval (let*->nested-lets exp) env)) | |
((application? exp) | |
(apply (actual-value (operator exp) env) | |
(operands exp) | |
env)) | |
(else (error "Unknown expression type: EVAL" exp)) | |
)) | |
;;;;;;;;;; | |
;;; ドライバループ | |
(define the-global-environment (setup-environment)) | |
(define input-prompt ";;; L-Eval input:") | |
(define output-prompt ";;; L-Eval value:") | |
(define (driver-loop) | |
(prompt-for-input input-prompt) | |
(let ((input (read))) | |
(let ((output (actual-value input the-global-environment))) | |
(announce-output output-prompt) | |
(user-print output))) | |
(driver-loop)) | |
(define (prompt-for-input string) | |
(newline) (display string) (newline)) | |
(define (announce-output string) | |
(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 (true? x) (not (eq? x #f))) | |
(define (false? x) (eq? x #f)) | |
;; 手続きの表現 | |
(define (make-procedure parameters body env) | |
(list 'procedure parameters (scan-out-defines body) env)) | |
(define (compound-procedure? p) | |
(tagged-list? p 'procedure)) | |
(define (procedure-parameters p) (cadr p)) | |
(define (procedure-body p) (caddr p)) | |
(define (procedure-environment p) (cadddr p)) | |
;; 環境に対する演算 | |
(define (enclosing-environment env) (cdr env)) | |
(define (first-frame env) (car env)) | |
(define the-empty-environment `()) | |
(define (make-frame variables values) | |
(cons variables values)) | |
(define (frame-variables frame) (car frame)) | |
(define (frame-values frame) (cdr frame)) | |
(define (add-binding-to-frame! var val frame) | |
(set-car! frame (cons var (car frame))) | |
(set-cdr! frame (cons val (cdr frame)))) | |
(define (extend-environment vars vals base-env) | |
(if (= (length vars) (length vals)) | |
(cons (make-frame vars vals) base-env) | |
(if (< (length vars) (length vals)) | |
(error "Too many arguments supplied" vars vals) | |
(error "Too few arguments supplied" vars vals)))) | |
(define (lookup-variable-value var env) | |
(define (env-loop env) | |
(define (scan vars vals) | |
(cond ((null? vars) (env-loop (enclosing-environment env))) | |
((eq? var (car vars)) | |
(if (eq? (car vals) '*unassigned*) | |
(error "Unassigned variable" var) | |
(car vals))) | |
(else (scan (cdr vars) (cdr vals))))) | |
(if (eq? env the-empty-environment) | |
(error "Unbound variable" var) | |
(let ((frame (first-frame env))) | |
(scan (frame-variables frame) | |
(frame-values frame))))) | |
(env-loop env)) | |
(define (set-variable-value! var val env) | |
(define (env-loop env) | |
(define (scan vars vals) | |
(cond ((null? vars) (env-loop (enclosing-environment env))) | |
((eq? var (car vars)) (set-car! vals val)) | |
(else (scan (cdr vars) (cdr vals))))) | |
(if (eq? env the-empty-environment) | |
(error "Unbound variable: SET!" var) | |
(let ((frame (first-frame env))) | |
(scan (frame-variables frame) | |
(frame-values frame))))) | |
(env-loop env)) | |
(define (define-variable! var val env) | |
(let ((frame (first-frame env))) | |
(define (scan vars vals) | |
(cond ((null? vars) (add-binding-to-frame! var val frame)) | |
((eq? var (car vars)) (set-car! vals val)) | |
(else (scan (cdr vars) (cdr vals))))) | |
(scan (frame-variables frame) (frame-values frame)))) | |
;; 基本手続き | |
(define apply-in-underlying-scheme apply) ; guileのapplyを退避させる | |
(define (primitive-procedure? proc) | |
(tagged-list? proc 'primitive)) | |
(define (primitive-implementation proc) (cadr proc)) | |
(define (apply-primitive-procedure proc args) | |
(apply-in-underlying-scheme (primitive-implementation proc) args)) | |
(define primitive-procedures | |
(list (list 'car car) | |
(list 'cdr cdr) | |
(list 'cadr cadr) | |
(list 'cddr cddr) | |
(list 'cons cons) | |
(list 'null? null?) | |
(list 'assoc assoc) | |
(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 (tagged-list? exp tag) | |
(if (pair? exp) | |
(eq? (car exp) tag) | |
#f)) | |
;; 自己評価式 | |
;; e.g. 1, "Hello World" | |
(define (self-evaluating? exp) | |
(cond ((number? exp) #t) | |
((string? exp) #t) | |
(else #f))) | |
;; 変数 | |
;; e.g. x, y | |
(define (variable? exp) (symbol? exp)) | |
;; クォート式 | |
;; e.g. (quote foo) | |
(define (quoted? exp) (tagged-list? exp 'quote)) | |
(define (text-of-quotation exp) (cadr exp)) | |
;; 代入 | |
;; e.g. (set! x 10) | |
(define (assignment? exp) (tagged-list? exp 'set!)) | |
(define (assignment-variable exp) (cadr exp)) | |
(define (assignment-value exp) (caddr exp)) | |
;; 定義 | |
;; e.g. (define x 11), (define (double x) (* x x)) | |
(define (definition? exp) (tagged-list? exp 'define)) | |
(define (definition-variable exp) | |
(if (symbol? (cadr exp)) | |
(cadr exp) | |
(caadr exp))) | |
(define (definition-value exp) | |
(if (symbol? (cadr exp)) | |
(caddr exp) | |
(make-lambda (cdadr exp) | |
(cddr exp)))) | |
;; lambda式 | |
;; e.g. (lambda (x) (* x x)) | |
(define (lambda? exp) (tagged-list? exp 'lambda)) | |
(define (lambda-parameters exp) (cadr exp)) | |
(define (lambda-body exp) (cddr exp)) | |
(define (make-lambda parameters body) | |
(cons 'lambda (cons parameters body))) | |
;; and | |
(define (and? exp) (tagged-list? exp 'and)) | |
(define (and-exps exp) (cdr exp)) | |
;; or | |
(define (or? exp) (tagged-list? exp 'or)) | |
(define (or-exps exp) (cdr exp)) | |
;; if式 | |
(define (if? exp) (tagged-list? exp 'if)) | |
(define (if-predicate exp) (cadr exp)) | |
(define (if-consequent exp) (caddr exp)) | |
(define (if-alternative exp) | |
(if (not (null? (cddr exp))) | |
(cadddr exp) | |
#f)) | |
(define (make-if predicate consequent alternative) | |
(list 'if predicate consequent alternative)) | |
;; begin | |
(define (begin? exp) (tagged-list? exp 'begin)) | |
(define (begin-actions exp) (cdr exp)) | |
(define (last-exp? seq) (null? (cdr seq))) | |
(define (first-exp seq) (car seq)) | |
(define (rest-exps seq) (cdr seq)) | |
(define (sequence->exp seq) | |
(cond ((null? seq) seq) | |
((last-exp? seq) (first-exp seq)) | |
(else (make-begin seq)))) | |
(define (make-begin seq) (cons 'begin seq)) | |
;; その他 | |
(define (application? exp) (pair? exp)) | |
(define (operator exp) (car exp)) | |
(define (operands exp) (cdr exp)) | |
(define (no-operands? ops) (null? ops)) | |
(define (first-operand ops) (car ops)) | |
(define (rest-operands ops) (cdr ops)) | |
;;; 派生式 | |
;; cond | |
(define (cond? exp) (tagged-list? exp 'cond)) | |
(define (cond-clauses exp) (cdr exp)) | |
(define (cond-else-clause? clause) | |
(eq? (cond-predicate clause) 'else)) | |
(define (cond-predicate clause) (car clause)) | |
(define (cond-actions clause) (cdr clause)) | |
(define (cond->if exp) (expand-clauses (cond-clauses exp))) | |
(define (expand-clauses clauses) | |
(if (null? clauses) | |
#f | |
(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) | |
(if (eq? (car (cond-actions first)) '=>) | |
(list (cadr (cond-actions first)) (cond-predicate first)) | |
(sequence->exp (cond-actions first))) | |
(expand-clauses rest)))))) | |
;; let | |
(define (let? exp) (tagged-list? exp 'let)) | |
(define (let-args exp) | |
(let ((bindings (cadr exp))) | |
(map car bindings))) | |
(define (let-exps exp) | |
(let ((bindings (cadr exp))) | |
(map cadr bindings))) | |
(define (let-body exp) (cddr exp)) | |
(define (named-let-args exp) | |
(let ((bindings (caddr exp))) | |
(map car bindings))) | |
(define (named-let-exps exp) | |
(let ((bindings (caddr exp))) | |
(map cdr bindings))) | |
(define (named-let-body exp) (cadddr exp)) | |
(define (let->combination exp) | |
(if (symbol? (cadr exp)) | |
(let ((f-name (cadr exp))) | |
(make-begin | |
(list | |
(list 'define (cons f-name (named-let-args exp)) | |
(named-let-body exp)) | |
(cons f-name (named-let-exps exp))))) | |
(begin | |
(newline) | |
(display (cons (make-lambda (let-args exp) (let-body exp)) (let-exps exp))) | |
(newline) | |
(cons (make-lambda (let-args exp) (let-body exp)) | |
(let-exps exp))))) | |
;; let* | |
(define (let*? exp) (tagged-list? exp 'let*)) | |
(define (let*-body exp) (cddr exp)) | |
(define (let*->nested-lets exp) | |
(define (iter varexps) | |
(if (null? varexps) | |
(let*-body exp) | |
(list 'let (list (car varexps)) (iter (cdr varexps))))) | |
(iter (cadr exp))) | |
;; 内部定義 | |
(define (scan-out-defines exp) | |
(define (has-define? exp) | |
(if (null? exp) | |
#f | |
(if (definition? (car exp)) | |
#t | |
(has-define? (cdr exp))))) | |
(define (body exp) | |
(if (tagged-list? (car exp) 'define) | |
(body (cdr exp)) | |
exp)) | |
(define (iter exp acc) | |
(if (tagged-list? (car exp) 'define) | |
(iter (cdr exp) | |
(cons (cons (cons (definition-variable (car exp)) (cons ''*unassigned* `())) (car acc)) | |
(cons (list 'set! (definition-variable (car exp)) (definition-value (car exp))) (cdr acc)))) | |
(cons (reverse (car acc)) (reverse (cdr acc))))) | |
(if (has-define? exp) | |
(let ((varexps-sets (iter exp (cons `() `())))) | |
(newline) | |
(display (list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp) ))))) | |
(newline) | |
(list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp)))))) | |
exp)) | |
;;;;;;;;;; | |
;;; 評価手続き | |
(define (list-of-values exps env) | |
(define (first-operand exps) (car exps)) | |
(if (no-operands? exps) | |
`() | |
(let ((first (eval (first-operand exps) env))) | |
(cons first (list-of-values (rest-operands exps) env))))) | |
(define (eval-and exps env) | |
(if (false? (eval (first-exp exps) env)) | |
#f | |
(if (last-exp? exps) | |
#t | |
(eval-and (rest-exps exps) env)))) | |
(define (eval-or exps env) | |
(if (true? (eval (first-exp exps) env)) | |
#t | |
(if (last-exp? exps) | |
#f | |
(eval-or (rest-exps exps) env)))) | |
(define (eval-if exp env) | |
(if (true? (eval (if-predicate exp) env)) | |
(eval (if-consequent exp) env) | |
(eval (if-alternative exp) env))) | |
(define (eval-sequence exps env) | |
(cond ((last-exp? exps) (eval (first-exp exps) env)) | |
(else | |
(eval (first-exp exps) env) | |
(eval-sequence (rest-exps exps) env)))) | |
(define (eval-assignment exp env) | |
(set-variable-value! (assignment-variable exp) | |
(eval (assignment-value exp) env) | |
env) | |
'ok) | |
(define (eval-definition exp env) | |
(define-variable! (definition-variable exp) | |
(eval (definition-value exp) env) | |
env) | |
'ok) | |
(define (apply procedure arguments) | |
(cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure arguments)) | |
((compound-procedure? procedure) | |
(eval-sequence (procedure-body procedure) | |
(extend-environment (procedure-parameters procedure) | |
arguments | |
(procedure-environment procedure)))) | |
(else error "Unknown procedure type: APPLY" procedure) | |
)) | |
;; eval | |
(define (eval exp env) | |
;; ここで場合わけしているので、新たな式の型が増えた場合に追加する必要がある | |
(cond ((self-evaluating? exp) exp) | |
((variable? exp) (lookup-variable-value exp env)) | |
((quoted? exp) (text-of-quotation exp)) | |
((assignment? exp) (eval-assignment exp env)) | |
((definition? exp) (eval-definition exp env)) | |
((and? exp) (eval-and (and-exps exp) env)) | |
((or? exp) (eval-or (or-exps exp) env)) | |
((if? exp) (eval-if exp env)) | |
((lambda? exp) (make-procedure (lambda-parameters exp) | |
(lambda-body exp) | |
env)) | |
((begin? exp) (eval-sequence (begin-actions exp) env)) | |
((cond? exp) (eval (cond->if exp) env)) | |
((let? exp) (eval (let->combination exp) env)) | |
((let*? exp) (eval (let*->nested-lets exp) env)) | |
((application? exp) (apply (eval (operator exp) env) (list-of-values (operands exp) env))) | |
(else (error "Unknown expression type: EVAL" exp)) | |
)) | |
;;;;;;;;;; | |
;;; ドライバループ | |
(define input-prompt ";;; M-Eval input:") | |
(define output-prompt ";;; M-Eval value:") | |
(define (driver-loop) | |
(prompt-for-input input-prompt) | |
(let ((input (read))) | |
(let ((output (eval input the-global-environment))) | |
(announce-output output-prompt) | |
(user-print output))) | |
(driver-loop)) | |
(define (prompt-for-input string) | |
(newline) (display string) (newline)) | |
(define (announce-output string) | |
(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))) |
;;; sicp-4-evaluator.scmをベースとする | |
;; 被演算子を左から評価 | |
(define (list-of-values exps env) | |
(define (first-operand exps) (car exps)) | |
(if (no-operands? exps) | |
`() | |
(let ((first (eval (first-operand exps) env))) | |
(cons first (list-of-values (rest-operands exps) env))))) | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (- 10 2) | |
;; ;;; M-Eval value: | |
;; 8 | |
;; 被演算子を右から評価 | |
(define (list-of-values exps env) | |
(define (first-operand exps) (car exps)) | |
(define (loop exps args) | |
(if (no-operands? exps) | |
args | |
(let ((first (eval (first-operand exps) env))) | |
(loop (rest-operands exps) (cons first args))))) | |
(loop exps `())) | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (- 10 2) | |
;; ;;; M-Eval value: | |
;; -8 |
;; evalの先頭に手続き適用を持ってくると... | |
;; (define (eval exp env) | |
;; (cond ((application? exp) (apply (eval (operator exp) env) (list-of-values (operands exp) env))) | |
;; ... | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (+ 1 2) | |
;; ;;; M-Eval value: | |
;; 3 | |
;; ;;; M-Eval input: | |
;; (define x 3) ; `Unbound variable define` が出力される | |
;; ice-9/boot-9.scm:1669:16: In procedure raise-exception: | |
;; Unbound variable define | |
;; 以下のように書き換えると... | |
(define (application? exp) (tagged-list? exp 'call)) | |
(define (operator exp) (cadr exp)) | |
(define (operands exp) (cddr exp)) | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (call + 1 2) ; 手続き適用にcallを使う | |
;; ;;; M-Eval value: | |
;; 3 | |
;; ;;; M-Eval input: | |
;; (define x 3) ; defineも大丈夫 | |
;; ;;; M-Eval value: | |
;; ok | |
;; ;;; M-Eval input: | |
;; (+ 1 2) ; callなしだと評価できなくなる | |
;; ice-9/boot-9.scm:1669:16: In procedure raise-exception: | |
;; Unknown expression type: EVAL (+ 1 2) |
(define (eval exp env) | |
(cond ((self-evaluating? exp) exp) | |
... | |
((and? exp) (eval-and (and-exps exp) env)) | |
((or? exp) (eval-or (or-exps exp) env)) | |
... | |
(define (and? exp) (tagged-list? exp 'and)) | |
(define (and-exps exp) (cdr exp)) | |
(define (or? exp) (tagged-list? exp 'or)) | |
(define (or-exps exp) (cdr exp)) | |
(define (eval-and exps env) | |
(if (false? (eval (first-exp exps) env)) | |
#f | |
(if (last-exp? exps) | |
#t | |
(eval-and (rest-exps exps) env)))) | |
(define (eval-or exps env) | |
(if (true? (eval (first-exp exps) env)) | |
#t | |
(if (last-exp? exps) | |
#f | |
(eval-or (rest-exps exps) env)))) | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (if (and (> 3 2) (= 4 4)) 'yes 'no) | |
;; ;;; M-Eval value: | |
;; yes | |
;; ;;; M-Eval input: | |
;; (if (and (> 3 2) (= 2 4)) 'yes 'no) | |
;; ;;; M-Eval value: | |
;; no | |
;; ;;; M-Eval input: | |
;; (if (or (> 3 2) (= 2 4)) 'yes 'no) | |
;; ;;; M-Eval value: | |
;; yes | |
;; ;;; M-Eval input: | |
;; (if (and (or (= 2 4) (> 3 2)) (= 1 0)) 'yes 'no) | |
;; ;;; M-Eval value: | |
;; no |
(define (expand-clauses clauses) | |
(if (null? clauses) | |
#f | |
(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) | |
(if (eq? (car (cond-actions first)) '=>) | |
(list (cadr (cond-actions first)) (cond-predicate first)) | |
(sequence->exp (cond-actions first))) | |
(expand-clauses rest)))))) | |
;; ;;; M-Eval input: | |
;; (cond ((assoc 'b '((a 1) (b 2))) => cadr) | |
;; (else false)) | |
;; ;;; M-Eval value: | |
;; 2 |
(define (eval exp env) | |
(cond ((self-evaluating? exp) exp) | |
... | |
((let? exp) (eval (let->combination exp) env)) | |
... | |
;; let | |
;; letは派生式なので別の式(lambda式)に変換するだけでいい | |
(define (let? exp) (tagged-list? exp 'let)) | |
(define (let-args exp) | |
(let ((varexps (cadr exp))) | |
(map car varexps))) | |
(define (let-exps exp) | |
(let ((varexps (cadr exp))) | |
(map cdr varexps))) | |
(define (let-body exp) (cddr exp)) | |
(define (let->combination exp) | |
(list (make-lambda (let-args exp) (let-body exp)) | |
(let-exps exp))) | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (define (adder initial) | |
;; (let ((acc initial)) | |
;; (lambda (x) | |
;; (set! acc (+ acc x)) | |
;; acc | |
;; ))) | |
;; ;;; M-Eval value: | |
;; ok | |
;; ;;; M-Eval input: | |
;; (define f (adder 0)) | |
;; ;;; M-Eval value: | |
;; ok | |
;; ;;; M-Eval input: | |
;; (f 1) | |
;; ;;; M-Eval value: | |
;; 1 | |
;; ;;; M-Eval input: | |
;; (f 2) | |
;; ;;; M-Eval value: | |
;; 3 | |
;; ;;; M-Eval input: |
(define (eval exp env) | |
(cond ((self-evaluating? exp) exp) | |
... | |
((let? exp) (eval (let->combination exp) env)) | |
... | |
;; let* | |
;; 入れ子のletに変換 | |
(define (let*? exp) (tagged-list? exp 'let*)) | |
(define (let*-body exp) (cddr exp)) | |
(define (let*->nested-lets exp) | |
(define (iter varexps) | |
(if (null? varexps) | |
(let*-body exp) | |
(list 'let (list (car varexps)) (iter (cdr varexps))))) | |
(iter (cadr exp))) | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (let* ((x 3) (y (+ x 2)) (z (+ x y 5))) | |
;; (* x z)) | |
;; ;;; M-Eval value: | |
;; 39 |
(define (named-let-args exp) | |
(let ((bindings (caddr exp))) | |
(map car bindings))) | |
(define (named-let-exps exp) | |
(let ((bindings (caddr exp))) | |
(map cdr bindings))) | |
(define (named-let-body exp) (cadddr exp)) | |
(define (let->combination exp) | |
(if (symbol? (cadr exp)) | |
(let ((f-name (cadr exp))) | |
(make-begin | |
(list | |
(list 'define (cons f-name (named-let-args exp)) | |
(named-let-body exp)) | |
(cons f-name (named-let-exps exp))))) | |
(list (make-lambda (let-args exp) (let-body exp)) | |
(let-exps exp))));; ;; M-Eval input: | |
;; (define (fib n) | |
;; (let fib-iter ((a 1) | |
;; (b 0) | |
;; (count n)) | |
;; (if (= count 0) | |
;; b | |
;; (fib-iter (+ a b) a (- count 1))))) | |
;; ;;; M-Eval value: | |
;; ok | |
;; ;;; M-Eval input: | |
;; (fib 10) | |
;; ;;; M-Eval value: | |
;; 55 |
(define (lookup-variable-value var env) | |
(define (env-loop env) | |
(define (scan vars vals) | |
(cond ((null? vars) (env-loop (enclosing-environment env))) | |
((eq? var (car vars)) | |
(if (eq? (car vals) '*unassigned*) | |
(error "Unassigned variable" var) | |
(car vals))) | |
(else (scan (cdr vars) (cdr vals))))) | |
(if (eq? env the-empty-environment) | |
(error "Unbound variable" var) | |
(let ((frame (first-frame env))) | |
(scan (frame-variables frame) | |
(frame-values frame))))) | |
(env-loop env)) | |
(define (scan-out-defines exp) | |
(define (has-define? exp) | |
(if (null? exp) | |
#f | |
(if (definition? (car exp)) | |
#t | |
(has-define? (cdr exp))))) | |
(define (body exp) | |
(if (tagged-list? (car exp) 'define) | |
(body (cdr exp)) | |
exp)) | |
(define (iter exp acc) | |
(if (tagged-list? (car exp) 'define) | |
(iter (cdr exp) | |
(cons (cons (cons (definition-variable (car exp)) (cons ''*unassigned* `())) (car acc)) | |
(cons (list 'set! (definition-variable (car exp)) (definition-value (car exp))) (cdr acc)))) | |
(cons (reverse (car acc)) (reverse (cdr acc))))) | |
(if (has-define? exp) | |
(let ((varexps-sets (iter exp (cons `() `())))) | |
(newline) | |
(display (list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp) ))))) | |
(newline) | |
(list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp)))))) | |
exp)) | |
(define (make-procedure parameters body env) | |
(list 'procedure parameters (scan-out-defines body) env)) | |
;; cf. 問題4.16 – SICP(計算機プログラムの構造と解釈)その188 : Serendip – Webデザイン・プログラミング https://www.serendip.ws/archives/1973 | |
;; | |
;; | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (define foo (lambda (x) (define a 1) (define b 2) (* (+ a x) b))) | |
;; | |
;; ((let ((a (quote *unassigned*)) (b (quote *unassigned*))) (set! a 1) (set! b 2) (* (+ a x) b))) | |
;; ;;; M-Eval value: | |
;; ok | |
;; ;;; M-Eval input: | |
;; (foo 7) | |
;; | |
;; ((lambda (a b) (set! a 1) (set! b 2) (* (+ a x) b)) (quote *unassigned*) (quote *unassigned*)) | |
;; ;;; M-Eval value: | |
;; 16 | |
;; | |
;; | |
;; ;;; M-Eval input: | |
;; (define (f x) | |
;; (define (even? n) | |
;; (if (= n 0) | |
;; true | |
;; (odd? (- n 1)))) | |
;; (define (odd? n) | |
;; (if (= n 0) | |
;; false | |
;; (even? (- n 1)))) | |
;; (cond ((even? x) 'even) | |
;; ((odd? x) 'odd))) | |
;; | |
;; ((let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (cond ((even? x) (quote even)) ((odd? x) (quote odd))))) | |
;; ;;; M-Eval value: | |
;; ok | |
;; ;;; M-Eval input: | |
;; (f 5) | |
;; | |
;; ((lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (cond ((even? x) (quote even)) ((odd? x) (quote odd)))) (quote *unassigned*) (quote *unassigned*)) | |
;; ;;; M-Eval value: | |
;; odd | |
;; ;;; M-Eval input: | |
;; (f 6) | |
;; | |
;; ((lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (cond ((even? x) (quote even)) ((odd? x) (quote odd)))) (quote *unassigned*) (quote *unassigned*)) | |
;; ;;; M-Eval value: | |
;; even |
;;; ここまでsicp-4-evaluator.scmと同じ | |
;;;;;;;;;; | |
;;; 評価手続き | |
;;; ↓の解析手続きの置き換わる | |
;;;;;;;;;; | |
;;; 解析手続き | |
(define (analyze-self-evaluating exp) | |
(lambda (env) exp)) | |
(define (analyze-quoted exp) | |
(let ((qval (text-of-quotation exp))) | |
(lambda (env) qval))) | |
(define (analyze-variable exp) | |
(lambda (env) (lookup-variable-value exp env))) | |
(define (analyze-assignment exp) | |
(let ((var (assignment-variable exp)) | |
(vproc (analyze (assignment-value exp)))) | |
(lambda (env) | |
(set-variable-value! var (vproc env) env) | |
'ok))) | |
(define (analyze-definition exp) | |
(let ((var (definition-variable exp)) | |
(vproc (analyze (definition-value exp)))) | |
(lambda (env) | |
(define-variable! var (vproc env) env) | |
'ok))) | |
(define (analyze-if exp) | |
(let ((pproc (analyze (if-predicate exp))) | |
(cproc (analyze (if-consequent exp))) | |
(aproc (analyze (if-alternative exp)))) | |
(lambda (env) (if (true? (pproc env)) | |
(cproc env) | |
(aproc env))))) | |
(define (analyze-lambda exp) | |
(let ((vars (lambda-parameters exp)) | |
(bproc (analyze-sequence (lambda-body exp)))) | |
(lambda (env) (make-procedure vars bproc env)))) | |
(define (analyze-sequence exps) | |
(define (sequentially proc1 proc2) | |
(lambda (env) (proc1 env) (proc2 env))) | |
(define (loop first-proc rest-procs) | |
(if (null? rest-procs) | |
first-proc | |
(loop (sequentially first-proc (car rest-procs)) | |
(cdr rest-procs)))) | |
(let ((procs (map analyze exps))) | |
(if (null? procs) (error "Empty sequence: ANALYZE")) | |
(loop (car procs) (cdr procs)))) | |
(define (analyze-application exp) | |
(let ((fproc (analyze (operator exp))) | |
(aprocs (map analyze (operands exp)))) | |
(lambda (env) | |
(execute-application | |
(fproc env) | |
(map (lambda (aproc) (aproc env)) aprocs))))) | |
(define (execute-application proc args) | |
(cond ((primitive-procedure? proc) (apply-primitive-procedure proc args)) | |
((compound-procedure? proc) | |
((procedure-body proc) (extend-environment (procedure-parameters proc) | |
args | |
(procedure-environment proc)))) | |
(else (error "Unknown procedure type: EXECUTE-APPLICATION" proc)))) | |
(define (analyze exp) | |
;; ここで場合わけしているので、新たな式の型が増えた場合に追加する必要がある | |
(cond ((self-evaluating? exp) (analyze-self-evaluating exp)) | |
((quoted? exp) (analyze-quoted exp)) | |
((variable? exp) (analyze-variable exp)) | |
((assignment? exp) (analyze-assignment exp)) | |
((definition? exp) (analyze-definition exp)) | |
((if? exp) (analyze-if exp)) | |
((lambda? exp) (analyze-lambda exp)) | |
((begin? exp) (analyze-sequence (begin-actions exp))) | |
((cond? exp) (analyze (cond->if exp))) | |
((let? exp) (analyze (let->combination exp))) | |
((application? exp) (analyze-application exp)) | |
(else (error "Unknown expression type: ANALYZE" exp)) | |
)) | |
;; eval | |
(define (eval exp env) ((analyze exp) env)) | |
;;;;;;;;;; | |
;;; ドライバループ | |
(define input-prompt ";;; M-Eval input:") | |
(define output-prompt ";;; M-Eval value:") | |
(define (driver-loop) | |
(prompt-for-input input-prompt) | |
(let ((input (read))) | |
(let ((output (eval input the-global-environment))) | |
(announce-output output-prompt) | |
(user-print output))) | |
(driver-loop)) | |
(define (prompt-for-input string) | |
(newline) (display string) (newline)) | |
(define (announce-output string) | |
(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))) | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (define (f x) | |
;; (let ((double (* x x))) | |
;; (+ double 10))) | |
;; ;;; M-Eval value: | |
;; ok | |
;; ;;; M-Eval input: | |
;; (f 10) | |
;; ;;; M-Eval value: | |
;; 110 |
(define (analyze exp) | |
(cond ((self-evaluating? exp) (analyze-self-evaluating exp)) | |
... | |
((unless? exp) (analyze (unless->if exp))) | |
... | |
;; unless | |
(define (unless? exp) (tagged-list? exp 'unless)) | |
(define (unless-predicate exp) (cadr exp)) | |
(define (unless-consequent exp) (caddr exp)) | |
(define (unless-alternative exp) | |
(if (not (null? (cddr exp))) | |
(cadddr exp) | |
#f)) | |
(define (unless->if exp) | |
(make-if (unless-predicate exp) | |
(unless-alternative exp) | |
(unless-consequent exp))) | |
;; scheme@(guile-user)> (driver-loop) | |
;; | |
;; ;;; M-Eval input: | |
;; (unless (> 21 20) 'a 'b) | |
;; ;;; M-Eval value: | |
;; b |