prolog user modules starts to work

parent fab0ae27
......@@ -41,6 +41,9 @@ Version 0.5,
Version 0.6, TODO
* Functional Streams DONE
* SWI Prolog namespacing
* SWI Prolog modules
* SWI Prolog ensure_loded
* SWI Prolog call semantics
* if directives
* swi compability
* GC of the (almost) unreachable tail of a stream (all)
......
(define-module (language prolog spec)
#:use-module (system base compile)
#:use-module (system base language)
#:use-module (logic guile-log guile-prolog readline)
#:use-module (logic guile-log iso-prolog)
#:use-module (language scheme compile-tree-il)
#:use-module (logic guile-log guile-prolog interpreter)
#:export (prolog))
......@@ -10,30 +10,78 @@
;;; Language definition
;;;
(define (beautify-prolog-user-module! module)
(let ((interface (module-public-interface module)))
(if (or (not interface)
(eq? interface module))
(let ((interface (make-module 31)))
(set-module-name! interface (module-name module))
(set-module-version! interface (module-version module))
(set-module-kind! interface 'interface)
(set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module)))
(not (eq? module the-root-module)))
;; Import the default set of bindings (from the SCM module) in MODULE.
(save-module-excursion
(lambda ()
(set-current-module module)
(use-modules ((guile) #:renamer renamer))))
#;(module-for-each
(lambda (k v)
(if (or #t (member k '(quote unquote)))
(module-define! module k v)
(module-define! module (symbol-append ':scm k) v)))
the-scm-module)
#;(for-each (lambda (x) (module-use! module x))
(module-uses! the-scm-module))
#;(module-use! module the-scm-module)))
(define (make-fresh-prolog-user-module)
(let ((m (make-module)))
;(set-module-name! m '(prolog-user))
(beautify-prolog-user-module! m)
m))
(define (copy-from-guile-user)
(let ((m (current-module))
(g (resolve-module '(guile-user))))
(process-use_module '(((guile))))
(module-for-each
(lambda (k v)
(module-define! m k v))
g)))
(define (renamer x)
(if (or (eq? x '@) (eq? x '@@) (eq? x 'quote))
x
(symbol-append 'scm- x)))
(define (process-use_module module-interface-args)
(let ((interfaces
(with-fluids
((*current-language* (lookup-language 'scheme)))
(map (lambda (mif-args)
(or (apply resolve-interface mif-args)
(error "no such module" mif-args)))
module-interface-args))))
(module-use-interfaces! (current-module) interfaces)))
(define-language prolog
#:title "Prolog"
#:reader read-prolog
#:compilers `((tree-il . ,compile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:evaluator (lambda (x module) (pk x) (primitive-eval x))
#:printer write
#:make-default-environment
(lambda ()
(let ((m (make-module)))
(define (--f--)
(let ((spec-mod (resolve-module '(language prolog spec))))
(define! 'use-modules #f)
(module-set! (current-module) 'use-modules
(module-ref spec-mod 'patched-use-modules))
(use-modules ((guile) #:renamer (symbol-prefix-proc 'scm-)))))
(set-module-name! m '(prolog-user))
(let ((m (make-fresh-prolog-user-module)))
;(set-module-name! m '(prolog-user))
(module-use! m (module-public-interface
(resolve-module '(logic guile-log iso-prolog))))
(save-module-excursion
(lambda ()
(set-current-module m)
(--f--)))
m)))
(define (ask str ok?)
......@@ -78,4 +126,4 @@
((equal? x 'n)
#t)
(else
#f)))))))))))
\ No newline at end of file
#f)))))))))))
......@@ -201,7 +201,7 @@
(clear
`((@ (logic guile-log) begin)
((@ (logic guile-log) <clear>))
((@ (logic guile-log) if) #f #f)))
((@ (guile) if) #f #f)))
(old
'((@ (guile) if) #f #f))
(ref
......@@ -266,7 +266,7 @@ HELP FOR PROLOG COMMANDS
(.set ) <ref> <val> set user variable ref to value val
---------------------------------------------------------------------
")
'(if #f #f))
'((@ (guile) if) #f #f))
((string? l)
......@@ -288,7 +288,7 @@ HELP FOR PROLOG COMMANDS
(nn? nn?)
(else
'(@ (logic guile-log iso-prolog) false))))
(if #f #f))))
((@ (guile) if) #f #f))))
(else
`((@ (guile) with-fluids)
(((@ (system base language) *current-language*)
......
......@@ -18,14 +18,19 @@
#:use-module (logic guile-log prolog namespace)
#:use-module (system base language)
#:use-module (logic guile-log)
#:use-module ((guile) #:select (@ @@))
#:use-module ((logic guile-log umatch) #:select (gp-var!))
#:export (reset-flags reset-prolog set)
#:re-export (;;modules
#:re-export (;;guile stuff that is needed
@ @@
;;module
module
use_module
module-optable-set!
module-optable-ref
set-module-optable-from-current
;;unknown cludge
gp-var!
......@@ -148,8 +153,8 @@
(<define> (default_module)
(<code> (set-current-module
(language-make-default-environment (current-language)))))
(<code> (set-current-module
((language-make-default-environment (lookup-language 'prolog))))))
(<define> (set x y) (<set> x y))
......
(define-module (logic guile-log prolog load)
#:use-module (logic guile-log prolog modules)
#:use-module (logic guile-log umatch)
#:use-module (system base language)
#:export (load-prolog ensure_loaded ensure_loaded_))
(define (process-use_module module-interface-args)
(with-fluids ((*current-language* (lookup-language 'scheme)))
(let ((interfaces (map (lambda (mif-args)
(or (apply resolve-interface mif-args)
(error "no such module" mif-args)))
module-interface-args)))
(module-use-interfaces! (current-module) interfaces))))
(define (load-prolog s p cc str)
(load (load-prolog_ str))
(cc s p))
(with-fluids ((*current-language* (lookup-language 'scheme)))
(let* ((pl (string-append str ".pl"))
(r (is-module-file? pl)))
(if (pk 'r r)
(let ((u (pk 'u (load-prolog_ str))))
(if u
(process-use_module `((,u)))))
(load (load-prolog_ str))))
(cc s p)))
(define (load-prolog_ str)
(let* ((str str)
(pl (string-append str ".pl"))
(scm (string-append str ".pl.scm")))
(define (action)
(with-output-to-file scm
(lambda ()
(format #t "(use-modules (logic guile-log iso-prolog))~%")
(format #t "(compile-prolog-file ~s)~%" pl))))
(let ((r (pk 'mod? (is-module-file? pl))))
(if r
(write-module-scratch r pl)
(with-output-to-file scm
(lambda ()
(format #t "(use-modules (logic guile-log iso-prolog))~%")
(format #t "(compile-prolog-file ~s)~%" pl))))))
(catch #t
(lambda ()
......@@ -25,8 +46,8 @@
(action))))
(lambda x (action)))
;(pk `(compiling and/or load of ,str))
;(pk `(compiling and/or load of ,str))
scm))
(define ensure_loaded_ load-prolog_)
(define ensure_loaded load-prolog)
\ No newline at end of file
(define ensure_loaded load-prolog)
......@@ -6,14 +6,21 @@
#:use-module (logic guile-log)
#:use-module (system base language)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 pretty-print)
#:export
(namespace-switch set-module-optable-from-current
module-optable-ref
module-optable-set!
module-mac
use-module-mac
use_module))
(is-module-file?
write-module-scratch
namespace-switch
set-module-optable-from-current
module-optable-ref
module-optable-set!
module-mac
use-module-mac
use_module))
(define (source-file stx)
(let ((r (syntax-source stx)))
......@@ -24,6 +31,88 @@
#f))
#f)))
(define (str-it x)
(cond
((string? x)
x)
((symbol? x)
(symbol->string x))
((procedure? x)
(procedure-name x))))
(define (make-file-from-path path ext)
(let lp ((l (reverse path)) (first? #t) (r ""))
(if (pair? l)
(let ((rr (str-it (car l))))
(if first?
(set! r (string-append rr ext))
(set! r (string-append r "/" rr)))
(lp (cdr l) #f r))
r)))
(define (write-module fpl fscm)
(lambda ()
(format #t "(use-modules (logic guile-log iso-prolog))~%")
(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))")
(format #t "(define *prolog-scm-path* ~s)~%" fscm)
(format #t "(define *prolog-reverse-path* ~s)~%" fpl)))
(define reg (make-regexp "\\W*\\:\\-\\W*module\\(([^,]*)"))
(define ws (make-regexp "^\\w*$"))
(define reg2 (make-regexp "^\\((.*)\\)$"))
(define prefix (make-regexp "^(.*)\\((.*)\\)$"))
(define (is-module-file? f)
(with-input-from-file (pk '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))))
(if ret
(let lp ((s (match:substring ret 1)) (r '()))
(let ((rr (regexp-exec prefix s)))
(if rr
(lp (match:substring rr 2)
(cons
(match:substring rr 1)
r))
(reverse (cons s r)))))
#f))))))))
(define default-scratch "guile-prolog-scratch")
(define home (cdr (string-split (getenv "HOME") #\/)))
(define scratch-directory (append home (list default-scratch)))
(define (mkdir* x)
(if (not (file-exists? x))
(mkdir x)))
(mkdir* (string-append (getenv "HOME") "/" default-scratch))
(mkdir* (string-append (getenv "HOME") "/" default-scratch "/language"))
(mkdir* (string-append (getenv "HOME") "/" default-scratch "/language/prolog"))
(mkdir*
(string-append (getenv "HOME") "/" default-scratch "/language/prolog/modules"))
(define (write-module-scratch path pl)
(let* ((pth (string-join (append scratch-directory
'(language prolog modules)
path)
"/"))
(scm? (is-scm-path? pth)))
(if scm?
(if (equal? (car scm?) pl)
(apply check #t pth) ;; equal paths, check timestamps
(apply check #f (list pl pth))) ;; always clobber
(apply check #f (list pl pth))) ;; always clobber
(map string->symbol (map str-it (append '(language prolog modules) path)))))
(define (lpath x) (string-split x #\/))
(define (find-module-path x)
(define l (lpath x))
......@@ -140,89 +229,83 @@
(resolve-module
'(language prolog modules system))))))))))))))
(define (pre-compile-prolog-file f)
(define (find-path f)
(let ((fpl (mk-file f ".pl"))
(fscm (mk-file f ".pl.scm")))
(let lp ((l %load-path))
(if (pair? l)
(let ((str-scm (string-join
(append
(string-split (car l) #\/)
fscm) "/")))
(if (file-exists? str-scm)
(with-input-from-file str-scm
(lambda ()
(let lp ((r (read)) (scm #f) (pl #f))
(match r
((? eof-object?)
(if (and scm pl)
(list pl scm)
#f))
(('*prolog-scm-path* x)
(lp (read) x pl))
((*prolog-reverse-path* x)
(lp (read) scm x))
(else
(lp (read) scm pl))))))
(lp (cdr l))))
#f))))
(define (check chk? fpl fscm)
(when (or (not chk?)
(not (file-exists? fscm))
(let* ((mpl (stat:mtime (stat fpl)))
(mscm (stat:mtime (stat fscm))))
(< (+ mscm 10) mpl)))
(with-output-to-file fscm
(write-module fpl fscm))))
(define (mk-file f ext)
(let ((r (reverse f)))
(reverse (cons (string-append
(symbol->string (car r))
(str-it (car r))
ext)
(map symbol->string
(map str-it
(cdr r))))))
(define (search-prolog-source f)
(let ((fpl (mk-file f ".pl"))
(fscm (mk-file f ".pl.scm")))
(let lp ((l %load-path))
(if (pair? l)
(let ((str-pl (string-join
(append
(string-split (car l) #\/)
fpl) "/"))
(str-scm (string-join
(append
(string-split (car l) #\/)
fscm) "/")))
(if (file-exists? str-pl)
(list str-pl str-scm)
(lp (cdr l))))
#f))))
(define (check fpl fscm)
(when (or (not (file-exists? fscm))
(let* ((mpl (stat:mtime (stat fpl)))
(mscm (stat:mtime (stat fscm))))
(< (+ mscm 10) mpl)))
(with-output-to-file fscm
(define (is-scm-path? str-scm)
(if (file-exists? str-scm)
(with-input-from-file str-scm
(lambda ()
(format #t "(use-modules (logic guile-log iso-prolog))~%")
(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))")
(format #t "(define *prolog-scm-path* ~s)~%" fscm)
(format #t "(define *prolog-reverse-path* ~s)~%" fpl)))))
(let lp ((r (read)) (scm #f) (pl #f))
(match r
((? eof-object?)
(if (and scm pl)
(list pl scm)
#f))
(('*prolog-scm-path* x)
(lp (read) x pl))
((*prolog-reverse-path* x)
(lp (read) scm x))
(else
(lp (read) scm pl))))))
#f))
(define (find-path f)
(let ((fpl (mk-file f ".pl"))
(fscm (mk-file f ".pl.scm")))
(let lp ((l %load-path))
(if (pair? l)
(let ((str-scm (string-join
(append
(string-split (car l) #\/)
fscm) "/")))
(if (file-exists? str-scm)
(is-scm-path? str-scm)
(lp (cdr l))))
#f))))
(define (search-prolog-source f)
(let ((fpl (mk-file f ".pl"))
(fscm (mk-file f ".pl.scm")))
(let lp ((l %load-path))
(if (pair? l)
(let ((str-pl (string-join
(append
(string-split (car l) #\/)
fpl) "/"))
(str-scm (string-join
(append
(string-split (car l) #\/)
fscm) "/")))
(if (file-exists? str-pl)
(list str-pl str-scm)
(lp (cdr l))))
#f))))
(define (pre-compile-prolog-file f)
(let ((pth (find-path f)))
(if pth
(apply check pth)
(apply check #t pth)
(let ((pth (search-prolog-source f)))
(if pth
(apply check pth)
(apply check #t pth)
(if #f #f))))))
(define ensure_loaded_p (make-fluid #f))
(define (use-module-mac stx l n m)
(define (atom c)
......
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