suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust datalog so that syntax objects are not used as source location

Browse Source 
information representation.

This should make datalog work better with compiled files and it
should also avoid an O(n^2) problem in the way it expands
This commit is contained in:
Robby Findler 2012-06-02 08:01:42 -05:00
parent d8a26e6c3c
commit 058504afbd
4 changed files with 64 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/datalog/ast.rkt
View File

@ -3,8 +3,7 @@
racket/match) racket/match)
(define srcloc/c (define srcloc/c
(or/c syntax? (or/c #f
false/c
(list/c any/c (list/c any/c
(or/c exact-positive-integer? #f) (or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f) (or/c exact-nonnegative-integer? #f)

17
collects/datalog/serialize.rkt
View File

@ -2,26 +2,27 @@
(require racket/contract (require racket/contract
racket/match racket/match
racket/list racket/list
"runtime.rkt") "runtime.rkt"
"ast.rkt")
(define remove-stx-objs (define remove-paths
(match-lambda (match-lambda
[(? hash? ht) [(? hash? ht)
(for/hash ([(k v) (in-hash ht)]) (for/hash ([(k v) (in-hash ht)])
(values k (remove-stx-objs v)))] (values k (remove-paths v)))]
[(? cons? c) [(? cons? c)
(cons (remove-stx-objs (car c)) (cons (remove-paths (car c))
(remove-stx-objs (cdr c)))] (remove-paths (cdr c)))]
[(? prefab-struct-key s) [(? prefab-struct-key s)
(apply make-prefab-struct (apply make-prefab-struct
(prefab-struct-key s) (prefab-struct-key s)
(remove-stx-objs (rest (vector->list (struct->vector s)))))] (remove-paths (rest (vector->list (struct->vector s)))))]
[(? syntax? s) [(? path? s)
#f] #f]
[x x])) [x x]))
(define (write-theory t) (define (write-theory t)
(write (remove-stx-objs t))) (write (remove-paths t)))
(define (hash->hash! ht) (define (hash->hash! ht)
(define ht! (make-hash)) (define ht! (make-hash))

42
collects/datalog/stx.rkt
View File

@ -65,13 +65,13 @@
#:literals (! ~ ?) #:literals (! ~ ?)
[(_ (~and tstx (! c))) [(_ (~and tstx (! c)))
(quasisyntax/loc #'tstx (quasisyntax/loc #'tstx
(assertion #'#,(unoriginal #'tstx) (datalog-clause c)))] (assertion #,(srcloc-list #'tstx) (datalog-clause c)))]
[(_ (~and tstx (~ c))) [(_ (~and tstx (~ c)))
(quasisyntax/loc #'tstx (quasisyntax/loc #'tstx
(retraction #'#,(unoriginal #'tstx) (datalog-clause c)))] (retraction #,(srcloc-list #'tstx) (datalog-clause c)))]
[(_ (~and tstx (? l))) [(_ (~and tstx (? l)))
(quasisyntax/loc #'tstx (quasisyntax/loc #'tstx
(query #'#,(unoriginal #'tstx) (datalog-literal/ref l)))])) (query #,(srcloc-list #'tstx) (datalog-literal/ref l)))]))
(define-syntax (datalog-stmt-var-selector stx) (define-syntax (datalog-stmt-var-selector stx)
(syntax-parse (syntax-parse
@ -130,11 +130,11 @@
(syntax-local-lift-expression (syntax-local-lift-expression
fake-lam)) fake-lam))
(quasisyntax/loc #'tstx (quasisyntax/loc #'tstx
(clause #'#,(unoriginal #'tstx) (datalog-literal/bind head) (clause #,(srcloc-list #'tstx) (datalog-literal/bind head)
(list (datalog-literal/ref body) ...)))] (list (datalog-literal/ref body) ...)))]
[(_ e) [(_ e)
(quasisyntax/loc #'e (quasisyntax/loc #'e
(clause #'#,(unoriginal #'e) (datalog-literal/bind e) empty))])) (clause #,(srcloc-list #'e) (datalog-literal/bind e) empty))]))
(define-syntax (datalog-literal/bind stx) (datalog-literal/b stx #t)) (define-syntax (datalog-literal/bind stx) (datalog-literal/b stx #t))
(define-syntax (datalog-literal/ref stx) (datalog-literal/b stx #f)) (define-syntax (datalog-literal/ref stx) (datalog-literal/b stx #f))
@ -146,18 +146,18 @@
[(_ sym:id) [(_ sym:id)
(syntax-property (syntax-property
(quasisyntax/loc #'sym (quasisyntax/loc #'sym
(literal #'#,(unoriginal #'sym) 'sym empty)) (literal #,(srcloc-list #'sym) 'sym empty))
(if binding? 'disappeared-binding 'disappeared-use) (if binding? 'disappeared-binding 'disappeared-use)
(syntax-local-introduce #'sym))] (syntax-local-introduce #'sym))]
[(_ (~and tstx (sym:id arg ... :- ans ...))) [(_ (~and tstx (sym:id arg ... :- ans ...)))
(quasisyntax/loc #'tstx (quasisyntax/loc #'tstx
(external #'#,(unoriginal #'tstx) 'sym sym (external #,(srcloc-list #'tstx) 'sym sym
(list (datalog-term arg) ...) (list (datalog-term arg) ...)
(list (datalog-term ans) ...)))] (list (datalog-term ans) ...)))]
[(_ (~and tstx (sym:id e ...))) [(_ (~and tstx (sym:id e ...)))
(syntax-property (syntax-property
(quasisyntax/loc #'tstx (quasisyntax/loc #'tstx
(literal #'#,(unoriginal #'tstx) 'sym (literal #,(srcloc-list #'tstx) 'sym
(list (datalog-term e) (list (datalog-term e)
...))) ...)))
(if binding? 'disappeared-binding 'disappeared-use) (if binding? 'disappeared-binding 'disappeared-use)
@ -198,26 +198,26 @@
(cond (cond
[(identifier-binding #'sym 0) [(identifier-binding #'sym 0)
(quasisyntax/loc #'sym (quasisyntax/loc #'sym
(constant #'#,(unoriginal #'sym) sym))] (constant #,(srcloc-list #'sym) sym))]
[(char-upper-case? (string-ref (symbol->string (syntax->datum #'sym)) 0)) [(char-upper-case? (string-ref (symbol->string (syntax->datum #'sym)) 0))
(quasisyntax/loc #'sym (quasisyntax/loc #'sym
(variable #'#,(unoriginal #'sym) 'sym))] (variable #,(srcloc-list #'sym) 'sym))]
[else [else
(quasisyntax/loc #'sym (quasisyntax/loc #'sym
(constant #'#,(unoriginal #'sym) 'sym))])] (constant #,(srcloc-list #'sym) 'sym))])]
[(_ sym:expr) [(_ sym:expr)
(quasisyntax/loc #'sym (quasisyntax/loc #'sym
(constant #'#,(unoriginal #'sym) sym))])) (constant #,(srcloc-list #'sym) sym))]))
(define-for-syntax (unoriginal stx) (define-for-syntax (srcloc-list stx)
(let loop ([stx stx]) (define src (syntax-source stx))
(cond `(list ,(if (path? src)
[(syntax? stx) `(bytes->path ,(path->bytes src))
(datum->syntax stx (loop (syntax-e stx)) stx)] `',src)
[(pair? stx) ',(syntax-line stx)
(cons (loop (car stx)) ',(syntax-column stx)
(loop (cdr stx)))] ',(syntax-position stx)
[else stx]))) ',(syntax-span stx)))
(provide datalog datalog! (provide datalog datalog!
:- ! ~ ?) :- ! ~ ?)

59
collects/tests/datalog/ast.rkt
View File

@ -1,9 +1,16 @@
#lang racket #lang racket
(require rackunit (require rackunit
datalog/ast) datalog/ast
racket/runtime-path)
(provide ast-tests) (provide ast-tests)
(define-runtime-path ast.rkt "ast.rkt")
(define sym1-srcloc (list ast.rkt 1 1 10 3))
(define sym2-srcloc (list #f #f #f #f #f))
(define lit1-srcloc (list ast.rkt #f #f 3000 3))
(define cl1-srcloc sym2-srcloc)
(define ast-tests (define ast-tests
(test-suite (test-suite
"ast" "ast"
@ -20,49 +27,49 @@
(test-suite (test-suite
"variable-equal?" "variable-equal?"
(test-not-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #f 'sym1))) (test-not-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #f 'sym1)))
(test-not-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #'sym1 'sym1))) (test-not-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable sym1-srcloc 'sym1)))
(test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #f 'sym2))) (test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #f 'sym2)))
(test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable #'sym2 'sym2)))) (test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable sym2-srcloc 'sym2))))
(test-suite (test-suite
"constant-equal?" "constant-equal?"
(test-not-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #f 'sym1))) (test-not-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #f 'sym1)))
(test-not-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym1))) (test-not-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc 'sym1)))
(test-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym2))) (test-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc 'sym2)))
(test-not-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #f "sym1"))) (test-not-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #f "sym1")))
(test-not-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym1"))) (test-not-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant sym1-srcloc "sym1")))
(test-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym2"))) (test-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant sym1-srcloc "sym2")))
(test-false "sym/str" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 "sym2"))) (test-false "sym/str" (constant-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc "sym2")))
(test-false "str/sym" (constant-equal? (make-constant #'sym1 "sym2") (make-constant #f 'sym1)))) (test-false "str/sym" (constant-equal? (make-constant sym1-srcloc "sym2") (make-constant #f 'sym1))))
(test-suite (test-suite
"term-equal?" "term-equal?"
(test-not-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #f 'sym1))) (test-not-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #f 'sym1)))
(test-not-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #'sym1 'sym1))) (test-not-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable sym1-srcloc 'sym1)))
(test-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #f 'sym2))) (test-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #f 'sym2)))
(test-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable #'sym2 'sym2))) (test-false "var/var" (term-equal? (make-variable #f 'sym1) (make-variable sym2-srcloc 'sym2)))
(test-not-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #f 'sym1))) (test-not-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #f 'sym1)))
(test-not-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym1))) (test-not-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc 'sym1)))
(test-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym2))) (test-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc 'sym2)))
(test-not-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #f "sym1"))) (test-not-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #f "sym1")))
(test-not-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym1"))) (test-not-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant sym1-srcloc "sym1")))
(test-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym2"))) (test-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant sym1-srcloc "sym2")))
(test-false "sym/str" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 "sym2"))) (test-false "sym/str" (term-equal? (make-constant #f 'sym1) (make-constant sym1-srcloc "sym2")))
(test-false "str/sym" (term-equal? (make-constant #'sym1 "sym2") (make-constant #f 'sym1))) (test-false "str/sym" (term-equal? (make-constant sym1-srcloc "sym2") (make-constant #f 'sym1)))
(test-false "con/var" (term-equal? (make-constant #'sym1 "sym2") (make-variable #f 'sym1))) (test-false "con/var" (term-equal? (make-constant sym1-srcloc "sym2") (make-variable #f 'sym1)))
(test-false "var/con" (term-equal? (make-variable #f 'sym1) (make-constant #'sym1 "sym2")))) (test-false "var/con" (term-equal? (make-variable #f 'sym1) (make-constant sym1-srcloc "sym2"))))
(test-suite (test-suite
"literal-equal?" "literal-equal?"
(test-not-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal #'lit1 'lit1 empty))) (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal lit1-srcloc 'lit1 empty)))
(test-not-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1)))
(make-literal #'lit1 'lit1 (list (make-variable #f 'sym1))))) (make-literal lit1-srcloc 'lit1 (list (make-variable #f 'sym1)))))
(test-not-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) (test-not-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1)))
(make-literal #'lit1 'lit1 (list (make-variable #'sym1 'sym1))))) (make-literal lit1-srcloc 'lit1 (list (make-variable sym1-srcloc 'sym1)))))
(test-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal #'lit1 'lit2 empty))) (test-false "lit" (literal-equal? (make-literal #f 'lit1 empty) (make-literal lit1-srcloc 'lit2 empty)))
(test-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) (make-literal #'lit1 'lit2 empty))) (test-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) (make-literal lit1-srcloc 'lit2 empty)))
(test-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1))) (test-false "lit" (literal-equal? (make-literal #f 'lit1 (list (make-variable #f 'sym1)))
(make-literal #'lit1 'lit2 (list (make-variable #'sym1 'sym2)))))) (make-literal lit1-srcloc 'lit2 (list (make-variable sym1-srcloc 'sym2))))))
(test-suite (test-suite
"clause-equal?" "clause-equal?"
@ -71,7 +78,7 @@
(test-not-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty))) (test-not-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty)))
(make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty))))) (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty)))))
(test-not-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) empty) (test-not-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) empty)
(make-clause #'cl1 (make-literal #f 'lit1 empty) empty))) (make-clause cl1-srcloc (make-literal #f 'lit1 empty) empty)))
(test-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) empty) (test-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) empty)
(make-clause #f (make-literal #f 'lit2 empty) empty))) (make-clause #f (make-literal #f 'lit2 empty) empty)))
(test-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty))) (test-false "lit" (clause-equal? (make-clause #f (make-literal #f 'lit1 empty) (list (make-literal #f 'lit1 empty)))