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)
(define srcloc/c
(or/c syntax?
false/c
(or/c #f
(list/c any/c
(or/c exact-positive-integer? #f)
(or/c exact-nonnegative-integer? #f)

17
collects/datalog/serialize.rkt
View File

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

42
collects/datalog/stx.rkt
View File

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

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

@ -1,9 +1,16 @@
#lang racket
(require rackunit
datalog/ast)
datalog/ast
racket/runtime-path)
(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
(test-suite
"ast"
@ -20,49 +27,49 @@
(test-suite
"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 #'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 #'sym2 'sym2))))
(test-false "var/var" (variable-equal? (make-variable #f 'sym1) (make-variable sym2-srcloc 'sym2))))
(test-suite
"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 #'sym1 'sym1)))
(test-false "sym/sym" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym2)))
(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-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 #'sym1 "sym1")))
(test-false "str/str" (constant-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym2")))
(test-false "sym/str" (constant-equal? (make-constant #f 'sym1) (make-constant #'sym1 "sym2")))
(test-false "str/sym" (constant-equal? (make-constant #'sym1 "sym2") (make-constant #f '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-srcloc "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-srcloc "sym2") (make-constant #f 'sym1))))
(test-suite
"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 #'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 #'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 #'sym1 'sym1)))
(test-false "sym/sym" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 'sym2)))
(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-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 #'sym1 "sym1")))
(test-false "str/str" (term-equal? (make-constant #f "sym1") (make-constant #'sym1 "sym2")))
(test-false "sym/str" (term-equal? (make-constant #f 'sym1) (make-constant #'sym1 "sym2")))
(test-false "str/sym" (term-equal? (make-constant #'sym1 "sym2") (make-constant #f 'sym1)))
(test-false "con/var" (term-equal? (make-constant #'sym1 "sym2") (make-variable #f 'sym1)))
(test-false "var/con" (term-equal? (make-variable #f 'sym1) (make-constant #'sym1 "sym2"))))
(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-srcloc "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-srcloc "sym2") (make-constant #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-srcloc "sym2"))))
(test-suite
"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)))
(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)))
(make-literal #'lit1 'lit1 (list (make-variable #'sym1 '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 (list (make-variable #f 'sym1))) (make-literal #'lit1 'lit2 empty)))
(make-literal lit1-srcloc 'lit1 (list (make-variable sym1-srcloc 'sym1)))))
(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-srcloc 'lit2 empty)))
(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
"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)))
(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)
(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)
(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)))