syndicate-lang
/
racket-matrix-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Leave Racket's objects opaque to unification.

This commit is contained in:
Tony Garnock-Jones 2012-05-09 13:44:11 -04:00
parent 8f10b2ad4d
commit 7395f9b1fa
1 changed files with 16 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
unify.rkt
View File

@ -2,6 +2,7 @@
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
(require (only-in racket/class object?))
(require "struct-map.rkt") (require "struct-map.rkt")
(provide (struct-out variable) (provide (struct-out variable)
@ -57,6 +58,13 @@
(define (non-wild? x) (define (non-wild? x)
(not (wild? x))) (not (wild? x)))
;; Any -> Boolean
;; Racket objects are structures, so we reject them explicitly for
;; now, leaving them opaque to unification.
(define (non-object-struct? x)
(and (struct? x)
(not (object? x))))
;; Any -> Set<Variable> ;; Any -> Set<Variable>
(define (variables-in x) (define (variables-in x)
(let walk ((x x) (acc (set))) (let walk ((x x) (acc (set)))
@ -64,7 +72,7 @@
[(variable? x) (set-add acc x)] [(variable? x) (set-add acc x)]
[(pair? x) (walk (car x) (walk (cdr x) acc))] [(pair? x) (walk (car x) (walk (cdr x) acc))]
[(vector? x) (foldl walk acc (vector->list x))] [(vector? x) (foldl walk acc (vector->list x))]
[(struct? x) (walk (struct->vector x #f) acc)] [(non-object-struct? x) (walk (struct->vector x #f) acc)]
[else acc]))) [else acc])))
;; Variable Any -> Boolean ;; Variable Any -> Boolean
@ -74,7 +82,7 @@
[(eq? var x) #t] [(eq? var x) #t]
[(pair? x) (or (walk (car x)) (walk (cdr x)))] [(pair? x) (or (walk (car x)) (walk (cdr x)))]
[(vector? x) (ormap walk (vector->list x))] [(vector? x) (ormap walk (vector->list x))]
[(struct? x) (walk (struct->vector x #f))] [(non-object-struct? x) (walk (struct->vector x #f))]
[else #f]))) [else #f])))
;; Variable Any Subst -> Subst ;; Variable Any Subst -> Subst
@ -115,7 +123,7 @@
(walk (car a) (car b) (walk (cdr a) (cdr b) env))] (walk (car a) (car b) (walk (cdr a) (cdr b) env))]
[(and (vector? a) (vector? b) (= (vector-length a) (vector-length b))) [(and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
(for/fold ([env env]) ([ea a] [eb b]) (walk ea eb env))] (for/fold ([env env]) ([ea a] [eb b]) (walk ea eb env))]
[(and (struct? a) (struct? b)) [(and (non-object-struct? a) (non-object-struct? b))
(walk (struct->vector a #f) (struct->vector b #f) env)] (walk (struct->vector a #f) (struct->vector b #f) env)]
[else (and (equal? a b) env)]))))) [else (and (equal? a b) env)])))))
@ -138,7 +146,7 @@
(define-values (val env1) (walk (vector-ref x i) env)) (define-values (val env1) (walk (vector-ref x i) env))
(vector-set! result i val) (vector-set! result i val)
env1))] env1))]
[(struct? x) (struct-map/accumulator walk env x)] [(non-object-struct? x) (struct-map/accumulator walk env x)]
[else (values x env)]))) [else (values x env)])))
;; Any -> Any ;; Any -> Any
@ -151,7 +159,7 @@
[else (define v (canonical-variable (hash-count env))) (hash-set! env t v) v])] [else (define v (canonical-variable (hash-count env))) (hash-set! env t v) v])]
[(pair? t) (cons (walk (car t)) (walk (cdr t)))] [(pair? t) (cons (walk (car t)) (walk (cdr t)))]
[(vector? t) (list->vector (map walk (vector->list t)))] [(vector? t) (list->vector (map walk (vector->list t)))]
[(struct? t) (struct-map walk t)] [(non-object-struct? t) (struct-map walk t)]
[else t]))) [else t])))
;; Any -> Boolean ;; Any -> Boolean
@ -197,7 +205,7 @@
v])] v])]
[(pair? t) (cons (walk (car t)) (walk (cdr t)))] [(pair? t) (cons (walk (car t)) (walk (cdr t)))]
[(vector? t) (list->vector (map walk (vector->list t)))] [(vector? t) (list->vector (map walk (vector->list t)))]
[(struct? t) (struct-map walk t)] [(non-object-struct? t) (struct-map walk t)]
[else t]))) [else t])))
;; Any -> Any ;; Any -> Any
@ -251,7 +259,7 @@
(cond (cond
[(pair? x) (cons (walk (car x)) (walk (cdr x)))] [(pair? x) (cons (walk (car x)) (walk (cdr x)))]
[(vector? x) (list->vector (map walk (vector->list x)))] [(vector? x) (list->vector (map walk (vector->list x)))]
[(struct? x) (struct-map walk x)] [(non-object-struct? x) (struct-map walk x)]
[else x]))) [else x])))
;; True iff a is a specialization (or instance) of b. ;; True iff a is a specialization (or instance) of b.
@ -264,7 +272,7 @@
(and (walk (car a) (car b)) (walk (cdr a) (cdr b)))] (and (walk (car a) (car b)) (walk (cdr a) (cdr b)))]
[(and (vector? a) (vector? b) (= (vector-length a) (vector-length b))) [(and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
(for/and ([aa a] [bb b]) (walk aa bb))] (for/and ([aa a] [bb b]) (walk aa bb))]
[(and (struct? a) (struct? b)) [(and (non-object-struct? a) (non-object-struct? b))
(walk (struct->vector a #f) (struct->vector b #f))] (walk (struct->vector a #f) (struct->vector b #f))]
[else (equal? a b)]))) [else (equal? a b)])))