Uses a more traditional read/expand/eval pipeline

original commit: c48d1b58b43a89c357c9fd883563b94f434c7eec

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)

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?)])
+ [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)]))

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))
+  eval-tests))