├── .editorconfig ├── .gitignore ├── .travis.yml ├── LICENSE.md ├── README.md ├── project.clj ├── src └── wam │ ├── anciliary.clj │ ├── compiler.clj │ ├── functor.clj │ ├── grammar.clj │ ├── graph_search.clj │ ├── instruction_set.clj │ └── store.clj └── test └── wam ├── anciliary_test.clj ├── assert_helpers.clj ├── compiler_test.clj ├── functor_test.clj ├── grammar_test.clj ├── instruction_set_test.clj └── store_test.clj /.editorconfig: -------------------------------------------------------------------------------- 1 | # Learn more about EditorConfig at http://editorconfig.org 2 | 3 | root = true 4 | 5 | [*] 6 | charset = utf-8 7 | trim_trailing_whitespace = true 8 | end_of_line = lf 9 | insert_final_newline = true 10 | 11 | [*.{clj,cljs,cljc}] 12 | indent_style = space 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | pom.xml 2 | pom.xml.asc 3 | *jar 4 | /lib/ 5 | /classes/ 6 | /target/ 7 | /checkouts/ 8 | /doc/api/ 9 | .lein-deps-sum 10 | .lein-repl-history 11 | .lein-plugins/ 12 | .lein-failures 13 | .nrepl-port 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: clojure 2 | lein: 2.8.1 3 | install: 4 | # Get recent node: 5 | - . $HOME/.nvm/nvm.sh 6 | - nvm install stable 7 | - nvm use stable 8 | - npm install 9 | before_script: 10 | - npm install -g eclint 11 | - eclint check .* * src/** test/** 12 | - lein install 13 | - lein cljfmt check 14 | script: 15 | - lein with-profile +dev cloverage --coveralls 16 | - curl -F 'json_file=@target/coverage/coveralls.json' 'https://coveralls.io/api/v1/jobs' 17 | jdk: 18 | - oraclejdk8 19 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Richard Hull 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Warren's Abstract Machine 2 | 3 | [![Build Status](https://travis-ci.org/rm-hull/wam.svg?branch=master)](http://travis-ci.org/rm-hull/wam) 4 | [![Coverage Status](https://coveralls.io/repos/github/rm-hull/wam/badge.svg?branch=master)](https://coveralls.io/github/rm-hull/wam?branch=master) 5 | [![Dependencies Status](https://versions.deps.co/rm-hull/wam/status.svg)](https://versions.deps.co/rm-hull/wam) 6 | [![Maintenance](https://img.shields.io/maintenance/yes/2018.svg?maxAge=2592000)]() 7 | 8 | A gradual WAM implementation in Clojure following Hassan Aït-Kaci's tutorial reconstruction. 9 | 10 | 11 | 12 | **Table of Contents** *generated with [DocToc](https://github.com/thlorenz/doctoc)* 13 | 14 | - [Language ℒ₀ – Unification](#language-%E2%84%92%E2%82%80--unification) 15 | - [Exercise 2.1 (pg. 9)](#exercise-21-pg-9) 16 | - [EBNF ℒ₀ Grammar & Parser Combinators](#ebnf-%E2%84%92%E2%82%80-grammar--parser-combinators) 17 | - [Compiling ℒ₀ queries](#compiling-%E2%84%92%E2%82%80-queries) 18 | - [Compiling ℒ₀ programs](#compiling-%E2%84%92%E2%82%80-programs) 19 | - [Exercise 2.2 (pg. 14)](#exercise-22-pg-14) 20 | - [Exercise 2.3 (pg. 14)](#exercise-23-pg-14) 21 | - [Exercise 2.4 (pg. 14)](#exercise-24-pg-14) 22 | - [Exercise 2.5 (pg. 14)](#exercise-25-pg-14) 23 | - [Language ℒ₁ – Argument Registers](#language-%E2%84%92%E2%82%81--argument-registers) 24 | - [Exercise 2.6 (pg. 18)](#exercise-26-pg-18) 25 | - [Exercise 2.7 (pg. 18)](#exercise-27-pg-18) 26 | - [Exercise 2.8 (pg. 18)](#exercise-28-pg-18) 27 | - [Exercise 2.9 (pg. 19)](#exercise-29-pg-19) 28 | - [Language ℒ₂ – Flat Resolution](#language-%E2%84%92%E2%82%82--flat-resolution) 29 | - [Language ℒ₃ – Prolog](#language-%E2%84%92%E2%82%83--prolog) 30 | - [References](#references) 31 | - [License](#license) 32 | 33 | 34 | 35 | ## Language ℒ₀ – Unification 36 | 37 | ### Exercise 2.1 (pg. 9) 38 | 39 | > Verify that the effect of executing the sequence of instructions shown in 40 | > Figure 2.3 (starting with `H` = 0) does indeed yield a correct heap 41 | > representation for the term _p(Z, h(Z, W), f(W))_ — the one shown earlier 42 | > as Figure 2.1, in fact. 43 | 44 | See [ℳ₀ machine instructions](https://github.com/rm-hull/wam/blob/L0/src/wam/instruction_set.clj) for implementation details 45 | 46 | ```clojure 47 | (use 'wam.instruction-set) 48 | (use 'wam.store) 49 | (use 'table.core) 50 | 51 | (def context (make-context)) 52 | 53 | (-> 54 | context 55 | (put-structure 'h|2, 'X3) 56 | (set-variable 'X2) 57 | (set-variable 'X5) 58 | (put-structure 'f|1, 'X4) 59 | (set-value 'X5) 60 | (put-structure 'p|3, 'X1) 61 | (set-value 'X2) 62 | (set-value 'X3) 63 | (set-value 'X4) 64 | heap 65 | (table :style :unicode)) 66 | ``` 67 | Produces: 68 | ``` 69 | ┌──────┬────────────┐ 70 | │ key │ value │ 71 | ├──────┼────────────┤ 72 | │ 1000 ╎ [STR 1001] │ 73 | │ 1001 ╎ h|2 │ 74 | │ 1002 ╎ [REF 1002] │ 75 | │ 1003 ╎ [REF 1003] │ 76 | │ 1004 ╎ [STR 1005] │ 77 | │ 1005 ╎ f|1 │ 78 | │ 1006 ╎ [REF 1003] │ 79 | │ 1007 ╎ [STR 1008] │ 80 | │ 1008 ╎ p|3 │ 81 | │ 1009 ╎ [REF 1002] │ 82 | │ 1010 ╎ [STR 1001] │ 83 | │ 1011 ╎ [STR 1005] │ 84 | └──────┴────────────┘ 85 | ``` 86 | 87 | ### EBNF ℒ₀ Grammar & Parser Combinators 88 | 89 | The simplistic EBNF [grammar rules](https://github.com/rm-hull/wam/blob/master/src/wam/grammar.clj) 90 | for ℒ₀ below have been implemented using a [parser monad](https://github.com/rm-hull/jasentaa). 91 | 92 | * _**<Digit>** ::= '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'_ 93 | 94 | * _**<Number>** ::= <Digit> <Digit>*_ 95 | 96 | * _**<LowerAlpha>** ::= 'a' .. 'z'_ 97 | 98 | * _**<UpperAlpha>** ::= 'A' .. 'Z'_ 99 | 100 | * _**<AlphaNum>** ::= <LowerAlpha> | <UpperAlpha> | <Digit>_ 101 | 102 | * _**<Predicate>** ::= <LowerAlpha> <AlphaNum>*_ 103 | 104 | * _**<Constant>** ::= <Number>_ 105 | 106 | * _**<Variable>** ::= <UpperAlpha> <AlphaNum>* |_ '_' 107 | 108 | * _**<Structure>** ::= <Predicate> | <Predicate> '(' <List> ')'_ 109 | 110 | * _**<List>** ::= <Element> | <Element> ',' <List>_ 111 | 112 | * _**<Element>** ::= <Variable> | <Constant> | <Structure>_ 113 | 114 | Parsing the term _p(Z, h(Z, W), f(W))_ with: 115 | 116 | ```clojure 117 | (use 'wam.grammar) 118 | (use 'jasentaa.parser) 119 | (parse-all structure "p(Z, h(Z, W), f(W))") 120 | ``` 121 | yields a structure as follows: 122 | ``` 123 | #Structure{:functor p|3, 124 | :args (#Variable{:name Z} 125 | #Structure{:functor h|2, 126 | :args (#Variable{:name Z} 127 | #Variable{:name W}})} 128 | #Structure{:functor f|1, 129 | :args (#Variable{:name W})})} 130 | ``` 131 | ### Compiling ℒ₀ queries 132 | 133 | Now that the term _p(Z, h(Z, W), f(W))_ parses into a hierarchical data 134 | structure, a breadth-first search is employed to allocate registers on a 135 | least available index basis: 136 | 137 | ```clojure 138 | (use 'wam.compiler) 139 | (use 'wam.grammar) 140 | (use 'jasentaa.parser) 141 | (use 'table.core) 142 | 143 | (def term (parse-all structure "p(Z, h(Z, W), f(W))")) 144 | (table (register-allocation term) :style :unicode) 145 | ``` 146 | evaluates as: 147 | ``` 148 | ┌──────────────────┬───────┐ 149 | │ key │ value │ 150 | ├──────────────────┼───────┤ 151 | │ p(Z h(Z W) f(W)) ╎ X1 │ 152 | │ Z ╎ X2 │ 153 | │ h(Z W) ╎ X3 │ 154 | │ f(W) ╎ X4 │ 155 | │ W ╎ X5 │ 156 | └──────────────────┴───────┘ 157 | ``` 158 | Inspecting the structures, and indeed it matches as follows: 159 | 160 | * X1 = p(X2, X3, X4) 161 | * X2 = Z 162 | * X3 = h(X2, X5) 163 | * X4 = f(X5) 164 | * X5 = W 165 | 166 | Next, given that we have a linear register allocation, walking 167 | the query term structures in depth-first post-order means that 168 | instructions can be assembled as follows: 169 | 170 | ```clojure 171 | (use 'wam.compiler) 172 | (use 'wam.grammar) 173 | (use 'table.core) 174 | 175 | (table 176 | (cons 177 | ["instr" "arg1" "arg2"] 178 | (emit-instructions query-builder term (register-allocation term))) 179 | :style :unicode) 180 | ``` 181 | 182 | Which returns a list of instructions, which corresponds to Figure 2.3 183 | in the tutorial: 184 | ``` 185 | ┌──────────────────────────────────────────────┬──────┬──────┐ 186 | │ instr │ arg1 │ arg2 │ 187 | ├──────────────────────────────────────────────┼──────┼──────┤ 188 | │ #function[wam.instruction-set/put-structure] ╎ h|2 ╎ X3 │ 189 | │ #function[wam.instruction-set/set-variable] ╎ X2 ╎ │ 190 | │ #function[wam.instruction-set/set-variable] ╎ X5 ╎ │ 191 | │ #function[wam.instruction-set/put-structure] ╎ f|1 ╎ X4 │ 192 | │ #function[wam.instruction-set/set-value] ╎ X5 ╎ │ 193 | │ #function[wam.instruction-set/put-structure] ╎ p|3 ╎ X1 │ 194 | │ #function[wam.instruction-set/set-value] ╎ X2 ╎ │ 195 | │ #function[wam.instruction-set/set-value] ╎ X3 ╎ │ 196 | │ #function[wam.instruction-set/set-value] ╎ X4 ╎ │ 197 | └──────────────────────────────────────────────┴──────┴──────┘ 198 | ``` 199 | The instructions are not directly executable as yet, as a context 200 | must be supplied in the first argument to each instruction, but 201 | they are however in a suitable format for returning a function 202 | that can execute them given a context: 203 | 204 | ```clojure 205 | (use 'wam.compiler) 206 | (use 'wam.grammar) 207 | (use 'wam.store) 208 | (use 'table.core) 209 | 210 | (def context (make-context)) 211 | 212 | (def query0 213 | (->> 214 | "p(Z, h(Z, W), f(W))" 215 | (parse-all structure) 216 | (compile-term query-builder))) 217 | 218 | (-> context query0 heap table) 219 | ``` 220 | This produces the same heap representation as earlier, but significantly, was 221 | instead generated automatically from executing emitted WAM instructions, 222 | which were derived from hierarchical data structures, which in turn were 223 | parsed from a string representation **"p(Z, h(Z, W), f(W))"**. 224 | ``` 225 | ┌──────┬────────────┐ 226 | │ key │ value │ 227 | ├──────┼────────────┤ 228 | │ 1000 ╎ [STR 1001] │ 229 | │ 1001 ╎ h|2 │ 230 | │ 1002 ╎ [REF 1002] │ 231 | │ 1003 ╎ [REF 1003] │ 232 | │ 1004 ╎ [STR 1005] │ 233 | │ 1005 ╎ f|1 │ 234 | │ 1006 ╎ [REF 1003] │ 235 | │ 1007 ╎ [STR 1008] │ 236 | │ 1008 ╎ p|3 │ 237 | │ 1009 ╎ [REF 1002] │ 238 | │ 1010 ╎ [STR 1001] │ 239 | │ 1011 ╎ [STR 1005] │ 240 | └──────┴────────────┘ 241 | ``` 242 | ### Compiling ℒ₀ programs 243 | 244 | Compiling a program term follows a similar vein to query term construction: 245 | registers are allocated breadth-first, but instead of walking the tree in 246 | post-order, a program is walked in pre-order. The rules for emitting instructions 247 | are also subtly different. Assuming the same helper methods as before: 248 | 249 | ```clojure 250 | (use 'wam.compiler) 251 | (use 'wam.grammar) 252 | (use 'table.core) 253 | 254 | ; Assume the same helper functions as before 255 | 256 | (def term (parse-all structure "p(f(X), h(Y, f(a)), Y)")) 257 | 258 | (table 259 | (cons 260 | ["instr" "arg1" "arg2"] 261 | (emit-instructions program-builder term (register-allocation term))) 262 | :style :unicode) 263 | 264 | ``` 265 | Which returns a list of instructions, which corresponds to Figure 2.4 266 | in the tutorial: 267 | ``` 268 | ┌───────────────────────────────────────────────┬──────┬──────┐ 269 | │ instr │ arg1 │ arg2 │ 270 | ├───────────────────────────────────────────────┼──────┼──────┤ 271 | │ #function[wam.instruction-set/get-structure] ╎ p|3 ╎ X1 │ 272 | │ #function[wam.instruction-set/unify-variable] ╎ X2 ╎ │ 273 | │ #function[wam.instruction-set/unify-variable] ╎ X3 ╎ │ 274 | │ #function[wam.instruction-set/unify-variable] ╎ X4 ╎ │ 275 | │ #function[wam.instruction-set/get-structure] ╎ f|1 ╎ X2 │ 276 | │ #function[wam.instruction-set/unify-variable] ╎ X5 ╎ │ 277 | │ #function[wam.instruction-set/get-structure] ╎ h|2 ╎ X3 │ 278 | │ #function[wam.instruction-set/unify-value] ╎ X4 ╎ │ 279 | │ #function[wam.instruction-set/unify-variable] ╎ X6 ╎ │ 280 | │ #function[wam.instruction-set/get-structure] ╎ f|1 ╎ X6 │ 281 | │ #function[wam.instruction-set/unify-variable] ╎ X7 ╎ │ 282 | │ #function[wam.instruction-set/get-structure] ╎ a|0 ╎ X7 │ 283 | └───────────────────────────────────────────────┴──────┴──────┘ 284 | ``` 285 | ### Exercise 2.2 (pg. 14) 286 | 287 | > Give heap representations for the terms _f(X, g(X, a))_ and _f(b, Y)_. 288 | > Let _a1_ and _a2_ be their respective heap addresses, 289 | > and let _ax_ and _ay_ be the heap addresses 290 | > corresponding to variables _X_ and _Y_, respectively. Trace the effects of 291 | > executing _unify(a1, a2)_, verifying that it terminates 292 | > with the eventual dereferenced bindings from _ax_ and 293 | > _ay_ corresponding to _X = b_ and _Y = g(b, a)_. 294 | 295 | By applying the query terms to an empty context, 296 | 297 | ```clojure 298 | (use 'wam.compiler) 299 | (use 'wam.store) 300 | (use 'table.core) 301 | 302 | (-> 303 | (make-context) 304 | (query "f(X, g(X, a))") 305 | (query "f(b, Y)") 306 | diag) 307 | ``` 308 | Gives the following heap structure. Note that the heap addresses for 309 | _a1_, _a2_, _ax_ and _ay_ 310 | have been annotated at locations 1006, 1012, 1008 and 1015 respectively. 311 | ``` 312 | Heap Registers Variables 313 | ------------------------------------------------------------ 314 | ┌──────┬────────────┐ ┌─────┬────────────┐ ┌─────┬───────┐ 315 | │ key │ value │ │ key │ value │ │ key │ value │ 316 | ├──────┼────────────┤ ├─────┼────────────┤ ├─────┼───────┤ 317 | │ 1000 ╎ [STR 1001] │ │ X1 ╎ [STR 1013] │ │ X ╎ X2 │ 318 | │ 1001 ╎ a|0 │ │ X2 ╎ [STR 1011] │ │ Y ╎ X3 │ 319 | │ 1002 ╎ [STR 1003] │ │ X3 ╎ [REF 1015] │ └─────┴───────┘ 320 | │ 1003 ╎ g|2 │ │ X4 ╎ [STR 1001] │ 321 | │ 1004 ╎ [REF 1004] │ └─────┴────────────┘ 322 | │ 1005 ╎ [STR 1001] │ 323 | │ 1006 ╎ [STR 1007] │ ← a1 324 | │ 1007 ╎ f|2 │ 325 | │ 1008 ╎ [REF 1004] │ ← aX 326 | │ 1009 ╎ [STR 1003] │ 327 | │ 1010 ╎ [STR 1011] │ 328 | │ 1011 ╎ b|0 │ 329 | │ 1012 ╎ [STR 1013] │ ← a2 330 | │ 1013 ╎ f|2 │ 331 | │ 1014 ╎ [STR 1011] │ 332 | │ 1015 ╎ [REF 1015] │ ← aY 333 | └──────┴────────────┘ 334 | ``` 335 | Now, calling _unify(a1, a2)_, the changed context store 336 | is displayed below. 337 | 338 | ```clojure 339 | (use 'wam.anciliary) 340 | 341 | (defn tee [v func] 342 | (func v) 343 | v) 344 | 345 | (-> 346 | (make-context) 347 | (query "f(X, g(X, a))") 348 | (query "f(b, Y)") 349 | (unify 1012 1006) 350 | diag 351 | (tee #(println "X =" (resolve-struct % (register-address 'X2)))) 352 | (tee #(println "Y =" (resolve-struct % (register-address 'X3))))) 353 | ``` 354 | Note that the context failed flag returns as false (not shown), indicating 355 | unification was successful. 356 | ``` 357 | Heap Registers Variables 358 | ------------------------------------------------------------ 359 | ┌──────┬────────────┐ ┌─────┬────────────┐ ┌─────┬───────┐ 360 | │ key │ value │ │ key │ value │ │ key │ value │ 361 | ├──────┼────────────┤ ├─────┼────────────┤ ├─────┼───────┤ 362 | │ 1000 ╎ [STR 1001] │ │ X1 ╎ [STR 1013] │ │ X ╎ X2 │ 363 | │ 1001 ╎ a|0 │ │ X2 ╎ [STR 1011] │ │ Y ╎ X3 │ 364 | │ 1002 ╎ [STR 1003] │ │ X3 ╎ [REF 1015] │ └─────┴───────┘ 365 | │ 1003 ╎ g|2 │ │ X4 ╎ [STR 1001] │ 366 | │ 1004 ╎ [STR 1011] │ └─────┴────────────┘ 367 | │ 1005 ╎ [STR 1001] │ 368 | │ 1006 ╎ [STR 1007] │ 369 | │ 1007 ╎ f|2 │ 370 | │ 1008 ╎ [REF 1004] │ 371 | │ 1009 ╎ [STR 1003] │ 372 | │ 1010 ╎ [STR 1011] │ 373 | │ 1011 ╎ b|0 │ 374 | │ 1012 ╎ [STR 1013] │ 375 | │ 1013 ╎ f|2 │ 376 | │ 1014 ╎ [STR 1011] │ 377 | │ 1015 ╎ [STR 1003] │ 378 | └──────┴────────────┘ 379 | 380 | X = b 381 | Y = g(b, a) 382 | ``` 383 | Inspecting the heap, and it becomes clear that: 384 | 385 | * dereferencing _ax_, `STR 1011` → `b|0`, so _X = b_ 386 | * dereferencing _ay_, `STR 1015` → `STR 1003` → `g|2`, so _Y = g(X, a) = g(b, a)_ 387 | 388 | ### Exercise 2.3 (pg. 14) 389 | 390 | > Verify that the effect of executing the sequence of instructions shown in 391 | > Figure 2.4 right after that in Figure 2.3 produces the MGU of the terms 392 | > _p(Z, h(Z, W), f(W))_ and _p(f(X), h(Y, f(a)), Y)_. That is, the 393 | > (dereferenced) bindings corresponding to _W = f(a)_, _X = f(a)_, 394 | > _Y = f(f(a))_, _Z = f(f(a))_. 395 | 396 | _MGU_ = Most General Unifier 397 | 398 | ```clojure 399 | (-> 400 | (make-context) 401 | 402 | ; fig 2.3: compiled code for ℒ₀ query ?- p(Z, h(Z, W), f(W)). 403 | (put-structure 'h|2, 'X3) 404 | (set-variable 'X2) 405 | (set-variable 'X5) 406 | (put-structure 'f|1, 'X4) 407 | (set-value 'X5) 408 | (put-structure 'p|3, 'X1) 409 | (set-value 'X2) 410 | (set-value 'X3) 411 | (set-value 'X4) 412 | 413 | ; fig 2.4: compiled code for ℒ₀ query ?- p(f(X), h(Y, f(a)), Y). 414 | (get-structure 'p|3, 'X1) 415 | (unify-variable 'X2) 416 | (unify-variable 'X3) 417 | (unify-variable 'X4) 418 | (get-structure 'f|1, 'X2) 419 | (unify-variable 'X5) 420 | (get-structure 'h|2, 'X3) 421 | (unify-value 'X4) 422 | (unify-variable 'X6) 423 | (get-structure 'f|1, 'X6) 424 | (unify-variable 'X7) 425 | (get-structure 'a|0, 'X7) 426 | 427 | diag 428 | 429 | (tee #(println "W =" (resolve-struct % (register-address 'X5)))) 430 | (tee #(println "X =" (resolve-struct % (register-address 'X5)))) 431 | (tee #(println "Y =" (resolve-struct % (register-address 'X4)))) 432 | (tee #(println "Z =" (resolve-struct % (register-address 'X2))))) 433 | ``` 434 | Prints: 435 | ``` 436 | Heap Registers Variables 437 | ------------------------------------------------------ 438 | ┌──────┬────────────┐ ┌─────┬────────────┐ ┌───────┐ 439 | │ key │ value │ │ key │ value │ │ value │ 440 | ├──────┼────────────┤ ├─────┼────────────┤ ├───────┤ 441 | │ 1000 ╎ [STR 1001] │ │ X1 ╎ [STR 1008] │ └───────┘ 442 | │ 1001 ╎ h|2 │ │ X2 ╎ [REF 1002] │ 443 | │ 1002 ╎ [STR 1013] │ │ X3 ╎ [STR 1001] │ 444 | │ 1003 ╎ [STR 1016] │ │ X4 ╎ [STR 1005] │ 445 | │ 1004 ╎ [STR 1005] │ │ X5 ╎ [REF 1014] │ 446 | │ 1005 ╎ f|1 │ │ X6 ╎ [REF 1003] │ 447 | │ 1006 ╎ [REF 1003] │ │ X7 ╎ [REF 1017] │ 448 | │ 1007 ╎ [STR 1008] │ └─────┴────────────┘ 449 | │ 1008 ╎ p|3 │ 450 | │ 1009 ╎ [REF 1002] │ 451 | │ 1010 ╎ [STR 1001] │ 452 | │ 1011 ╎ [STR 1005] │ 453 | │ 1012 ╎ [STR 1013] │ 454 | │ 1013 ╎ f|1 │ 455 | │ 1014 ╎ [REF 1003] │ 456 | │ 1015 ╎ [STR 1016] │ 457 | │ 1016 ╎ f|1 │ 458 | │ 1017 ╎ [STR 1019] │ 459 | │ 1018 ╎ [STR 1019] │ 460 | │ 1019 ╎ a|0 │ 461 | └──────┴────────────┘ 462 | 463 | W = f(a) 464 | X = f(a) 465 | Y = f(f(a)) 466 | Z = f(f(a)) 467 | ``` 468 | 469 | ### Exercise 2.4 (pg. 14) 470 | 471 | > What are the respective sequences of ℳ₀ instructions for ℒ₀ _query_ 472 | > term ?-_p(f(X), h(Y, f(a)), Y)_ and _program_ term _p(Z, h(Z, W), f(W))_? 473 | 474 | Setting the execution trace to `true` and running the two terms: 475 | 476 | ```clojure 477 | (-> 478 | (make-context) 479 | (assoc :trace true) 480 | (query "p(Z, h(Z, W), f(W))") 481 | (program "p(f(X), h(Y, f(a)), Y)")) 482 | ``` 483 | 484 | Gives the following instruction list: 485 | ``` 486 | put_structure h|2, X3 487 | set_variable X2 488 | set_variable X5 489 | put_structure f|1, X4 490 | set_value X5 491 | put_structure p|3, X1 492 | set_value X2 493 | set_value X3 494 | set_value X4 495 | get_structure p|3, X1 496 | unify_variable X2 497 | unify_variable X3 498 | unify_variable X4 499 | get_structure f|1, X2 500 | unify_variable X5 501 | get_structure h|2, X3 502 | unify_value X4 503 | unify_variable X6 504 | get_structure f|1, X6 505 | unify_variable X7 506 | get_structure a|0, X7 507 | ``` 508 | 509 | ### Exercise 2.5 (pg. 14) 510 | 511 | > After doing Exercise 2.4, verify that the effects of executing the sequence 512 | > you produced yields the same solution as that of [Exercise 2.3](#exercise-23-pg-14). 513 | 514 | 515 | Executing: 516 | 517 | ```clojure 518 | (-> 519 | (make-context) 520 | (assoc :trace true) 521 | (query "p(Z, h(Z, W), f(W))") 522 | (program "p(f(X), h(Y, f(a)), Y)") 523 | diag 524 | 525 | (tee #(println "W =" (resolve-struct % (register-address 'X5)))) 526 | (tee #(println "X =" (resolve-struct % (register-address 'X5)))) 527 | (tee #(println "Y =" (resolve-struct % (register-address 'X4)))) 528 | (tee #(println "Z =" (resolve-struct % (register-address 'X2))))) 529 | ``` 530 | This gives the same output as [exercise 2.3](#exercise-23-pg-14) (albeit with extra register allocations): 531 | ``` 532 | Heap Registers Variables 533 | ------------------------------------------------------------ 534 | ┌──────┬────────────┐ ┌─────┬────────────┐ ┌─────┬───────┐ 535 | │ key │ value │ │ key │ value │ │ key │ value │ 536 | ├──────┼────────────┤ ├─────┼────────────┤ ├─────┼───────┤ 537 | │ 1000 ╎ [STR 1001] │ │ X1 ╎ [STR 1008] │ │ W ╎ X5 │ 538 | │ 1001 ╎ h|2 │ │ X2 ╎ [REF 1002] │ │ X ╎ X5 │ 539 | │ 1002 ╎ [STR 1013] │ │ X3 ╎ [STR 1001] │ │ Y ╎ X4 │ 540 | │ 1003 ╎ [STR 1016] │ │ X4 ╎ [STR 1005] │ │ Z ╎ X2 │ 541 | │ 1004 ╎ [STR 1005] │ │ X5 ╎ [REF 1014] │ └─────┴───────┘ 542 | │ 1005 ╎ f|1 │ │ X6 ╎ [REF 1003] │ 543 | │ 1006 ╎ [REF 1003] │ │ X7 ╎ [REF 1017] │ 544 | │ 1007 ╎ [STR 1008] │ └─────┴────────────┘ 545 | │ 1008 ╎ p|3 │ 546 | │ 1009 ╎ [REF 1002] │ 547 | │ 1010 ╎ [STR 1001] │ 548 | │ 1011 ╎ [STR 1005] │ 549 | │ 1012 ╎ [STR 1013] │ 550 | │ 1013 ╎ f|1 │ 551 | │ 1014 ╎ [REF 1003] │ 552 | │ 1015 ╎ [STR 1016] │ 553 | │ 1016 ╎ f|1 │ 554 | │ 1017 ╎ [STR 1019] │ 555 | │ 1018 ╎ [STR 1019] │ 556 | │ 1019 ╎ a|0 │ 557 | └──────┴────────────┘ 558 | 559 | W = f(a) 560 | X = f(a) 561 | Y = f(f(a)) 562 | Z = f(f(a)) 563 | ``` 564 | 565 | ## Language ℒ₁ – Argument Registers 566 | 567 | ### Exercise 2.6 (pg. 18) 568 | 569 | > Verify that the effect of executing the sequence of ℳ₁ instructions 570 | > shown in Figure 2.9 produces the same heap representation as that produced by 571 | > the ℳ₀ code of Figure 2.3 (see [Exercise 2.1](#exercise-21-pg-9)). 572 | 573 | Assuming the same imports and initial context as perviously: 574 | 575 | ```clojure 576 | (-> 577 | (make-context) 578 | (put-variable 'X4, 'A1) 579 | (put-structure 'h|2, 'A2) 580 | (set-value 'X4) 581 | (set-variable 'X5) 582 | (put-structure 'f|1, 'A3) 583 | (set-value 'X5) 584 | heap 585 | table) 586 | ``` 587 | gives: 588 | ``` 589 | ┌──────┬────────────┐ 590 | │ key │ value │ 591 | ├──────┼────────────┤ 592 | │ 1000 ╎ [REF 1000] │ 593 | │ 1001 ╎ [STR 1002] │ 594 | │ 1002 ╎ h|2 │ 595 | │ 1003 ╎ [REF 1000] │ 596 | │ 1004 ╎ [REF 1004] │ 597 | │ 1005 ╎ [STR 1006] │ 598 | │ 1006 ╎ f|1 │ 599 | │ 1007 ╎ [REF 1004] │ 600 | └──────┴────────────┘ 601 | ``` 602 | Apart from the term root, the heap is layed out _similarly_ to that of 603 | Figure 2.3 as below, albeit with different references: 604 | ``` 605 | ┌──────┬────────────┐ 606 | ┌──────┬────────────┐ │ key │ value │ 607 | │ key │ value │ ├──────┼────────────┤ 608 | ├──────┼────────────┤ │ 1000 ╎ [REF 1000] │ 609 | │ 1000 ╎ [STR 1001] │ │ 1001 ╎ [STR 1002] │ 610 | │ 1001 ╎ h|2 │ │ 1002 ╎ h|2 │ 611 | │ 1002 ╎ [REF 1002] │ │ 1003 ╎ [REF 1000] │ 612 | │ 1003 ╎ [REF 1003] │ │ 1004 ╎ [REF 1004] │ 613 | │ 1004 ╎ [STR 1005] │ │ 1005 ╎ [STR 1006] │ 614 | │ 1005 ╎ f|1 │ │ 1006 ╎ f|1 │ 615 | │ 1006 ╎ [REF 1003] │ │ 1007 ╎ [REF 1004] │ 616 | │ 1007 ╎ [STR 1008] │ └──────┴────────────┘ 617 | │ 1008 ╎ p|3 │ 618 | │ 1009 ╎ [REF 1002] │ 619 | │ 1010 ╎ [STR 1001] │ 620 | │ 1011 ╎ [STR 1005] │ 621 | └──────┴────────────┘ 622 | 623 | ``` 624 | 625 | ### Exercise 2.7 (pg. 18) 626 | 627 | > Verify that the effect of executing the sequence of ℳ₁ instructions 628 | > shown in Figure 2.10 right after that in Figure 2.9 produces the MGU of the 629 | > terms _p(Z, h(Z, W), f(W))_ and _p(f(X), h(Y, f(a)), Y)_. That is, the binding 630 | > _W = f(a)_, _X = f(a)_, _Y = f(f(a))_, _Z = f(f(a))_. 631 | 632 | Defining _p/3_ as: 633 | 634 | ```clojure 635 | (def p|3 636 | (list 637 | [get-structure 'f|1, 'A1] 638 | [unify-variable 'X4] 639 | [get-structure 'h|2, 'A2] 640 | [unify-variable 'X5] 641 | [unify-variable 'X6] 642 | [get-value 'X5, 'A3] 643 | [get-structure 'f|1, 'X6] 644 | [unify-variable 'X7] 645 | [get-structure 'a|0, 'X7] 646 | [proceed])) 647 | ``` 648 | Then, executing the program term directly after the query term: 649 | 650 | ```clojure 651 | (-> 652 | ctx 653 | (put-variable 'X4, 'A1) 654 | (put-structure 'h|2, 'A2) 655 | (set-value 'X4) 656 | (set-variable 'X5) 657 | (put-structure 'f|1, 'A3) 658 | (set-value 'X5) 659 | (load 'p|3 p|3) 660 | (call 'p|3) 661 | diag 662 | (tee #(println "W =" (resolve-struct % (register-address 'X4)))) 663 | (tee #(println "X =" (resolve-struct % (register-address 'X4)))) 664 | (tee #(println "Y =" (resolve-struct % (register-address 'A3)))) 665 | (tee #(println "Z =" (resolve-struct % (register-address 'X5))))) 666 | ``` 667 | 668 | gives: 669 | 670 | ``` 671 | Heap Registers Variables 672 | ------------------------------------------------------ 673 | ┌──────┬────────────┐ ┌─────┬────────────┐ ┌───────┐ 674 | │ key │ value │ │ key │ value │ │ value │ 675 | ├──────┼────────────┤ ├─────┼────────────┤ ├───────┤ 676 | │ 1000 ╎ [STR 1009] │ │ X1 ╎ [REF 1000] │ └───────┘ 677 | │ 1001 ╎ [STR 1002] │ │ X2 ╎ [STR 1002] │ 678 | │ 1002 ╎ h|2 │ │ X3 ╎ [STR 1006] │ 679 | │ 1003 ╎ [REF 1000] │ │ X4 ╎ [REF 1010] │ 680 | │ 1004 ╎ [STR 1012] │ │ X5 ╎ [REF 1000] │ 681 | │ 1005 ╎ [STR 1006] │ │ X6 ╎ [REF 1004] │ 682 | │ 1006 ╎ f|1 │ │ X7 ╎ [REF 1013] │ 683 | │ 1007 ╎ [REF 1004] │ └─────┴────────────┘ 684 | │ 1008 ╎ [STR 1009] │ 685 | │ 1009 ╎ f|1 │ 686 | │ 1010 ╎ [REF 1004] │ 687 | │ 1011 ╎ [STR 1012] │ 688 | │ 1012 ╎ f|1 │ 689 | │ 1013 ╎ [STR 1015] │ 690 | │ 1014 ╎ [STR 1015] │ 691 | │ 1015 ╎ a|0 │ 692 | └──────┴────────────┘ 693 | 694 | W = f(a) 695 | X = f(a) 696 | Y = f(f(a)) 697 | Z = f(f(a)) 698 | ``` 699 | ### Exercise 2.8 (pg. 18) 700 | 701 | > What are the respective sequences of ℳ₁ instructions for ℒ₁ _query_ 702 | > term ?-_p(f(X), h(Y, f(a)), y)_ and ℒ₁ _program_ term _p(Z, h(Z, W), f(W))_? 703 | 704 | There is a bit of a leap here in the tutorial, and I'm not sure if I fully 705 | understand, but the query term ?-_p(f(X), h(Y, f(a)), y)_ is now build from 706 | the following instructions: 707 | 708 | ``` 709 | put-structure f|1, A1 710 | set-variable X4) 711 | put-structure h|2, A2 712 | set-variable A3) 713 | put-structure f|1, X5 714 | put-structure a|0, X6 715 | set-value A3 716 | call p|3 717 | ``` 718 | 719 | And the program term _p(Z, h(Z, W), f(W))_ is comprised of: 720 | 721 | ``` 722 | unify-variable A1 723 | get-structure h|2, A2 724 | unify-value A1 725 | unify-variable X4 726 | get-structure f|1, A3 727 | unify-value X4 728 | proceed 729 | ``` 730 | 731 | ### Exercise 2.9 (pg. 19) 732 | 733 | > After doing [Exercise 2.8](#exercise-28-pg-18), verify that the effect of executing the 734 | > sequence you produced yields the same solution as that of [Exercise 2.7](#exercise-27-pg-18). 735 | 736 | 737 | Executing the program against the query term does give the same unification 738 | result as previously: 739 | 740 | ```clojure 741 | (def p|3 742 | (list 743 | [unify-variable 'A1] 744 | [get-structure 'h|2, 'A2] 745 | [unify-value 'A1] 746 | [unify-variable 'X4] 747 | [get-structure 'f|1, 'A3] 748 | [unify-value 'X4] 749 | [proceed])) 750 | 751 | (-> 752 | ctx 753 | (put-structure 'f|1, 'A1) 754 | (set-variable 'X4) 755 | (put-structure 'h|2, 'A2) 756 | (set-variable 'A3) 757 | (put-structure 'f|1, 'X5) 758 | (put-structure 'a|0, 'X6) 759 | (set-value 'A3) 760 | (load 'p|3 p|3) 761 | (call 'p|3) 762 | (diag) 763 | (tee #(println "W =" (resolve-struct % (register-address 'X4)))) 764 | (tee #(println "X =" (resolve-struct % (register-address 'X4)))) 765 | (tee #(println "Y =" (resolve-struct % (register-address 'A3)))) 766 | (tee #(println "Z =" (resolve-struct % (register-address 'A1))))) 767 | ``` 768 | 769 | Outputs: 770 | 771 | ``` 772 | Heap Registers Variables 773 | ------------------------------------------------------ 774 | ┌──────┬────────────┐ ┌─────┬────────────┐ ┌───────┐ 775 | │ key │ value │ │ key │ value │ │ value │ 776 | ├──────┼────────────┤ ├─────┼────────────┤ ├───────┤ 777 | │ 1000 ╎ [STR 1001] │ │ X1 ╎ [STR 1001] │ └───────┘ 778 | │ 1001 ╎ f|1 │ │ X2 ╎ [STR 1004] │ 779 | │ 1002 ╎ [STR 1007] │ │ X3 ╎ [REF 1005] │ 780 | │ 1003 ╎ [STR 1004] │ │ X4 ╎ [STR 1007] │ 781 | │ 1004 ╎ h|2 │ │ X5 ╎ [STR 1007] │ 782 | │ 1005 ╎ [STR 1001] │ │ X6 ╎ [STR 1009] │ 783 | │ 1006 ╎ [STR 1007] │ └─────┴────────────┘ 784 | │ 1007 ╎ f|1 │ 785 | │ 1008 ╎ [STR 1009] │ 786 | │ 1009 ╎ a|0 │ 787 | │ 1010 ╎ [REF 1005] │ 788 | └──────┴────────────┘ 789 | 790 | W = f(a) 791 | X = f(a) 792 | Y = f(f(a)) 793 | Z = f(f(a)) 794 | ``` 795 | 796 | ## Language ℒ₂ – Flat Resolution 797 | 798 | TODO 799 | 800 | ## Language ℒ₃ – Prolog 801 | 802 | TODO 803 | 804 | ## References 805 | 806 | * http://www.ai.sri.com/pubs/files/641.pdf 807 | * http://wambook.sourceforge.net/wambook.pdf 808 | * http://stefan.buettcher.org/cs/wam/wam.pdf 809 | * http://www.cs.ox.ac.uk/jeremy.gibbons/publications/wam.pdf 810 | * https://gist.github.com/kachayev/b5887f66e2985a21a466 811 | 812 | ## License 813 | 814 | The MIT License (MIT) 815 | 816 | Copyright (c) 2015 Richard Hull 817 | 818 | Permission is hereby granted, free of charge, to any person obtaining a copy 819 | of this software and associated documentation files (the "Software"), to deal 820 | in the Software without restriction, including without limitation the rights 821 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 822 | copies of the Software, and to permit persons to whom the Software is 823 | furnished to do so, subject to the following conditions: 824 | 825 | The above copyright notice and this permission notice shall be included in all 826 | copies or substantial portions of the Software. 827 | 828 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 829 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 830 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 831 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 832 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 833 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 834 | SOFTWARE. 835 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject rm-hull/wam "0.0.1-SNAPSHOT" 2 | :description "Warren's Abstract Machine" 3 | :url "https://github.com/rm-hull/wam" 4 | :license { 5 | :name "The MIT License (MIT)" 6 | :url "http://opensource.org/licenses/MIT"} 7 | :dependencies [ 8 | [org.clojure/clojure "1.9.0"] 9 | [rm-hull/jasentaa "0.2.5"] 10 | [rm-hull/table "0.7.0"]] 11 | :scm {:url "git@github.com:rm-hull/wam.git"} 12 | :source-paths ["src"] 13 | :jar-exclusions [#"(?:^|/).git"] 14 | :codox { 15 | :source-paths ["src"] 16 | :output-path "doc/api" 17 | :source-uri "http://github.com/rm-hull/wam/blob/master/{filepath}#L{line}"} 18 | :min-lein-version "2.8.1" 19 | :profiles { 20 | :dev { 21 | :global-vars {*warn-on-reflection* true} 22 | :plugins [ 23 | [lein-codox "0.10.3"] 24 | [lein-cljfmt "0.5.7"] 25 | [lein-cloverage "1.0.10"]]}}) 26 | -------------------------------------------------------------------------------- /src/wam/anciliary.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | (ns wam.anciliary 25 | (:refer-clojure :exclude [deref]) 26 | (:require 27 | [clojure.string :refer [join]] 28 | [wam.store :as s] 29 | [wam.functor :as f])) 30 | 31 | (def cell-type 32 | "Convenience wrapper to obtain the cell type" 33 | first) 34 | 35 | (def cell-value 36 | "Convenience wrapper to obtain the cell value" 37 | second) 38 | 39 | (defn ^:private cell-type? 40 | "Function maker to determine if a cell is of a given type, 41 | presently the known types are REF (reference) or STR (structure)." 42 | [allowed-types] 43 | (fn [cell] 44 | (and 45 | (coll? cell) 46 | (= (count cell) 2) 47 | (contains? allowed-types (cell-type cell))))) 48 | 49 | (def ref? 50 | "Convenience wrapper for REF cell types" 51 | (cell-type? #{'REF})) 52 | 53 | (def str? 54 | "Convenience wrapper for STR cell types" 55 | (cell-type? #{'STR})) 56 | 57 | (def cell? 58 | "Convenience wrapper for any cell types" 59 | (cell-type? #{'REF 'STR})) 60 | 61 | (defn deref 62 | "Follows a possible reference chain until it reaches either an unbound REF 63 | cell or a non-REF cell, the address of which it returns. The effect of 64 | dereferencing is none other than composing variable substitutions." 65 | [ctx addr] 66 | (if (symbol? addr) 67 | (deref ctx (s/register-address addr)) 68 | (let [cell (s/get-store ctx addr)] 69 | (cond 70 | (not (cell? cell)) 71 | addr 72 | 73 | (and (ref? cell) (not= (cell-value cell) addr)) 74 | (recur ctx (cell-value cell)) 75 | 76 | :else addr)))) 77 | 78 | (def ^:private push conj) 79 | 80 | (defn ^:private push-args 81 | "Push the folllwing n args onto the stack, counting up from v1, 82 | interleaving with v2, incrementing at each reduction." 83 | [stack n v1 v2] 84 | (reduce 85 | (fn [stack i] (-> 86 | stack 87 | (push (+ v1 i)) 88 | (push (+ v2 i)))) 89 | stack 90 | (range 1 (inc n)))) 91 | 92 | (defn bind 93 | "Effectuate the binding of the heap cell to the address" 94 | [ctx a1 a2] 95 | (let [cell1 (s/get-store ctx a1) 96 | cell2 (s/get-store ctx a2)] 97 | (if (and (ref? cell1) (or (not (ref? cell2)) (< a2 a1))) 98 | (s/set-store ctx a1 cell2) 99 | (s/set-store ctx a2 cell1)))) 100 | 101 | (defn unify 102 | "Unification algorithm based on the UNION/FIND method [AHU74], where 103 | variable substitutions are built, applied, and composed through 104 | dereference pointers. The unification operation is performed on a 105 | pair of store addresses, and applied for all functors and their 106 | arguments, repeated iteratively until the stack is exhausted." 107 | [ctx a1 a2] 108 | 109 | (loop [ctx ctx 110 | fail false 111 | stack (-> [] (push a1) (push a2))] 112 | 113 | (if (or fail (empty? stack)) 114 | (s/fail ctx fail) 115 | (let [d1 (deref ctx (peek stack)) 116 | d2 (deref ctx (peek (pop stack))) 117 | stack (pop (pop stack))] 118 | (if (= d1 d2) 119 | (recur ctx fail stack) 120 | (let [cell1 (s/get-store ctx d1) 121 | cell2 (s/get-store ctx d2)] 122 | (if (or (ref? cell1) (ref? cell2)) 123 | (recur (bind ctx d1 d2) fail stack) 124 | (let [v1 (cell-value cell1) 125 | v2 (cell-value cell2) 126 | f|N1 (s/get-store ctx v1) 127 | f|N2 (s/get-store ctx v2)] 128 | (if (= f|N1 f|N2) 129 | (recur ctx fail (push-args stack (f/arity f|N1) v1 v2)) 130 | (recur ctx true stack)))))))))) 131 | 132 | (declare resolve-struct) 133 | 134 | (defn- resolve-functor [ctx addr] 135 | (let [functor (s/get-store ctx addr) 136 | process-args (fn [] 137 | (for [i (range (f/arity functor))] 138 | (resolve-struct ctx (+ addr i 1)))) 139 | decorate (fn [coll] (if (seq coll) (str "(" (join ", " coll) ")")))] 140 | (str (f/name functor) (decorate (process-args))))) 141 | 142 | (defn resolve-struct [ctx addr] 143 | (let [v (s/get-store ctx (deref ctx addr))] 144 | (if (str? v) 145 | (resolve-functor ctx (cell-value v)) 146 | (throw (IllegalArgumentException. "No structure at address" addr))))) 147 | 148 | -------------------------------------------------------------------------------- /src/wam/compiler.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (ns wam.compiler 24 | (:require 25 | [clojure.string :as s] 26 | [clojure.set :refer [union]] 27 | [jasentaa.parser :refer [parse-all]] 28 | [wam.instruction-set :refer :all] 29 | [wam.store :refer [friendly]] 30 | [wam.grammar :as g] 31 | [wam.graph-search :refer :all])) 32 | 33 | (defn register-names 34 | "Generates an infinite incrementing sequence of register symbols, 35 | e.g. X1, X2, X3, X4 ..." 36 | [prefix] 37 | (->> 38 | (iterate inc 1) 39 | (map #(symbol (str prefix %))))) 40 | 41 | (defn register-allocation 42 | "Variable registers are allocated to a term on a least available index basis 43 | such that (1) register X1 is always allocated to the otutermost term, and 44 | (2) the same register is allocated to all occurrences of a given variable. 45 | For example, registers are allocated to the variables of the term 46 | p(Z, h(Z,W), f(W)) as follows: 47 | 48 | X1 = p(X2, X3, X4) 49 | X2 = Z 50 | X3 = h(X2, X5) 51 | X4 = f(X5) 52 | X5 = W 53 | 54 | This amounts to saying that a term is seen as a flattened conjunctive set 55 | of equations of the form Xi = X or Xi = f(Xi1, ..., Xin), n>=0 where 56 | the Xi's are all distinct new variable names. 57 | 58 | A hashmap is returned with key as the term, and the value as allocated 59 | register," 60 | [term] 61 | (zipmap 62 | (bfs term) 63 | (register-names 'X))) 64 | 65 | (def query-builder 66 | {:structure-walker 67 | dfs-post-order 68 | 69 | :instruction-builder 70 | (fn [term register seen? arg?] 71 | (if (seen? term) 72 | (list set-value register) 73 | (cond 74 | (instance? wam.grammar.Structure term) 75 | (list put-structure (:functor term) register) 76 | 77 | (instance? wam.grammar.Variable term) 78 | (list set-variable register) 79 | 80 | :else nil)))}) 81 | 82 | (def program-builder 83 | {:structure-walker 84 | dfs-pre-order 85 | 86 | :instruction-builder 87 | (fn [term register seen? arg?] 88 | (cond 89 | (instance? wam.grammar.Structure term) 90 | (if arg? 91 | (list unify-variable register) 92 | (list get-structure (:functor term) register)) 93 | 94 | (instance? wam.grammar.Variable term) 95 | (if (seen? term) 96 | (list unify-value register) 97 | (list unify-variable register)) 98 | 99 | :else nil))}) 100 | 101 | (defn compile-structure 102 | [instruction-builder structure register-allocation seen?] 103 | (loop [args (:args structure) 104 | seen? seen? 105 | result [(instruction-builder 106 | structure 107 | (register-allocation structure) 108 | seen? 109 | false)]] 110 | (if (empty? args) 111 | result 112 | (recur 113 | (rest args) 114 | (conj seen? (first args)) 115 | (conj 116 | result 117 | (instruction-builder 118 | (first args) 119 | (register-allocation (first args)) 120 | seen? 121 | true)))))) 122 | 123 | (defn emit-instructions 124 | "Constructs a sequence of instructions (missing the context argument) 125 | suitable for threading with a context. The builder determines how 126 | the structures in the term are walked (generally pre-order for 127 | programs, and post-order for queries), and emits the most 128 | appropriate instructions for each structure, which is reliant on 129 | which arguments have been previously processed." 130 | [builder term register-allocation] 131 | (let [structure-walker (:structure-walker builder) 132 | instruction-builder (:instruction-builder builder)] 133 | (loop [structures (structure-walker term) 134 | seen? #{} 135 | result []] 136 | (if (empty? structures) 137 | result 138 | (let [structure (first structures)] 139 | (recur 140 | (rest structures) 141 | (conj (union seen? (set (:args structure))) structure) 142 | (concat 143 | result 144 | (compile-structure 145 | instruction-builder 146 | structure 147 | register-allocation 148 | seen?)))))))) 149 | 150 | (defn assoc-variables [ctx register-allocation] 151 | (->> 152 | register-allocation 153 | (filter #(instance? wam.grammar.Variable (first %))) 154 | (update ctx :variables concat))) 155 | 156 | (defn single-step 157 | "Execute an instruction with respect to the supplied context, if 158 | the fail flag has not been set. If the context has failed, then 159 | just return the context unchanged (i.e. don't execute the instruction). 160 | This causes the remaining instructions to also fall through." 161 | [ctx [instr & args]] 162 | (if-not (:fail ctx) 163 | (do 164 | (when (:trace ctx) 165 | (println (friendly (cons instr args)))) 166 | (apply instr ctx args)) 167 | ctx)) 168 | 169 | (defn compile-term 170 | "Emits a sequence of instructions that equates to provided term according 171 | to the rules of the builder. Returns a function which is capable of 172 | executing the instructions given a context." 173 | [builder term] 174 | (let [register-allocation (register-allocation term) 175 | instrs (emit-instructions builder term register-allocation)] 176 | (fn [ctx] 177 | (reduce single-step (assoc-variables ctx register-allocation) instrs)))) 178 | 179 | (defn query [ctx expression] 180 | (let [executor (->> 181 | expression 182 | (parse-all g/structure) 183 | (compile-term query-builder))] 184 | (executor ctx))) 185 | 186 | (defn program [ctx expression] 187 | (let [executor (->> 188 | expression 189 | (parse-all g/structure) 190 | (compile-term program-builder))] 191 | (executor ctx))) 192 | -------------------------------------------------------------------------------- /src/wam/functor.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2016 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | (ns wam.functor 25 | (:refer-clojure :exclude [name]) 26 | (:require [clojure.string :refer [split]])) 27 | 28 | (defn ^:private split-symbol [functor] 29 | (-> functor clojure.core/name (split #"\|"))) 30 | 31 | (defn name 32 | "Extract the name of a functor, either given as a symbol or a wam.grammar.Functor" 33 | [functor] 34 | (if (symbol? functor) 35 | (-> functor split-symbol first) 36 | (:name functor))) 37 | 38 | (def arity 39 | "Determine the arity given a functor (as either a symbol or a 40 | wam.grammar.Functor) representation" 41 | (memoize 42 | (fn [functor] 43 | (if (symbol? functor) 44 | (-> functor split-symbol second (Integer/parseInt)) 45 | (:arg-count functor))))) 46 | -------------------------------------------------------------------------------- /src/wam/grammar.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (ns wam.grammar 24 | (:refer-clojure :exclude [list]) 25 | (:require 26 | [jasentaa.monad :as m] 27 | [jasentaa.position :refer [strip-location]] 28 | [jasentaa.parser.basic :refer :all] 29 | [jasentaa.parser.combinators :refer :all])) 30 | 31 | (defrecord Constant [value] 32 | Object 33 | (toString [this] (with-out-str (pr this))) 34 | 35 | Comparable 36 | (compareTo [this other] (compare (:value this) (:value other)))) 37 | 38 | (defrecord Variable [name] 39 | Object 40 | (toString [this] (with-out-str (pr this))) 41 | 42 | Comparable 43 | (compareTo [this other] (compare (:name this) (:name other)))) 44 | 45 | (defrecord Structure [functor args] 46 | Object 47 | (toString [this] (with-out-str (pr this)))) 48 | 49 | (defrecord Functor [name arg-count] 50 | Object 51 | (toString [this] (with-out-str (pr this)))) 52 | 53 | (defmethod print-method Structure [x ^java.io.Writer writer] 54 | (print-method (-> x :functor :name) writer) 55 | (when-not (empty? (:args x)) 56 | (print-method (:args x) writer))) 57 | 58 | (defmethod print-method Variable [x ^java.io.Writer writer] 59 | (print-method (:name x) writer)) 60 | 61 | (defmethod print-method Constant [x ^java.io.Writer writer] 62 | (print-method (:value x) writer)) 63 | 64 | (defmethod print-method Functor [x ^java.io.Writer writer] 65 | (print-method (:name x) writer) 66 | (.write writer "|") 67 | (print-method (:arg-count x) writer)) 68 | 69 | (def digit (from-re #"[0-9]")) 70 | 71 | (def number 72 | (m/do* 73 | (v <- (plus digit)) 74 | (m/return (Integer/parseInt (strip-location v))))) 75 | 76 | (def lower-alpha (from-re #"[a-z]")) 77 | 78 | (def upper-alpha (from-re #"[A-Z]")) 79 | 80 | (def alpha-num (strip-location (any-of lower-alpha upper-alpha digit))) 81 | 82 | (def predicate 83 | (m/do* 84 | (a <- lower-alpha) 85 | (as <- (many alpha-num)) 86 | (m/return (strip-location (cons a as))))) 87 | 88 | (def constant 89 | (m/do* 90 | ; (c <- (any-of predicate number)) 91 | (n <- number) 92 | (m/return (Constant. n)))) 93 | 94 | (def variable 95 | (or-else 96 | (m/do* 97 | (a <- upper-alpha) 98 | (as <- (many alpha-num)) 99 | (m/return (Variable. (symbol (strip-location (cons a as)))))) 100 | (m/do* 101 | (match "_") 102 | (m/return (Variable. '_))))) 103 | 104 | (declare list) 105 | 106 | (def structure 107 | (or-else 108 | (m/do* 109 | (p <- predicate) 110 | (m/return (Structure. 111 | (Functor. (symbol p) 0) 112 | nil))) 113 | (m/do* 114 | (p <- predicate) 115 | (symb "(") 116 | (l <- list) 117 | (symb ")") 118 | (m/return (Structure. 119 | (Functor. (symbol p) (count l)) 120 | l))))) 121 | 122 | (def element 123 | (any-of variable constant structure)) 124 | 125 | (def list 126 | (separated-by (token element) (symb ","))) 127 | -------------------------------------------------------------------------------- /src/wam/graph_search.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | (ns wam.graph-search 24 | (:require [wam.grammar :as g])) 25 | 26 | (defn traverse-pre [term] 27 | (cond 28 | (seq? term) 29 | (map traverse-pre term) 30 | 31 | (instance? wam.grammar.Structure term) 32 | (cons term (traverse-pre (:args term))) 33 | 34 | :else nil)) 35 | 36 | (defn traverse-post [term] 37 | (cond 38 | (seq? term) 39 | (map traverse-post term) 40 | 41 | (instance? wam.grammar.Structure term) 42 | (concat (traverse-post (:args term)) [term]) 43 | 44 | :else nil)) 45 | 46 | (defn dfs-pre-order [term] 47 | (remove nil? (flatten (traverse-pre term)))) 48 | 49 | (defn dfs-post-order [term] 50 | (remove nil? (flatten (traverse-post term)))) 51 | 52 | (defn append [queue coll] 53 | (if (empty? coll) 54 | queue 55 | (recur 56 | (conj queue (first coll)) 57 | (rest coll)))) 58 | 59 | (defn queue 60 | ([] clojure.lang.PersistentQueue/EMPTY) 61 | ([coll] (reduce conj clojure.lang.PersistentQueue/EMPTY coll))) 62 | 63 | (defn bfs [term] 64 | (loop [queue (queue [term]) 65 | seen #{} 66 | result []] 67 | (if (empty? queue) 68 | result 69 | (let [v (peek queue) 70 | queue (pop queue)] 71 | 72 | (cond 73 | (seen v) 74 | (recur queue seen result) 75 | 76 | (instance? wam.grammar.Structure v) 77 | (recur (append queue (:args v)) (conj seen v) (conj result v)) 78 | 79 | :else 80 | (recur queue (conj seen v) (conj result v))))))) 81 | -------------------------------------------------------------------------------- /src/wam/instruction_set.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | ;; ℳ₀ machine instructions 25 | (ns wam.instruction-set 26 | (:require 27 | [clojure.string :refer [join]] 28 | [wam.anciliary :as a] 29 | [wam.store :as s])) 30 | 31 | (defn put-structure 32 | "This instruction marks the beginning of a structure (without 33 | embedded substructures) occurring as a goal argument. The 34 | instruction pushes the functor f|N for the structure onto the 35 | heap, and puts a corresponding structure pointer into register 36 | Xi. Execution then proceeds in \"write\" mode." 37 | [ctx f|N Xi] 38 | (let [h (s/pointer ctx :h) 39 | v ['STR (inc h)]] 40 | (-> 41 | ctx 42 | (s/set-store h v) 43 | (s/set-store (inc h) f|N) 44 | (s/set-register Xi v) 45 | (s/increment :h) 46 | (s/increment :h)))) 47 | 48 | ; Slight discrepancy between what David Warren refers to as 'put_variable' 49 | ; and Aït-Kaci as 'set_variable' 50 | (defn set-variable 51 | "This instruction represents an argument of the final goal that is an 52 | unbound variable. THe instruction creates an unbound variable on the 53 | heap, and puts a reference to it in the Xi register." 54 | [ctx Xi] 55 | (let [h (s/pointer ctx :h) 56 | v ['REF h]] 57 | (-> 58 | ctx 59 | (s/set-store h v) 60 | (s/set-register Xi v) 61 | (s/increment :h)))) 62 | 63 | (defn set-value [ctx Xi] 64 | (let [h (s/pointer ctx :h) 65 | v (s/get-register ctx Xi)] 66 | (-> 67 | ctx 68 | (s/set-store h v) 69 | (s/increment :h)))) 70 | 71 | (defn get-structure [ctx f|N Xi] 72 | (let [addr (a/deref ctx Xi) 73 | cell (s/get-store ctx addr)] 74 | (cond 75 | (a/ref? cell) 76 | (let [h (s/pointer ctx :h) 77 | v ['STR (inc h)]] 78 | (-> 79 | ctx 80 | (s/set-store h v) 81 | (s/set-store (inc h) f|N) 82 | (a/bind addr h) 83 | (s/increment :h) 84 | (s/increment :h) 85 | (s/mode :write))) 86 | 87 | (a/str? cell) 88 | (let [a (a/cell-value cell)] 89 | (if (= (s/get-store ctx a) f|N) 90 | (-> 91 | ctx 92 | (assoc-in [:pointer :s] (inc a)) 93 | (s/mode :read)) 94 | (s/fail ctx))) 95 | 96 | :else 97 | (s/fail ctx)))) 98 | 99 | (defn unify-variable [ctx Xi] 100 | (condp = (:mode ctx) 101 | 102 | :read 103 | (let [s (s/pointer ctx :s) 104 | v (s/get-store ctx s)] 105 | (-> 106 | ctx 107 | (s/set-register Xi v) 108 | (s/increment :s))) 109 | 110 | :write 111 | (let [h (s/pointer ctx :h) 112 | v ['REF h]] 113 | (-> 114 | ctx 115 | (s/set-store h v) 116 | (s/set-register Xi v) 117 | (s/increment :h) 118 | (s/increment :s))))) 119 | 120 | (defn unify-value [ctx Xi] 121 | (condp = (:mode ctx) 122 | 123 | :read 124 | (let [s (s/pointer ctx :s)] 125 | (-> 126 | ctx 127 | (a/unify Xi s) 128 | (s/increment :s))) 129 | 130 | :write 131 | (-> 132 | ctx 133 | (set-value Xi) 134 | (s/increment :s)))) 135 | 136 | (defn put-variable [ctx Xn Ai] 137 | (let [h (s/pointer ctx :h) 138 | v ['REF h]] 139 | (-> 140 | ctx 141 | (s/set-store h v) 142 | (s/set-register Ai v) 143 | (s/set-register Xn v) 144 | (s/increment :h)))) 145 | 146 | (defn put-value [ctx Xn Ai] 147 | (s/set-register ctx Ai (s/get-register ctx Xn))) 148 | 149 | (defn get-variable [ctx Xn Ai] 150 | (s/set-register ctx Xn (s/get-register ctx Ai))) 151 | 152 | (defn get-value [ctx Xn Ai] 153 | (a/unify ctx Xn Ai)) 154 | 155 | (defn proceed [ctx] 156 | ctx) 157 | 158 | (defn ^:private exec [ctx] 159 | (if (:fail ctx) 160 | ctx 161 | (let [p (s/pointer ctx :p) 162 | [instr & args] (s/get-store ctx p) 163 | ctx (-> 164 | (apply instr ctx args) 165 | (s/increment :p))] 166 | (do 167 | (when (:trace ctx) 168 | (println (s/func-name instr) (join ", " args))) 169 | 170 | (if (= instr proceed) 171 | ctx 172 | (recur ctx)))))) 173 | 174 | (defn call [ctx p|N] 175 | (if-let [new-p (s/program-address ctx p|N)] 176 | (-> 177 | ctx 178 | (assoc-in [:pointer :p] new-p) 179 | (exec)) 180 | (s/fail ctx))) 181 | 182 | -------------------------------------------------------------------------------- /src/wam/store.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | (ns wam.store 25 | (:require 26 | [table.core :refer [table table-str]] 27 | [clojure.string :refer [join split-lines]])) 28 | 29 | (def ^:private supported-modes #{:read :write}) 30 | (def ^:private supported-pointers #{:p :np :h :s}) 31 | (def program-pointer-start 0) 32 | (def heap-start 1000) 33 | (def heap-size 1000) 34 | (def heap-end (+ heap-start heap-size)) 35 | (def register-start (inc heap-end)) 36 | (def register-size 30) 37 | (def register-end (+ register-start register-size)) 38 | 39 | (def register-address 40 | (memoize 41 | (fn [Xi] 42 | (let [offset (->> Xi str (re-find #"\d+") Integer/parseInt)] 43 | (if (> offset register-size) 44 | (throw (IllegalArgumentException.)) 45 | (+ register-start offset)))))) 46 | 47 | (defn pointer [ctx ptr] 48 | (if (supported-pointers ptr) 49 | (get-in ctx [:pointer ptr]) 50 | (throw (IllegalArgumentException. (str "Unsuported pointer " ptr))))) 51 | 52 | (defn increment [ctx ptr] 53 | (if (supported-pointers ptr) 54 | (update-in ctx [:pointer ptr] inc) 55 | (throw (IllegalArgumentException. (str "Unsuported pointer " ptr))))) 56 | 57 | (defn program-address [ctx p|N] 58 | (:start-addr (get-in ctx [:program-offsets p|N]))) 59 | 60 | (defn get-store [ctx addr] 61 | (get-in ctx [:store addr])) 62 | 63 | (defn get-register [ctx Xi] 64 | (let [addr (register-address Xi)] 65 | (get-store ctx addr))) 66 | 67 | (defn set-store [ctx addr v] 68 | (assoc-in ctx [:store addr] v)) 69 | 70 | (defn set-register [ctx Xi v] 71 | (let [addr (register-address Xi)] 72 | (set-store ctx addr v))) 73 | 74 | (defn make-context [] 75 | {:fail false 76 | :mode :read 77 | :pointer {:p program-pointer-start ;; Program pointer 78 | :np program-pointer-start ;; next instr pointer 79 | :h heap-start ;; Top of heap 80 | :s heap-start ;; Structure pointer 81 | } 82 | :store {} 83 | :program-offsets {}}) 84 | 85 | (defn load [ctx p|N instrs] 86 | (let [len (count instrs) 87 | np (pointer ctx :np) 88 | ctx (-> 89 | ctx 90 | (assoc-in [:program-offsets p|N] {:start-addr np :size len}) 91 | (update-in [:pointer :np] (partial + len)))] 92 | (loop [ctx ctx 93 | i np 94 | [instr & more] instrs] 95 | (if (nil? instr) 96 | ctx 97 | (recur 98 | (set-store ctx i instr) 99 | (inc i) 100 | more))))) 101 | 102 | (defn fail 103 | ([ctx] (fail ctx true)) 104 | ([ctx status] (assoc ctx :fail status))) 105 | 106 | (defn mode [ctx new-mode] 107 | (if (supported-modes new-mode) 108 | (assoc ctx :mode new-mode) 109 | (throw (IllegalArgumentException. (str "Unsupported mode " new-mode))))) 110 | 111 | ;; == Diagnostic tools == 112 | ;; move out into a separate namespace 113 | 114 | (defn ^:private extract-from-store 115 | ([ctx start end] 116 | (extract-from-store ctx start end identity)) 117 | 118 | ([ctx start end row-mapper] 119 | (->> 120 | ctx 121 | :store 122 | (filter (fn [[k v]] (<= start k end))) 123 | (map row-mapper) 124 | (into (sorted-map))))) 125 | 126 | (defn heap [ctx] 127 | (extract-from-store ctx heap-start heap-end)) 128 | 129 | (defn registers [ctx] 130 | (extract-from-store ctx register-start register-end 131 | (fn [[k v]] [(symbol (str "X" (- k register-start))) v]))) 132 | 133 | (defn variables [ctx] 134 | (->> 135 | ctx 136 | :variables 137 | (into (sorted-map)))) 138 | 139 | (defn func-name [func] 140 | (second (re-find #"\$(.*)@" (str func)))) 141 | 142 | (defn friendly [[instr & args]] 143 | (str (func-name instr) " " (join ", " args))) 144 | 145 | (defn program [ctx p|N] 146 | (if-let [prog (get-in ctx [:program-offsets p|N])] 147 | (extract-from-store 148 | ctx 149 | (:start-addr prog) 150 | (+ (:start-addr prog) (:size prog)) 151 | (fn [[k v]] [k (friendly v)])))) 152 | 153 | (defn diag [ctx] 154 | (let [inflate (fn [data] (lazy-cat data (repeat nil))) 155 | heap (split-lines (table-str (heap ctx) :style :unicode)) 156 | regs (inflate (split-lines (table-str (registers ctx) :style :unicode))) 157 | vars (inflate (split-lines (table-str (variables ctx) :style :unicode))) 158 | data (map list heap regs vars)] 159 | 160 | (when (:fail ctx) 161 | (println "FAILED")) 162 | 163 | (table (cons ["Heap" "Registers" "Variables"] data) :style :borderless)) 164 | ctx) 165 | 166 | -------------------------------------------------------------------------------- /test/wam/anciliary_test.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | (ns wam.anciliary-test 25 | (:refer-clojure :exclude [deref]) 26 | (:require 27 | [clojure.test :refer :all] 28 | [wam.store :as s] 29 | [wam.anciliary :refer :all])) 30 | 31 | (deftest check-ref? 32 | (testing "ref?" 33 | (is (false? (ref? []))) 34 | (is (false? (ref? [1]))) 35 | (is (false? (ref? [1 2]))) 36 | (is (false? (ref? [1 2 3]))) 37 | (is (false? (ref? nil))) 38 | (is (false? (ref? ['STR 3]))) 39 | (is (false? (ref? ['REF 3 3]))) 40 | (is (true? (ref? ['REF 3]))))) 41 | 42 | (deftest check-str? 43 | (testing "str?" 44 | (is (false? (str? []))) 45 | (is (false? (str? [1]))) 46 | (is (false? (str? [1 2]))) 47 | (is (false? (str? [1 2 3]))) 48 | (is (false? (str? nil))) 49 | (is (true? (str? ['STR 3]))) 50 | (is (false? (str? ['STR 3 5]))) 51 | (is (false? (str? ['REF 3]))))) 52 | 53 | (deftest check-cell? 54 | (testing "cell?" 55 | (is (false? (cell? []))) 56 | (is (false? (cell? [1]))) 57 | (is (false? (cell? [1 2]))) 58 | (is (false? (cell? [1 2 3]))) 59 | (is (false? (cell? nil))) 60 | (is (false? (cell? ['STR 3 6 6]))) 61 | (is (false? (cell? ['REF 3 5]))) 62 | (is (true? (cell? ['STR 3]))) 63 | (is (true? (cell? ['REF 3]))))) 64 | 65 | (deftest check-deref 66 | (testing "deref follow refs" 67 | (let [ctx (-> 68 | (s/make-context) 69 | (s/set-store 0 ['REF 2]) 70 | (s/set-store 1 ['REF 3]) 71 | (s/set-store 2 ['REF 1]) 72 | (s/set-store 3 ['REF 3]) 73 | (s/set-store 4 ['STR 5]) 74 | (s/set-store 5 'f|2) 75 | (s/set-store 6 ['REF 3]) 76 | (s/set-register 'X3 ['REF 4]))] 77 | (is (= (deref ctx 0) 3)) 78 | (is (= (deref ctx 1) 3)) 79 | (is (= (deref ctx 2) 3)) 80 | (is (= (deref ctx 3) 3)) 81 | (is (= (deref ctx 4) 4)) 82 | (is (= (deref ctx 5) 5)) 83 | (is (= (deref ctx 6) 3)) 84 | (is (= (deref ctx 'X3) 4))))) 85 | 86 | -------------------------------------------------------------------------------- /test/wam/assert_helpers.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | (ns wam.assert-helpers 25 | (:require 26 | [clojure.string :as str] 27 | [table.core :as t] 28 | [wam.store :as s])) 29 | 30 | (defn heap [offset] 31 | (+ s/heap-start offset)) 32 | 33 | (defn register [offset] 34 | (+ s/register-start offset)) 35 | 36 | ; Some helper functions to get round limitations in table 37 | (defn- inflate [table] 38 | (let [max-cols (reduce max 0 (map count table))] 39 | (map #(take max-cols (lazy-cat % (repeat nil))) table))) 40 | 41 | (defn- headers [& headers] 42 | (fn [table] (cons headers table))) 43 | 44 | (def instr 45 | (comp 46 | t/table 47 | inflate 48 | (headers "instr" "arg1" "arg2") 49 | (partial map (fn [[instr & args]] (cons (s/func-name instr) args))))) 50 | 51 | (defn- line-trim [s] 52 | (->> 53 | s 54 | (str/split-lines) 55 | (map str/trim) 56 | (remove empty?) 57 | (str/join "\n"))) 58 | 59 | (defn tbl= [actual expected] 60 | (= 61 | (line-trim (with-out-str (t/table actual))) 62 | (line-trim expected))) 63 | 64 | (defn instr= [actual expected] 65 | (= 66 | (line-trim (with-out-str (instr actual))) 67 | (line-trim expected))) 68 | 69 | -------------------------------------------------------------------------------- /test/wam/compiler_test.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | (ns wam.compiler-test 25 | (:require 26 | [clojure.test :refer :all] 27 | [jasentaa.parser :refer [parse-all]] 28 | [wam.assert-helpers :refer :all] 29 | [wam.anciliary :refer [unify resolve-struct]] 30 | [wam.compiler :refer :all] 31 | [wam.instruction-set :refer :all] 32 | [wam.grammar :refer [structure]] 33 | [wam.store :as s])) 34 | 35 | (deftest check-register-allocation 36 | (testing "Register allocation" 37 | (is (tbl= (register-allocation (parse-all structure "p(Z, h(Z, W), f(W))")) 38 | "+------------------+-------+ 39 | | key | value | 40 | +------------------+-------+ 41 | | p(Z h(Z W) f(W)) | X1 | 42 | | Z | X2 | 43 | | h(Z W) | X3 | 44 | | f(W) | X4 | 45 | | W | X5 | 46 | +------------------+-------+")) 47 | 48 | (is (tbl= (register-allocation (parse-all structure "p(f(X), h(Y, f(a)), Y)")) 49 | "+---------------------+-------+ 50 | | key | value | 51 | +---------------------+-------+ 52 | | p(f(X) h(Y f(a)) Y) | X1 | 53 | | f(X) | X2 | 54 | | h(Y f(a)) | X3 | 55 | | Y | X4 | 56 | | X | X5 | 57 | | f(a) | X6 | 58 | | a | X7 | 59 | +---------------------+-------+")) 60 | 61 | (is (tbl= (register-allocation (parse-all structure "f(X, g(X,a))")) 62 | "+-------------+-------+ 63 | | key | value | 64 | +-------------+-------+ 65 | | f(X g(X a)) | X1 | 66 | | X | X2 | 67 | | g(X a) | X3 | 68 | | a | X4 | 69 | +-------------+-------+")))) 70 | 71 | (deftest check-query-builder 72 | (testing "Query builder" 73 | (let [term (parse-all structure "f(X, g(X,a))") 74 | register-allocation (register-allocation term)] 75 | (is (instr= (emit-instructions query-builder term register-allocation) 76 | "+---------------+------+------+ 77 | | instr | arg1 | arg2 | 78 | +---------------+------+------+ 79 | | put_structure | a|0 | X4 | 80 | | put_structure | g|2 | X3 | 81 | | set_variable | X2 | | 82 | | set_value | X4 | | 83 | | put_structure | f|2 | X1 | 84 | | set_value | X2 | | 85 | | set_value | X3 | | 86 | +---------------+------+------+"))) 87 | 88 | (let [term (parse-all structure "p(Z, h(Z, W), f(W))") 89 | register-allocation (register-allocation term)] 90 | (is (instr= (emit-instructions query-builder term register-allocation) 91 | "+---------------+------+------+ 92 | | instr | arg1 | arg2 | 93 | +---------------+------+------+ 94 | | put_structure | h|2 | X3 | 95 | | set_variable | X2 | | 96 | | set_variable | X5 | | 97 | | put_structure | f|1 | X4 | 98 | | set_value | X5 | | 99 | | put_structure | p|3 | X1 | 100 | | set_value | X2 | | 101 | | set_value | X3 | | 102 | | set_value | X4 | | 103 | +---------------+------+------+"))))) 104 | 105 | (deftest check-program-builder 106 | (testing "Program builder" 107 | (let [term (parse-all structure "p(f(X), h(Y, f(a)), Y)") 108 | register-allocation (register-allocation term)] 109 | (is (instr= (emit-instructions program-builder term register-allocation) 110 | "+----------------+------+------+ 111 | | instr | arg1 | arg2 | 112 | +----------------+------+------+ 113 | | get_structure | p|3 | X1 | 114 | | unify_variable | X2 | | 115 | | unify_variable | X3 | | 116 | | unify_variable | X4 | | 117 | | get_structure | f|1 | X2 | 118 | | unify_variable | X5 | | 119 | | get_structure | h|2 | X3 | 120 | | unify_value | X4 | | 121 | | unify_variable | X6 | | 122 | | get_structure | f|1 | X6 | 123 | | unify_variable | X7 | | 124 | | get_structure | a|0 | X7 | 125 | +----------------+------+------+"))))) 126 | 127 | (deftest check-compile 128 | (testing "Query compilation" 129 | (let [q (->> 130 | "p(Z, h(Z, W), f(W))" 131 | (parse-all structure) 132 | (compile-term query-builder))] 133 | (is (tbl= (-> (s/make-context) q s/heap) 134 | "+------+------------+ 135 | | key | value | 136 | +------+------------+ 137 | | 1000 | [STR 1001] | 138 | | 1001 | h|2 | 139 | | 1002 | [REF 1002] | 140 | | 1003 | [REF 1003] | 141 | | 1004 | [STR 1005] | 142 | | 1005 | f|1 | 143 | | 1006 | [REF 1003] | 144 | | 1007 | [STR 1008] | 145 | | 1008 | p|3 | 146 | | 1009 | [REF 1002] | 147 | | 1010 | [STR 1001] | 148 | | 1011 | [STR 1005] | 149 | +------+------------+")))) 150 | 151 | (testing "Sequential queries" 152 | (is (tbl= 153 | (-> 154 | (s/make-context) 155 | (query "f(X, g(X, a))") 156 | (query "f(b, Y)") 157 | s/heap) 158 | "+------+------------+ 159 | | key | value | 160 | +------+------------+ 161 | | 1000 | [STR 1001] | 162 | | 1001 | a|0 | 163 | | 1002 | [STR 1003] | 164 | | 1003 | g|2 | 165 | | 1004 | [REF 1004] | 166 | | 1005 | [STR 1001] | 167 | | 1006 | [STR 1007] | 168 | | 1007 | f|2 | 169 | | 1008 | [REF 1004] | 170 | | 1009 | [STR 1003] | 171 | | 1010 | [STR 1011] | 172 | | 1011 | b|0 | 173 | | 1012 | [STR 1013] | 174 | | 1013 | f|2 | 175 | | 1014 | [STR 1011] | 176 | | 1015 | [REF 1015] | 177 | +------+------------+"))) 178 | 179 | (testing "Unification" 180 | (is (tbl= 181 | (-> 182 | (s/make-context) 183 | (query "f(X, g(X, a))") 184 | (query "f(b, Y)") 185 | (unify (heap 6) (heap 12)) 186 | s/heap) 187 | "+------+------------+ 188 | | key | value | 189 | +------+------------+ 190 | | 1000 | [STR 1001] | 191 | | 1001 | a|0 | 192 | | 1002 | [STR 1003] | 193 | | 1003 | g|2 | 194 | | 1004 | [STR 1011] | 195 | | 1005 | [STR 1001] | 196 | | 1006 | [STR 1007] | 197 | | 1007 | f|2 | 198 | | 1008 | [REF 1004] | 199 | | 1009 | [STR 1003] | 200 | | 1010 | [STR 1011] | 201 | | 1011 | b|0 | 202 | | 1012 | [STR 1013] | 203 | | 1013 | f|2 | 204 | | 1014 | [STR 1011] | 205 | | 1015 | [STR 1003] | 206 | +------+------------+")))) 207 | 208 | (deftest ex2.2 209 | (let [ctx (-> 210 | (s/make-context) 211 | (query "f(X, g(X, a))") 212 | (query "f(b, Y)") 213 | (unify (heap 12) (heap 6)))] 214 | (is (= (resolve-struct ctx (s/register-address 'X2)) "b")) 215 | (is (= (resolve-struct ctx (s/register-address 'X3)) "g(b, a)")))) 216 | 217 | (deftest ex2.3 218 | (let [ctx (-> 219 | (s/make-context) 220 | 221 | ; fig 2.3: compiled code for ℒ₀ query ?- p(Z, h(Z, W), f(W)). 222 | (put-structure 'h|2, 'X3) 223 | (set-variable 'X2) 224 | (set-variable 'X5) 225 | (put-structure 'f|1, 'X4) 226 | (set-value 'X5) 227 | (put-structure 'p|3, 'X1) 228 | (set-value 'X2) 229 | (set-value 'X3) 230 | (set-value 'X4) 231 | 232 | ; fig 2.4: compiled code for ℒ₀ query ?- p(f(X), h(Y, f(a)), Y). 233 | (get-structure 'p|3, 'X1) 234 | (unify-variable 'X2) 235 | (unify-variable 'X3) 236 | (unify-variable 'X4) 237 | (get-structure 'f|1, 'X2) 238 | (unify-variable 'X5) 239 | (get-structure 'h|2, 'X3) 240 | (unify-value 'X4) 241 | (unify-variable 'X6) 242 | (get-structure 'f|1, 'X6) 243 | (unify-variable 'X7) 244 | (get-structure 'a|0, 'X7)) 245 | 246 | W (resolve-struct ctx (s/register-address 'X5)) 247 | X (resolve-struct ctx (s/register-address 'X5)) 248 | Y (resolve-struct ctx (s/register-address 'X4)) 249 | Z (resolve-struct ctx (s/register-address 'X2))] 250 | (is (= W "f(a)")) 251 | (is (= X "f(a)")) 252 | (is (= Y "f(f(a))")) 253 | (is (= Z "f(f(a))")))) 254 | 255 | (deftest ex2.5 256 | (let [ctx (-> 257 | (s/make-context) 258 | (query "p(Z, h(Z, W), f(W))") 259 | (program "p(f(X), h(Y, f(a)), Y)")) 260 | 261 | W (resolve-struct ctx (s/register-address 'X5)) 262 | X (resolve-struct ctx (s/register-address 'X5)) 263 | Y (resolve-struct ctx (s/register-address 'X4)) 264 | Z (resolve-struct ctx (s/register-address 'X2))] 265 | (is (= W "f(a)")) 266 | (is (= X "f(a)")) 267 | (is (= Y "f(f(a))")) 268 | (is (= Z "f(f(a))")))) 269 | 270 | (defn tee [v func] 271 | (func v) 272 | v) 273 | 274 | (-> 275 | (s/make-context) 276 | (assoc :trace true) 277 | (query "father(R, henry)") 278 | (program "father(richard, henry)") 279 | s/diag 280 | (tee #(println "R" (resolve-struct % 1002)))) 281 | 282 | ; put_structure henry|0, X3 283 | ; put_structure father|2, X1 284 | ; set_variable X2 285 | ; set_value X3 286 | ; get_structure father|2, X1 287 | ; unify_variable X2 288 | ; unify_variable X3 289 | ; get_structure richard|0, X2 290 | ; get_structure henry|0, X3 291 | ; 292 | ; Heap Registers Variables 293 | ; ------------------------------------------------------- 294 | ; ┌─────┬───────────┐ ┌─────┬─────────┐ ┌─────┬───────┐ 295 | ; │ key │ value │ │ key │ value │ │ key │ value │ 296 | ; ├─────┼───────────┤ ├─────┼─────────┤ ├─────┼───────┤ 297 | ; │ 0 ╎ [STR 1] │ │ X1 ╎ [STR 3] │ │ R ╎ X2 │ 298 | ; │ 1 ╎ henry|0 │ │ X2 ╎ [REF 4] │ └─────┴───────┘ 299 | ; │ 2 ╎ [STR 3] │ │ X3 ╎ [STR 1] │ 300 | ; │ 3 ╎ father|2 │ └─────┴─────────┘ 301 | ; │ 4 ╎ [STR 7] │ 302 | ; │ 5 ╎ [STR 1] │ 303 | ; │ 6 ╎ [STR 7] │ 304 | ; │ 7 ╎ richard|0 │ 305 | ; └─────┴───────────┘ 306 | ; 307 | ; R richard 308 | ; {:fail false, :mode :read, :pointer {:h 8, :s 2, :x 1000}, :store {0 [STR 1], 7 richard|0, 1001 [STR 3], 1 henry|0, 4 [STR 7], 1002 [REF 4], 1003 [STR 1], 6 [STR 7], 3 father|2, 2 [STR 3], 5 [STR 1]}, :trace true, :variables ([R X2])} 309 | 310 | (-> 311 | (s/make-context) 312 | (assoc :trace true) 313 | (query "father(R, henry)") 314 | (program "father(henry, richard)") 315 | s/diag 316 | (tee #(println "R" (resolve-struct % 1002)))) 317 | 318 | ; put_structure henry|0, X3 319 | ; put_structure father|2, X1 320 | ; set_variable X2 321 | ; set_value X3 322 | ; get_structure father|2, X1 323 | ; unify_variable X2 324 | ; unify_variable X3 325 | ; get_structure henry|0, X2 326 | ; get_structure richard|0, X3 327 | ; 328 | ; Heap Registers Variables 329 | ; ------------------------------------------------------ 330 | ; ┌─────┬──────────┐ ┌─────┬─────────┐ ┌─────┬───────┐ 331 | ; │ key │ value │ │ key │ value │ │ key │ value │ 332 | ; ├─────┼──────────┤ ├─────┼─────────┤ ├─────┼───────┤ 333 | ; │ 0 ╎ [STR 1] │ │ X1 ╎ [STR 3] │ │ R ╎ X2 │ 334 | ; │ 1 ╎ henry|0 │ │ X2 ╎ [REF 4] │ └─────┴───────┘ 335 | ; │ 2 ╎ [STR 3] │ │ X3 ╎ [STR 1] │ 336 | ; │ 3 ╎ father|2 │ └─────┴─────────┘ 337 | ; │ 4 ╎ [STR 7] │ 338 | ; │ 5 ╎ [STR 1] │ 339 | ; │ 6 ╎ [STR 7] │ 340 | ; │ 7 ╎ henry|0 │ 341 | ; └─────┴──────────┘ 342 | ; 343 | ; R henry 344 | ; {:fail true, :mode :write, :pointer {:h 8, :s 6, :x 1000}, :store {0 [STR 1], 7 henry|0, 1001 [STR 3], 1 henry|0, 4 [STR 7], 1002 [REF 4], 1003 [STR 1], 6 [STR 7], 3 father|2, 2 [STR 3], 5 [STR 1]}, :trace true, :variables ([R X2])} 345 | 346 | (-> 347 | (s/make-context) 348 | (assoc :trace true) 349 | (query "father(richard, J)") 350 | (program "father(W, K)") 351 | s/diag 352 | ;(tee #(println "J" (resolve-struct % 1003))) 353 | ;(tee #(println "K" (resolve-struct % 1003))) 354 | ;(tee #(println "W" (resolve-struct % 1002))) 355 | ) 356 | 357 | -------------------------------------------------------------------------------- /test/wam/functor_test.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | (ns wam.functor-test 25 | (:refer-clojure :exclude [name]) 26 | (:require 27 | [clojure.test :refer :all] 28 | [wam.functor :refer :all])) 29 | 30 | (deftest check-arity 31 | (testing "arity" 32 | (testing "symbol" 33 | (is (= (arity 'f|0) 0)) 34 | (is (= (arity 'f|1) 1)) 35 | (is (= (arity 'f|39) 39))) 36 | (testing "record" 37 | (is (= (arity (wam.grammar.Functor. "f" 0)) 0)) 38 | (is (= (arity (wam.grammar.Functor. "f" 1)) 1)) 39 | (is (= (arity (wam.grammar.Functor. "f" 39)) 39))) 40 | (testing "map" 41 | (is (= (arity {:name "f" :arg-count 0}) 0)) 42 | (is (= (arity {:name "f" :arg-count 1}) 1)) 43 | (is (= (arity {:name "f" :arg-count 39}) 39))))) 44 | 45 | (deftest check-name 46 | (testing "name" 47 | (testing "symbol" 48 | (is (= (name 'f|0) "f")) 49 | (is (= (name 'g|1) "g")) 50 | (is (= (name 'father|39) "father"))) 51 | (testing "record" 52 | (is (= (name (wam.grammar.Functor. "f" 0)) "f")) 53 | (is (= (name (wam.grammar.Functor. "g" 1)) "g")) 54 | (is (= (name (wam.grammar.Functor. "father" 39)) "father"))) 55 | (testing "map" 56 | (is (= (name {:name "f" :arg-count 0}) "f")) 57 | (is (= (name {:name "g" :arg-count 1}) "g")) 58 | (is (= (name {:name "father" :arg-count 39}) "father"))))) 59 | 60 | -------------------------------------------------------------------------------- /test/wam/grammar_test.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | (ns wam.grammar-test 25 | (:import 26 | [java.text ParseException] 27 | [wam.grammar Constant Variable Structure Functor]) 28 | (:require 29 | [clojure.test :refer :all] 30 | [jasentaa.parser :refer [parse-all]] 31 | [wam.grammar :refer [structure predicate constant variable]])) 32 | 33 | (deftest check-variable 34 | (testing "Variables" 35 | (is (= (parse-all variable "W") (Variable. 'W))) 36 | (is (= (parse-all variable "TEMP") (Variable. 'TEMP))) 37 | (is (= (parse-all variable "Temp") (Variable. 'Temp))) 38 | (is (= (parse-all variable "_") (Variable. '_))) 39 | (is (thrown-with-msg? 40 | ParseException #"Unable to parse text" 41 | (parse-all variable "w"))) 42 | (is (not= (parse-all variable "W") (Variable. 'X))))) 43 | 44 | (deftest check-constant 45 | (testing "Constants" 46 | (is (= (parse-all constant "3") (Constant. 3))) 47 | (is (thrown-with-msg? 48 | ParseException #"Unable to parse text" 49 | (parse-all constant "W"))))) 50 | 51 | (deftest check-predicate 52 | (testing "Predicates" 53 | (is (= (parse-all predicate "fred") "fred")) 54 | (is (= (parse-all predicate "b4rn3y") "b4rn3y")) 55 | (is (thrown-with-msg? 56 | ParseException #"Unable to parse text" 57 | (parse-all predicate "Wilma!"))))) 58 | 59 | (deftest check-structure 60 | (testing "Structures" 61 | (is (= (parse-all structure "p") (Structure. (Functor. 'p 0) nil))) 62 | (is (= (parse-all structure "f(W)") (Structure. (Functor. 'f 1) (list (Variable. 'W))))) 63 | (is (= (parse-all structure "h(Z, W)") (Structure. (Functor. 'h 2) (list (Variable. 'Z) (Variable. 'W))))) 64 | (is (= (parse-all structure "h(Z,W)") (Structure. (Functor. 'h 2) (list (Variable. 'Z) (Variable. 'W))))) 65 | (is (= (parse-all structure "p(Z, h(Z, W), f(W))") 66 | (Structure. 67 | (Functor. 'p 3) 68 | (list 69 | (Variable. 'Z) 70 | (Structure. 71 | (Functor. 'h 2) 72 | (list 73 | (Variable. 'Z) 74 | (Variable. 'W))) 75 | (Structure. 76 | (Functor. 'f 1) 77 | (list 78 | (Variable. 'W))))))))) 79 | 80 | (deftest writer-output 81 | (testing "Output rendering" 82 | (is (= (with-out-str (print (parse-all structure "p(Z,h(Z,W),f(W))"))) 83 | "p(Z h(Z W) f(W))")))) 84 | -------------------------------------------------------------------------------- /test/wam/instruction_set_test.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2015 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | ;; ℳ₀ machine instructions 25 | (ns wam.instruction-set-test 26 | (:require 27 | [clojure.test :refer :all] 28 | [wam.assert-helpers :refer :all] 29 | [wam.anciliary :refer [resolve-struct]] 30 | [wam.instruction-set :refer :all] 31 | [wam.store :as s])) 32 | 33 | (def ctx (s/make-context)) 34 | 35 | (deftest check-set-value 36 | (testing "set-value" 37 | (let [new-ctx (-> 38 | ctx 39 | (s/set-register 'X3 27) 40 | (set-value 'X3))] 41 | (is (= (s/pointer new-ctx :h) (heap 1))) 42 | (is (= (s/get-store new-ctx (heap 0)) 27))))) 43 | 44 | (deftest check-set-variable 45 | (testing "set-variable" 46 | (let [new-ctx (-> 47 | ctx 48 | (s/set-register 'X4 55) 49 | (set-variable 'X4))] 50 | (is (= (s/pointer new-ctx :h) (heap 1))) 51 | (is (= (s/get-store new-ctx (heap 0)) ['REF (heap 0)])) 52 | (is (= (s/get-register new-ctx 'X4) ['REF (heap 0)]))))) 53 | 54 | (deftest check-put-structure 55 | (testing "put-structure" 56 | (let [new-ctx (-> 57 | ctx 58 | (put-structure 'f|n 'X3))] 59 | (is (= (s/pointer new-ctx :h) (heap 2))) 60 | (is (= (s/get-store new-ctx (heap 0)) ['STR (heap 1)])) 61 | (is (= (s/get-store new-ctx (heap 1)) 'f|n)) 62 | (is (= (s/get-register new-ctx 'X3) ['STR (heap 1)]))))) 63 | 64 | (deftest check-get-structure 65 | (testing "get-structure") 66 | (let [ctx (-> 67 | ctx 68 | (s/set-store (heap 0) ['REF (heap 3)]) 69 | (s/set-store (heap 1) ['STR (heap 2)]) 70 | (s/set-store (heap 2) 'f|0) 71 | (s/set-store (heap 3) ['REF (heap 3)]) 72 | (assoc-in [:pointer :h] (heap 4)) 73 | (s/set-register 'X1 ['REF (heap 0)]) 74 | (s/set-register 'X2 ['REF (heap 1)]) 75 | (s/set-register 'X3 ['REF (heap 2)]))] 76 | 77 | (testing "REF" 78 | (let [new-ctx (get-structure ctx 'g|2 'X1)] 79 | (is (= (s/pointer new-ctx :h) (heap 6))) 80 | (is (= (:mode new-ctx) :write)) 81 | (is (false? (:fail new-ctx))) 82 | (is (= (s/get-store new-ctx (heap 3)) ['STR (heap 5)])) 83 | (is (= (s/get-store new-ctx (heap 4)) ['STR (heap 5)])) 84 | (is (= (s/get-store new-ctx (heap 5)) 'g|2)))) 85 | 86 | (testing "STR (fail)" 87 | (let [new-ctx (get-structure ctx 'g|2 'X2)] 88 | (is (true? (:fail new-ctx))))) 89 | 90 | (testing "STR (match)" 91 | (let [new-ctx (get-structure ctx 'f|0 'X2)] 92 | (is (= (s/pointer new-ctx :s) (heap 3))) 93 | (is (= (:mode new-ctx) :read)) 94 | (is (false? (:fail new-ctx))))) 95 | 96 | (testing "no match" 97 | (let [new-ctx (get-structure ctx 'g|2 'X3)] 98 | (is (true? (:fail new-ctx))))))) 99 | 100 | (deftest check-unify-variable 101 | (testing "unify-variable" 102 | (testing "read-mode" 103 | (let [new-ctx (-> 104 | ctx 105 | (s/mode :read) 106 | (s/set-store (heap 0) ['REF 3]) 107 | (unify-variable 'X1))] 108 | (is (= (s/get-register new-ctx 'X1) ['REF 3])) 109 | (is (= (s/pointer new-ctx :s) (heap 1))))) 110 | 111 | (testing "write-mode" 112 | (let [new-ctx (-> 113 | ctx 114 | (s/mode :write) 115 | (assoc-in [:pointer :h] (heap 2)) 116 | (assoc-in [:pointer :s] (heap 5)) 117 | (unify-variable 'X1))] 118 | (is (= (s/get-store new-ctx (heap 2)) ['REF (heap 2)])) 119 | (is (= (s/get-register new-ctx 'X1) ['REF (heap 2)])) 120 | (is (= (s/pointer new-ctx :h) (heap 3))) 121 | (is (= (s/pointer new-ctx :s) (heap 6))))) 122 | 123 | (testing "unknown mode" 124 | (is (thrown? IllegalArgumentException 125 | (-> 126 | ctx 127 | (assoc :mode :banana) 128 | (unify-variable 'X5))))))) 129 | 130 | (deftest check-unify-value 131 | (testing "unify-value" 132 | (testing "read-mode" 133 | ;; TODO 134 | ) 135 | 136 | (testing "write-mode" 137 | (let [new-ctx (-> 138 | ctx 139 | (s/mode :write) 140 | (assoc-in [:pointer :h] 9) 141 | (assoc-in [:pointer :s] 3) 142 | (s/set-register 'X2 ['STR 1]) 143 | (unify-value 'X2))] 144 | (is (= (s/get-store new-ctx 9) ['STR 1])) 145 | (is (= (s/pointer new-ctx :h) 10)) 146 | (is (= (s/pointer new-ctx :s) 4)))) 147 | 148 | (testing "unknown mode" 149 | (is (thrown? IllegalArgumentException 150 | (-> 151 | ctx 152 | (assoc :mode :banana) 153 | (unify-value 'X5))))))) 154 | 155 | (deftest ex2.1 156 | ; Compiled code for L0 query ?-p(Z,h(Z,W),f(W)). 157 | 158 | (is (tbl= 159 | (-> 160 | ctx 161 | (put-structure 'h|2, 'X3) 162 | (set-variable 'X2) 163 | (set-variable 'X5) 164 | (put-structure 'f|1, 'X4) 165 | (set-value 'X5) 166 | (put-structure 'p|3, 'X1) 167 | (set-value 'X2) 168 | (set-value 'X3) 169 | (set-value 'X4) 170 | s/heap) 171 | "+------+------------+ 172 | | key | value | 173 | +------+------------+ 174 | | 1000 | [STR 1001] | 175 | | 1001 | h|2 | 176 | | 1002 | [REF 1002] | 177 | | 1003 | [REF 1003] | 178 | | 1004 | [STR 1005] | 179 | | 1005 | f|1 | 180 | | 1006 | [REF 1003] | 181 | | 1007 | [STR 1008] | 182 | | 1008 | p|3 | 183 | | 1009 | [REF 1002] | 184 | | 1010 | [STR 1001] | 185 | | 1011 | [STR 1005] | 186 | +------+------------+"))) 187 | 188 | (deftest check-put-variable 189 | (testing "put-variable" 190 | (let [new-ctx (-> ctx (put-variable 'X4 'A1))] 191 | (is (= (s/pointer new-ctx :h) (heap 1))) 192 | (is (= (s/get-store new-ctx (heap 0)) ['REF (heap 0)])) 193 | (is (= (s/get-register new-ctx 'X4) ['REF (heap 0)])) 194 | (is (= (s/get-register new-ctx 'A1) ['REF (heap 0)]))))) 195 | 196 | (deftest check-put-value 197 | (testing "put-value" 198 | (let [new-ctx (-> 199 | ctx 200 | (s/set-register 'X4 32) 201 | (put-value 'X4 'A1))] 202 | (is (= (s/get-register new-ctx 'A1) 32))))) 203 | 204 | (deftest check-get-variable 205 | (testing "get-variable" 206 | (let [new-ctx (-> 207 | ctx 208 | (s/set-register 'A1 99) 209 | (get-variable 'X4 'A1))] 210 | (is (= (s/get-register new-ctx 'X4) 99))))) 211 | 212 | (deftest check-get-value 213 | (testing "get-value" 214 | (let [new-ctx (-> 215 | ctx 216 | (s/set-register 'A1 99) 217 | (get-value 'X1 'A1))] 218 | (is (false? (:fail new-ctx 'X4)))))) 219 | 220 | (deftest check-call 221 | (testing "call" 222 | (testing "non-existent program" 223 | (let [ctx (-> 224 | (s/make-context) 225 | (call 'p|5))] 226 | (is (true? (:fail ctx))) 227 | (is (= (s/pointer ctx :p) 0)))) 228 | 229 | (testing "simple proceed" 230 | (let [ctx (-> 231 | (s/make-context) 232 | (s/load 'h|2 [[proceed]]) 233 | (call 'h|2))] 234 | 235 | (is (false? (:fail ctx))) 236 | (is (= (s/pointer ctx :p) 1)))))) 237 | 238 | (deftest ex2.6 239 | (is (tbl= 240 | (-> 241 | (s/make-context) 242 | (put-variable 'X4, 'A1) 243 | (put-structure 'h|2, 'A2) 244 | (set-value 'X4) 245 | (set-variable 'X5) 246 | (put-structure 'f|1, 'A3) 247 | (set-value 'X5) 248 | s/heap) 249 | "+------+------------+ 250 | | key | value | 251 | +------+------------+ 252 | | 1000 | [REF 1000] | 253 | | 1001 | [STR 1002] | 254 | | 1002 | h|2 | 255 | | 1003 | [REF 1000] | 256 | | 1004 | [REF 1004] | 257 | | 1005 | [STR 1006] | 258 | | 1006 | f|1 | 259 | | 1007 | [REF 1004] | 260 | +------+------------+"))) 261 | 262 | (deftest ex2.7 263 | (let [p|3 (list 264 | [get-structure 'f|1, 'A1] 265 | [unify-variable 'X4] 266 | [get-structure 'h|2, 'A2] 267 | [unify-variable 'X5] 268 | [unify-variable 'X6] 269 | [get-value 'X5, 'A3] 270 | [get-structure 'f|1, 'X6] 271 | [unify-variable 'X7] 272 | [get-structure 'a|0, 'X7] 273 | [proceed]) 274 | ctx (-> 275 | (s/make-context) 276 | (put-variable 'X4, 'A1) 277 | (put-structure 'h|2, 'A2) 278 | (set-value 'X4) 279 | (set-variable 'X5) 280 | (put-structure 'f|1, 'A3) 281 | (set-value 'X5) 282 | (s/load 'p|3 p|3) 283 | (call 'p|3)) 284 | 285 | W (resolve-struct ctx (s/register-address 'X4)) 286 | X (resolve-struct ctx (s/register-address 'X4)) 287 | Y (resolve-struct ctx (s/register-address 'A3)) 288 | Z (resolve-struct ctx (s/register-address 'A1))] 289 | 290 | (s/diag ctx) 291 | 292 | (println "W =" W) 293 | (println "X =" X) 294 | (println "Y =" Y) 295 | (println "Z =" Z))) 296 | 297 | ; Heap Registers Variables 298 | ; ------------------------------------------------- 299 | ; ┌─────┬──────────┐ ┌─────┬──────────┐ ┌───────┐ 300 | ; │ key │ value │ │ key │ value │ │ value │ 301 | ; ├─────┼──────────┤ ├─────┼──────────┤ ├───────┤ 302 | ; │ 0 ╎ [STR 9] │ │ X1 ╎ [REF 0] │ └───────┘ 303 | ; │ 1 ╎ [STR 2] │ │ X2 ╎ [STR 2] │ 304 | ; │ 2 ╎ h|2 │ │ X3 ╎ [STR 6] │ 305 | ; │ 3 ╎ [REF 0] │ │ X4 ╎ [REF 10] │ 306 | ; │ 4 ╎ [STR 12] │ │ X5 ╎ [REF 0] │ 307 | ; │ 5 ╎ [STR 6] │ │ X6 ╎ [REF 4] │ 308 | ; │ 6 ╎ f|1 │ │ X7 ╎ [REF 13] │ 309 | ; │ 7 ╎ [REF 4] │ └─────┴──────────┘ 310 | ; │ 8 ╎ [STR 9] │ 311 | ; │ 9 ╎ f|1 │ 312 | ; │ 10 ╎ [REF 4] │ 313 | ; │ 11 ╎ [STR 12] │ 314 | ; │ 12 ╎ f|1 │ 315 | ; │ 13 ╎ [STR 15] │ 316 | ; │ 14 ╎ [STR 15] │ 317 | ; │ 15 ╎ a|0 │ 318 | ; └─────┴──────────┘ 319 | 320 | -------------------------------------------------------------------------------- /test/wam/store_test.clj: -------------------------------------------------------------------------------- 1 | ;; The MIT License (MIT) 2 | ;; 3 | ;; Copyright (c) 2016 Richard Hull 4 | ;; 5 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 6 | ;; of this software and associated documentation files (the "Software"), to deal 7 | ;; in the Software without restriction, including without limitation the rights 8 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | ;; copies of the Software, and to permit persons to whom the Software is 10 | ;; furnished to do so, subject to the following conditions: 11 | ;; 12 | ;; The above copyright notice and this permission notice shall be included in all 13 | ;; copies or substantial portions of the Software. 14 | ;; 15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;; SOFTWARE. 22 | 23 | 24 | (ns wam.store-test 25 | (:require 26 | [clojure.test :refer :all] 27 | [wam.assert-helpers :refer :all] 28 | [wam.store :as s])) 29 | 30 | (deftest check-make-context 31 | (testing "Initial context creation" 32 | (let [ctx (s/make-context)] 33 | (is (= (ctx :fail) false)) 34 | (is (= (ctx :mode) :read)) 35 | (is (= (s/pointer ctx :p) s/program-pointer-start)) 36 | (is (= (s/pointer ctx :h) s/heap-start)) 37 | (is (= (s/pointer ctx :s) s/heap-start)) 38 | (is (contains? ctx :store)) 39 | (is (empty? (ctx :store))) 40 | (is (contains? ctx :program-offsets)) 41 | (is (empty? (ctx :program-offsets)))))) 42 | 43 | (deftest check-fail 44 | (testing "Fail instruction" 45 | (let [ctx (s/make-context)] 46 | (is (false? (ctx :fail))) 47 | (is (true? ((s/fail ctx) :fail))) 48 | (is (true? ((s/fail ctx true) :fail))) 49 | (is (false? ((s/fail ctx false) :fail)))))) 50 | 51 | (deftest check-pointer-access 52 | (testing "Pointer access" 53 | (let [ctx (s/make-context)] 54 | (is (= (s/pointer ctx :p) 0)) 55 | (is (= (s/pointer ctx :h) (heap 0))) 56 | (is (= (s/pointer ctx :s) (heap 0))) 57 | (is (thrown? IllegalArgumentException (s/pointer ctx nil))) 58 | (is (thrown? IllegalArgumentException (s/pointer ctx :banana)))))) 59 | 60 | (deftest check-pointer-increment 61 | (testing "Pointer incrementing" 62 | (let [ctx (s/make-context)] 63 | (is (= (-> ctx (s/increment :p) (s/pointer :p)) 1)) 64 | (is (= (-> ctx (s/increment :h) (s/pointer :h)) (heap 1))) 65 | (is (= (-> ctx (s/increment :s) (s/pointer :s)) (heap 1))) 66 | (is (thrown? IllegalArgumentException (s/increment ctx nil))) 67 | (is (thrown? IllegalArgumentException (s/increment ctx :banana)))))) 68 | 69 | (deftest check-register-address 70 | (testing "Register addressing" 71 | (let [ctx (s/make-context)] 72 | (is (= (s/register-address 'X1) (+ s/register-start 1))) 73 | (is (= (s/register-address 'X14) (+ s/register-start 14))) 74 | (is (= (s/register-address 'A3) (+ s/register-start 3))) 75 | (is (thrown? IllegalArgumentException (s/register-address 'X55)))))) 76 | 77 | (deftest check-mode 78 | (testing "Set mode" 79 | (let [ctx (s/make-context)] 80 | (is (= (ctx :mode) :read)) 81 | (is (= ((s/mode ctx :write) :mode) :write)) 82 | (is (thrown? IllegalArgumentException (s/mode ctx nil))) 83 | (is (thrown? IllegalArgumentException (s/mode ctx :banana)))))) 84 | 85 | --------------------------------------------------------------------------------