はい。今度はScheme（処理系はGaucheを使用）でForthを実装してみました。
プログラムは5つの部分に分かれていて、
１）スタック管理
２）標準入力からプログラムを読むリーダ
３）ForthプログラムをSchemeプログラムに変換するトランスレータ
４）ワードが登録される辞書
５）実行制御
という構成になっています。
とりあえず、各部分の説明をしていきます。
１）スタック管理
;;; スタック管理
(define *data-stack* '())
(define (push val)
(set! *data-stack* (cons val *data-stack*)))
(define (pop)
(cond
((null? *data-stack*)
(raise "Stack UnderFlow."))
(else
(let ((val (car *data-stack*)))
(set! *data-stack* (cdr *data-stack*))
val))))
スタック管理は面倒くさくないグローバル変数を使ったものにしました。
関数もPUSHとPOPのみです。POPにはスタックアンダーフローがでたら例外が投げられるようになっています。
２）標準入力からプログラムを読むリーダ
;;; 標準入力から読み込み、トークンに分割する。
(define (trim str)
(begin
(set! str (regexp-replace #/^\s+/ str ""))
(set! str (regexp-replace #/\s+$/ str ""))
str))
;; シンボルに使えない文字を変換する
(define (def-word-translate str)
(begin
(set! str (regexp-replace-all #/\;/ str "edef"))
(set! str (regexp-replace-all #/\:/ str "sdef"))
(set! str (regexp-replace-all #/\./ str "dot"))
(set! str (regexp-replace-all #/\.([a-zA-Z])/ str "dot\\1"))
(set! str (regexp-replace-all #/\s+/ str " "))
str))
;; 半角スペースで分割
(define (tokenizer str)
(token->symbol (string-split (def-word-translate str) " ")))
;; トークンをシンボルと数値のリストにする
(define (token->symbol tokens)
(cond
((null? tokens) '())
((rxmatch #/[0-9\.]+/ (car tokens))
(cons (string->number (car tokens))
(token->symbol (cdr tokens))))
(else
(cons (string->symbol (car tokens))
(token->symbol (cdr tokens))))))
;; 標準入力からプログラムを読み取り、トークンにして返す
(define (reader)
(let ((line (read-line)))
(cond
((eof-object? line) '())
((string=? "" (trim line))
(reader))
(else
(tokenizer (trim line))))))
基本的には標準入力から入ってきた文字列をトークンに分割するだけなのですが、「；」や「．」がSchemeでは特別な意味を持っているので、変換してからトークンに分割しています。
３）ForthプログラムをSchemeプログラムに変換するトランスレータ
;;; ForthプログラムをSchemeに変換する
(define *program* '())
(define (translate-token token)
(cond
((number? token)
(list 'push token))
((search-dict token)
(list (get-dict token)))
(else
(raise (format #f "Undefined [~A]." token)))))
(define (define-word tokens)
(cond
((null? tokens)
(raise "Syntax Error: [;] is missing."))
((eq? 'edef (car tokens)) '())
(else
(cons (translate-token (car tokens))
(define-word (cdr tokens))))))
(define (translate tokens define-flag)
(cond
((null? tokens) '())
((and define-flag)
(if (eq? (car tokens) 'edef)
(translate (cdr tokens) #f)
(translate (cdr tokens) #t)))
((eq? (car tokens) 'sdef)
(add-dict (cadr tokens)
(append '(lambda ()) (define-word (cddr tokens))))
(translate (cdr tokens) #t))
(else
(cons (translate-token (car tokens))
(translate (cdr tokens) #f)))))
トランスレータは今はこれだけです。これに「ループ処理」や「ローカル変数」などを実装するともっと長くなりそうです。
ワード定義もここでやっていて、
(append '(lambda ()) '(define-word ...))
とやれば、手軽にワードを生成することができますね。
４）ワードが登録される辞書
;;; 辞書用プログラム
(define *dictionaly* (make-hash-table 'equal?))
;; 辞書初期化
(define (init-dict)
(begin
(hash-table-put! *dictionaly* '+
(lambda () (push (+ (pop) (pop)))))
(hash-table-put! *dictionaly* '-
(lambda () (let ((a (pop))) (push (- (pop) a)))))
(hash-table-put! *dictionaly* '*
(lambda () (let ((a (pop))) (push (* (pop) a)))))
(hash-table-put! *dictionaly* '/
(lambda () (let ((a (pop))) (push (/ (pop) a)))))
(hash-table-put! *dictionaly* 'mod
(lambda () (let ((a (pop))) (push (mod (pop) a)))))
(hash-table-put! *dictionaly* 'dot
(lambda () (print (pop))))
(hash-table-put! *dictionaly* 'dots
(lambda () (print (reverse *data-stack*))))
(hash-table-put! *dictionaly* 'exit
(lambda () (exit)))
))
;; 辞書に追加
(define (add-dict key val)
(hash-table-put! *dictionaly* key val))
;; 辞書検索
(define (search-dict key)
(hash-table-exists? *dictionaly* key))
;; 辞書から取得
(define (get-dict key)
(if (search-dict key)
(hash-table-get *dictionaly* key)
(raise (format #f "Undefined [~A]" key))))
ワード辞書もグローバル変数としました。辞書からワードを取得するとき、ワードが存在しなければ例外が投げられます。
ワードは「init-dict」関数に追加していけば使える組み込みワードが増えます。今は四則演算と表示くらいしかないですがｗ
５）実行制御
;;; Forthエントリポイント
;; 処理系初期化
(define (init-forth)
(begin
(load "./dictionaly")
(load "./reader")
(load "./stack")
(load "./translate")
(init-dict)))
;; ForthプログラムをSchemeに変換した結果を実行する
(define (exec-forth prog ret)
(cond
((null? prog) ret)
(else
(exec-forth (cdr prog)
(eval (car prog) (interaction-environment))))))
(init-forth)
(let loop ()
(display "> ")
(flush)
(display (exec-forth (translate (reader) #f) #f))
(newline)
(loop))
これは特に説明することもないです。
処理系の初期化関数とトランスレートしたForthプログラムの実行くらいです。
トランスレートしたプログラムはただevalしてるだけですね。
こんな感じです。
