Scheme - レジスタ計算機での計算(翻訳系(文面アドレス(翻訳時環境, 文面アドレスを返す手続き)))

計算機プログラムの構造と解釈[第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.41.を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
• プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
• Scheme手習い

問題 5.41.

コード(BBEdit, Emacs)

compile_time_environment.scm

;; -*- coding: utf-8 -*-

(load "./environment.scm")

;; 文面アドレスの選択子、構成子
(define (lexcal-address-frame-number lexcal-address)
  (car lexcal-address))
(define (lexcal-address-displacement-number lexcal-address)
  (cdr lexcal-address))

(define (make-lexcal-address frame-number displacement-number)
  (cons frame-number displacement-number))

(define (lexical-address-lookup lexcal-address env)
  (let ((frame-number (lexcal-address-frame-number lexcal-address))
        (displacement-number
         (lexcal-address-displacement-number lexcal-address)))
    (let ((frame (list-ref env frame-number)))
      (let ((vals (frame-values frame)))
        (let ((val (list-ref vals displacement-number)))
          (if (eq? val '*unassigned*)
              (let ((vars (frame-variables frame)))
                (error "Unbound variable:"
                       (liset-ref vars displacement-number)))
              val))))))

(define (lexcal-address-set! lexcal-address val env)
  (let ((frame-number (lexcal-address-frame-number lexcal-address))
        (displacement-number
         (lexcal-address-displacement-number lexcal-address)))
    (let ((frame (list-ref env frame-number)))
      (let ((vals (frame-values frame)))
        (define (inner vals n)
          (cond ((null? vals)
                 (error "Unbound variable -- LEXCAL-ADDRESS-SET!"))
                ((= n 0)
                 (set-car! vals val))
                (else (inner (cdr vals) (- n 1)))))
        (inner vals displacement-number)))))
        
(define (extend-compile-time-environment frame base-env)
  (cons frame base-env))

(define (find-variable var comp-time-env)
  (define (find-frame-number n comp-time-env)
    (cond ((null? comp-time-env) #f)
          ((memq var (car comp-time-env)) n)
          (else
           (find-frame-number (+ n 1)
                              (cdr comp-time-env)))))
  (define (find-displacement-number frame)
    (if (eq? (car frame) var)
        0
        (+ 1 (find-displacement-number (cdr frame)))))
  (let ((frame-number (find-frame-number 0 comp-time-env)))
    (if frame-number               
        (list frame-number
              (find-displacement-number
               (list-ref comp-time-env frame-number)))
        'not-found)))

sample41.scm

#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-

(load "./compile_time_environment.scm")

(for-each (lambda (var)
            (print (find-variable var '((y z) (a b c d e) (x y)))))
          (list 'c 'x 'w))

入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))

$ ./sample41.scm 
(1 2)
(2 0)
not-found
$