diff --git a/collects/datalog/lang/lang.rkt b/collects/datalog/lang/lang.rkt deleted file mode 100644 index 342dfb16ef..0000000000 --- a/collects/datalog/lang/lang.rkt +++ /dev/null @@ -1,28 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base - "../private/compiler.rkt") - "../pretty.rkt") - -(define (print-result value) - (if (void? value) - (void) - (displayln (format-literals value)))) - -(define-syntax (module-begin stx) - (syntax-case stx () - [(module-begin) - #'(#%module-begin)] - [(module-begin ast ...) - (with-syntax ([(begin rs ...) (compile-module (syntax->datum #'(ast ...)))]) - #'(#%module-begin - (begin (print-result rs) ...)))])) - -(define-syntax (top-interaction stx) - (syntax-case stx () - [(_ . stmt) - (quasisyntax/loc stx - (print-result - #,(compile-stmt (syntax->datum #'stmt))))])) - -(provide (rename-out [module-begin #%module-begin] - [top-interaction #%top-interaction])) \ No newline at end of file diff --git a/collects/datalog/lang/reader.rkt b/collects/datalog/lang/reader.rkt index 67a6e727c9..a3e1dfd083 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 86fee23749..1b613685af 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 2f5b15bb64..39b7b78ff0 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 diff --git a/collects/tests/datalog/private/compiler.rkt b/collects/tests/datalog/private/compiler.rkt deleted file mode 100644 index 74cc1c653c..0000000000 --- a/collects/tests/datalog/private/compiler.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket -(require rackunit - (for-template datalog/eval) - datalog/parse - datalog/private/compiler) - -(provide compiler-tests) - -(define s1 - (parse-statement - (open-input-string - "parent(john,douglas)."))) - -(define compiler-tests - (test-suite - "compiler" - - (test-equal? "stmt" - (syntax->datum (compile-stmt s1)) - `(eval-statement ,s1)) - (test-equal? "module" - (syntax->datum (compile-module (list s1))) - `(begin (eval-statement ,s1))))) - \ No newline at end of file