├── LICENSE ├── README.md ├── mk.scm ├── test-check.scm └── type-inferencer.scm /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 William E. Byrd 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 | # hindley-milner-type-inferencer 2 | Relational Hindley-Milner type inferencer in miniKanren. Supports polymorphic 'let'. Performs type habitation. 3 | -------------------------------------------------------------------------------- /mk.scm: -------------------------------------------------------------------------------- 1 | ;;; 28 November 02014 WEB 2 | ;;; 3 | ;;; * Fixed missing unquote before E in 'drop-Y-b/c-dup-var' 4 | ;;; 5 | ;;; * Updated 'rem-xx-from-d' to check against other constraints after 6 | ;;; unification, in order to remove redundant disequality constraints 7 | ;;; subsumed by absento constraints. 8 | 9 | ;;; newer version: Sept. 18 2013 (with eigens) 10 | ;;; Jason Hemann, Will Byrd, and Dan Friedman 11 | ;;; E = (e* . x*)*, where e* is a list of eigens and x* is a list of variables. 12 | ;;; Each e in e* is checked for any of its eigens be in any of its x*. Then it fails. 13 | ;;; Since eigen-occurs-check is chasing variables, we might as will do a memq instead 14 | ;;; of an eq? when an eigen is found through a chain of walks. See eigen-occurs-check. 15 | ;;; All the e* must be the eigens created as part of a single eigen. The reifier just 16 | ;;; abandons E, if it succeeds. If there is no failure by then, there were no eigen 17 | ;;; violations. 18 | 19 | (define empty-c '(() () () () () () ())) 20 | 21 | (define eigen-tag (vector 'eigen-tag)) 22 | 23 | (define-syntax inc 24 | (syntax-rules () 25 | ((_ e) (lambdaf@ () e)))) 26 | 27 | (define-syntax lambdaf@ 28 | (syntax-rules () 29 | ((_ () e) (lambda () e)))) 30 | 31 | (define-syntax lambdag@ 32 | (syntax-rules (:) 33 | ((_ (c) e) (lambda (c) e)) 34 | ((_ (c : B E S) e) 35 | (lambda (c) 36 | (let ((B (c->B c)) (E (c->E c)) (S (c->S c))) 37 | e))) 38 | ((_ (c : B E S D Y N T) e) 39 | (lambda (c) 40 | (let ((B (c->B c)) (E (c->E c)) (S (c->S c)) (D (c->D c)) 41 | (Y (c->Y c)) (N (c->N c)) (T (c->T c))) 42 | e))))) 43 | 44 | (define rhs 45 | (lambda (pr) 46 | (cdr pr))) 47 | 48 | (define lhs 49 | (lambda (pr) 50 | (car pr))) 51 | 52 | (define eigen-var 53 | (lambda () 54 | (vector eigen-tag))) 55 | 56 | (define eigen? 57 | (lambda (x) 58 | (and (vector? x) (eq? (vector-ref x 0) eigen-tag)))) 59 | 60 | (define var 61 | (lambda (dummy) 62 | (vector dummy))) 63 | 64 | (define var? 65 | (lambda (x) 66 | (and (vector? x) (not (eq? (vector-ref x 0) eigen-tag))))) 67 | 68 | (define walk 69 | (lambda (u S) 70 | (cond 71 | ((and (var? u) (assq u S)) => 72 | (lambda (pr) (walk (rhs pr) S))) 73 | (else u)))) 74 | 75 | (define prefix-S 76 | (lambda (S+ S) 77 | (cond 78 | ((eq? S+ S) '()) 79 | (else (cons (car S+) 80 | (prefix-S (cdr S+) S)))))) 81 | 82 | (define unify 83 | (lambda (u v s) 84 | (let ((u (walk u s)) 85 | (v (walk v s))) 86 | (cond 87 | ((eq? u v) s) 88 | ((var? u) (ext-s-check u v s)) 89 | ((var? v) (ext-s-check v u s)) 90 | ((and (pair? u) (pair? v)) 91 | (let ((s (unify (car u) (car v) s))) 92 | (and s (unify (cdr u) (cdr v) s)))) 93 | ((or (eigen? u) (eigen? v)) #f) 94 | ((equal? u v) s) 95 | (else #f))))) 96 | 97 | (define occurs-check 98 | (lambda (x v s) 99 | (let ((v (walk v s))) 100 | (cond 101 | ((var? v) (eq? v x)) 102 | ((pair? v) 103 | (or 104 | (occurs-check x (car v) s) 105 | (occurs-check x (cdr v) s))) 106 | (else #f))))) 107 | 108 | (define eigen-occurs-check 109 | (lambda (e* x s) 110 | (let ((x (walk x s))) 111 | (cond 112 | ((var? x) #f) 113 | ((eigen? x) (memq x e*)) 114 | ((pair? x) 115 | (or 116 | (eigen-occurs-check e* (car x) s) 117 | (eigen-occurs-check e* (cdr x) s))) 118 | (else #f))))) 119 | 120 | (define empty-f (lambdaf@ () (mzero))) 121 | 122 | (define ext-s-check 123 | (lambda (x v s) 124 | (cond 125 | ((occurs-check x v s) #f) 126 | (else (cons `(,x . ,v) s))))) 127 | 128 | (define unify* 129 | (lambda (S+ S) 130 | (unify (map lhs S+) (map rhs S+) S))) 131 | 132 | (define-syntax case-inf 133 | (syntax-rules () 134 | ((_ e (() e0) ((f^) e1) ((c^) e2) ((c f) e3)) 135 | (let ((c-inf e)) 136 | (cond 137 | ((not c-inf) e0) 138 | ((procedure? c-inf) (let ((f^ c-inf)) e1)) 139 | ((not (and (pair? c-inf) 140 | (procedure? (cdr c-inf)))) 141 | (let ((c^ c-inf)) e2)) 142 | (else (let ((c (car c-inf)) (f (cdr c-inf))) 143 | e3))))))) 144 | 145 | (define-syntax fresh 146 | (syntax-rules () 147 | ((_ (x ...) g0 g ...) 148 | (lambdag@ (c : B E S D Y N T) 149 | (inc 150 | (let ((x (var 'x)) ...) 151 | (let ((B (append `(,x ...) B))) 152 | (bind* (g0 `(,B ,E ,S ,D ,Y ,N ,T)) g ...)))))))) 153 | 154 | (define-syntax eigen 155 | (syntax-rules () 156 | ((_ (x ...) g0 g ...) 157 | (lambdag@ (c : B E S) 158 | (let ((x (eigen-var)) ...) 159 | ((fresh () (eigen-absento `(,x ...) B) g0 g ...) c)))))) 160 | 161 | (define-syntax bind* 162 | (syntax-rules () 163 | ((_ e) e) 164 | ((_ e g0 g ...) (bind* (bind e g0) g ...)))) 165 | 166 | (define bind 167 | (lambda (c-inf g) 168 | (case-inf c-inf 169 | (() (mzero)) 170 | ((f) (inc (bind (f) g))) 171 | ((c) (g c)) 172 | ((c f) (mplus (g c) (lambdaf@ () (bind (f) g))))))) 173 | 174 | (define-syntax run 175 | (syntax-rules () 176 | ((_ n (q) g0 g ...) 177 | (take n 178 | (lambdaf@ () 179 | ((fresh (q) g0 g ... 180 | (lambdag@ (final-c) 181 | (let ((z ((reify q) final-c))) 182 | (choice z empty-f)))) 183 | empty-c)))) 184 | ((_ n (q0 q1 q ...) g0 g ...) 185 | (run n (x) (fresh (q0 q1 q ...) g0 g ... (== `(,q0 ,q1 ,q ...) x)))))) 186 | 187 | (define-syntax run* 188 | (syntax-rules () 189 | ((_ (q0 q ...) g0 g ...) (run #f (q0 q ...) g0 g ...)))) 190 | 191 | (define take 192 | (lambda (n f) 193 | (cond 194 | ((and n (zero? n)) '()) 195 | (else 196 | (case-inf (f) 197 | (() '()) 198 | ((f) (take n f)) 199 | ((c) (cons c '())) 200 | ((c f) (cons c 201 | (take (and n (- n 1)) f)))))))) 202 | 203 | (define-syntax conde 204 | (syntax-rules () 205 | ((_ (g0 g ...) (g1 g^ ...) ...) 206 | (lambdag@ (c) 207 | (inc 208 | (mplus* 209 | (bind* (g0 c) g ...) 210 | (bind* (g1 c) g^ ...) ...)))))) 211 | 212 | (define-syntax mplus* 213 | (syntax-rules () 214 | ((_ e) e) 215 | ((_ e0 e ...) (mplus e0 216 | (lambdaf@ () (mplus* e ...)))))) 217 | 218 | (define mplus 219 | (lambda (c-inf f) 220 | (case-inf c-inf 221 | (() (f)) 222 | ((f^) (inc (mplus (f) f^))) 223 | ((c) (choice c f)) 224 | ((c f^) (choice c (lambdaf@ () (mplus (f) f^))))))) 225 | 226 | 227 | (define c->B (lambda (c) (car c))) 228 | (define c->E (lambda (c) (cadr c))) 229 | (define c->S (lambda (c) (caddr c))) 230 | (define c->D (lambda (c) (cadddr c))) 231 | (define c->Y (lambda (c) (cadddr (cdr c)))) 232 | (define c->N (lambda (c) (cadddr (cddr c)))) 233 | (define c->T (lambda (c) (cadddr (cdddr c)))) 234 | 235 | (define-syntax conda 236 | (syntax-rules () 237 | ((_ (g0 g ...) (g1 g^ ...) ...) 238 | (lambdag@ (c) 239 | (inc 240 | (ifa ((g0 c) g ...) 241 | ((g1 c) g^ ...) ...)))))) 242 | 243 | (define-syntax ifa 244 | (syntax-rules () 245 | ((_) (mzero)) 246 | ((_ (e g ...) b ...) 247 | (let loop ((c-inf e)) 248 | (case-inf c-inf 249 | (() (ifa b ...)) 250 | ((f) (inc (loop (f)))) 251 | ((a) (bind* c-inf g ...)) 252 | ((a f) (bind* c-inf g ...))))))) 253 | 254 | (define-syntax condu 255 | (syntax-rules () 256 | ((_ (g0 g ...) (g1 g^ ...) ...) 257 | (lambdag@ (c) 258 | (inc 259 | (ifu ((g0 c) g ...) 260 | ((g1 c) g^ ...) ...)))))) 261 | 262 | (define-syntax ifu 263 | (syntax-rules () 264 | ((_) (mzero)) 265 | ((_ (e g ...) b ...) 266 | (let loop ((c-inf e)) 267 | (case-inf c-inf 268 | (() (ifu b ...)) 269 | ((f) (inc (loop (f)))) 270 | ((c) (bind* c-inf g ...)) 271 | ((c f) (bind* (unit c) g ...))))))) 272 | 273 | (define mzero (lambda () #f)) 274 | 275 | (define unit (lambda (c) c)) 276 | 277 | (define choice (lambda (c f) (cons c f))) 278 | 279 | (define tagged? 280 | (lambda (S Y y^) 281 | (exists (lambda (y) (eqv? (walk y S) y^)) Y))) 282 | 283 | (define untyped-var? 284 | (lambda (S Y N t^) 285 | (let ((in-type? (lambda (y) (eq? (walk y S) t^)))) 286 | (and (var? t^) 287 | (not (exists in-type? Y)) 288 | (not (exists in-type? N)))))) 289 | 290 | (define-syntax project 291 | (syntax-rules () 292 | ((_ (x ...) g g* ...) 293 | (lambdag@ (c : B E S) 294 | (let ((x (walk* x S)) ...) 295 | ((fresh () g g* ...) c)))))) 296 | 297 | (define walk* 298 | (lambda (v S) 299 | (let ((v (walk v S))) 300 | (cond 301 | ((var? v) v) 302 | ((pair? v) 303 | (cons (walk* (car v) S) (walk* (cdr v) S))) 304 | (else v))))) 305 | 306 | (define reify-S 307 | (lambda (v S) 308 | (let ((v (walk v S))) 309 | (cond 310 | ((var? v) 311 | (let ((n (length S))) 312 | (let ((name (reify-name n))) 313 | (cons `(,v . ,name) S)))) 314 | ((pair? v) 315 | (let ((S (reify-S (car v) S))) 316 | (reify-S (cdr v) S))) 317 | (else S))))) 318 | 319 | (define reify-name 320 | (lambda (n) 321 | (string->symbol 322 | (string-append "_" "." (number->string n))))) 323 | 324 | (define drop-dot 325 | (lambda (X) 326 | (map (lambda (t) 327 | (let ((a (lhs t)) 328 | (d (rhs t))) 329 | `(,a ,d))) 330 | X))) 331 | 332 | (define sorter 333 | (lambda (ls) 334 | (list-sort lex<=? ls))) 335 | 336 | (define lex<=? 337 | (lambda (x y) 338 | (string<=? (datum->string x) (datum->string y)))) 339 | 340 | (define datum->string 341 | (lambda (x) 342 | (call-with-string-output-port 343 | (lambda (p) (display x p))))) 344 | 345 | (define anyvar? 346 | (lambda (u r) 347 | (cond 348 | ((pair? u) 349 | (or (anyvar? (car u) r) 350 | (anyvar? (cdr u) r))) 351 | (else (var? (walk u r)))))) 352 | 353 | (define anyeigen? 354 | (lambda (u r) 355 | (cond 356 | ((pair? u) 357 | (or (anyeigen? (car u) r) 358 | (anyeigen? (cdr u) r))) 359 | (else (eigen? (walk u r)))))) 360 | 361 | (define member* 362 | (lambda (u v) 363 | (cond 364 | ((equal? u v) #t) 365 | ((pair? v) 366 | (or (member* u (car v)) (member* u (cdr v)))) 367 | (else #f)))) 368 | 369 | ;;; 370 | 371 | (define drop-N-b/c-const 372 | (lambdag@ (c : B E S D Y N T) 373 | (let ((const? (lambda (n) 374 | (not (var? (walk n S)))))) 375 | (cond 376 | ((find const? N) => 377 | (lambda (n) `(,B ,E ,S ,D ,Y ,(remq1 n N) ,T))) 378 | (else c))))) 379 | 380 | (define drop-Y-b/c-const 381 | (lambdag@ (c : B E S D Y N T) 382 | (let ((const? (lambda (y) 383 | (not (var? (walk y S)))))) 384 | (cond 385 | ((find const? Y) => 386 | (lambda (y) `(,B ,E ,S ,D ,(remq1 y Y) ,N ,T))) 387 | (else c))))) 388 | 389 | (define remq1 390 | (lambda (elem ls) 391 | (cond 392 | ((null? ls) '()) 393 | ((eq? (car ls) elem) (cdr ls)) 394 | (else (cons (car ls) (remq1 elem (cdr ls))))))) 395 | 396 | (define same-var? 397 | (lambda (v) 398 | (lambda (v^) 399 | (and (var? v) (var? v^) (eq? v v^))))) 400 | 401 | (define find-dup 402 | (lambda (f S) 403 | (lambda (set) 404 | (let loop ((set^ set)) 405 | (cond 406 | ((null? set^) #f) 407 | (else 408 | (let ((elem (car set^))) 409 | (let ((elem^ (walk elem S))) 410 | (cond 411 | ((find (lambda (elem^^) 412 | ((f elem^) (walk elem^^ S))) 413 | (cdr set^)) 414 | elem) 415 | (else (loop (cdr set^)))))))))))) 416 | 417 | (define drop-N-b/c-dup-var 418 | (lambdag@ (c : B E S D Y N T) 419 | (cond 420 | (((find-dup same-var? S) N) => 421 | (lambda (n) `(,B ,E ,S ,D ,Y ,(remq1 n N) ,T))) 422 | (else c)))) 423 | 424 | (define drop-Y-b/c-dup-var 425 | (lambdag@ (c : B E S D Y N T) 426 | (cond 427 | (((find-dup same-var? S) Y) => 428 | (lambda (y) 429 | `(,B ,E ,S ,D ,(remq1 y Y) ,N ,T))) 430 | (else c)))) 431 | 432 | (define var-type-mismatch? 433 | (lambda (S Y N t1^ t2^) 434 | (cond 435 | ((num? S N t1^) (not (num? S N t2^))) 436 | ((sym? S Y t1^) (not (sym? S Y t2^))) 437 | (else #f)))) 438 | 439 | (define term-ununifiable? 440 | (lambda (S Y N t1 t2) 441 | (let ((t1^ (walk t1 S)) 442 | (t2^ (walk t2 S))) 443 | (cond 444 | ((or (untyped-var? S Y N t1^) (untyped-var? S Y N t2^)) #f) 445 | ((var? t1^) (var-type-mismatch? S Y N t1^ t2^)) 446 | ((var? t2^) (var-type-mismatch? S Y N t2^ t1^)) 447 | ((and (pair? t1^) (pair? t2^)) 448 | (or (term-ununifiable? S Y N (car t1^) (car t2^)) 449 | (term-ununifiable? S Y N (cdr t1^) (cdr t2^)))) 450 | (else (not (eqv? t1^ t2^))))))) 451 | 452 | (define T-term-ununifiable? 453 | (lambda (S Y N) 454 | (lambda (t1) 455 | (let ((t1^ (walk t1 S))) 456 | (letrec 457 | ((t2-check 458 | (lambda (t2) 459 | (let ((t2^ (walk t2 S))) 460 | (cond 461 | ((pair? t2^) (and 462 | (term-ununifiable? S Y N t1^ t2^) 463 | (t2-check (car t2^)) 464 | (t2-check (cdr t2^)))) 465 | (else (term-ununifiable? S Y N t1^ t2^))))))) 466 | t2-check))))) 467 | 468 | (define num? 469 | (lambda (S N n) 470 | (let ((n (walk n S))) 471 | (cond 472 | ((var? n) (tagged? S N n)) 473 | (else (number? n)))))) 474 | 475 | (define sym? 476 | (lambda (S Y y) 477 | (let ((y (walk y S))) 478 | (cond 479 | ((var? y) (tagged? S Y y)) 480 | (else (symbol? y)))))) 481 | 482 | (define drop-T-b/c-Y-and-N 483 | (lambdag@ (c : B E S D Y N T) 484 | (let ((drop-t? (T-term-ununifiable? S Y N))) 485 | (cond 486 | ((find (lambda (t) ((drop-t? (lhs t)) (rhs t))) T) => 487 | (lambda (t) `(,B ,E ,S ,D ,Y ,N ,(remq1 t T)))) 488 | (else c))))) 489 | 490 | (define move-T-to-D-b/c-t2-atom 491 | (lambdag@ (c : B E S D Y N T) 492 | (cond 493 | ((exists (lambda (t) 494 | (let ((t2^ (walk (rhs t) S))) 495 | (cond 496 | ((and (not (untyped-var? S Y N t2^)) 497 | (not (pair? t2^))) 498 | (let ((T (remq1 t T))) 499 | `(,B ,E ,S ((,t) . ,D) ,Y ,N ,T))) 500 | (else #f)))) 501 | T)) 502 | (else c)))) 503 | 504 | (define terms-pairwise=? 505 | (lambda (pr-a^ pr-d^ t-a^ t-d^ S) 506 | (or 507 | (and (term=? pr-a^ t-a^ S) 508 | (term=? pr-d^ t-a^ S)) 509 | (and (term=? pr-a^ t-d^ S) 510 | (term=? pr-d^ t-a^ S))))) 511 | 512 | (define T-superfluous-pr? 513 | (lambda (S Y N T) 514 | (lambda (pr) 515 | (let ((pr-a^ (walk (lhs pr) S)) 516 | (pr-d^ (walk (rhs pr) S))) 517 | (cond 518 | ((exists 519 | (lambda (t) 520 | (let ((t-a^ (walk (lhs t) S)) 521 | (t-d^ (walk (rhs t) S))) 522 | (terms-pairwise=? pr-a^ pr-d^ t-a^ t-d^ S))) 523 | T) 524 | (for-all 525 | (lambda (t) 526 | (let ((t-a^ (walk (lhs t) S)) 527 | (t-d^ (walk (rhs t) S))) 528 | (or 529 | (not (terms-pairwise=? pr-a^ pr-d^ t-a^ t-d^ S)) 530 | (untyped-var? S Y N t-d^) 531 | (pair? t-d^)))) 532 | T)) 533 | (else #f)))))) 534 | 535 | (define drop-from-D-b/c-T 536 | (lambdag@ (c : B E S D Y N T) 537 | (cond 538 | ((find 539 | (lambda (d) 540 | (exists 541 | (T-superfluous-pr? S Y N T) 542 | d)) 543 | D) => 544 | (lambda (d) `(,B ,E ,S ,(remq1 d D) ,Y ,N ,T))) 545 | (else c)))) 546 | 547 | (define drop-t-b/c-t2-occurs-t1 548 | (lambdag@ (c : B E S D Y N T) 549 | (cond 550 | ((find (lambda (t) 551 | (let ((t-a^ (walk (lhs t) S)) 552 | (t-d^ (walk (rhs t) S))) 553 | (mem-check t-d^ t-a^ S))) 554 | T) => 555 | (lambda (t) 556 | `(,B ,E ,S ,D ,Y ,N ,(remq1 t T)))) 557 | (else c)))) 558 | 559 | (define split-t-move-to-d-b/c-pair 560 | (lambdag@ (c : B E S D Y N T) 561 | (cond 562 | ((exists 563 | (lambda (t) 564 | (let ((t2^ (walk (rhs t) S))) 565 | (cond 566 | ((pair? t2^) (let ((ta `(,(lhs t) . ,(car t2^))) 567 | (td `(,(lhs t) . ,(cdr t2^)))) 568 | (let ((T `(,ta ,td . ,(remq1 t T)))) 569 | `(,B ,E ,S ((,t) . ,D) ,Y ,N ,T)))) 570 | (else #f)))) 571 | T)) 572 | (else c)))) 573 | 574 | (define find-d-conflict 575 | (lambda (S Y N) 576 | (lambda (D) 577 | (find 578 | (lambda (d) 579 | (exists (lambda (pr) 580 | (term-ununifiable? S Y N (lhs pr) (rhs pr))) 581 | d)) 582 | D)))) 583 | 584 | (define drop-D-b/c-Y-or-N 585 | (lambdag@ (c : B E S D Y N T) 586 | (cond 587 | (((find-d-conflict S Y N) D) => 588 | (lambda (d) `(,B ,E ,S ,(remq1 d D) ,Y ,N ,T))) 589 | (else c)))) 590 | 591 | (define cycle 592 | (lambdag@ (c) 593 | (let loop ((c^ c) 594 | (fns^ (LOF)) 595 | (n (length (LOF)))) 596 | (cond 597 | ((zero? n) c^) 598 | ((null? fns^) (loop c^ (LOF) n)) 599 | (else 600 | (let ((c^^ ((car fns^) c^))) 601 | (cond 602 | ((not (eq? c^^ c^)) 603 | (loop c^^ (cdr fns^) (length (LOF)))) 604 | (else (loop c^ (cdr fns^) (sub1 n)))))))))) 605 | 606 | (define absento 607 | (lambda (u v) 608 | (lambdag@ (c : B E S D Y N T) 609 | (cond 610 | [(mem-check u v S) (mzero)] 611 | [else (unit `(,B ,E ,S ,D ,Y ,N ((,u . ,v) . ,T)))])))) 612 | 613 | (define eigen-absento 614 | (lambda (e* x*) 615 | (lambdag@ (c : B E S D Y N T) 616 | (cond 617 | [(eigen-occurs-check e* x* S) (mzero)] 618 | [else (unit `(,B ((,e* . ,x*) . ,E) ,S ,D ,Y ,N ,T))])))) 619 | 620 | (define mem-check 621 | (lambda (u t S) 622 | (let ((t (walk t S))) 623 | (cond 624 | ((pair? t) 625 | (or (term=? u t S) 626 | (mem-check u (car t) S) 627 | (mem-check u (cdr t) S))) 628 | (else (term=? u t S)))))) 629 | 630 | (define term=? 631 | (lambda (u t S) 632 | (cond 633 | ((unify u t S) => 634 | (lambda (S0) 635 | (eq? S0 S))) 636 | (else #f)))) 637 | 638 | (define ground-non-? 639 | (lambda (pred) 640 | (lambda (u S) 641 | (let ((u (walk u S))) 642 | (cond 643 | ((var? u) #f) 644 | (else (not (pred u)))))))) 645 | ;; moved 646 | (define ground-non-symbol? 647 | (ground-non-? symbol?)) 648 | 649 | (define ground-non-number? 650 | (ground-non-? number?)) 651 | 652 | (define symbolo 653 | (lambda (u) 654 | (lambdag@ (c : B E S D Y N T) 655 | (cond 656 | [(ground-non-symbol? u S) (mzero)] 657 | [(mem-check u N S) (mzero)] 658 | [else (unit `(,B ,E ,S ,D (,u . ,Y) ,N ,T))])))) 659 | 660 | (define numbero 661 | (lambda (u) 662 | (lambdag@ (c : B E S D Y N T) 663 | (cond 664 | [(ground-non-number? u S) (mzero)] 665 | [(mem-check u Y S) (mzero)] 666 | [else (unit `(,B ,E ,S ,D ,Y (,u . ,N) ,T))])))) 667 | ;; end moved 668 | 669 | (define =/= ;; moved 670 | (lambda (u v) 671 | (lambdag@ (c : B E S D Y N T) 672 | (cond 673 | ((unify u v S) => 674 | (lambda (S0) 675 | (let ((pfx (prefix-S S0 S))) 676 | (cond 677 | ((null? pfx) (mzero)) 678 | (else (unit `(,B ,E ,S (,pfx . ,D) ,Y ,N ,T))))))) 679 | (else c))))) 680 | 681 | (define == 682 | (lambda (u v) 683 | (lambdag@ (c : B E S D Y N T) 684 | (cond 685 | ((unify u v S) => 686 | (lambda (S0) 687 | (cond 688 | ((==fail-check B E S0 D Y N T) (mzero)) 689 | (else (unit `(,B ,E ,S0 ,D ,Y ,N ,T)))))) 690 | (else (mzero)))))) 691 | 692 | (define succeed (== #f #f)) 693 | 694 | (define fail (== #f #t)) 695 | 696 | (define ==fail-check 697 | (lambda (B E S0 D Y N T) 698 | (cond 699 | ((eigen-absento-fail-check E S0) #t) 700 | ((atomic-fail-check S0 Y ground-non-symbol?) #t) 701 | ((atomic-fail-check S0 N ground-non-number?) #t) 702 | ((symbolo-numbero-fail-check S0 Y N) #t) 703 | ((=/=-fail-check S0 D) #t) 704 | ((absento-fail-check S0 T) #t) 705 | (else #f)))) 706 | 707 | (define eigen-absento-fail-check 708 | (lambda (E S0) 709 | (exists (lambda (e*/x*) (eigen-occurs-check (car e*/x*) (cdr e*/x*) S0)) E))) 710 | 711 | (define atomic-fail-check 712 | (lambda (S A pred) 713 | (exists (lambda (a) (pred (walk a S) S)) A))) 714 | 715 | (define symbolo-numbero-fail-check 716 | (lambda (S A N) 717 | (let ((N (map (lambda (n) (walk n S)) N))) 718 | (exists (lambda (a) (exists (same-var? (walk a S)) N)) 719 | A)))) 720 | 721 | (define absento-fail-check 722 | (lambda (S T) 723 | (exists (lambda (t) (mem-check (lhs t) (rhs t) S)) T))) 724 | 725 | (define =/=-fail-check 726 | (lambda (S D) 727 | (exists (d-fail-check S) D))) 728 | 729 | (define d-fail-check 730 | (lambda (S) 731 | (lambda (d) 732 | (cond 733 | ((unify* d S) => 734 | (lambda (S+) (eq? S+ S))) 735 | (else #f))))) 736 | 737 | (define reify 738 | (lambda (x) 739 | (lambda (c) 740 | (let ((c (cycle c))) 741 | (let* ((S (c->S c)) 742 | (D (walk* (c->D c) S)) 743 | (Y (walk* (c->Y c) S)) 744 | (N (walk* (c->N c) S)) 745 | (T (walk* (c->T c) S))) 746 | (let ((v (walk* x S))) 747 | (let ((R (reify-S v '()))) 748 | (reify+ v R 749 | (let ((D (remp 750 | (lambda (d) 751 | (let ((dw (walk* d S))) 752 | (or 753 | (anyvar? dw R) 754 | (anyeigen? dw R)))) 755 | (rem-xx-from-d c)))) 756 | (rem-subsumed D)) 757 | (remp 758 | (lambda (y) (var? (walk y R))) 759 | Y) 760 | (remp 761 | (lambda (n) (var? (walk n R))) 762 | N) 763 | (remp (lambda (t) 764 | (or (anyeigen? t R) (anyvar? t R))) T))))))))) 765 | 766 | (define reify+ 767 | (lambda (v R D Y N T) 768 | (form (walk* v R) 769 | (walk* D R) 770 | (walk* Y R) 771 | (walk* N R) 772 | (rem-subsumed-T (walk* T R))))) 773 | 774 | (define form 775 | (lambda (v D Y N T) 776 | (let ((fd (sort-D D)) 777 | (fy (sorter Y)) 778 | (fn (sorter N)) 779 | (ft (sorter T))) 780 | (let ((fd (if (null? fd) fd 781 | (let ((fd (drop-dot-D fd))) 782 | `((=/= . ,fd))))) 783 | (fy (if (null? fy) fy `((sym . ,fy)))) 784 | (fn (if (null? fn) fn `((num . ,fn)))) 785 | (ft (if (null? ft) ft 786 | (let ((ft (drop-dot ft))) 787 | `((absento . ,ft)))))) 788 | (cond 789 | ((and (null? fd) (null? fy) 790 | (null? fn) (null? ft)) 791 | v) 792 | (else (append `(,v) fd fn fy ft))))))) 793 | 794 | (define sort-D 795 | (lambda (D) 796 | (sorter 797 | (map sort-d D)))) 798 | 799 | (define sort-d 800 | (lambda (d) 801 | (list-sort 802 | (lambda (x y) 803 | (lex<=? (car x) (car y))) 804 | (map sort-pr d)))) 805 | 806 | (define drop-dot-D 807 | (lambda (D) 808 | (map drop-dot D))) 809 | 810 | (define lex<-reified-name? 811 | (lambda (r) 812 | (charstring r) 0) 815 | #\_))) 816 | 817 | (define sort-pr 818 | (lambda (pr) 819 | (let ((l (lhs pr)) 820 | (r (rhs pr))) 821 | (cond 822 | ((lex<-reified-name? r) pr) 823 | ((lex<=? r l) `(,r . ,l)) 824 | (else pr))))) 825 | 826 | (define rem-subsumed 827 | (lambda (D) 828 | (let rem-subsumed ((D D) (d^* '())) 829 | (cond 830 | ((null? D) d^*) 831 | ((or (subsumed? (car D) (cdr D)) 832 | (subsumed? (car D) d^*)) 833 | (rem-subsumed (cdr D) d^*)) 834 | (else (rem-subsumed (cdr D) 835 | (cons (car D) d^*))))))) 836 | 837 | (define subsumed? 838 | (lambda (d d*) 839 | (cond 840 | ((null? d*) #f) 841 | (else 842 | (let ((d^ (unify* (car d*) d))) 843 | (or 844 | (and d^ (eq? d^ d)) 845 | (subsumed? d (cdr d*)))))))) 846 | 847 | (define rem-xx-from-d 848 | (lambdag@ (c : B E S D Y N T) 849 | (let ((D (walk* D S))) 850 | (remp not 851 | (map (lambda (d) 852 | (cond 853 | ((unify* d S) => 854 | (lambda (S0) 855 | (cond 856 | ((==fail-check B E S0 '() Y N T) #f) 857 | (else (prefix-S S0 S))))) 858 | (else #f))) 859 | D))))) 860 | 861 | (define rem-subsumed-T 862 | (lambda (T) 863 | (let rem-subsumed ((T T) (T^ '())) 864 | (cond 865 | ((null? T) T^) 866 | (else 867 | (let ((lit (lhs (car T))) 868 | (big (rhs (car T)))) 869 | (cond 870 | ((or (subsumed-T? lit big (cdr T)) 871 | (subsumed-T? lit big T^)) 872 | (rem-subsumed (cdr T) T^)) 873 | (else (rem-subsumed (cdr T) 874 | (cons (car T) T^)))))))))) 875 | 876 | (define subsumed-T? 877 | (lambda (lit big T) 878 | (cond 879 | ((null? T) #f) 880 | (else 881 | (let ((lit^ (lhs (car T))) 882 | (big^ (rhs (car T)))) 883 | (or 884 | (and (eq? big big^) (member* lit^ lit)) 885 | (subsumed-T? lit big (cdr T)))))))) 886 | 887 | (define LOF 888 | (lambda () 889 | `(,drop-N-b/c-const ,drop-Y-b/c-const ,drop-Y-b/c-dup-var 890 | ,drop-N-b/c-dup-var ,drop-D-b/c-Y-or-N ,drop-T-b/c-Y-and-N 891 | ,move-T-to-D-b/c-t2-atom ,split-t-move-to-d-b/c-pair 892 | ,drop-from-D-b/c-T ,drop-t-b/c-t2-occurs-t1))) 893 | -------------------------------------------------------------------------------- /test-check.scm: -------------------------------------------------------------------------------- 1 | (define-syntax test 2 | (syntax-rules () 3 | ((_ title tested-expression expected-result) 4 | (begin 5 | (printf "Testing ~s\n" title) 6 | (let* ((expected expected-result) 7 | (produced tested-expression)) 8 | (or (equal? expected produced) 9 | (printf "Failed: ~a~%Expected: ~a~%Computed: ~a~%" 10 | 'tested-expression expected produced))))))) 11 | -------------------------------------------------------------------------------- /type-inferencer.scm: -------------------------------------------------------------------------------- 1 | (load "mk.scm") 2 | (load "test-check.scm") 3 | 4 | (define (!-o gamma expr type) 5 | (conde 6 | ((symbolo expr) 7 | (lookupo gamma expr type)) 8 | ((numbero expr) 9 | (== 'int type)) 10 | ((== #f expr) 11 | (== 'bool type)) 12 | ((== #t expr) 13 | (== 'bool type)) 14 | ((fresh (x e T1 T2) 15 | (== `(lambda (,x) ,e) expr) 16 | (== `(,T1 -> ,T2) type) 17 | (symbolo x) 18 | (!-o `((,x : ,T1) . ,gamma) e T2))) 19 | ((fresh (f e e^ t-ignore) 20 | (== `(let ((,f ,e)) ,e^) expr) 21 | (symbolo f) 22 | (!-o `((,f poly ,e ,gamma) . ,gamma) e^ type) 23 | (!-o gamma e t-ignore))) 24 | ((fresh (e1 e2 T) 25 | (== `(,e1 ,e2) expr) 26 | (!-o gamma e1 `(,T -> ,type)) 27 | (!-o gamma e2 T))) 28 | ((fresh (e1 e2) 29 | (== `(+ ,e1 ,e2) expr) 30 | (== 'int type) 31 | (!-o gamma e1 'int) 32 | (!-o gamma e2 'int))) 33 | ((fresh (e1 e2 T1 T2) 34 | (== `(cons ,e1 ,e2) expr) 35 | (== `(pair ,T1 ,T2) type) 36 | (!-o gamma e1 T1) 37 | (!-o gamma e2 T2))) 38 | ((fresh (e1 e2 e3) 39 | (== `(if ,e1 ,e2 ,e3) expr) 40 | (!-o gamma e1 'bool) 41 | (!-o gamma e2 type) 42 | (!-o gamma e3 type))))) 43 | 44 | (define (lookupo gamma x t) 45 | (fresh () 46 | (symbolo x) 47 | (conde 48 | ((fresh (e gamma^ _) 49 | (== `((,x poly ,e ,gamma^) . ,_) gamma) 50 | (!-o gamma^ e t))) 51 | ((fresh (_) 52 | (== `((,x : ,t) . ,_) gamma))) 53 | ((fresh (y _ gamma^) 54 | (== `((,y . ,_) . ,gamma^) gamma) 55 | (=/= x y) 56 | (symbolo y) 57 | (lookupo gamma^ x t)))))) 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | (test "!-1" 69 | (run* (q) (!-o '() '(lambda (y) y) q)) 70 | '((_.0 -> _.0))) 71 | 72 | (test "!-2" 73 | (run* (q) (!-o '() '((lambda (y) y) (lambda (z) z)) q)) 74 | '((_.0 -> _.0))) 75 | 76 | (test "!-3" 77 | (run* (q) (!-o '() '((lambda (y) y) (lambda (z) (lambda (w) (w z)))) q)) 78 | '((_.0 -> ((_.0 -> _.1) -> _.1)))) 79 | 80 | (test "!-4" 81 | (run* (q) (!-o '() '(lambda (y) (y y)) q)) 82 | '()) 83 | 84 | (test "!-5" 85 | (run* (q) (!-o '() '5 q)) 86 | '(int)) 87 | 88 | (test "!-6" 89 | (run* (q) (!-o '() '#t q)) 90 | '(bool)) 91 | 92 | (test "!-10" 93 | (run* (q) (!-o '() '(if #t 3 4) q)) 94 | '(int)) 95 | 96 | (test "!-pair-1" 97 | (run* (q) (!-o '() '(cons 3 #t) q)) 98 | '((pair int bool))) 99 | 100 | (test "!-pair-4" 101 | (run* (q) (!-o '() '(cons (cons #f 6) (cons 3 #t)) q)) 102 | '((pair (pair bool int) (pair int bool)))) 103 | 104 | (test "!-pair-100-let" 105 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (f (cons (f 5) (f #t)))) q)) 106 | '((pair int bool))) 107 | 108 | (test "!-pair-100-lambda" 109 | (run* (q) (!-o '() '((lambda (f) (f (cons (f 5) (f #t)))) (lambda (x) x)) q)) 110 | '()) 111 | 112 | (test "!-12" 113 | (run* (q) (!-o '() '(let ((x 3)) #t) q)) 114 | '(bool)) 115 | 116 | (test "!-13" 117 | (run* (q) (!-o '() '(let ((x 3)) x) q)) 118 | '(int)) 119 | 120 | (test "!-14" 121 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (f 5)) q)) 122 | '(int)) 123 | 124 | (test "!-16" 125 | (run* (q) (!-o '() '(let ((f (lambda (x) (x x)))) 3) q)) 126 | '()) 127 | 128 | (test "!-18" 129 | ;;; test from http://okmij.org/ftp/ML/generalization.html 130 | (run* (q) (!-o '() '(lambda (x) (let ((y (lambda (z) z))) y)) q)) 131 | '((_.0 -> (_.1 -> _.1)))) 132 | 133 | (test "!-15a" 134 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (f 5)) q)) 135 | '(int)) 136 | 137 | (test "!-15b" 138 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (f #t)) q)) 139 | '(bool)) 140 | 141 | (test "!-15c-pair" 142 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (f (cons 5 #t))) q)) 143 | '((pair int bool))) 144 | 145 | (test "!-15d-pair" 146 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (f (f (cons 5 #t)))) q)) 147 | '((pair int bool))) 148 | 149 | (test "!-15h-let" 150 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (f (f 5))) q)) 151 | '(int)) 152 | 153 | (test "!-15h-lambda" 154 | (run* (q) (!-o '() '((lambda (f) (f (f 5))) (lambda (x) x)) q)) 155 | '(int)) 156 | 157 | (test "!-15f" 158 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (if (f 5) (f 6) (f 7))) q)) 159 | '()) 160 | 161 | (test "!-15f2-let" 162 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (if (f #t) (f 6) (f 7))) q)) 163 | '(int)) 164 | 165 | (test "!-15f2-lambda" 166 | (run* (q) (!-o '() '((lambda (f) (if (f #t) (f 6) (f 7))) (lambda (x) x)) q)) 167 | '()) 168 | 169 | (test "!-15f3-let" 170 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (if #t (f 6) (f 7))) q)) 171 | '(int)) 172 | 173 | (test "!-15f3-lambda" 174 | (run* (q) (!-o '() '((lambda (f) (if #t (f 6) (f 7))) (lambda (x) x)) q)) 175 | '(int)) 176 | 177 | (test "!-15g" 178 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (if (f #t) (f 6) (f 7))) q)) 179 | '(int)) 180 | 181 | (test "!-15-pair-let" 182 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) (f (cons (f 5) (f #t)))) q)) 183 | '((pair int bool))) 184 | 185 | (test "!-15-pair-lambda" 186 | (run* (q) (!-o '() '((lambda (f) (f (cons (f 5) (f #t)))) (lambda (x) x)) q)) 187 | '()) 188 | 189 | (test "!-let-env-1" 190 | (run* (q) (!-o '() '(let ((x #t)) (let ((f (lambda (a) a))) (let ((y 7)) (let ((x 5)) (+ (f x) (f y)))))) q)) 191 | '(int)) 192 | 193 | (test "!-let-env-2" 194 | (run* (q) (!-o '() '(let ((x #t)) (let ((f (lambda (a) a))) (let ((y 7)) (+ (f x) (f y))))) q)) 195 | '()) 196 | 197 | (test "!-let-env-3" 198 | (run* (q) (!-o '() '(let ((x 5)) (let ((f (lambda (a) a))) (let ((y 7)) (+ (f x) (f y))))) q)) 199 | '(int)) 200 | 201 | (test "!-let-env-4" 202 | (run* (q) (!-o '() '(let ((x 5)) (let ((f (lambda (a) x))) (let ((y #t)) (+ (f x) (f y))))) q)) 203 | '(int)) 204 | 205 | (test "!-let-env-5" 206 | (run* (q) (!-o '() '(let ((f 5)) (let ((f f)) f)) q)) 207 | '(int)) 208 | 209 | (test "!-let-env-6" 210 | (run* (q) (!-o '() '(let ((x 5)) (let ((f (lambda (x) x))) (f #f))) q)) 211 | '(bool)) 212 | 213 | (test "!-let-env-7a" 214 | (run* (q) (!-o '() '(let ((x 5)) (let ((f (lambda (y) x))) (let ((x #t)) (f x)))) q)) 215 | '(int)) 216 | 217 | (test "!-let-env-7b" 218 | (run* (q) (!-o '() '((lambda (x) (let ((f (lambda (y) x))) (let ((x #t)) (f x)))) 5) q)) 219 | '(int)) 220 | 221 | (test "!-let-env-7c" 222 | (run* (q) (!-o '() '((lambda (x) (let ((f (lambda (y) x))) ((lambda (x) (f x)) #t))) 5) q)) 223 | '(int)) 224 | 225 | (test "!-let-env-7d" 226 | (run* (q) (!-o '() '((lambda (x) ((lambda (f) ((lambda (x) (f x)) #t)) (lambda (y) x))) 5) q)) 227 | '(int)) 228 | 229 | 230 | ;;; Tests from https://github.com/namin/TAPL-in-miniKanren-cKanren-core.logic/blob/master/clojure-tapl/tapl/test/tapl/test/letpoly.clj 231 | (test "!-40" 232 | (run* (q) (!-o '() '(lambda (x) (lambda (y) (x y))) q)) 233 | '(((_.0 -> _.1) -> (_.0 -> _.1)))) 234 | 235 | (test "!-41" 236 | (run* (q) (!-o '() '(lambda (f) (lambda (a) ((lambda (d) f) (f a)))) q)) 237 | '(((_.0 -> _.1) -> (_.0 -> (_.0 -> _.1))))) 238 | 239 | (test "!-42" 240 | (run* (q) (!-o '() '(let ((a (lambda (a) a))) a) q)) 241 | '((_.0 -> _.0))) 242 | 243 | (test "!-43" 244 | (run* (q) (!-o '() '(let ((a (lambda (a) a))) (a a)) q)) 245 | '((_.0 -> _.0))) 246 | 247 | (test "!-44" 248 | (run* (q) (!-o '() '(lambda (a) (let ((b a)) b)) q)) 249 | '((_.0 -> _.0))) 250 | 251 | (test "!-45" 252 | (run* (q) (!-o '() '(lambda (f) (lambda (a) (let ((id (lambda (x) x))) ((lambda (d) (id f)) ((id f) (id a)))))) q)) 253 | '(((_.0 -> _.1) -> (_.0 -> (_.0 -> _.1))))) 254 | 255 | (test "!-46" 256 | (run* (q) (!-o '() '(lambda (f) (lambda (a) (let ((id (lambda (a) a))) ((lambda (d) (id f)) ((id f) (id a)))))) q)) 257 | '(((_.0 -> _.1) -> (_.0 -> (_.0 -> _.1))))) 258 | 259 | (test "!-21" 260 | (run* (q) (!-o '() '(let ((f (lambda (x) x))) f) q)) 261 | '((_.0 -> _.0))) 262 | 263 | (test "!-19" 264 | (run 1 (q) (fresh (lam) (== `(let ((f ,lam)) (f (f 5))) q)) (!-o '() q 'int)) 265 | '(((let ((f (lambda (_.0) _.1))) (f (f 5))) (num _.1) (sym _.0)))) 266 | 267 | (test "!-20" 268 | (run 1 (q) (fresh (lam) (== `(let ((f ,lam)) (if (f #t) (f 6) (f 7))) q)) (!-o '() q 'int)) 269 | '(((let ((f (lambda (_.0) _.0))) (if (f #t) (f 6) (f 7))) (sym _.0)))) 270 | 271 | (test "!-23" 272 | ;;; self-application via let polymorphism. I guess that's a thing??? 273 | (run* (q) 274 | (!-o '() '(let ((f (lambda (x) 5))) (f f)) q)) 275 | '(int)) 276 | 277 | (test "!-23b" 278 | ;;; self-application without let poly doesn't type check! 279 | (run* (q) 280 | (!-o '() '((lambda (f) (f f)) (lambda (x) 5)) q)) 281 | '()) 282 | 283 | (test "!-23c" 284 | (run* (q) 285 | (!-o '() '((lambda (x) (x x)) (lambda (x) (x x))) q)) 286 | '()) 287 | 288 | (test "!-23d" 289 | ;;; self-application via let polymorphism. I guess that's a thing??? 290 | (run* (q) 291 | (!-o '() '(let ((f (lambda (x) x))) (f f)) q)) 292 | '((_.0 -> _.0))) 293 | 294 | (test "!-23e" 295 | ;;; self-application without let poly doesn't type check! 296 | (run* (q) 297 | (!-o '() '((lambda (f) (f f)) (lambda (x) x)) q)) 298 | '()) 299 | 300 | (test "!-23f" 301 | ;;; omega still doesn't typecheck 302 | (run* (q) 303 | (!-o '() '(let ((f (lambda (x) (x x)))) (f f)) q)) 304 | '()) 305 | 306 | (test "!-23g" 307 | (run* (q) 308 | (!-o '() '((lambda (x) (x x)) (lambda (x) (x x))) q)) 309 | '()) 310 | 311 | (test "!-23h" 312 | (run* (q) 313 | (!-o '() '(let ((f (lambda (x) (x 5)))) (f f)) q)) 314 | '()) 315 | 316 | 317 | (test "!-29" 318 | (run* (q) 319 | (!-o '() 320 | '(let ((f0 (lambda (x) x))) 321 | 5) 322 | q)) 323 | '(int)) 324 | 325 | (test "!-30" 326 | (run* (q) 327 | (!-o '() 328 | '(let ((f0 (lambda (x) x))) 329 | (let ((f1 (lambda (y) y))) 330 | 5)) 331 | q)) 332 | '(int)) 333 | 334 | (test "!-31" 335 | (run* (q) 336 | (!-o '() 337 | '(let ((f0 (lambda (x) x))) 338 | (let ((f1 (lambda (y) y))) 339 | (f1 5))) 340 | q)) 341 | '(int)) 342 | 343 | (test "!-37" 344 | (run* (q) 345 | (!-o '() 346 | '(let ((f0 (lambda (x) x))) 347 | (let ((f1 (lambda (y) y))) 348 | f1)) 349 | q)) 350 | '((_.0 -> _.0))) 351 | 352 | (test "!-36" 353 | (run* (q) 354 | (!-o '() 355 | '(let ((f0 (lambda (x) x))) 356 | (let ((f1 (lambda (y) y))) 357 | f0)) 358 | q)) 359 | '((_.0 -> _.0))) 360 | 361 | (test "!-32" 362 | (run* (q) 363 | (!-o '() 364 | '(let ((f0 (lambda (x) x))) 365 | (let ((f1 (lambda (y) y))) 366 | (f0 5))) 367 | q)) 368 | '(int)) 369 | 370 | (test "!-33" 371 | (run* (q) 372 | (!-o '() 373 | '(let ((f0 (lambda (x) x))) 374 | (let ((f1 (lambda (y) y))) 375 | (f0 (f1 5)))) 376 | q)) 377 | '(int)) 378 | 379 | (test "!-34" 380 | (run* (q) 381 | (!-o '() 382 | '(let ((f0 (lambda (x) x))) 383 | (let ((f1 (lambda (y) y))) 384 | (f0 (f0 (f1 (f1 (f0 (f1 (f0 5))))))))) 385 | q)) 386 | '(int)) 387 | 388 | (test "!-28" 389 | (run* (q) 390 | (!-o '() 391 | '(let ((f0 (lambda (x) x))) 392 | (let ((f1 (lambda (y) f0))) 393 | 5)) 394 | q)) 395 | '(int)) 396 | 397 | (test "!-27" 398 | (run* (q) 399 | (!-o '() 400 | '(let ((f0 (lambda (x) x))) 401 | (let ((f1 (lambda (y) (f0 y)))) 402 | 5)) 403 | q)) 404 | '(int)) 405 | 406 | (test "!-26" 407 | (run* (q) 408 | (!-o '() 409 | '(let ((f0 (lambda (x) x))) 410 | (let ((f1 (lambda (y) (f0 (f0 y))))) 411 | 5)) 412 | q)) 413 | '(int)) 414 | 415 | (test "!-25" 416 | (run* (q) 417 | (!-o '() 418 | '(let ((f0 (lambda (x) x))) 419 | (let ((f1 (lambda (y) (f0 (f0 y))))) 420 | f1)) 421 | q)) 422 | '((_.0 -> _.0))) 423 | 424 | (test "!-25a" 425 | (run 1 (q) 426 | (fresh (lam) 427 | (== `(let ((f ,lam)) (f (cons (f 5) (f #t)))) q) 428 | (!-o '() q '(pair int bool)))) 429 | '(((let ((f (lambda (_.0) _.0))) (f (cons (f 5) (f #t)))) (sym _.0)))) 430 | 431 | (test "!-25b" 432 | (run 10 (q) 433 | (fresh (lam) 434 | (== `(let ((f ,lam)) (f (cons (f 5) (f #t)))) q) 435 | (!-o '() q '(pair int bool)))) 436 | '(((let ((f (lambda (_.0) _.0))) (f (cons (f 5) (f #t)))) 437 | (sym _.0)) 438 | ((let ((f (lambda (_.0) (cons _.1 #f)))) 439 | (f (cons (f 5) (f #t)))) 440 | (num _.1) (sym _.0)) 441 | ((let ((f (lambda (_.0) (let ((_.1 _.2)) _.0)))) 442 | (f (cons (f 5) (f #t)))) 443 | (=/= ((_.0 _.1))) (num _.2) (sym _.0 _.1)) 444 | ((let ((f (lambda (_.0) (let ((_.1 #f)) _.0)))) 445 | (f (cons (f 5) (f #t)))) 446 | (=/= ((_.0 _.1))) (sym _.0 _.1)) 447 | ((let ((f (lambda (_.0) (cons _.1 #t)))) 448 | (f (cons (f 5) (f #t)))) 449 | (num _.1) (sym _.0)) 450 | ((let ((f (lambda (_.0) (let ((_.1 #t)) _.0)))) 451 | (f (cons (f 5) (f #t)))) 452 | (=/= ((_.0 _.1))) (sym _.0 _.1)) 453 | ((let ((f (let ((_.0 _.1)) (lambda (_.2) _.2)))) 454 | (f (cons (f 5) (f #t)))) 455 | (num _.1) (sym _.0 _.2)) 456 | ((let ((f (let ((_.0 #f)) (lambda (_.1) _.1)))) 457 | (f (cons (f 5) (f #t)))) 458 | (sym _.0 _.1)) 459 | ((let ((f (let ((_.0 #t)) (lambda (_.1) _.1)))) 460 | (f (cons (f 5) (f #t)))) 461 | (sym _.0 _.1)) 462 | ((let ((f (lambda (_.0) (let ((_.1 _.0)) _.0)))) 463 | (f (cons (f 5) (f #t)))) 464 | (=/= ((_.0 _.1))) (sym _.0 _.1)))) 465 | 466 | (test "!-30a" 467 | (run* (q) 468 | (!-o '() '(let ((f0 (lambda (x) (cons x x)))) 469 | (f0 (lambda (z) z))) q)) 470 | '((pair (_.0 -> _.0) (_.0 -> _.0)))) 471 | 472 | (test "!-30b" 473 | (run* (q) 474 | (!-o '() 475 | '(let ((f0 (lambda (x) (cons x x)))) 476 | (let ((f1 (lambda (y) (f0 (f0 y))))) 477 | (f1 (lambda (z) z)))) 478 | q)) 479 | '((pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))) 480 | 481 | (test "!-30c" 482 | (run* (q) 483 | (!-o '() 484 | '(let ((f0 (lambda (x) (cons x x)))) 485 | (let ((f1 (lambda (y) (f0 (f0 y))))) 486 | (let ((f2 (lambda (y) (f1 (f1 y))))) 487 | (f2 (lambda (z) z))))) 488 | q)) 489 | '((pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))))) 490 | 491 | (test "!-30d" 492 | (run* (q) 493 | (!-o '() 494 | '(let ((f0 (lambda (x) (cons x x)))) 495 | (let ((f1 (lambda (y) (f0 (f0 y))))) 496 | (let ((f2 (lambda (y) (f1 (f1 y))))) 497 | (let ((f3 (lambda (y) (f2 (f2 y))))) 498 | (f3 (lambda (z) z)))))) 499 | q)) 500 | '((pair (pair (pair (pair (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))) (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))))) (pair (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))) (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))))) (pair (pair (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))) (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))))) (pair (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))) (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))))))) (pair (pair (pair (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))) (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))))) (pair (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))) (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))))) (pair (pair (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))) (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))))) (pair (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))) (pair (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0)))) (pair (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))) (pair (pair (_.0 -> _.0) (_.0 -> _.0)) (pair (_.0 -> _.0) (_.0 -> _.0))))))))))) 501 | 502 | ;;; This test returns after several minutes, producing an absurdly gigantic type! 503 | #| 504 | (test "!-30e" 505 | (run* (q) 506 | (!-o '() 507 | '(let ((f0 (lambda (x) (cons x x)))) 508 | (let ((f1 (lambda (y) (f0 (f0 y))))) 509 | (let ((f2 (lambda (y) (f1 (f1 y))))) 510 | (let ((f3 (lambda (y) (f2 (f2 y))))) 511 | (let ((f4 (lambda (y) (f3 (f3 y))))) 512 | (f4 (lambda (z) z))))))) 513 | q)) 514 | '???) 515 | |# 516 | 517 | (test "!-24a" 518 | (run* (q) 519 | (!-o '() '(let ((f0 (lambda (x) x))) 520 | (f0 (lambda (z) z))) q)) 521 | '((_.0 -> _.0))) 522 | 523 | (test "!-24b" 524 | (run* (q) 525 | (!-o '() 526 | '(let ((f0 (lambda (x) x))) 527 | (let ((f1 (lambda (y) (f0 (f0 y))))) 528 | (f1 (lambda (z) z)))) 529 | q)) 530 | '((_.0 -> _.0))) 531 | 532 | (test "!-24c" 533 | (run* (q) 534 | (!-o '() 535 | '(let ((f0 (lambda (x) x))) 536 | (let ((f1 (lambda (y) (f0 (f0 y))))) 537 | (let ((f2 (lambda (y) (f1 (f1 y))))) 538 | (f2 (lambda (z) z))))) 539 | q)) 540 | '((_.0 -> _.0))) 541 | 542 | (test "!-24d" 543 | (run* (q) 544 | (!-o '() 545 | '(let ((f0 (lambda (x) x))) 546 | (let ((f1 (lambda (y) (f0 (f0 y))))) 547 | (let ((f2 (lambda (y) (f1 (f1 y))))) 548 | (let ((f3 (lambda (y) (f2 (f2 y))))) 549 | (f3 (lambda (z) z)))))) 550 | q)) 551 | '((_.0 -> _.0))) 552 | 553 | #!eof 554 | 555 | ;; these tests take too long to terminate! 556 | 557 | (test "!-24e" 558 | (run* (q) 559 | (!-o '() 560 | '(let ((f0 (lambda (x) x))) 561 | (let ((f1 (lambda (y) (f0 (f0 y))))) 562 | (let ((f2 (lambda (y) (f1 (f1 y))))) 563 | (let ((f3 (lambda (y) (f2 (f2 y))))) 564 | (let ((f4 (lambda (y) (f3 (f3 y))))) 565 | (f4 (lambda (z) z))))))) 566 | q)) 567 | '((_.0 -> _.0))) 568 | 569 | (test "!-24f" 570 | (run* (q) 571 | (!-o '() 572 | '(let ((f0 (lambda (x) x))) 573 | (let ((f1 (lambda (y) (f0 (f0 y))))) 574 | (let ((f2 (lambda (y) (f1 (f1 y))))) 575 | (let ((f3 (lambda (y) (f2 (f2 y))))) 576 | (let ((f4 (lambda (y) (f3 (f3 y))))) 577 | (let ((f5 (lambda (y) (f4 (f4 y))))) 578 | (f5 (lambda (z) z)))))))) 579 | q)) 580 | '((_.0 -> _.0))) 581 | --------------------------------------------------------------------------------