cleanup + include now works + define-set only clamp local function objects

parent f6e1cf18
......@@ -13,7 +13,8 @@
#:use-module (logic guile-log prolog conversion)
#:use-module (logic guile-log prolog names)
#:re-export (;; Scheme functions
compile-string compile-file save-operator-table prolog-run
compile-prolog-string compile-prolog-file
save-operator-table prolog-run
load-prolog clear-directives
init-char-conversion
save-char-conversion-table
......
......@@ -1020,4 +1020,3 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(syntax-rules ()
((_ w a ...)
(<with-guile-log> w code ...)))))
......@@ -6,30 +6,30 @@
#:use-module (ice-9 rdelim)
#:use-module (ice-9 pretty-print)
#:export (pmatch plambda X XL N M <p-define> <p-lambda> .. xx <p-cc>
s-false s-true s-scan-item
s-test s-test! s-char
s-seq s-id
s-and s-and! s-and!! s-and-i
s-or s-or-i s-or! s-not s-not!
s-reg s-char s-reg! s-char! s-read s-eof
clear-tokens mk-token tok-ws* tok-ws* Ds
s* s+ fn f< f> s-ws* s-ws+ s-pk s-nl s-nl! s-do-nl
mk-simple-token p-freeze
make-file-reader file-next-line file-skip
pr-char pr-nl pr-test pr-reg
s-tag s-tag! pr-tag s-clear-body pr-not
s-rpl f-rpl s-tr f-tr
f-and f-and! f-and!!
f-or f-or! f-not
f-seq f-seq! f-seq!!
f* f+ f-tag f-tag! f-tag-pr
f-reg f-reg! f-reg-pr
f-false f-true
f-eof f-nl f-nl! f-nl-pr
parse parse-no-clear
*current-file-parsing*
*translator*))
s-false s-true s-scan-item
s-test s-test! s-char
s-seq s-id
s-and s-and! s-and!! s-and-i
s-or s-or-i s-or! s-not s-not!
s-reg s-char s-reg! s-char! s-read s-eof
clear-tokens mk-token tok-ws* tok-ws* Ds
s* s+ fn f< f> s-ws* s-ws+ s-pk s-nl s-nl! s-do-nl
mk-simple-token p-freeze
make-file-reader file-next-line file-skip
pr-char pr-nl pr-test pr-reg
s-tag s-tag! pr-tag s-clear-body pr-not
s-rpl f-rpl s-tr f-tr
f-and f-and! f-and!!
f-or f-or! f-not
f-seq f-seq! f-seq!!
f* f+ f-tag f-tag! f-tag-pr
f-reg f-reg! f-reg-pr
f-false f-true
f-eof f-nl f-nl! f-nl-pr
parse parse-no-clear
*current-file-parsing*
*translator*))
(define do-print #f)
(define pp
......@@ -104,7 +104,7 @@
(else #f))))
(if w
(with-syntax (((ch ...) w))
#'(s-seq (s-char ch) ...))
#'(s-seq (s-char ch) ...))
(error "argument to s-tag is either string or symbol")))))))
(define-syntax s-tag!
......@@ -334,10 +334,9 @@
(define s-ws+ (s+ s-ws))
(define map #f)
(define *freeze-map* (make-fluid #f))
(define (clear-tokens)
(set! map (make-hash-table)))
(fluid-set! *freeze-map* (make-hash-table)))
(clear-tokens)
;; The idea of this function is to perform a tokenizing activity
......@@ -359,7 +358,8 @@
(define (p-freeze tok f mk)
(<p-lambda> (c)
(<and!>
(<let> ((val (hash-ref map (cons* N M tok) #f))
(<let> ((val (hash-ref (fluid-ref *freeze-map*)
(cons* N M tok) #f))
(fr (<newframe>)))
(if (not val)
(<let> ((n N) (m M))
......@@ -367,7 +367,8 @@
(<let> ((val (mk S c cc)))
(<code>
(<unwind> fr)
(hash-set! map (cons* n m tok) (list X XL N M val)))
(hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) (list X XL N M val)))
(<p-cc> val)))
(<apply> s-true val))))))
......@@ -388,26 +389,25 @@
((str matcher)
(define f
(lambda ()
(clear-tokens)
(<clear>)
(<run> 1 (cout)
(<values> (x xl n m out)
(matcher '() (make-file-reader) 0 0 _))
(<code> (print-last-line xl))
(<=> cout out))))
(with-fluids ((*freeze-map* (fluid-ref *freeze-map*)))
(clear-tokens)
(<run> 1 (cout)
(<values> (x xl n m out)
(matcher '() (make-file-reader) 0 0 _))
(<code> (print-last-line xl))
(<=> cout out)))))
(if (string? str)
(with-input-from-string str f)
(with-input-from-port str f)))
((matcher)
(clear-tokens)
(<clear>)
(<run> 1 (cout)
(<values> (x xl n m out)
(matcher '() (make-file-reader) 0 0 _))
(<code> (print-last-line xl))
(<=> cout out)))))
(with-fluids ((*freeze-map* (fluid-ref *freeze-map*)))
(clear-tokens)
(<run> 1 (cout)
(<values> (x xl n m out)
(matcher '() (make-file-reader) 0 0 _))
(<code> (print-last-line xl))
(<=> cout out))))))
(define parse-no-clear
(case-lambda
......
......@@ -20,17 +20,18 @@
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log parser)
#:export (compile-string compile-file read-prolog-term save-operator-table))
#:export (compile-prolog-string compile-prolog-file
read-prolog-term save-operator-table))
(define-syntax-rule (define-or-set! f x)
(let ((xx x))
(if (defined? 'f)
(if (module-locally-bound? (current-module) 'f)
(set! f xx)
(define! 'f xx))
(set-procedure-property! xx 'name 'f)))
(define do-print #f)
(define do-print #t)
(define pp
(case-lambda
((s x)
......@@ -84,7 +85,7 @@
(define (flatten x)
(match x
(((#:group x) . l)
(((#:translated 0 (#:include file x)) . l)
(flatten (append x l)))
((x . l)
(cons x (flatten l)))
......@@ -148,10 +149,13 @@
(list v (get.. "," y) '())))))
(pp 'compile l)
(define (mcar x) (if (pair? x) (car x) '()))
(pp 'compile-1 l)
(clear-syms)
(let* ((l-r (pp 'l-r (stable-sort (map top (car (pp 'compile (reverse (flatten l)))))
less)))
(let* ((l-r (pp 'l-r (stable-sort
(map top (pp 'compile-2
(flatten (mcar l))))
less)))
(in.r (let lp ((l-r l-r) (def '()) (r '()))
(match (pp 'ini l-r)
......@@ -327,14 +331,14 @@
(define (get-rhs stx)
(lambda (x) (goal stx x)))
(define-syntax compile-string
(define-syntax compile-prolog-string
(lambda (x)
(syntax-case x ()
((n str)
(compile #'n
(prolog-parse #'n (syntax->datum #'str)))))))
(define-syntax compile-file
(define-syntax compile-prolog-file
(lambda (x)
(syntax-case x ()
((n str)
......
......@@ -17,6 +17,7 @@
#:use-module ((logic guile-log)
#:select (<define> <let> <scm> <var?>))
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:replace (include)
#:export (dynamic multifile discontiguous op set_prolog_flag get-flag
set-flag
......@@ -27,17 +28,35 @@
clear-directives is-dynamic?
))
(define do-print #f)
(define pp
(case-lambda
((s x)
(when do-print
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when do-print
(pretty-print (syntax->datum x)))
x)))
(define do-character-convert #f)
(define (acar x)
(if (pair? x)
(car x)
'()))
(define-parser-directive (include stx l N M)
(match l
((#:string fname)
`(#:group
(with-input-from-file fname
(lambda ()
(with-fluids ((*prolog-file* fname))
(prolog-parse stx))))))))
((#:string fname _ _)
`(#:include ,fname
,(acar
(with-input-from-file fname
(lambda ()
(with-fluids ((*prolog-file* fname))
(prolog-parse stx)))))))))
(define (partial-list? x)
(match x
......@@ -77,7 +96,7 @@
(fluid-set! *dynamics* (cons f
(fluid-ref *dynamics*)))
#`(define-dynamic! #,(datum->syntax stx f)))))
((parse-PI err (get-refstr N M)) l)))))
((parse-PI err N M) l)))))
(define (is-dynamic? f)
(member f (fluid-ref *dynamics*)))
......
......@@ -15,7 +15,7 @@
(with-output-to-file scm
(lambda ()
(format #t "(use-modules (logic guile-log iso-prolog))~%")
(format #t "(compile-file ~s)~%" pl))))
(format #t "(compile-prolog-file ~s)~%" pl))))
(catch #t
(lambda ()
......
......@@ -2,6 +2,7 @@
#:use-module (logic guile-log parsing operator-parser)
#:use-module (ice-9 match)
#:use-module (logic guile-log vlist)
#:use-module ((logic guile-log umatch) #:select (*current-stack*))
#:use-module (ice-9 pretty-print)
#:use-module (system syntax)
#:use-module (logic guile-log parser)
......@@ -20,7 +21,9 @@
(define *prolog-file* (make-fluid #f))
(define (get-refstr N M)
(format #f "~a:(~a,~a)" (fluid-ref *prolog-file*) M N))
(if (fluid-ref *prolog-file*)
(format #f "~a:(~a,~a)" (fluid-ref *prolog-file*) M N)
(format #f "~a:(~a,~a)" (module-name (current-module)) M N)))
(define do-print #f)
(define pp
......@@ -422,7 +425,7 @@
(define (f-parse-1 stx m)
(<p-lambda> (c)
(.. (d) (m GL:_))
(<p-cc> (cons (parse-1 stx (<scm> d)) c))))
(<p-cc> (cons (parse-1 S stx (<scm> d)) c))))
;; For now we do not do anything here but it is possible to implement
;; parser directions here
......@@ -436,41 +439,44 @@
(define (f . a) . code)
(set-object-property! on 'prolog-directive f)))
(define (parse-1 stx x)
(define (parse-1 s stx x)
(define (ferr f n m)
`(#:translated 0
,(format
#f
"in ~a term directive ~a did not point to an available global directive"
(get-refstr n m) f)))
(match x
(((fx _ ":-" _ ) (#:term (#:atom nm _ _) l _ _) N M)
(call-with-values (lambda () (syntax-local-binding (datum->syntax stx nm)))
(lambda (type val)
(case type
((global)
(let* ((sym (car val))
(mod (cdr val))
(f (module-ref (resolve-module mod) sym))
(p (object-property f 'prolog-directive)))
(if p
(if (procedure? p)
`(#:translated 0 ,(p stx l N M))
`(#:translated 0 ,(f stx l N M)))
(ferr nm N M))))
(else
(ferr nm N M))))))
"in ~a term directive ~a did not point to an available global directive"
(get-refstr n m) f)))
(with-fluids ((*current-stack* s))
(match x
(((fx _ ":-" _ ) (#:term (#:atom nm _ _) l _ _) N M)
(call-with-values
(lambda () (syntax-local-binding (datum->syntax stx nm)))
(lambda (type val)
(case type
((global)
(let* ((sym (car val))
(mod (cdr val))
(f (module-ref (resolve-module mod) sym))
(p (object-property f 'prolog-directive)))
(if p
(if (procedure? p)
`(#:translated 0 ,(p stx l N M))
`(#:translated 0 ,(f stx l N M)))
(ferr nm N M))))
(else
(ferr nm N M))))))
(x x)))
(x x))))
;; A very simple error recovery and analyzer :-)
(define ferr* (f-seq (f+ (f-or! ws+ (f-not (s-char #\.))))
(s-char #\.) ws))
(s-char #\.)
ws))
(define ferr
(<p-lambda> (c)
(<let> ((n N) (m M))
(<let> ((n N) (m M))
(.. (d) (ferr* c))
(<code> (warn (format #f "Error somwhere beteen ~a -> ~a"
(get-refstr n m) (get-refstr N M))))
......
......@@ -67,7 +67,23 @@
x)))))))
(define *kanren-assq* #f)
(define-syntax <run>
(define-syntax-rule (mk<run> <run> <run*>)
(define-syntax-rule (<run> . l)
(let ((fr (gp-newframe (fluid-ref *current-stack*))))
(dynamic-wind
(lambda ()
#f)
(lambda ()
(let ((r (<run*> . l)))
(gp-unwind fr)
r))
(lambda ()
(gp-unwind fr))))))
(mk<run> <run> <run*>)
(define-syntax <run*>
(syntax-rules (*)
((_ (v) code ...)
(let ((fr (gp-newframe (fluid-ref *current-stack*))))
......@@ -175,12 +191,13 @@
r)
(p))))))))))))
(define-syntax <ask>
(define-syntax <ask*>
(syntax-rules ()
((_ code ...)
(let ((cc (lambda (s p) #t))
(p (lambda () #f)))
(gp-clear (fluid-ref *current-stack*))
(let ((s (make-empty-s)))
(<with-guile-log> (s p cc)
(<and> code ...)))))))
(mk<run> <ask> <ask*>)
\ No newline at end of file
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