the pairs swi module compiles

parent 68f7516b
......@@ -29,7 +29,7 @@
(read-line)))))
(define add-history
(if (provided? 'readline)
(if (provided? 'readline)
(@ (ice-9 readline) add-history)
(lambda (pr) pr)))
......
......@@ -21,7 +21,10 @@
#:use-module ((guile) #:select (@ @@))
#:use-module ((logic guile-log umatch) #:select (gp-var!))
#:export (reset-flags reset-prolog set)
#:re-export (;;guile stuff that is needed
#:re-export (;;swi stuff
meta_predicate
;;guile stuff that is needed
@ @@
;;module
......
......@@ -209,6 +209,10 @@
(set! functors (cons (get-fu stx sym w) functors))
#f)
((('fx _ ":-" _) _ n m)
(warn "COPMILE ERROR: now known :- directive at ~a" (get-refstr n m))
#f)
((('xfy _ "|" _) args rs n m)
(set! simple-lam #t)
(top `(((xfx _ ":-" _)
......
......@@ -29,6 +29,7 @@
clear-directives is-dynamic?
get_prolog_flags_handle
module
meta_predicate
))
(define do-print #f)
......@@ -57,6 +58,9 @@
(define-parser-directive (module stx l n m)
(module-mac stx l n m))
(define-parser-directive (meta_predicate stx l n m)
#f)
(define-parser-directive-onfkn use_module (use-module-stx stx l N M)
(use-module-mac stx l N M))
......
......@@ -219,8 +219,7 @@
'(tp ...))
(define-goal-transformer nm-func (nm-tr stx n m a ...)
#`(nm-code #,(tp stx a) ...)))))
(meta-mk-prolog-term mk-prolog-term-0 stx () ())
(meta-mk-prolog-term mk-prolog-term-1 stx (x) (tp))
(meta-mk-prolog-term mk-prolog-term-2 stx (x y) (tp-x tp-y))
......@@ -575,9 +574,14 @@ floor(x) (floor x)
v a)
;; CALL
(<define> (call-fkn g)
(<code> (gp-var-set *call-expression* g S))
(goal-eval g))
(define call-fkn
(<case-lambda>
((g)
(<code> (gp-var-set *call-expression* g S))
(goal-eval g))
((g . l)
(<code> (gp-var-set *call-expression* g S))
(goal-eval (vector (cons g l))))))
(<define-guile-log-rule> (call-mac g) (call-fkn g))
(mk-prolog-term-1 tr-call call call-mac a)
......
......@@ -89,6 +89,12 @@
((#:variable '_ n m)
(warn (format #f "compilation-error ~a '_' cannot be a goal"
(get-refstr n m))))
((#:term (#:atom 'call . _) ((_ _ "," _) (and f (#:atom . _)) l n m) . u)
(goal stx `(#:term ,f ,l ,@u)))
((#:term (#:atom 'call . _) ((_ _ "," _) (and f (#:variable . _))
l n m) . u)
(goal stx `(#:termvar ,f ,l ,@u)))
((#:term (and atom (#:atom f . _)) () #f n m)
(f->stxfkn #f f #f atom garg #:goal stx #f n m '()))
......
......@@ -27,7 +27,7 @@
(if r
(let ((r (assq 'filename r)))
(if r
(cdr r)
(cdr r)
#f))
#f)))
......@@ -56,8 +56,8 @@
(format #t "(compile-prolog-file ~s)~%" fpl)
(format #t "(define *optable-save-first* #t)
(when *optable-save-first*
(save-operator-table)
(set-module-optable-from-current))")
(set! *optable-save-first* #f)
(module-optable-set! (save-operator-table)))~%")
(format #t "(define *prolog-scm-path* ~s)~%" fscm)
(format #t "(define *prolog-reverse-path* ~s)~%" fpl)))
......@@ -68,14 +68,14 @@
(define prefix (make-regexp "^(.*)\\((.*)\\)$"))
(define (is-module-file? f)
(with-input-from-file (pk 'file f)
(with-input-from-file f
(lambda ()
(let lp ((l (read-line)))
(if (eof-object? l)
#f
(if (regexp-exec ws l)
(lp (read-line))
(let ((ret (pk 'reg (regexp-exec reg l))))
(let ((ret (regexp-exec reg l)))
(if ret
(let lp ((s (match:substring ret 1)) (r '()))
(let ((rr (regexp-exec prefix s)))
......@@ -147,7 +147,7 @@
(define (module-optable-ref module)
(if (module-defined? module '*module-optable*)
(module-ref module '*module-optable*)
(module-optable-ref (resolve-module '(language prolog modules system)))))
*standard-opmap*))
(define module-optable-set!
(case-lambda
......@@ -163,7 +163,9 @@
(opdata-set! (module-ref module '*module-optable*)))
(define (set-module-optable-from-current)
(module-set! (current-module) '*module-optable* (opdata-ref)))
(if (module-defined? (current-module) '*module-optable*)
(module-set! (current-module) '*module-optable* (opdata-ref))
(module-define! (current-module) '*module-optable* (opdata-ref))))
(<define> (namespace-switch new-module code)
(<let*> ((old-module (current-module))
......@@ -183,7 +185,7 @@
(define (module-mac stx l n m)
(define (do-name x)
(match x
(match (pk 'do x)
((#:term (#:atom n . _) x . _)
(cons* n (do-name x)))
((#:atom name . l)
......
......@@ -714,9 +714,31 @@
(.. (d) (m GL:_))
(<p-cc> (read-1 stx (<scm> d)))))
(define auto-comma (f-seq ws ":-" ws
(f-cons* expr (f-seq ws expr)
(ff* (f-seq ws expr)))))
(define (resurge x n m)
(match x
((a . l)
`((xfy _ "," _) ,a ,(resurge l n m) ,n ,m))
((a) a)
(() '())))
(define auto-comma-tok
(<p-lambda> (c)
(.. (c) (ws c))
(<let> ((n N) (m M))
(.. (c) (auto-comma c))
(<p-cc> `((fx _ ,":-" _) (#:term ,(car c) ,(resurge (cdr c) n m)
#f ,n ,m)
,n ,m)))))
(define (fp m) (f-seq ws (f-or! (f-seq m ws "." ws)
(f-seq auto-comma-tok ws "." ws))))
(define (f-parse-1 stx m)
(<p-lambda> (c)
(.. (d) (m GL:_))
(.. (d) ((fp m) GL:_))
(<p-cc> (cons (pp 'p1 (parse-1 S stx (pp 'man (<scm> d)))) c))))
;; For now we do not do anything here but it is possible to implement
......@@ -800,8 +822,7 @@
(define (prolog-tokens stx)
(let ((f (f* (f-clear-body
(f-or!
(f-seq ws (f-parse-1 stx expr)
ws (f-char #\.) ws)
(f-parse-1 stx expr)
ferr)))))
(<p-lambda> (c)
......
(use-modules (system base language))
(use-modules (system repl repl))
(use-modules (system repl common))
(use-modules (ice-9 readline))
(activate-readline)
(load (string-append (getenv "HOME") "/.guile"))
(define f0 (string-append (getenv "HOME") "/guile-prolog-scratch"))
(define f1 (string-append (getenv "HOME") "/guile-prolog-scratch/language"))
(define f2 (string-append (getenv "HOME")
"/guile-prolog-scratch/language/prolog"))
(define f3 (string-append (getenv "HOME")
"/guile-prolog-scratch/language/prolog/modules"))
(if (not (file-exists? f0))
(mkdir f0))
(if (not (file-exists? f1))
(mkdir f2))
(if (not (file-exists? f2))
(mkdir f2))
(if (not (file-exists? f3))
(mkdir f3))
(set! %load-path (cons f0 %load-path))
(define (f)
(set-current-module
((language-make-default-environment (lookup-language 'prolog))))
(let ((lang (lookup-language 'prolog)))
(current-language lang)
(start-repl lang)))
(let ((status (start-repl lang)))
(run-hook exit-hook)
status)))
(f)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment