001: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
002: ;; SICP第２版をベースにしたSchemeで書かれたSchemeインタプリタ
003: ;; 山本修身 (osami@meijo-u.ac.jp)
004: ;; Wed Dec 2 13:51:28 JST 2015
005: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
006:
007: (define apply-in-underlying-scheme apply)
008:
009: (define (myscheme)
010: ;; 評価子の定義
011: (define (eval exp env)
012: (cond ((self-evaluating? exp) exp)
013: ((variable? exp)
014: (lookup-variable-value exp env))
015: ((quoted? exp) (text-of-quotation exp))
016: ((assignment? exp) (eval-assignment exp env))
017: ((definition? exp) (eval-definition exp env))
018: ((if? exp) (eval-if exp env))
019: ((lambda? exp)
020: (make-procedure (lambda-parameters exp)
021: (lambda-body exp)
022: env))
023: ((begin? exp)
024: (eval-sequence (begin-actions exp) env))
025: ((cond? exp) (eval (cond->if exp) env))
026: ((let? exp) (eval (let->lambda exp) env))
027: ((application? exp)
028: (apply (eval (operator exp) env)
029: (list-of-values (operands exp) env)))
030: (else
031: (error "Unknown expression type -- EVAL" exp))))
032:
033: ;; 関数へ引数を適用する関数 apply の定義
034: (define (apply procedure arguments)
035: (cond ((primitive-procedure? procedure) ; プリミティブ関数の場合
036: (apply-primitive-procedure procedure arguments))
037: ((compound-procedure? procedure) ; 関数がlambdaで記述されている場合
038: (eval-sequence
039: (procedure-body procedure)
040: (extend-environment
041: (procedure-parameters procedure)
042: arguments
043: (procedure-environment procedure))))
044: (else
045: (error
046: "Unknown procedure type -- APPLY" procedure))))
047:
048: ;; 式のリストのそれぞれの要素を評価してリストにする
049: (define (list-of-values exps env)
050: (if (no-operand? exps) '()
051: (cons (eval (first-operand exps) env)
052: (list-of-values (rest-operands exps) env))))
053:
054: ;; if文の処理
055: (define (eval-if exp env)
056: (if (true? (eval (if-predicate exp) env))
057: (eval (if-consequent exp) env)
058: (eval (if-alternative exp) env)))
059:
060: ;; 式のリストを順に評価して最後の式の値を返す
061: (define (eval-sequence exps env)
062: (cond ((last-exp? exps)(eval (first-exp exps) env))
063: (else (eval (first-exp exps) env)
064: (eval-sequence (rest-exps exps) env))))
065:
066: ;; set! による代入を評価する
067: (define (eval-assignment exp env)
068: (set-variable-value! (assignment-variable exp)
069: (eval (assignment-value exp) env)
070: env)
071: 'ok)
072:
073: ;; define による変数の定義を実行する．
074: (define (eval-definition exp env)
075: (define-variable! (definition-variable exp)
076: (eval (definition-value exp) env)
077: env)
078: (list 'ok ': (definition-variable exp) 'is 'defined))
079:
080: ;; 数や文字列など評価時にそのまま返すものかどうかを判定
081: (define (self-evaluating? exp)
082: (cond ((number? exp) #t)
083: ((string? exp) #t)
084: ((eq? exp #t) #t)
085: ((eq? exp #f) #t)
086: (else #f)))
087:
088: ;; 変数であるか否かを判定
089: (define (variable? exp) (symbol? exp))
090:
091: ;; quoteがついているかどうかを判定．またquoteの本体を取り出す
092: (define (quoted? exp) (tagged-list? exp 'quote))
093: (define (text-of-quotation exp) (cadr exp))
094:
095: ;; ('mytag (...)) のような形になってるかを判定する．tagを指定する
096: (define (tagged-list? exp tag)
097: (if (pair? exp)
098: (eq? (car exp) tag)
099: #f))
100:
101: ;; exp が代入式 (set! .. )であるか判定．また代入の変数と式を取り出す．
102: (define (assignment? exp)
103: (tagged-list? exp 'set!))
104: (define (assignment-variable exp) (cadr exp))
105: (define (assignment-value exp) (caddr exp))
106:
107: ;; 定義式 (define ... )であるか否かを判定．また，定義変数，定義の値を
108: ;; 取り出す．ただし， (define (foo ... ) ) の形のものは
109: ;; (lambda (...) ...)という式にする．
110: (define (definition? exp)
111: (tagged-list? exp 'define))
112: (define (definition-variable exp)
113: (if (symbol? (cadr exp))
114: (cadr exp)
115: (caadr exp)))
116: (define (definition-value exp)
117: (if (symbol? (cadr exp))
118: (caddr exp)
119: (make-lambda (cdadr exp)
120: (cddr exp))))
121:
122: ;; lambda式であるか否かを判定する．また，lambdaの変数や本体を取り出す
123: (define (lambda? exp) (tagged-list? exp 'lambda))
124: (define (lambda-parameters exp) (cadr exp))
125: (define (lambda-body exp) (cddr exp))
126:
127: ;; lambda式を作る
128: (define (make-lambda parameters body)
129: (cons 'lambda (cons parameters body)))
130:
131: ;; if式であるかどうか判定する．またifの条件，真，偽の場合に評価する
132: ;; 式をそれぞれ取り出す．(if (...) exp) という形にも対応している．
133: (define (if? exp) (tagged-list? exp 'if))
134: (define (if-predicate exp) (cadr exp))
135: (define (if-consequent exp) (caddr exp))
136: (define (if-alternative exp)
137: (if (not (null? (cdddr exp)))
138: (cadddr exp)
139: 'false))
140:
141: ;; if式を作る．
142: (define (make-if predicate consequent alternative)
143: (list 'if predicate consequent alternative))
144:
145: ;; begin式であるか否かを判定する．また，beginの式の列，
146: ;; begin内の最後のであるかどうかの判定，最初の式の取り出し，
147: ;; 2番目以降の式の取り出し，式の列からbeginを作る関数の定義．
148: ;; 式が一つしかなければ，beginをつけない．
149: (define (begin? exp) (tagged-list? exp 'begin))
150: (define (begin-actions exp) (cdr exp))
151: (define (last-exp? seq) (null? (cdr seq)))
152: (define (first-exp seq) (car seq))
153: (define (rest-exps seq) (cdr seq))
154: (define (sequence->exp seq)
155: (cond ((null? seq) seq)
156: ((last-exp? seq) (first-exp seq))
157: (else (make-begin seq))))
158: (define (make-begin seq) (cons 'begin seq))
159:
160: ;; 関数呼び出しか否かの判定．また，関数，引数の取り出し，
161: ;; 引数が無い場合の判定．引数がないかどうかの判定，最初の
162: ;; 引数，2番目以降の引数の取り出し．
163: (define (application? exp) (pair? exp))
164: (define (operator exp) (car exp))
165: (define (operands exp) (cdr exp))
166: (define (no-operand? ops) (null? ops))
167: (define (first-operand ops) (car ops))
168: (define (rest-operands ops) (cdr ops))
169:
170: ;; cond式か否かの判定．cond式の本体の取り出し，else節であるか
171: ;; どうかの判定，節の条件の取り出し，節の本体の取り出し，
172: ;; condをifに変換するための関数の定義．
173: (define (cond? exp) (tagged-list? exp 'cond))
174: (define (cond-clauses exp) (cdr exp))
175: (define (cond-else-clause? clause)
176: (eq? (cond-predicate clause) 'else))
177: (define (cond-predicate clause) (car clause))
178: (define (cond-actions clause) (cdr clause))
179: (define (cond->if exp)
180: (expand-clauses (cond-clauses exp)))
181: (define (expand-clauses clauses)
182: (if (null? clauses)
183: 'false
184: (let ((first (car clauses))
185: (rest (cdr clauses)))
186: (if (cond-else-clause? first)
187: (if (null? rest)
188: (sequence->exp (cond-actions first))
189: (error "ELSE clause isn't last -- COND->IF"
190: clauses))
191: (make-if (cond-predicate first)
192: (sequence->exp (cond-actions first))
193: (expand-clauses rest))))))
194:
195: ;; 真である（偽でない）ことの判定および，偽であることの判定．
196: (define (true? x) (not (eq? x #f)))
197: (define (false? x) (eq? x #f))
198:
199: ;; let式であるか否かの判定．また，letで定義されている変数，
200: ;; それらに対応する式の取り出し．letの本体の取り出し．
201: ;; さらにlet式をlambdaを用いて書いたものに変換する関数の定義．
202: (define (let? exp) (tagged-list? exp 'let))
203: (define (let-variables exp) (map car (cadr exp)))
204: (define (let-exps exp) (map cadr (cadr exp)))
205: (define (let-body exp) (cddr exp))
206: (define (let->lambda exp)
207: (cons
208: (cons 'lambda
209: (cons (let-variables exp) (let-body exp)))
210: (let-exps exp)))
211:
212: ;; 関数本体の定義．関数本体であるか否かの判定，関数のパラメター，
213: ;; 関数の本体，関数の環境のそれぞれの取り出し．
214: (define (make-procedure parameters body env)
215: (list 'procedure parameters body env))
216: (define (compound-procedure? p)
217: (tagged-list? p 'procedure))
218: (define (procedure-parameters p) (cadr p))
219: (define (procedure-body p) (caddr p))
220: (define (procedure-environment p) (cadddr p))
221:
222: ;; ある環境の親環境および直近のフレームの取り出し．最初の環境
223: ;; (中身のない環境．番兵として利用）の定義，フレームの変数列
224: ;; および値の列の取り出し，フレームへのバインディングの追加，
225: ;; 新たな環境の生成のための関数の定義．さらに変数の探索
226: ;; ための関数の定義．
227: (define (enclosing-environment env) (cdr env))
228: (define (first-frame env) (car env))
229: (define the-empty-environment '())
230: (define (make-frame variables values)
231: (cons variables values))
232: (define (frame-variables frame) (car frame))
233: (define (frame-values frame) (cdr frame))
234: (define (add-binding-to-frame! var val frame)
235: (set-car! frame (cons var (car frame)))
236: (set-cdr! frame (cons val (cdr frame))))
237: (define (extend-environment vars vals base-env)
238: (if (= (length vars) (length vals))
239: (cons (make-frame vars vals) base-env)
240: (if (< (length vars) (length vals))
241: (error "Too many arguments supplied" vars vals)
242: (error "Too few arguments supplied" vars vals))))
243: (define (lookup-variable-value var env)
244: (define (env-loop env)
245: (define (scan vars vals)
246: (cond ((null? vars)
247: (env-loop (enclosing-environment env)))
248: ((eq? var (car vars))
249: (car vals))
250: (else (scan (cdr vars) (cdr vals)))))
251: (if (eq? env the-empty-environment)
252: (error "Unbounded variable" var)
253: (let ((frame (first-frame env)))
254: (scan (frame-variables frame)
255: (frame-values frame)))))
256: (env-loop env))
257:
258: ;; set!を実現するための関数．
259: (define (set-variable-value! var val env)
260: (define (env-loop env)
261: (define (scan vars vals)
262: (cond ((null? vars)
263: (env-loop (enclosing-environment env)))
264: ((eq? var (car vars))
265: (set-car! vals val))
266: (else (scan (cdr vars) (cdr vals)))))
267: (if (eq? env the-empty-environment)
268: (error "Unbound variable -- SET!" var)
269: (let ((frame (first-frame env)))
270: (scan (frame-variables frame)
271: (frame-values frame)))))
272: (env-loop env))
273: ;; 現在の直近のフレームにバインディングを追加する．
274: (define (define-variable! var val env)
275: (let ((frame (first-frame env)))
276: (define (scan vars vals)
277: (cond ((null? vars)
278: (add-binding-to-frame! var val frame))
279: ((eq? var (car vars))
280: (set-car! vals val))
281: (else (scan (cdr vars) (cdr vals)))))
282: (scan (frame-variables frame)
283: (frame-values frame))))
284:
285: ;; 組み込み関数であるか否かの判定．ベースシステム上（この場合はkawa）
286: ;; 利用すべき関数．
287: (define (primitive-procedure? proc)
288: (tagged-list? proc 'primitive))
289: (define (primitive-implementation proc) (cadr proc))
290:
291: ;; 組み込み関数の定義．また，組み込み関数の名前，組み込み関数本体の生成
292: ;; のための関数の定義．さらにベースシステム上での組み込み関数の実行の
293: ;; ための関数．
294: (define primitive-procedures
295: `((car ,car) (cdr ,cdr) (cons ,cons) (null? ,null?)
296: (* ,*) (+ ,+) (- ,-) (/ ,/) (= ,=) (> ,>) (>= ,>=) (< ,<)(<= ,<=)
297: (not ,not) (and ,and) (or ,or) (display ,user-print) (newline ,newline)
298: (true? ,true?) (false? ,false?)))
299: (define (primitive-procedure-names) (map car primitive-procedures))
300: (define (primitive-procedure-objects)
301: (map (lambda (proc) (list 'primitive (cadr proc)))
302: primitive-procedures))
303: (define (apply-primitive-procedure proc args)
304: (apply-in-underlying-scheme
305: (primitive-implementation proc) args))
306:
307: ;; 環境の初期化，大域環境の生成
308: (define (setup-environment)
309: (let ((initial-env
310: (extend-environment (primitive-procedure-names)
311: (primitive-procedure-objects)
312: the-empty-environment)))
313: (define-variable! 'true #t initial-env)
314: (define-variable! 'false #f initial-env)
315: initial-env))
316: (define the-global-environment (setup-environment))
317:
318:
319: ;; 数や式など表示のための関数．lambdaで定義した関数以外は
320: ;; ベースシステム(kawa)のものをそのまま用いる．lambdaで
321: ;; 作られたものは"compound-procedure"というキーワードと共に
322: ;; 引数や定義本体を表示する．
323: (define (user-print object)
324: (if (compound-procedure? object)
325: (display (list 'compound-procedure
326: (procedure-parameters object)
327: (procedure-body object)
328: '<procedure-env>))
329: (display object)))
330:
331: ;; システムが立ち上がったときに基本的な関数を定義する．
332: (define (init-definitions)
333: (let loop ((defs '((define (zero? x) (= x 0))
334: (define (cadr x) (car (cdr x)))
335: (define (cddr x) (cdr (cdr x)))
336: (define (cdar x) (cdr (car x)))
337: (define (caar x) (car (car x))))))
338: (when (not (null? defs))
339: (eval (car defs) the-global-environment)
340: (loop (cdr defs)))))
341: (init-definitions)
342:
343:
344: ;; REPL の本体．プロンプトを出して(read)で入力された式を手に
345: ;; 入れる．
346: (define (repl)
347: (display "my-scheme> ")
348: (let ((exp (read)))
349: (when (not (eq? exp #!eof))
350: (display "==> ")
351: (user-print (eval exp the-global-environment))
352: (newline)
353: (repl))))
354:
355: (display "** Scheme in Scheme **")
356: (newline)
357: (repl)
358: (display "Bye, see you.")
359: (newline))
360:
361: (myscheme)
362:
363: