diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index 67a6e72..a3e1dfd 100644 --- a/collects/datalog/lang/reader.rkt +++ b/collects/datalog/lang/reader.rkt @@ -1,31 +1,31 @@ (module reader syntax/module-reader - #:language 'datalog/lang/lang - #:read - (lambda ([in (current-input-port)]) - (this-read-syntax #f in)) + #:language 'datalog/sexp/lang + #:read (lambda ([in (current-input-port)]) (this-read-syntax #f in)) #:read-syntax this-read-syntax #:whole-body-readers? #t #:info (lambda (key defval default) ; XXX Should have different comment character key (case key [(drracket:submit-predicate) - repl-submit?] + (dynamic-require 'datalog/tool/submit 'repl-submit?)] [(color-lexer) - (dynamic-require `datalog/tool/syntax-color 'get-syntax-token)] + (dynamic-require 'datalog/tool/syntax-color 'get-syntax-token)] [else (default key defval)])) (require datalog/parse - datalog/tool/submit) + datalog/private/compiler) (define (this-read-syntax [src #f] [in (current-input-port)]) - (parameterize ([current-source-name src]) - (let ([ast (parse-program in)]) - (list `(#%module-begin ,@ast))))) + (list + (compile-program + (parameterize ([current-source-name src]) + (parse-program in))))) ; XXX This is almost certainly wrong. (define (even-read src ip) (begin0 - (parameterize ([current-source-name src]) - (datum->syntax #f (parse-statement ip))) + (compile-statement + (parameterize ([current-source-name src]) + (parse-statement ip))) (current-read-interaction odd-read))) (define (odd-read src ip) (current-read-interaction even-read) diff --git a/collects/datalog/private/compiler.rkt b/collects/datalog/private/compiler.rkt index 86fee23..1b61368 100644 --- a/collects/datalog/private/compiler.rkt +++ b/collects/datalog/private/compiler.rkt @@ -1,20 +1,58 @@ #lang racket/base (require racket/contract - "../ast.rkt" - (for-syntax racket/base)) -(require (for-template racket/base - "../eval.rkt")) - -(define (compile-module asts) - (with-syntax ([(s ...) asts]) - (syntax - (begin (eval-statement s) ...)))) - -(define (compile-stmt ast) - (with-syntax ([s ast]) - (syntax - (eval-statement s)))) + racket/match + datalog/ast + (only-in datalog/sexp/lang + ? :- ! ~)) +(require (for-template datalog/sexp/lang)) (provide/contract - [compile-module (list? . -> . syntax?)] - [compile-stmt (statement/c . -> . syntax?)]) \ No newline at end of file + [compile-program (program/c . -> . syntax?)] + [compile-statement (statement/c . -> . syntax?)]) + +(define (compile-program p) + (quasisyntax + (#%module-begin #,@(map compile-statement p)))) + +(define compile-statement + (match-lambda + [(assertion srcloc c) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (! #,(compile-clause c)))] + [(retraction srcloc c) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (~ #,(compile-clause c)))] + [(query srcloc l) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (? #,(compile-literal l)))])) + +(define compile-clause + (match-lambda + [(clause srcloc head (list)) + (define srcstx (datum->syntax #f 'x srcloc)) + (compile-literal head)] + [(clause srcloc head body) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (:- #,@(map compile-literal (list* head body))))])) + +(define compile-literal + (match-lambda + [(literal srcloc '= (and ts (app length 2))) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (= #,@(map compile-term ts)))] + [(literal srcloc pred ts) + (define srcstx (datum->syntax #f 'x srcloc)) + (quasisyntax/loc srcstx + (#,pred #,@(map compile-term ts)))])) + +(define compile-term + (match-lambda + [(variable srcloc sym) + (datum->syntax #f sym srcloc)] + [(constant srcloc sym) + (datum->syntax #f sym srcloc)])) diff --git a/collects/tests/datalog/main.rkt b/collects/tests/datalog/main.rkt index 2f5b15b..39b7b78 100644 --- a/collects/tests/datalog/main.rkt +++ b/collects/tests/datalog/main.rkt @@ -15,8 +15,7 @@ "private/variant.rkt" "runtime.rkt" - "eval.rkt" - "private/compiler.rkt") + "eval.rkt") (run-tests (test-suite @@ -35,6 +34,4 @@ variant-tests runtime-tests - eval-tests - - compiler-tests)) \ No newline at end of file + eval-tests)) \ No newline at end of file