From 6bd7978c32b19a58607b406b598faae99bb59222 Mon Sep 17 00:00:00 2001 From: Hiroshi Sakurai Date: Sat, 14 Feb 2015 09:47:18 +0900 Subject: [PATCH] added module2 --- docs/README.md | 8 +- docs/module/Makefile | 10 +- docs/module/README.md | 244 ++++++++++- docs/module2/README.md | 946 +++++++++++++++++++++++++++++++++++++++++ docs/module2/a.ml | 108 +++++ docs/module2/aa.ml | 4 + docs/module2/b.ml | 105 +++++ docs/module2/bb.ml | 2 + docs/module2/cc.ml | 4 + docs/module2/t01.ml | 31 ++ docs/module2/t02.ml | 45 ++ docs/module2/t03.ml | 48 +++ docs/module2/t04.ml | 56 +++ docs/module2/t04_a.ml | 93 ++++ docs/module2/t05.ml | 80 ++++ docs/module2/t06.ml | 101 +++++ docs/module2/t07.ml | 109 +++++ docs/module2/t08.ml | 128 ++++++ docs/module2/t09.ml | 130 ++++++ docs/module2/t10.ml | 142 +++++++ docs/module2/t10_2.ml | 280 ++++++++++++ docs/module2/t11.ml | 181 ++++++++ 22 files changed, 2840 insertions(+), 15 deletions(-) create mode 100644 docs/module2/README.md create mode 100644 docs/module2/a.ml create mode 100644 docs/module2/aa.ml create mode 100644 docs/module2/b.ml create mode 100644 docs/module2/bb.ml create mode 100644 docs/module2/cc.ml create mode 100644 docs/module2/t01.ml create mode 100644 docs/module2/t02.ml create mode 100644 docs/module2/t03.ml create mode 100644 docs/module2/t04.ml create mode 100644 docs/module2/t04_a.ml create mode 100644 docs/module2/t05.ml create mode 100644 docs/module2/t06.ml create mode 100644 docs/module2/t07.ml create mode 100644 docs/module2/t08.ml create mode 100644 docs/module2/t09.ml create mode 100644 docs/module2/t10.ml create mode 100644 docs/module2/t10_2.ml create mode 100644 docs/module2/t11.ml diff --git a/docs/README.md b/docs/README.md index da5d145..f381238 100644 --- a/docs/README.md +++ b/docs/README.md @@ -5,15 +5,17 @@ 現在、AltJSと呼ばれる言語群が存在します。これはJavaScriptへのトランスレータであるプログラミング言語の総称です。 λ計算のAltJSも数多く存在しています。 しかしながら、λ計算ベースの言語からJavaScriptへの変換後のコードは余美しい物ではありません。 -なぜならば、λ計算の変換過程での正規形にはA正規形や、k正規形、β正規形等があるが、広く知られているJavaScriptへの変換用の正規形が知られていない為です。 -そこで、この文章では、JavaScriptへの単純な変換方法について述べ、より発展的なJavaScriptへの変換を提案します。 +様々なプログラムが正確に動作することが重要なので、可読性は犠牲になっているのでしょう。 +λ計算の変換過程での正規形にはA正規形や、k正規形、β正規形等があります。 +この文章では、JavaScriptへの単純な変換方法について述べ、より発展的なJavaScriptへの変換を提案します。 ## 2. イントロダクション 現在、AltJSと呼ばれる言語群が存在します。これはJavaScriptへのトランスレータであるプログラミング言語の総称です。 js\_of\_ocaml、Elm等、λ計算のAltJSも数多く存在しています。 しかしながら、λ計算ベースの言語からJavaScriptへの変換後のコードは美しい物ではないようです。 -なぜならば、λ計算の変換過程での正規形にはA正規形や、k正規形、β正規形等があるが、広く知られているJavaScriptへの変換用の正規形が知られていない為のように思います。 +なぜならば、λ計算の変換過程での正規形にはA正規形や、k正規形、β正規形等があります。 +同じようにJavaScriptへの着実で奇麗な変換方法があれば良いでしょう。 ## 2.1. 各正規形について diff --git a/docs/module/Makefile b/docs/module/Makefile index d821fc9..f117161 100644 --- a/docs/module/Makefile +++ b/docs/module/Makefile @@ -1,7 +1,7 @@ -default: module13 run +default: module15 run run: - ./module13 + ./module15 module02: module02.ml ocamlfind ocamlc -package ppx_deriving.show module02.ml -o module02 @@ -55,5 +55,9 @@ module14: module14.ml ocamlfind ocamlc -package ppx_deriving.show module14.ml -o module14 ./module14 +module15: module15.ml + ocamlfind ocamlc -package ppx_deriving.show module15.ml -o module15 + ./module15 + clean: - rm -rf *.cm* module02 module03 module04 module05 module06 module07 module08 module09 module10 module11 module12 module13 module14 + rm -rf *.cm* module02 module03 module04 module05 module06 module07 module08 module09 module10 module11 module12 module13 module14 module15 diff --git a/docs/module/README.md b/docs/module/README.md index 46f8803..18c878d 100644 --- a/docs/module/README.md +++ b/docs/module/README.md @@ -2,7 +2,9 @@ ## 1. はじめに -モジュールの機能があれば、ファイルを複数に分けてプログラムを作成出来て便利です。しかし、作るノウハウがまとまっている文章はあまり見た事がありません。そこで、ここでは、OCamlのモジュールシステムをシミュレーションしてみます。シミュレーションするにあたって、データ構造を作成し、ファイルシステムからの読み込みを行えるようにします。出来たら、数字を計算するだけのインタプリタを作成してうまく動いたら、拡張して行きます。そこそこ動くようになったら、ネイティブな関数も呼べるようにして印字機能を作ります。 +とりあえず、15.6からで良いと思われます。 + +モジュールの機能があれば、ファイルを複数に分けてプログラムを作成出来て便利です。ここでは、OCamlのモジュールシステムをシミュレーションしてみます。シミュレーションするにあたって、データ構造を作成し、ファイルシステムからの読み込みを行えるようにします。出来たら、数字を計算するだけのインタプリタを作成してうまく動いたら、拡張して行きます。そこそこ動くようになったら、ネイティブな関数も呼べるようにして印字機能を作ります。 ## 2. データ構造 @@ -687,9 +689,229 @@ read c.ml ファイルを何度もOpenするのでは効率がよくありません。ファイルをキャッシュしましょう。 +今まで環境は、変数名と値のリストでした。ここに、ファイル名と環境を追加します。 +ファイルを読み込み、コンパイルした結果も保存するのです。 + +あれ、でも保存してた気がする？いや、今保存しているのはモジュールそのものです。 +`A.print_int_ln`を見つけると、モジュールを読み込みます。これは良いのです。 +Openした場合に、モジュールが保存されません。これが問題です。Openした場合にファイルを開いたのであれば、その結果をモジュールとして保存しましょう。否、モジュールを読み込んだ後に、Openで展開するように処理を変えましょう。 + +うーん。結局うまく行かない理由は、Letの処理にありました。Letでは、環境を捨てます。名前は捨てないと行けないのです。でも、読み込んだモジュールは保持したい。従って、Letの後に環境からモジュールを検索してモジュールのみ取り出します。これで良いはずです。 + +しかし複雑になってしまいました。 + ## 15. 依存フローを作成する -## 16. 依存解析する + +## 15.1. 作って見る + +ocamlのプログラムの場合は、実はOpenがあったらとか、モジュールが使われていたら、そのとき読み込まれるというわけではありません。予め読み込み順を指定しておき、その順番に読み込まれます。 + +しかしながら、それでは、面倒です。自動で依存関係を調べて勝手に読み込んでくれたら良いのにと思います。 + +そこで、自動的に解析される事を考えます。 + +コンパイラを作成する場合は、型推論を行う場合や、変数の型を知りたい場合等、依存元を先にコンパイルする必要があるかもしれません。 + + +処理方法は、メインファイルが依存しているファイルは全てオープンし、そのより上のファイルを読み込んで行く事で、全てのファイルを認識出来ます。 +どのファイルがどのファイルを読み込んでいるかを記録しておくと、それはグラフの情報となります。 +依存解析をすることで、コンパイル順を決定する事が出来るでしょう。 +ここでは、変数の参照と、Openのみを解析して、読み込みフローを作成します。 + + +嫌な例を考えよう。 + +``` +g.ml +module B = struct + module C = struct + let c = 1 + end +end + +h.ml +open G +open B +open C;; +print_int c +``` + +これが正しく動く必要があります。これを正しく動作させることを考えなくては行けません。 +このような例が沢山必要です。やっと問題の本質に行き着いたのかな。 +モジュールシステムの最も重要な本質的な部分を考えましょう。 +例えば、ファイル名の一文字目を大文字に変えるとかは本質的な処理ではありません。 +２項演算子も、依存の解析には重要でありません。重要なのは、openとmoduleと変数です。OpenとModとVarで抽象的なデータ構造を作る事こそが本質でしょう。 + +まず、変数は捨てましょう。最も重要なのは、OpenとModとファイルです。 + +``` +type e = + Unit + Open of string * e + Mod of string * e * e + +type f = + FUnit + FFile of string * e * f + +let files = + FFile("G", Mod("B",Mod("C",Unit,Unit),Unit), + FFile("H", Open("G",Open("B",Open("C",Unit))), + FUnit)) +``` + +この小さいデータ構造で、出来る可能性について検討しましょう。 +どうやって解析すべきなんでしょうね。よくわからないので、評価してみましょう。 + +``` +let rec eval = function + | Unit -> [] + | Open(x,e) -> x::(eval e) + | Mod(x,e,e2) -> x::(eval e)@(eval e2) + +let rec evalf = function + | FUnit -> [] + | FFile(x,e,f) -> x::(eval e) @ (evalf f) + +let _ = + Printf.printf "[%s]\n" (String.concat ";" (evalf files)) +``` + +とりあえず、出てくる名前を単純に書き出してみました。 + +``` +[G;B;C;H;G;B;C] +``` + +いいですね。でもこれは、全部リストにしてしまってるのでちょっと違いますね。 + +ファイル毎に分けてみましょう。 + + +``` +let rec eval = function + | Unit -> [] + | Open(x,e) -> x::(eval e) + | Mod(x,e,e2) -> x::(eval e)@(eval e2) + +let rec evalf = function + | FUnit -> [] + | FFile(x,e,f) -> (x,(eval e)) :: (evalf f) + +let _ = + Printf.printf "%s\n" (show_sss (evalf files)) +``` + +``` +[("G", ["B"; "C"]); ("H", ["G"; "B"; "C"])] +``` + + +Gではモジュール作っただけで、依存してませんよ。ってことで、じゃあ削りましょう。 + +``` +let rec eval = function + | Unit -> [] + | Open(x,e) -> x::(eval e) + | Mod(x,e,e2) -> (eval e)@(eval e2) + +let rec evalf = function + | FUnit -> [] + | FFile(x,e,f) -> (x,(eval e)) :: (evalf f) + +let _ = + Printf.printf "%s\n" (show_sss (evalf files)) +``` + +``` +[("G", []); ("H", ["G"; "B"; "C"])] +``` + +でも、HはBやCは依存しませんよ。間違えてます。それに、メインのモジュールはHです。 + +``` +let rec read (file:string) = function + | FUnit -> assert false + | FFile((x:string),(e:e),_) + when x = file -> + e + | FFile(_,_,xs) -> read file xs + +let rec eval files = function + | Unit -> [] + | Open(x,e) -> x::(eval files e) + | Mod(x,e,e2) -> (eval files e)@(eval files e2) + +let rec evalf files file = + let e = read file files in + eval files e + +let _ = + Printf.printf "%s\n" (show_ss (evalf files "H")) +``` + +``` +["G"; "B"; "C"] +``` + +HはGに依存してます。それは結構ですけど、BやCはGの物です。これを解決しないといけませんよね。 +うーん、、、。ハマった。これって、今までやって来た事を繰り返してません？ + +## 15.2. いったんまとめる + +一度奇麗にしましょう。 + +## 15.3. 削る + +1,2節では、ハマってしまいました。14章まで積み上げて来た物をぶっ壊して１から勿体ないですね。 +考え方を変えるんだ！14章のプログラムから削りだせば良いんだ。 + +## 15.4. リファクタリングする + +15.3節のプログラムをリファクタリングして15.2の形に合わせましょう。 + +## 15.5. 読み込み順のソート + +読み込み順のソートを行えば、問題ないはずです。 +相互参照もチェックできるようにしました。 + + +## 15.6. ファイル読み込みに環境を渡さない。 + +ファイル読み込みするときに、必要以上に検索しないようにする為のキャッシュが効いています。 +でもバグってしまいます。困った。ここで、一度副作用有りで作ってみましょう。 +環境を受け渡しすれば速いけど、分かり辛くなるのは問題です。 + +再考しましょう。 + +まず、内部モジュールが邪魔です。これは明らかです。 + +Openがあるだけの物で、しっかり作り直します。 +これで、しっかりとした解析をする事が基本になります。 + +## 15.7. 環境を拡張しやすいようにする + +環境がただのリストでしたが、複数追加したくなる可能性を感じたので、書き換えます。 + +## 15.8. 内部モジュールで拡張しなおす + +拡張しました。 + +## 15.9. 変数に対応する。 + +変数はオープンした場合とは違って、一時的な参照に過ぎません。 +開かれた履歴は残しますが、それだけです。 + +## 16. 変数について解析する + +15章ではOpenとModuleについての解析が出来ました。 +このアルゴリズムは、ファイルを１度ずつ読み込み、読み込み順を一気に求めます。 +これは一見問題ないように思うかもしれませんが、相互依存しているファイルを見つける事は出来ません。 + +## 18. グラフの作成と依存解析 + +15章では、コンパイラ内部で行うには十分な読み込み順の検索が出来ました。 ## 17. まとめ @@ -698,13 +920,17 @@ read c.ml 評価器に十分な機能を追加した後、Openしたり、モジュールの読み込みを作成してみました。 今回はインタプリタの作成ですが、このような考えを元にコンパイラへ応用を考えると良いでしょう。 -実のところ、ファイルの依存関係はとくに、わざわざグラフを作らなくても済む事が分かったように思います。 -コンパイラを作成する場合は、依存元を先にコンパイルすると、 -型推論が着実に行えます。とりあえず、メインファイルが依存しているファイルは全てオープンし、そのより上のファイルを読み込んで行く事で、全てのファイルを認識出来ます。 -どのファイルがどのファイルを読み込んでいるかを記録しておくと、それはグラフの情報となります。 -依存解析をすることで、コンパイル順を決定する事が出来るでしょう。 -$a \ne 0$, there are two solutions to \(ax^2 + bx + c = 0\) and they are -$$x = {-b \pm \sqrt{b^2-4ac} \over 2a}.$$ +## リンク + +smlで作ったモジュールシステム: + +https://github.com/jordanlewis/simple-module-system + +simple module system: + + +ocaml関連の論文 +https://ocaml.org/docs/papers.html \ No newline at end of file diff --git a/docs/module2/README.md b/docs/module2/README.md new file mode 100644 index 0000000..c3385ad --- /dev/null +++ b/docs/module2/README.md @@ -0,0 +1,946 @@ +# モジュールシステムと依存解析 + +## はじめに + + モジュールの機能があれば、ファイルを複数に分けてプログラムを作成出来て便利です。 + そこで、OCamlのモジュールシステムを分析し、最小限のデータ構造でアルゴリズムを考えます。 + まず1章で非常に簡単なOpenがあるだけのデータ構造を考え、2章でトラバースしてみます。 + 3章でサブモジュールがある場合の問題について取り上げ、再帰的な読み込みの必要性を述べ、実装してみます。 + 4章では結果のデータ構造について考え、実装します。 + 5章ではファイルのキャッシュを、６章では再入の防止を考えます。 + 7章と8章でそれぞれ、依存グラフの取得と、読み込み順の取得を考えます。 + 9章ではサブモジュールについて拡張し、10章で変数について拡張します。 + 11章では処理系に組み込んで使う事を考え、最後に12章でまとめます。 + +## 1. データ構造 + + とにかく、簡単なデータ構造でファイルの依存解析を考えましょう。 + + type e = + | Unit + | Open of string * e + + オープンして、継続し、最後Unitで終わるだけの言語を考えます。 + + どんなデータが表現出来るかと言うと、 + + module FileSystem = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let read f = List.assoc f files + end + + + こんな感じですのデータ構造を表現出来ます。Aは何もオープンしません。 + EはAをオープンしており、Aに依存しています。 + FはEに依存しています。Gはとにかく色々なプログラムに依存しています。 + + HとIは相互依存しています。 + + J,K,Lは三つどもえの状態で依存しています。 + + これらのデータの依存関係を解析したいわけです。 + + let _ = + Format.printf "%s\n" (show_e (FS.read "A")) + + 読み込みはこのように行います。 + +## 2. トラバース + + トラバースするプログラムを書いてみます。 + + type e = + | Unit + | Open of string * e + [@@deriving show] + + module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let read f = List.assoc f files + end + + type ss = string list + [@@deriving show] + + let rec eval = function + | Unit -> [] + | Open(x,e) -> x::(eval e) + + let test file = + let e = FS.read file in + Format.printf "## %s\n" file; + Format.printf " %s\n" (show_e e); + let ss = eval e in + Format.printf " %s\n" (show_ss ss) + + let _ = + List.iter(fun (file,_) -> + test file + ) FS.files + + 実行結果 + + ## A + T02.Unit + [] + ## E + T02.Open ("A", T02.Unit) + ["A"] + ## F + T02.Open ("E", T02.Unit) + ["E"] + ## Inner + T02.Open ("F", T02.Unit) + ["F"] + ## G + T02.Open ("Inner", T02.Open ("E", T02.Open ("F", T02.Unit))) + ["Inner"; "E"; "F"] + ## H + T02.Open ("I", T02.Unit) + ["I"] + ## I + T02.Open ("H", T02.Unit) + ["H"] + ## J + T02.Open ("K", T02.Unit) + ["K"] + ## K + T02.Open ("L", T02.Unit) + ["L"] + ## L + T02.Open ("J", T02.Unit) + ["J"] + + 何とも奇麗に依存情報が表示されました。 + +## 3. 再帰的な読み込み + + ここで、サブモジュールを考えましょう。 + + type e = + | Unit + | Open of string * e + | Mod of string * e * e + + こいつがくせ者なのです。たった１行追加しただけです。 + しかしこれが、くせ者なのです。 + + "A", + Mod("B", + Unit, + Unit); + "C", + Open("A", + Open("B", + Unit); + + このプログラムがその問題の本質を捉えています。問題はOpen(B)が、Aのサブモジュールなのか、 + ファイルを開く事なのかは、Aを開いてみないと分からないのです。 + + 何を言っているんだ？っていますが、以下のプログラムを作ってみてください。 + + aa.ml + + module Bb = struct + let a = "Aa.Bb.a" + end + + bb.ml + + let a = "Bb.a" + + cc.ml + + open Aa + let _ = + Printf.printf "Bb.a=%s\n" Bb.a + + という３つのプログラムを作り以下のようにコンパイル＆実行します。 + + ocamlc aa.ml bb.ml cc.ml -o cc + $ ./cc + Aa.Bb.a + + aa.mlの中味が表示されています。悪いご冗談をと思うのですが、事実です。 + + つまり、openしたモジュールは先に調べなくてはなりません。 + ということは、１つのファイルを調べている間に、他の依存があったら、再入、再入と再帰的に解析して行く必要があるのです。 + + さて、再帰的に解析するプログラムを書いてみましょう。 + + サブモジュールはとりあえず後回しにしましょう。 + + let rec eval = function + | Unit -> [] + | Open(x,e2) -> + let e1 = FS.read x in + let ls = eval e1 in + ls @ x::(eval e2) + + 実行すると + + ## A + T03.Unit + [] + ## E + T03.Open ("A", T03.Unit) + ["A"] + ## F + T03.Open ("E", T03.Unit) + ["A"; "E"] + ## Inner + T03.Open ("F", T03.Unit) + ["A"; "E"; "F"] + ## G + T03.Open ("Inner", T03.Open ("E", T03.Open ("F", T03.Unit))) + ["A"; "E"; "F"; "Inner"; "A"; "E"; "A"; "E"; "F"] + ## H + T03.Open ("I", T03.Unit) + Fatal error: exception Stack_overflow + + こんな結果になりました。そうご参照していると、HからIを読んで、IからHを読んでと繰り返してエラーです。 + + Gを見ると、同じ物が繰り返し表示されてますし、FはEしか見てないのに、Aも表示されています。また、同じファイルを何度も読んでいるのも問題です。 + + 1. 結果をモジュール毎に分けて残す。 + 2. 同じファイルはキャッシュする。 + 3. 一度見たファイルは再入しない。 + + というような事を考えなくてはなりません。 + +## 4. 結果のデータ構造 + + 結果をモジュール毎に分けて残す為に、呼び出した情報をツリー状に返すようにしてみましょう。 + +### 4.1. 依存情報の為のデータ構造 + + 一度、より単純なデータ構造で色々実験してみましょう。 + + type e = + | End + | Let of string * e * e + [@@deriving show] + + endとletだけがある言語を考えます。 + 具体的にデータを書いてみると、以下のようなデータを作る事が出来ます。 + + let e = + Let("O1", + Let("N1", + Let("M1", End, + Let("M2", End, + End)), + Let("N2", + Let("M1", End, + Let("M2", End, + End)), + End)), + Let("O2", + Let("N1", + Let("M1", End, + Let("M2", End, + End)), + Let("N2", + Let("M1", End, + Let("M2", End, + End)), + End)), + End)) + + これを以下のデータ構造に変換する事を考えましょう。 + + type l = + | Tag of string * l list + and ls = l list + [@@deriving show] + + l では以下のように先ほどのデータを表す事が出来ます。 + + let l = + Tag("O1",[ + Tag("N1", [ + Tag("M1", []); + Tag("M2", []); + ]); + Tag("N1", [ + Tag("M1", []); + Tag("M2", []); + ]); + ]) + +#### 4.1.1. eからlへ変換 + + e の利点は１つのデータ構造で表す事が出来る事です。 + lのほうが普通に考えれば分かりやすいのですが、lsとlの２つの処理を作らなくては行けません。 + リスト構造をeのデータに持たせてしまえば、1つの関数で処理出来る訳です。 + + まず、このようなXMLのようなタグを持っただけのデータに変換する事を考えましょう。 + + let rec e2l (e:e):l list = + match e with + | End -> [] + | Let(x,e1,e2) -> + Tag(x, e2l e1)::(e2l e2) + + これだけで、変換出来ます。 + 使ってみましょう。 + + let _ = + let l = e2l e in + Printf.printf "%s\n" (show_ls l) + + 結果として先ほど示したようなデータが出力されます。 + + [T04_a.Tag ("O1", + [T04_a.Tag ("N1", [T04_a.Tag ("M1", []); T04_a.Tag ("M2", [])]); + T04_a.Tag ("N2", [T04_a.Tag ("M1", []); T04_a.Tag ("M2", [])])]); + T04_a.Tag ("O2", + [T04_a.Tag ("N1", [T04_a.Tag ("M1", []); T04_a.Tag ("M2", [])]); + T04_a.Tag ("N2", [T04_a.Tag ("M1", []); T04_a.Tag ("M2", [])])])] + + ネストが分かりにくいかもしれないので、書き換えると + + [ + T04_a.Tag ("O1", [ + T04_a.Tag ("N1", [ + T04_a.Tag ("M1", []); + T04_a.Tag ("M2", []) + ]); + T04_a.Tag ("N2", [ + T04_a.Tag ("M1", []); + T04_a.Tag ("M2", []) + ]) + ]); + T04_a.Tag ("O2", [ + T04_a.Tag ("N1", [ + T04_a.Tag ("M1", []); + T04_a.Tag ("M2", []) + ]); + T04_a.Tag ("N2", [ + T04_a.Tag ("M1", []); + T04_a.Tag ("M2", []) + ]) + ]) + ] + + このように、正しく変換されている事が分かります。 + +#### 4.1.2. lから親と子のリストの取得 + + 次に、このタグデータからタグデータ名と子の要素名のリストのリストを作ってみましょう。 + これは、依存情報のリストを作る事に対応します。 + + let rec f2 = function + | Tag(s,ls) -> + + タグ名を子のリストから作成し + + let tagnames = List.map(fun (Tag(n,_)) -> n) ls in + + 後続のlsについて再帰的に呼び出します。@つかってますが、まぁ良いでしょう。 + + let nexts = List.fold_left (fun l tag -> + (f2 tag) @ l + ) [] ls in + + タグ名とタグ名のリストを組にした物と継続のリストを結合して返せば完了です。 + + (s,tagnames)::nexts + + 印字の為にsssタイプを作って、 + + type sss = (string * string list) list + [@@deriving show] + + 使ってみましょう。 + + let _ = + let sss = f2 (Tag("root",l)) in + Printf.printf "f2 %s\n" (show_sss sss); + + 結果は + + f2 [("root", ["O1"; "O2"]); ("O2", ["N1"; "N2"]); ("N2", ["M1"; "M2"]); + ("M2", []); ("M1", []); ("N1", ["M1"; "M2"]); ("M2", []); ("M1", []); + ("O1", ["N1"; "N2"]); ("N2", ["M1"; "M2"]); ("M2", []); ("M1", []); + ("N1", ["M1"; "M2"]); ("M2", []); ("M1", [])] + + できましたね。リストはタグじゃないからrootって付けました。 + XMLを処理する場合もこういうことをする事があったりしません？ + 面倒くさいwこのめんどくささをなくしたい訳ですね。 + +#### 4.1.3. eから親と子のリストの取得 + + 次はeから同じ物を作ってみましょう。 + + let rec f3 (e:e) = + match e with + | End -> [] + | Let(x,e1,e2) -> + let rec names = function + | End -> [] + | Let(x,_,e2) -> x::(names e2) + in + let names = names e1 in + (x,names)::(f3 e1)@(f3 e2) + + 考え方は一緒です最初に子どもの名前のリストを作って、後続のプログラムと結合します。 + 使ってみましょう。 + + let _ = + let sss = f3 e in + Printf.printf "f3 %s\n" (show_sss sss) + + 結果は同じように出ました。rootがないですが + + f3 [("O1", ["N1"; "N2"]); ("N1", ["M1"; "M2"]); ("M1", []); ("M2", []); + ("N2", ["M1"; "M2"]); ("M1", []); ("M2", []); ("O2", ["N1"; "N2"]); + ("N1", ["M1"; "M2"]); ("M1", []); ("M2", []); ("N2", ["M1"; "M2"]); + ("M1", []); ("M2", [])] + + いいかんじです。 + +#### 4.1.4. eから親と子のリストの取得2 + + @を使っているのが気持悪い所でしたので、なくして、さらに同じ物が複数現れないようにしてみましょう。 + + let rec f4 env e = + match e with + | End -> env + | Let(x,e1,e2) -> + let rec names = function + | End -> [] + | Let(x,_,e2) -> x::(names e2) + in + if(List.mem_assoc x env) then + (f4 (f4 env e2) e1) + else + (x,names e1)::(f4 (f4 env e2) e1) + + let _ = + let sss = f4 [] e in + Printf.printf "f4 %s\n" (show_sss sss) + + できました。 + + f4 [("M2", []); ("M1", []); ("N2", ["M1"; "M2"]); ("N1", ["M1"; "M2"]); + ("O2", ["N1"; "N2"]); ("O1", ["N1"; "N2"])] + + このように、eの構造から、親とこのリストを作る事が出来ます。親とこの関係は、依存リストとして扱う事が出来ます。 + +### 4.2. 組み込み + + これらのノウハウを元に現状のプログラムの結果を考えましょう。 + + type r = + | RUnit + | RLet of string * r * r + and ss = string list + [@@deriving show] + + 型rを用意して、RUnitとRLetがあるようにします。この構造であれば、ツリー状にデータが残せるはずです。 + + let rec eval = function + | Unit -> RUnit + | Open(x, e2) -> + let e1 = FS.read x in + let r1 = eval e1 in + let r2 = eval e2 in + RLet(x, r1, r2) + + and start x = + let e = (FS.read x) in + Format.printf " %s\n" (show_e e); + let r = eval e in + RLet(x, r, RUnit) + + let test file = + Format.printf "## %s\n" file; + let r = start file in + Format.printf " %s\n" (show_r r) + + 結果は以下のようになります。 + + ## A + T04.Unit + T04.RLet ("A", T04.RUnit, T04.RUnit) + ## E + T04.Open ("A", T04.Unit) + T04.RLet ("E", T04.RLet ("A", T04.RUnit, T04.RUnit), T04.RUnit) + ## F + T04.Open ("E", T04.Unit) + T04.RLet ("F", + T04.RLet ("E", T04.RLet ("A", T04.RUnit, T04.RUnit), T04.RUnit), T04.RUnit) + ## Inner + T04.Open ("F", T04.Unit) + T04.RLet ("Inner", + T04.RLet ("F", + T04.RLet ("E", T04.RLet ("A", T04.RUnit, T04.RUnit), T04.RUnit), + T04.RUnit), T04.RUnit) + ## G + T04.Open ("Inner", T04.Open ("E", T04.Open ("F", T04.Unit))) + T04.RLet ("G", + T04.RLet ("Inner", + T04.RLet ("F", + T04.RLet ("E", T04.RLet ("A", T04.RUnit, T04.RUnit), T04.RUnit), + T04.RUnit), + T04.RLet ("E", T04.RLet ("A", T04.RUnit, T04.RUnit), + T04.RLet ("F", + T04.RLet ("E", T04.RLet ("A", T04.RUnit, T04.RUnit), T04.RUnit), + T04.RUnit))), T04.RUnit) + ## H + T04.Open ("I", T04.Unit) + Fatal error: exception Stack_overflow + + Hはやはりエラーになりますが、ツリー状に情報が残っています。 + +## 5. ファイルのキャッシュ + + ファイルを何度も読み込むのは処理が遅くなるので高速化の為に１回だけ読み込み後はキャッシュしましょう。 + 環境情報を用意して、そこに読み込んだファイルの情報を残すようにします。 + + + type r = + | RUnit + | RLet of string * r * r + | RRef of r + and ss = string list + [@@deriving show] + type v = + | VEnv of env * r + and env = {g:(string * v) list} + [@@deriving show] + + let empty = {g=[]} + let rec occur {g=env} x = + List.mem_assoc x env + + let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + + let add_cache {g=env} x v = {g=(x,v)::env} + + let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + and read env x1 = + let (env1, r1) = eval env (FS.read x1) in + (add_cache env1 x1 (VEnv (env1, r1)), r1) + and cache env x1 = + let (env1, r1) = get_cache env x1 in + (env, RRef r1) + and start x = + let (_,r) = read empty x in + RLet(x, r, RUnit) + + これで、キャッシュは出来ていますが、やっぱり再入してしまいます。 + + ## A + T05.RLet ("A", T05.RUnit, T05.RUnit) + ## E + T05.RLet ("E", T05.RLet ("A", T05.RUnit, T05.RUnit), T05.RUnit) + ## F + T05.RLet ("F", + T05.RLet ("E", T05.RLet ("A", T05.RUnit, T05.RUnit), T05.RUnit), T05.RUnit) + ## Inner + T05.RLet ("Inner", + T05.RLet ("F", + T05.RLet ("E", T05.RLet ("A", T05.RUnit, T05.RUnit), T05.RUnit), + T05.RUnit), T05.RUnit) + ## G + T05.RLet ("G", + T05.RLet ("Inner", + T05.RLet ("F", + T05.RLet ("E", T05.RLet ("A", T05.RUnit, T05.RUnit), T05.RUnit), + T05.RUnit), + T05.RLet ("E", (T05.RRef T05.RLet ("A", T05.RUnit, T05.RUnit)), + T05.RLet ("F", + (T05.RRef + T05.RLet ("E", T05.RLet ("A", T05.RUnit, T05.RUnit), T05.RUnit)), + T05.RUnit))), T05.RUnit) + ## H + Fatal error: exception Stack_overflow + +## 6. 再入の防止 + + 再入を防止するには、再入したことの判定が必要です。 + 再入判定の為の目印を用意して、目印が見つかったら再入していると判定しましょう。 + 具体的には、ファイルを読み込むときに、キャッシュ情報に読み込み中である情報を書き込みましょう。 + 読み込み中に更に読み込もうとしたら、再帰的に読み込んでいる事になるので、エラーです。 + + type vに以下のデータ追加します: + + | VCycle + + そして読み込み関数のreadでファイル読み込みの後、評価する前にファイル名にVCycleの目印を入れます。 + + and read env x1 = + Format.printf "read %s\n" x1; + let (env1, r1) = eval (add_cache env x1 VCycle) (FS.read x1) in + (add_cache env1 x1 (VEnv (env1, r1)), r1) + + 次に結果の type rに以下のデータを追加します: + + | RCycle + + キャッシュの取得関数にVCycleならRCycleを返すようにしましょう: + + let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + + 実行すると以下のようになります。 + + ## A + T06.RLet ("A", T06.RUnit, T06.RUnit) + ## E + T06.RLet ("E", T06.RLet ("A", T06.RUnit, T06.RUnit), T06.RUnit) + ## F + T06.RLet ("F", + T06.RLet ("E", T06.RLet ("A", T06.RUnit, T06.RUnit), T06.RUnit), T06.RUnit) + ## Inner + T06.RLet ("Inner", + T06.RLet ("F", + T06.RLet ("E", T06.RLet ("A", T06.RUnit, T06.RUnit), T06.RUnit), + T06.RUnit), T06.RUnit) + ## G + T06.RLet ("G", + T06.RLet ("Inner", + T06.RLet ("F", + T06.RLet ("E", T06.RLet ("A", T06.RUnit, T06.RUnit), T06.RUnit), + T06.RUnit), + T06.RLet ("E", (T06.RRef T06.RLet ("A", T06.RUnit, T06.RUnit)), + T06.RLet ("F", + (T06.RRef + T06.RLet ("E", T06.RLet ("A", T06.RUnit, T06.RUnit), T06.RUnit)), + T06.RUnit))), T06.RUnit) + ## H + T06.RLet ("H", + T06.RLet ("I", T06.RLet ("H", (T06.RRef T06.RCycle), T06.RUnit), T06.RUnit), + T06.RUnit) + ## I + T06.RLet ("I", + T06.RLet ("H", T06.RLet ("I", (T06.RRef T06.RCycle), T06.RUnit), T06.RUnit), + T06.RUnit) + ## J + T06.RLet ("J", + T06.RLet ("K", + T06.RLet ("L", T06.RLet ("J", (T06.RRef T06.RCycle), T06.RUnit), + T06.RUnit), T06.RUnit), T06.RUnit) + ## K + T06.RLet ("K", + T06.RLet ("L", + T06.RLet ("J", T06.RLet ("K", (T06.RRef T06.RCycle), T06.RUnit), + T06.RUnit), T06.RUnit), T06.RUnit) + ## L + T06.RLet ("L", + T06.RLet ("J", + T06.RLet ("K", T06.RLet ("L", (T06.RRef T06.RCycle), T06.RUnit), + T06.RUnit), T06.RUnit), T06.RUnit) + + + RLet ("G", + RLet ("Inner", + RLet ("E", + RLet ("F", + RUnit, + (RRef + RLet ("E", + RUnit, + RLet ("A", + RUnit, + RUnit)))), + (RRef RLet ("A", RUnit, RUnit))), + RLet ("F", + RUnit, + RLet ("E", + RUnit, + RLet ("A", RUnit, RUnit)))), + RUnit) + + 再帰的な参照を含んでいるプログラムも全て読み込む事が出来ました。 + 再帰的なデータ構造については、再入がある事も分かります。 + +## 7. 依存グラフの取得 + + 次は依存グラフを作りましょう。4.1.4で作成したプログラムを改良して組み込めばよいのです。 + + type deps = (string * string list) list + [@@deriving show] + + let rec deps env e = + match e with + | RRef e -> deps env e + | RLet(x,e1,e2) -> + let rec names = function + | RRef e -> names e + | RLet(x,_,e2) -> x::(names e2) + | _ -> [] + in + if(List.mem_assoc x env) then + (deps (deps env e2) e1) + else + (x,names e1)::(deps (deps env e2) e1) + | _ -> env + + P1に関連するファイルの、依存リストは以下のようになります。 + + [("P1", ["O1"; "O2"; "O3"]); ("O1", ["N1"; "N2"; "N3"]); + ("O2", ["N1"; "N2"; "N3"]); ("O3", ["N1"; "N2"; "N3"]); + ("N1", ["M1"; "M2"; "M3"]); ("N2", ["M1"; "M2"; "M3"]); + ("N3", ["M1"; "M2"; "M3"]); ("M1", []); ("M2", []); ("M3", [])] + +## 8. 読み込み順の取得 + + 読み込み順を取得するsortという関数を作ってみましょう。 + + let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + + 動かすと、 + + ## A + T06.RLet ("A", T06.RUnit, T06.RUnit) + ["A"] + ## E + T06.RLet ("E", T06.RLet ("A", T06.RUnit, T06.RUnit), T06.RUnit) + ["A"; "E"] + ## F + T06.RLet ("F", + T06.RLet ("E", + T06.RLet ("A", + T06.RUnit, + T06.RUnit + ), + T06.RUnit), + T06.RUnit) + + ["A"; "E"; "F"] + ## Inner + T06.RLet ("Inner", + T06.RLet ("F", + T06.RLet ("E", + T06.RLet ("A", T06.RUnit, + T06.RUnit), + T06.RUnit), + T06.RUnit), + T06.RUnit) + + ["A"; "E"; "F"; "Inner"] + ## G + T06.RLet ("G", + T06.RLet ("Inner", + T06.RLet ("F", + T06.RLet ("E", T06.RLet ("A", T06.RUnit, T06.RUnit), T06.RUnit), + T06.RUnit), + T06.RLet ("E", (T06.RRef T06.RLet ("A", T06.RUnit, T06.RUnit)), + T06.RLet ("F", + (T06.RRef + T06.RLet ("E", T06.RLet ("A", T06.RUnit, T06.RUnit), T06.RUnit)), + T06.RUnit))), T06.RUnit) + ["A"; "E"; "F"; "Inner"; "E"; "F"; "G"] + ## H + T06.RLet ("H", + T06.RLet ("I", T06.RLet ("H", (T06.RRef T06.RCycle), T06.RUnit), T06.RUnit), + T06.RUnit) + ["H"; "I"; "H"] + ## I + T06.RLet ("I", + T06.RLet ("H", T06.RLet ("I", (T06.RRef T06.RCycle), T06.RUnit), T06.RUnit), + T06.RUnit) + ["I"; "H"; "I"] + ## J + T06.RLet ("J", + T06.RLet ("K", + T06.RLet ("L", T06.RLet ("J", (T06.RRef T06.RCycle), T06.RUnit), + T06.RUnit), T06.RUnit), T06.RUnit) + ["J"; "L"; "K"; "J"] + ## K + T06.RLet ("K", + T06.RLet ("L", + T06.RLet ("J", T06.RLet ("K", (T06.RRef T06.RCycle), T06.RUnit), + T06.RUnit), T06.RUnit), T06.RUnit) + ["K"; "J"; "L"; "K"] + ## L + T06.RLet ("L", + T06.RLet ("J", + T06.RLet ("K", T06.RLet ("L", (T06.RRef T06.RCycle), T06.RUnit), + T06.RUnit), T06.RUnit), T06.RUnit) + ["L"; "K"; "J"; "L"] + + 良さそうです。 + ただ読み出し順に同じファイルが含まれてしまってます。 + + let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet(s,RRef _,r2) -> sort r2 + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + + と書き換えれば、 + + ## A + ["A"] + ## E + ["A"; "E"] + ## F + ["A"; "E"; "F"] + ## Inner + ["A"; "E"; "F"; "Inner"] + ## G + ["A"; "E"; "F"; "Inner"; "G"] + ## H + ["I"; "H"] + ## I + ["H"; "I"] + ## J + ["L"; "K"; "J"] + ## K + ["J"; "L"; "K"] + ## L + ["K"; "J"; "L"] + + うまく行きました。 + +## 9. サブモジュールの導入 + + サブモジュールを作りましょう。 + + type e = + | Unit + | Open of string * e + | Mod of string * e * e + + + を追加します。 + + | VEnvIn of env * r + | RCons of r * r + + + type vにはVEnvInを追加します。 + type rにはRConsを追加します。 + +## 10. 変数の導入 + + 次は、変数を追加しましょう。Openと殆ど同じですが、 + + type e = + | Unit + | Open of string * e + | Var of string * e + +## 11. 処理系への組み込み + + せっかく考えたプログラムですので、出来ればこのまま使いたい物です。 + そこでこの章では、実際の処理系に組み込む事を考えます。 + + 実際の処理系は、コンパイラのメイン関数がファイルを読み込み、構文解析をして構文木sを作成するとします。 + その後すぐにコンパイルの処理に入る訳ですが、ここで、構文木sをeに書き換えるとしましょう。 + そうすると、構文木eへの書き換え途中に、別の構文木sの読み込みが必要になってしまいます。 + + これではうまく行きません。ファイルシステムとして考えていた部分が通常のコンパイラの構文解析器と考えましょう。 + モジュールシステムを先に読み込みます。モジュールシステムは、ファイルシステムにパーサ結果を求めます。 + ファイルシステム自体はパース結果をキャッシュしておいても良いでしょうし、再読み込みしても良いでしょうが、要するにメモリ容量との相談になるでしょう。 + 重要なのは、モジュールシステム主導で動作するようにする事です。 + モジュールシステムがファイルシステムにアクセスして、パース結果を取得し、パース結果を元に、構文木sからeへの変換処理を行って、解析します。 + 解析結果が出たら、解析結果に乗っ取って、インタプリタが評価を開始します。 + + type s = + | Unit + | Var of string list + | Mod of string * s + | Open of string * s + | Let of string * e * e + | Int of int + | Bin of e * op * e + + +## 12. まとめ + + 依存情報を調べるアルゴリズムの為の簡単なデータ構造を考え、実際に作成してみました。 + + 最初に以下のデータ構造を作って依存関係を出力してみました。 + + type e = + | Unit + | Open of string * e + + 3章から6章で、サブモジュールを使うには、再帰的な読み込みが必要である事を見て、再帰的な読み込みを行うようにしました。 + 7章と8章では、結果データを解析しました。 + + 9章ではサブモジュールを追加し、解析可能なようにしました。 + + type e = + | Unit + | Open of string * e + | Mod of string * e * e + + 10章では変数Varを追加しました。 + + type e = + | Unit + | Open of string * e + | Mod of string * e * e + | Var of string * e * e + + 11章では以下の言語sから実際のコンパイラへの組み込み方法について考え、シンプルな実装を作成しました。 + + type s = + | Unit + | Var of string list + | Mod of string * s + | Open of string * s + | Let of string * e * e + | Int of int + | Bin of e * op * e + + OCamlの主な依存関係を効率的に計算する手法について考え実装する事が出来ました。 diff --git a/docs/module2/a.ml b/docs/module2/a.ml new file mode 100644 index 0000000..5e60407 --- /dev/null +++ b/docs/module2/a.ml @@ -0,0 +1,108 @@ +type e = + | Unit + | Open of string * e +and v = + | VEnv of env * r + | VCycle +and r = + | RUnit + | RCycle + | RRef of r + | RLet of string * r * r +and env = (string * v) list +and ss = string list +[@@deriving show] + +module FileSystem = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let caches:env ref = ref [] + let read f = + caches := (f, VCycle) :: !caches; + List.assoc f files +end + +let rec occur env x = + List.mem_assoc x !FileSystem.caches + +let rec get_cache env x = + match List.assoc x !FileSystem.caches with + | VEnv(e,r) -> (e,r) + | VCycle -> ([],RCycle) + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) +and read env x1 = + Format.printf "read %s\n" x1; + let (env, r1) = eval env (FileSystem.read x1) in + FileSystem.caches := (x1,VEnv (env, r1)) :: !FileSystem.caches; + (env, r1) +and cache env x1 = + Format.printf "cache %s\n" x1; + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and start x = + FileSystem.caches := []; + let (env,r) = read [] x in + RLet(x, r, RUnit) + +let sort e = + let rec rem (elt : 'a) (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> if elt = x then rem elt xs else x :: (rem elt xs) + in + let rec nub (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> x :: (nub (rem x xs)) + in + let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + in nub (sort e) + +let _ = + let r = start "G" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "H" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "J" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + \ No newline at end of file diff --git a/docs/module2/aa.ml b/docs/module2/aa.ml new file mode 100644 index 0000000..299e4ac --- /dev/null +++ b/docs/module2/aa.ml @@ -0,0 +1,4 @@ +module Bb = struct + let a = "Aa.Bb.a" +end + diff --git a/docs/module2/b.ml b/docs/module2/b.ml new file mode 100644 index 0000000..eaa5137 --- /dev/null +++ b/docs/module2/b.ml @@ -0,0 +1,105 @@ +type e = + | Unit + | Open of string * e +and v = + | VEnv of env * r + | VCycle +and r = + | RUnit + | RCycle + | RRef of r + | RLet of string * r * r +and env = {g:(string * v) list} +and ss = string list +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let read f = List.assoc f files +end + +let empty = {g=[]} +let rec occur {g=env} x = + List.mem_assoc x env + +let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + +let add_cache {g=env} x v = {g=(x,v)::env} + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) +and read env x1 = + Format.printf "read %s\n" x1; + let (env1, r1) = eval (add_cache env x1 VCycle) (FS.read x1) in + (add_cache env1 x1 (VEnv (env1, r1)), r1) +and cache env x1 = + Format.printf "cache %s\n" x1; + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and start x = + let (_,r) = read empty x in + RLet(x, r, RUnit) + +let sort e = + let rec rem (elt : 'a) (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> if elt = x then rem elt xs else x :: (rem elt xs) + in + let rec nub (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> x :: (nub (rem x xs)) + in + let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + in nub (sort e) + +let _ = + let r = start "G" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "H" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "J" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); diff --git a/docs/module2/bb.ml b/docs/module2/bb.ml new file mode 100644 index 0000000..cdcf517 --- /dev/null +++ b/docs/module2/bb.ml @@ -0,0 +1,2 @@ +let a = "Bb.a" + diff --git a/docs/module2/cc.ml b/docs/module2/cc.ml new file mode 100644 index 0000000..f3b782b --- /dev/null +++ b/docs/module2/cc.ml @@ -0,0 +1,4 @@ +open Aa +let _ = + Printf.printf "Bb.a=%d\n" Bb.a + diff --git a/docs/module2/t01.ml b/docs/module2/t01.ml new file mode 100644 index 0000000..b4d5d32 --- /dev/null +++ b/docs/module2/t01.ml @@ -0,0 +1,31 @@ +type e = + | Unit + | Open of string * e +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let read f = List.assoc f files +end + +let _ = + Format.printf "%s\n" (show_e (FS.read "A")) + + diff --git a/docs/module2/t02.ml b/docs/module2/t02.ml new file mode 100644 index 0000000..942b524 --- /dev/null +++ b/docs/module2/t02.ml @@ -0,0 +1,45 @@ +type e = + | Unit + | Open of string * e +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let read f = List.assoc f files +end + +type ss = string list +[@@deriving show] + +let rec eval = function + | Unit -> [] + | Open(x,e) -> x::(eval e) + +let test file = + let e = FS.read file in + Format.printf "## %s\n" file; + Format.printf " %s\n" (show_e e); + let ss = eval e in + Format.printf " %s\n" (show_ss ss) + +let _ = + List.iter(fun (file,_) -> + test file + ) FS.files diff --git a/docs/module2/t03.ml b/docs/module2/t03.ml new file mode 100644 index 0000000..516aee8 --- /dev/null +++ b/docs/module2/t03.ml @@ -0,0 +1,48 @@ +type e = + | Unit + | Open of string * e +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let read f = List.assoc f files +end + +type ss = string list +[@@deriving show] + +let rec eval = function + | Unit -> [] + | Open(x,e2) -> + let e1 = FS.read x in + let ls = eval e1 in + ls @ x::(eval e2) + +let test file = + let e = FS.read file in + Format.printf "## %s\n" file; + Format.printf " %s\n" (show_e e); + let ss = eval e in + Format.printf " %s\n" (show_ss ss) + +let _ = + List.iter(fun (file,_) -> + test file + ) FS.files diff --git a/docs/module2/t04.ml b/docs/module2/t04.ml new file mode 100644 index 0000000..646462a --- /dev/null +++ b/docs/module2/t04.ml @@ -0,0 +1,56 @@ +type e = + | Unit + | Open of string * e +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let read f = List.assoc f files +end + +type r = + | RUnit + | RLet of string * r * r +and ss = string list +[@@deriving show] + +let rec eval = function + | Unit -> RUnit + | Open(x, e2) -> + let e1 = FS.read x in + let r1 = eval e1 in + let r2 = eval e2 in + RLet(x, r1, r2) + +and start x = + let e = (FS.read x) in + Format.printf " %s\n" (show_e e); + let r = eval e in + RLet(x, r, RUnit) + +let test file = + Format.printf "## %s\n" file; + let r = start file in + Format.printf " %s\n" (show_r r) + +let _ = + List.iter(fun (file,_) -> + test file + ) FS.files diff --git a/docs/module2/t04_a.ml b/docs/module2/t04_a.ml new file mode 100644 index 0000000..d02fa39 --- /dev/null +++ b/docs/module2/t04_a.ml @@ -0,0 +1,93 @@ +type e = + | Unit + | Let of string * e * e +and l = + | Tag of string * l list +and ls = l list +and sss = (string * string list) list +[@@deriving show] + +let e = + Let("O1", + Let("N1", + Let("M1", Unit, + Let("M2", Unit, + Unit)), + Let("N2", + Let("M1", Unit, + Let("M2", Unit, + Unit)), + Unit)), + Let("O2", + Let("N1", + Let("M1", Unit, + Let("M2", Unit, + Unit)), + Let("N2", + Let("M1", Unit, + Let("M2", Unit, + Unit)), + Unit)), + Unit)) + +let l = + Tag("O1",[ + Tag("N1", [ + Tag("M1", []); + Tag("M2", []); + ]); + Tag("N1", [ + Tag("M1", []); + Tag("M2", []); + ]); + ]) + +let rec f (e:e):l list = + match e with + | Unit -> [] + | Let(x,e1,e2) -> + Tag(x, f e1)::(f e2) + +let rec f2 = function + | Tag(s,ls) -> + let tagnames = List.map(fun (Tag(n,_)) -> n) ls in + (s,tagnames)::(List.fold_left (fun l tag -> (f2 tag)@l) [] ls) + +let rec f3 (e:e) = + match e with + | Unit -> [] + | Let(x,e1,e2) -> + + let rec names (e:e):string list = + match e with + | Unit -> [] + | Let(x,_,e2) -> + x::(names e2) + in + let names = names e1 in + (x,names)::(f3 e1)@(f3 e2) + +let rec f4 env e = + match e with + | Unit -> env + | Let(x,e1,e2) -> + let rec names = function + | Unit -> [] + | Let(x,_,e2) -> x::(names e2) + in + if(List.mem_assoc x env) then + (f4 (f4 env e2) e1) + else + (f4 (f4 ((x,names e1)::env) e2) e1) + +let _ = + let l = f e in + Printf.printf "%s\n" (show_ls l); + let sss = f2 (Tag("root",l)) in + Printf.printf "f2 %s\n" (show_sss sss); + + let sss = f3 e in + Printf.printf "f3 %s\n" (show_sss sss); + + let sss = f4 [] e in + Printf.printf "f4 %s\n" (show_sss sss) diff --git a/docs/module2/t05.ml b/docs/module2/t05.ml new file mode 100644 index 0000000..e67878e --- /dev/null +++ b/docs/module2/t05.ml @@ -0,0 +1,80 @@ +type e = + | Unit + | Open of string * e +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let read f = List.assoc f files +end + +type r = + | RUnit + | RLet of string * r * r + | RRef of r +and ss = string list +[@@deriving show] + + +type v = + | VEnv of env * r +and env = {g:(string * v) list} +[@@deriving show] + +let empty = {g=[]} +let rec occur {g=env} x = + List.mem_assoc x env + +let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + +let add_cache {g=env} x v = {g=(x,v)::env} + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) +and read env x1 = + let (env1, r1) = eval env (FS.read x1) in + (add_cache env1 x1 (VEnv (env1, r1)), r1) +and cache env x1 = + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and start x = + let (_,r) = read empty x in + RLet(x, r, RUnit) + +let test file = + Format.printf "## %s\n" file; + let r = start file in + Format.printf " %s\n" (show_r r) + +let _ = + List.iter(fun (file,_) -> + test file + ) FS.files diff --git a/docs/module2/t06.ml b/docs/module2/t06.ml new file mode 100644 index 0000000..11217a3 --- /dev/null +++ b/docs/module2/t06.ml @@ -0,0 +1,101 @@ +type e = + | Unit + | Open of string * e +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + "M1",Unit; + "M2",Unit; + "M3",Unit; + "N1", + Open("M1",Open("M2",Open("M3",Unit))); + "N2", + Open("M1",Open("M2",Open("M3",Unit))); + "N3", + Open("M1",Open("M2",Open("M3",Unit))); + "O1", + Open("N1",Open("N2",Open("N3",Unit))); + "O2", + Open("N1",Open("N2",Open("N3",Unit))); + "O3", + Open("N1",Open("N2",Open("N3",Unit))); + "P1", + Open("O1",Open("O2",Open("O3",Unit))); + + ] + let read f = List.assoc f files +end + +type r = + | RUnit + | RLet of string * r * r + | RRef of r + | RCycle +and ss = string list +[@@deriving show] + + +type v = + | VEnv of env * r + | VCycle +and env = {g:(string * v) list} +[@@deriving show] + +let empty = {g=[]} +let rec occur {g=env} x = + List.mem_assoc x env + +let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + +let add_cache {g=env} x v = {g=(x,v)::env} + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) +and read env x1 = + let (env1, r1) = eval (add_cache env x1 VCycle) (FS.read x1) in + (add_cache env1 x1 (VEnv (env1, r1)), r1) +and cache env x1 = + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and start x:r = + let (_,r) = read empty x in + RLet(x, r, RUnit) + +let test file = + Format.printf "## %s\n" file; + let r = start file in + Format.printf " %s\n" (show_r r) + +let _ = + List.iter(fun (file,_) -> + test file + ) FS.files diff --git a/docs/module2/t07.ml b/docs/module2/t07.ml new file mode 100644 index 0000000..c2061ff --- /dev/null +++ b/docs/module2/t07.ml @@ -0,0 +1,109 @@ +type e = + | Unit + | Open of string * e +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + "M1",Unit; + "M2",Unit; + "M3",Unit; + "N1", + Open("M1",Open("M2",Open("M3",Unit))); + "N2", + Open("M1",Open("M2",Open("M3",Unit))); + "N3", + Open("M1",Open("M2",Open("M3",Unit))); + "O1", + Open("N1",Open("N2",Open("N3",Unit))); + "O2", + Open("N1",Open("N2",Open("N3",Unit))); + "O3", + Open("N1",Open("N2",Open("N3",Unit))); + "P1", + Open("O1",Open("O2",Open("O3",Unit))); + + ] + let read f = List.assoc f files +end + +type r = + | RUnit + | RLet of string * r * r + | RRef of r + | RCycle +and ss = string list +[@@deriving show] + + +type v = + | VEnv of env * r + | VCycle +and env = {g:(string * v) list} +[@@deriving show] + +let empty = {g=[]} +let rec occur {g=env} x = + List.mem_assoc x env + +let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + +let add_cache {g=env} x v = {g=(x,v)::env} + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) +and read env x1 = + let (env1, r1) = eval (add_cache env x1 VCycle) (FS.read x1) in + (add_cache env1 x1 (VEnv (env1, r1)), r1) +and cache env x1 = + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and start x:r = + let (_,r) = read empty x in + RLet(x, r, RUnit) + +let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet(s,RRef _,r2) -> sort r2 + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + +let test file = + Format.printf "## %s\n" file; + let r = start file in + Format.printf " %s\n" (show_r r); + Format.printf " %s\n" (show_ss (sort r)) + +let _ = + List.iter(fun (file,_) -> + test file + ) FS.files diff --git a/docs/module2/t08.ml b/docs/module2/t08.ml new file mode 100644 index 0000000..eca929c --- /dev/null +++ b/docs/module2/t08.ml @@ -0,0 +1,128 @@ +type e = + | Unit + | Open of string * e +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + "M1",Unit; + "M2",Unit; + "M3",Unit; + "N1", + Open("M1",Open("M2",Open("M3",Unit))); + "N2", + Open("M1",Open("M2",Open("M3",Unit))); + "N3", + Open("M1",Open("M2",Open("M3",Unit))); + "O1", + Open("N1",Open("N2",Open("N3",Unit))); + "O2", + Open("N1",Open("N2",Open("N3",Unit))); + "O3", + Open("N1",Open("N2",Open("N3",Unit))); + "P1", + Open("O1",Open("O2",Open("O3",Unit))); + + ] + let read f = List.assoc f files +end + +type r = + | RUnit + | RLet of string * r * r + | RRef of r + | RCycle +and ss = string list +[@@deriving show] + + +type v = + | VEnv of env * r + | VCycle +and env = {g:(string * v) list} +[@@deriving show] + +let empty = {g=[]} +let rec occur {g=env} x = + List.mem_assoc x env + +let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + +let add_cache {g=env} x v = {g=(x,v)::env} + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) +and read env x1 = + let (env1, r1) = eval (add_cache env x1 VCycle) (FS.read x1) in + (add_cache env1 x1 (VEnv (env1, r1)), r1) +and cache env x1 = + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and start x:r = + let (_,r) = read empty x in + RLet(x, r, RUnit) + +let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet(s,RRef _,r2) -> sort r2 + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + +type deps = (string * string list) list +[@@deriving show] + +let rec deps env e = + match e with + | RRef e -> deps env e + | RLet(x,e1,e2) -> + let rec names = function + | RRef e -> names e + | RLet(x,_,e2) -> x::(names e2) + | _ -> [] + in + if(List.mem_assoc x env) then + (deps (deps env e2) e1) + else + (x,names e1)::(deps (deps env e2) e1) + | _ -> env + +let test file = + Format.printf "## %s\n" file; + let r = start file in + Format.printf " %s\n" (show_r r); + Format.printf " %s\n" (show_ss (sort r)); + Format.printf " %s\n" (show_deps (deps [] r)) + +let _ = + List.iter(fun (file,_) -> + test file + ) FS.files diff --git a/docs/module2/t09.ml b/docs/module2/t09.ml new file mode 100644 index 0000000..f4127f9 --- /dev/null +++ b/docs/module2/t09.ml @@ -0,0 +1,130 @@ +type e = + | Unit + | Open of string * e +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "E", + Open("A", Unit); + "F", + Open("E", Unit); + "Inner", + Open("F", Unit); + "G", + Open("Inner", Open("E", Open("F", Unit))); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + "M1",Unit; + "M2",Unit; + "M3",Unit; + "N1", + Open("M1",Open("M2",Open("M3",Unit))); + "N2", + Open("M1",Open("M2",Open("M3",Unit))); + "N3", + Open("M1",Open("M2",Open("M3",Unit))); + "O1", + Open("N1",Open("N2",Open("N3",Unit))); + "O2", + Open("N1",Open("N2",Open("N3",Unit))); + "O3", + Open("N1",Open("N2",Open("N3",Unit))); + "P1", + Open("O1",Open("O2",Open("O3",Unit))); + + ] + let read f = List.assoc f files +end + +type r = + | RUnit + | RLet of string * r * r + | RRef of r + | RCycle + | RCons of r * r +and ss = string list +[@@deriving show] + + +type v = + | VEnv of env * r + | VEnvIn of env * r + | VCycle +and env = {g:(string * v) list} +[@@deriving show] + +let empty = {g=[]} +let rec occur {g=env} x = + List.mem_assoc x env + +let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + +let add_cache {g=env} x v = {g=(x,v)::env} + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) +and read env x1 = + let (env1, r1) = eval (add_cache env x1 VCycle) (FS.read x1) in + (add_cache env1 x1 (VEnv (env1, r1)), r1) +and cache env x1 = + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and start x:r = + let (_,r) = read empty x in + RLet(x, r, RUnit) + +let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet(s,RRef _,r2) -> sort r2 + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + +type deps = (string * string list) list +[@@deriving show] + +let rec deps env e = + match e with + | RRef e -> deps env e + | RLet(x,e1,e2) -> + let rec names = function + | RRef e -> names e + | RLet(x,_,e2) -> x::(names e2) + | _ -> [] + in + if(List.mem_assoc x env) then + (deps (deps env e2) e1) + else + (x,names e1)::(deps (deps env e2) e1) + | _ -> env + +let test file = + Format.printf "## %s\n" file; + let r = start file in + Format.printf " %s\n" (show_r r); + Format.printf " %s\n" (show_ss (sort r)); + Format.printf " %s\n" (show_deps (deps [] r)) + +let _ = + List.iter(fun (file,_) -> + test file + ) FS.files diff --git a/docs/module2/t10.ml b/docs/module2/t10.ml new file mode 100644 index 0000000..bbb643f --- /dev/null +++ b/docs/module2/t10.ml @@ -0,0 +1,142 @@ +type e = +| Unit +| Open of string * e +| Mod of string * e * e +and v = +| VEnv of env * r +| VEnvIn of env * r +| VCycle +and r = +| RUnit +| RCycle +| RRef of r +| RLet of string * r * r +| RCons of r * r +and env = {caches:(string * v) list} +and ss = string list +[@@deriving show] + +module FS = struct + let files = [ + "A", + Unit; + "C", + Unit; + "E", + Mod("In", + Mod("B", + Unit, + Open ("B", + Unit)), + Open("In", + Open("F", + Open("B", + Open("A", + Unit))))); + "F", + Open("A", + Open("C", + Unit)); + "Inner", + Open("F", + Unit); + "G", + Open("Inner", + Open("E", + Open("F", + Unit))); + + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + ] + let read f = List.assoc f files +end + +let rcons = function + | (RUnit,r) | (r,RUnit) -> r + | (r1,r2) -> RCons(r1, r2) + +let sort e = + let rec rem (elt : 'a) (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> if elt = x then rem elt xs else x :: (rem elt xs) + in + let rec nub (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> x :: (nub (rem x xs)) + in + let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet(s,RRef(_),r2) -> sort r2 + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + | RCons(r1,r2) -> sort r1 @ sort r2 + in nub (sort e) + +let rec occur {caches=env} x = + List.mem_assoc x env + +let rec get_cache {caches=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VEnvIn(e,r) -> (e,r) + | VCycle -> ({caches=[]},RCycle) + +let rec ignore_inner {caches=env} = + {caches=List.filter (function |(x,VEnvIn(_,_))-> false | _ -> true) env} + +let add_cache {caches=env} x v = {caches=(x,v)::env} +let empty = {caches=[]} + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + | Mod(s, e1, e2) -> + let (env, r1) = eval env e1 in + let (env, r2) = eval (add_cache env s (VEnvIn(env, r1))) e2 in + (env, rcons(r1, r2)) +and read env x1 = + let env = ignore_inner env in + Format.printf "read %s\n" x1; + let (env1, r1) = eval (add_cache env x1 VCycle) (FS.read x1) in + (add_cache env1 x1 (VEnv (env1, r1)), r1) +and cache env x1 = + Format.printf "cache %s\n" x1; + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and start x = + let (_,r) = read empty x in + RLet(x, r, RUnit) + +let _ = + let r = start "G" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "H" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "J" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + \ No newline at end of file diff --git a/docs/module2/t10_2.ml b/docs/module2/t10_2.ml new file mode 100644 index 0000000..6eafc14 --- /dev/null +++ b/docs/module2/t10_2.ml @@ -0,0 +1,280 @@ +type e = +| Unit +| Open of string * e +| Mod of string * e * e +| Var of string * e * e +and v = +| VEnv of env * r +| VCycle +and r = +| RUnit +| RCycle +| RRef of r +| RLet of string * r * r +and env = {g:(string * v) list;l:(string * v) list} +and ss = string list +[@@deriving show] + +module FileSystem = struct + let files = [ + "A", + Unit; + "E", + Mod("In", + Mod("InC", + Unit, + Mod("InB", + Unit, + Open ("InB", + Unit))), + Open("In", + Open("InC", + Open("InB", + Open("A", + Unit))))); + + "F", + Open("A", Unit); + "G", + Open("F", Open("E", Unit)); + "H", Open("I", Unit); + "I", Open("H", Unit); + "J", Open("K", Unit); + "K", Open("L", Unit); + "L", Open("J", Unit); + + "M", + Mod("InN", + Mod("InP", + Unit, + Unit), + Unit); + "O", + Open("M", + Open("InN", + Open("InP", + Unit))); + + (* error *) + "PE", + Mod("InP1", + Open("M", + Unit), + Open("InN", + Unit)); + "R1", + Unit; + "R", + Mod("InP1", + Open("M", + Open("InN", + Unit)), + Open("R1", + Unit)); + + (* error *) + "SE", + Mod("InP1", + Var("M",Unit, + Open("InN", + Unit)), + Open("R1", + Unit)); + + "T", + Mod("InP1", + Var("M",Unit, + Unit), + Var("M",Unit, + Open("R1", + Unit))); + + "U", + Open("M", + Open("InN", + Unit)); + + (* TODO *) + "V", + Mod("InP1", + Var("M",Unit, + Unit), + Var("M",Var("InN",Unit,Unit), + Unit)); + + (* error *) + "VE", + Mod("InP1", + Var("M",Unit, + Unit), + Var("M",Var("InN1",Unit,Unit), + Unit)); + ] + let read f = List.assoc f files +end + +let rcons = function + | (RUnit,r) | (r,RUnit) -> r + | (r1,r2) -> RLet("_",r1, r2) + +let sort e = + let rec rem (elt : 'a) (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> if elt = x then rem elt xs else x :: (rem elt xs) + in + let rec nub (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> x :: (nub (rem x xs)) + in + let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet("_",r1,r2) -> sort r1 @ sort r2 + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + in nub (sort e) + +let empty = {g=[];l=[]} +let rec occur {g=env} x = + List.mem_assoc x env + +let rec loccur {l=env} x = + List.mem_assoc x env + +let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + +let rec get_lcache {l=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + +let add_cache {g=g;l=l} x v = {g=(x,v)::g;l=l} +let add_lcache {g=g;l=l} x v = {g=g;l=(x,v)::l} + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if loccur env x1 then + let (env, r1) = lcache env x1 in + let (env, r2) = eval env e2 in + (env, r2) + else if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + | Mod(s, e1, e2) -> + let (env1, r1) = eval env e1 in + let env = {g=env1.g @ env.g;l=env.l} in + let (env, r2) = eval (add_lcache env s (VEnv(env1, r1))) e2 in + (env, rcons(r1, r2)) + | Var(x0, e1, e2) -> + if loccur env x0 then + let (env1, r0) = lcache env x0 in + let (env1, r1) = eval env1 e1 in + let (env, r2) = eval (add_lcache env x0 (VEnv(env1, r1))) e2 in + (env, rcons(r0, rcons(r1,r2))) + else if occur env x0 then + let (env1, r0) = cache env x0 in + let (env1, r1) = eval (add_cache env x0 (VEnv(env1, r0))) e2 in + let (env, r2) = eval (add_cache env x0 (VEnv(env1, r1))) e2 in + (env, RLet(x0, r0, rcons(r1, r2))) + else + let (env1, r0) = read env x0 in + let (env1, r1) = eval env1 e1 in + let (env, r2) = eval (add_cache env x0 (VEnv(env1, r1))) e2 in + (env, RLet(x0, r0, rcons(r1, r2))) +and read {g=g;l=l} x1 = + Format.printf "read %s\n" x1; + let ({g=g1;l=l1}, r1) = eval (add_cache {g=g;l=[]} x1 VCycle) (FileSystem.read x1) in + (add_cache {g=g1;l=l1@l} x1 (VEnv ({g=g1;l=l1}, r1)), r1) +and cache env x1 = + Format.printf "cache %s\n" x1; + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and lcache {g=g;l=l} x1 = + Format.printf "lcache %s\n" x1; + let ({g=g1;l=l1}, r1) = get_lcache {g=g;l=l} x1 in + (add_lcache {g=g;l=l1@l} x1 (VEnv ({g=g1;l=l1}, r1)), RRef r1) +and start x = + let (_,r) = read empty x in + RLet(x, r, RUnit) + +let _ = + let r = start "G" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "H" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "J" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "O" in + Format.printf "%s\n" (show_r r); + + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + (try + let r = start "PE" in + Format.printf "%s\n" (show_r r); + with + | _ -> + Format.printf "error ok\n"; + ); + + let r = start "R" in + Format.printf "%s\n" (show_r r); + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + (try + let r = start "SE" in + Format.printf "%s\n" (show_r r); + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + with + | _ -> + Format.printf "error ok\n"; + ); + + let r = start "T" in + Format.printf "%s\n" (show_r r); + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "U" in + Format.printf "%s\n" (show_r r); + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + let r = start "V" in + Format.printf "%s\n" (show_r r); + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + + (try + let r = start "VE" in + Format.printf "%s\n" (show_r r); + let ss = sort r in + Format.printf "%s\n" (show_ss ss); + with + | _ -> + Format.printf "error ok\n"; + ) diff --git a/docs/module2/t11.ml b/docs/module2/t11.ml new file mode 100644 index 0000000..82b466b --- /dev/null +++ b/docs/module2/t11.ml @@ -0,0 +1,181 @@ +module S = struct + type s = + | Unit + | Var of string list + | Mod of string * s * s + | Open of string * s + | Let of string * s * s + | Int of int + | Bin of s * string * s +end + +type e = + | Unit + | Open of string * e + | Mod of string * e * e + | Var of string * e * e +and v = + | VEnv of env * r + | VCycle +and r = + | RUnit + | RCycle + | RRef of r + | RLet of string * r * r +and env = {g:(string * v) list;l:(string * v) list} +and ss = string list +and sss = (string * string list) list +[@@deriving show] + +module FS1 = struct + open S + + let files = [ + "a.ml", + Let("a", Int 1, + Unit); + "b.ml", + Let("b", Var["A";"a"], + Unit); + "c.ml", + Open("B", + Bin(Var["A";"a"],"+",Var ["b"]) + ); + ] + let read f = List.assoc f files +end + +module FS = struct + + let filename f = + (String.uncapitalize f) ^ ".ml" + + let modulename f = + let m = (String.capitalize f) in + String.sub m 0 ((String.length m) - 3) + + let rec convert r = function + | S.Unit -> r + | S.Var(x::_::_) -> Var(x,Unit,r) + | S.Var(_) -> r + | S.Mod(x,s1,s2) -> Mod(x, convert Unit s1, convert r s2) + | S.Open(x,s) -> Open(x, convert r s) + | S.Let(x,s1,s2) -> convert (convert r s2) s1 + | S.Int(_) -> r + | S.Bin(s1,_,s2) -> convert (convert r s2) s1 + + let read f = + let s = FS1.read(filename f)in + let e = convert Unit s in + e +end + + + +let rcons = function + | (RUnit,r) | (r,RUnit) -> r + | (r1,r2) -> RLet("_",r1, r2) + +let sort e = + let rec rem (elt : 'a) (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> if elt = x then rem elt xs else x :: (rem elt xs) + in + let rec nub (lst : 'a list) : 'a list = match lst with + | [] -> [] + | x :: xs -> x :: (nub (rem x xs)) + in + let rec sort = function + | RUnit -> [] + | RCycle -> [] + | RRef _ -> [] + | RLet("_",r1,r2) -> sort r1 @ sort r2 + | RLet(s,r1,r2) -> sort r1 @ s :: sort r2 + in nub (sort e) + +let empty = {g=[];l=[]} +let rec occur {g=env} x = + List.mem_assoc x env + +let rec loccur {l=env} x = + List.mem_assoc x env + +let rec get_cache {g=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + +let rec get_lcache {l=env} x = + match List.assoc x env with + | VEnv(e,r) -> (e,r) + | VCycle -> (empty,RCycle) + +let add_cache {g=g;l=l} x v = {g=(x,v)::g;l=l} +let add_lcache {g=g;l=l} x v = {g=g;l=(x,v)::l} + +let rec eval (env:env) = function + | Unit -> (env, RUnit) + | Open(x1, e2) -> + if loccur env x1 then + let (env, r1) = lcache env x1 in + let (env, r2) = eval env e2 in + (env, r2) + else if occur env x1 then + let (env, r1) = cache env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + else + let (env, r1) = read env x1 in + let (env, r2) = eval env e2 in + (env, RLet(x1, r1, r2)) + | Mod(s, e1, e2) -> + let (env1, r1) = eval env e1 in + let env = {g=env1.g @ env.g;l=env.l} in + let (env, r2) = eval (add_lcache env s (VEnv(env1, r1))) e2 in + (env, rcons(r1, r2)) + | Var(x0, e1, e2) -> + if loccur env x0 then + let (env1, r0) = lcache env x0 in + let (env1, r1) = eval env1 e1 in + let (env, r2) = eval (add_lcache env x0 (VEnv(env1, r1))) e2 in + (env, rcons(r0, rcons(r1,r2))) + else if occur env x0 then + let (env1, r0) = cache env x0 in + let (env1, r1) = eval (add_cache env x0 (VEnv(env1, r0))) e2 in + let (env, r2) = eval (add_cache env x0 (VEnv(env1, r1))) e2 in + (env, RLet(x0, r0, rcons(r1, r2))) + else + let (env1, r0) = read env x0 in + let (env1, r1) = eval env1 e1 in + let (env, r2) = eval (add_cache env x0 (VEnv(env1, r1))) e2 in + (env, RLet(x0, r0, rcons(r1, r2))) +and read {g=g;l=l} x1 = + (* + Format.printf "read %s\n" x1; + *) + let ({g=g1;l=l1}, r1) = eval (add_cache {g=g;l=[]} x1 VCycle) (FS.read x1) in + (add_cache {g=g1;l=l1@l} x1 (VEnv ({g=g1;l=l1}, r1)), r1) +and cache env x1 = + (* + Format.printf "cache %s\n" x1; + *) + let (env1, r1) = get_cache env x1 in + (env, RRef r1) +and lcache {g=g;l=l} x1 = + (* + Format.printf "lcache %s\n" x1; + *) + let ({g=g1;l=l1}, r1) = get_lcache {g=g;l=l} x1 in + (add_lcache {g=g;l=l1@l} x1 (VEnv ({g=g1;l=l1}, r1)), RRef r1) +and start x = + let (_,r) = read empty x in + RLet(x, r, RUnit) + +let analize ml = + let x = FS.modulename ml in + let r = start x in + sort r + +let _ = + let r = analize "c.ml" in + Printf.printf "result %s\n" (show_ss r)