vlist fixes

parent a0a969ce
......@@ -11,11 +11,13 @@
#:use-module (logic guile-log prolog char)
#:use-module (logic guile-log prolog char-conversion)
#: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
load-prolog clear-directives
init-char-conversion
save-char-conversion-table
;; Math
sin cos atan exp log sqrt
......@@ -72,6 +74,7 @@
round floor ceiling truncate
;; symbols directive
include
operator_specifier
fx fy xf yf xfx yfx xfy
operator_priority
......
......@@ -3,10 +3,10 @@
#:use-module (logic guile-log parser)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (ice-9 vlist)
#:use-module (logic guile-log vlist)
#:export (make-opdata add-operator rem-operator mk-operator-expression
table->assq assq->table mk-fop
get-operator get-binops get-unops))
get-operator get-binops get-unops))
#|
Enhanced Classic Prolog Operator Parser
......@@ -19,10 +19,14 @@
|#
(define null! 'a-very-ugly-hack-of-operator-table-nulling-id)
(define-syntax-rule (my-hash-ref table key default)
(let ((xx (vhash-assq key (fluid-ref table))))
(let ((xx (vhash-assoc key (fluid-ref table))))
(if xx
(cdr xx)
(let ((r (cdr xx)))
(if (eq? r null!)
default
r))
default)))
(define (to-string name)
......@@ -34,12 +38,23 @@
(equal? x y)))
(define (table->assq table)
(vhash-fold-right (lambda (k v s) (cons (cons k v) s))
'() table))
(define ha (make-hash-table))
(let lp ((l (vhash->assoc table)))
(if (pair? l)
(cond
((eq? (cdar l) null!)
(begin
(hash-set! ha (caar l) #t)
(lp (cdr l))))
((hash-ref ha (caar l))
(lp (cdr l)))
(else
(cons (car l) (lp (cdr l)))))
'())))
(define (assq->table a)
(fold (lambda (x s)
(vhash-consq (car x) (cdr x) s))
(vhash-cons (car x) (cdr x) s))
vlist-null (reverse a)))
(define (rem-operator table type key)
......@@ -56,8 +71,10 @@
(lp l (cons x pre)))
(() (reverse pre))))))
(if (null? li)
(fluid-set! table (vhash-delq k (fluid-ref table)))
(fluid-set! table (vhash-consq k li (fluid-ref table)))))))))
(fluid-set! table
(vhash-cons k null! (fluid-ref table)))
(fluid-set! table
(vhash-cons k li (fluid-ref table)))))))))
(define (get-operator table type key)
(let* ((nm (string->list (to-string key)))
......@@ -69,7 +86,7 @@
(match x
( (( (_ . (? (== type)))
(? (== r)) . _) . l)
(lp l (cons (car x) pre)))
(lp l (cons (car x) pre)))
((x . l)
(lp l pre))
(() (reverse pre))))))
......@@ -88,7 +105,7 @@
(let lp ((pre pre) (tail tail))
(match pre
(()
(fluid-set! data (vhash-consq ch tail (fluid-ref data))))
(fluid-set! data (vhash-cons ch tail (fluid-ref data))))
((x . l)
(lp l (cons x tail))))))
......
......@@ -10,7 +10,7 @@
#:use-module (logic guile-log prolog directives)
#:use-module (logic guile-log prolog parser)
#:use-module (logic guile-log prolog symbols)
#:use-module ((logic guile-log prolog goal-transformers)
#:use-module ((logic guile-log prolog names)
#:select (make-unbound-fkn end_of_file))
#:use-module (logic guile-log umatch)
#:use-module ((logic guile-log) #:renamer (lambda (x)
......@@ -82,6 +82,14 @@
(< (length xa) (length ya))
#f))))))))
(define (flatten x)
(match x
(((#:group x) . l)
(flatten (append x l)))
((x . l)
(cons x (flatten l)))
(x x)))
(define (top x)
(match (pp 'top x)
(((('xfx _ ":-" _) (#:term (#:atom v . _) y . _) z n m))
......@@ -119,7 +127,7 @@
((#:translated _ (#:untranslate x))
(top x))
((#:translated _ _)
x)
......@@ -142,7 +150,7 @@
(pp 'compile l)
(clear-syms)
(let* ((l-r (pp 'l-r (stable-sort (map top (car (pp 'compile (reverse l))))
(let* ((l-r (pp 'l-r (stable-sort (map top (car (pp 'compile (reverse (flatten l)))))
less)))
(in.r (let lp ((l-r l-r) (def '()) (r '()))
......@@ -269,8 +277,8 @@
(match l
((#:variable x n m)
(when (and (not (eq? x '_)) (= (hashq-ref tab x 0) 1))
(warn (format #f "At (~a:~a), Variable ~a only used one time"
m n x))))
(warn (format #f "At ~a, Variable ~a only used one time"
(get-refstr n m) x))))
((x . l)
(lp x) (lp l))
(_ #t))))
......@@ -287,7 +295,7 @@
(loop y))
(((_ . _) x _ _)
(loop x))
((#:group x)
(loop x))
......@@ -332,8 +340,9 @@
((n str)
(with-input-from-file (syntax->datum #'str)
(lambda ()
(compile #'n
(prolog-parse #'n))))))))
(with-fluids ((*prolog-file* (syntax->datum #'str)))
(compile #'n
(prolog-parse #'n)))))))))
(define (read-prolog-term stream module)
(let ((stx (vector 'syntax-object 'a '((top))
......
(define-module (logic guile-log prolog char-conversion)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (ice-9 vlist)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog parser)
#:use-module (logic guile-log prolog directives)
#:use-module (logic guile-log vlist)
#:use-module (ice-9 match)
#:use-module (logic guile-log umatch)
#:use-module ((logic guile-log)
#:renamer (lambda (x)
(if (eq? x '_)
'__
x)))
#:export
(init-char-conversion char-convert char-conversions->assq
save-char-conversion-table
assq->char-conversions char_conversion
do-character-convert
assq->char-conversions
current_char_conversion init-char-conversion))
(define *conversion* (make-fluid vlist-null))
......@@ -15,25 +24,7 @@
(define (init-char-conversion)
(fluid-set! *conversion* vlist-null))
(when (not (defined? 'vhash->assq))
(define! 'vhash->assq
(lambda (vhash)
(define touch (if (defined? 'vlist-length)
(make-hash-table (* 2 (vlist-length vhash)))
(make-hash-table)))
(vhash-fold
(lambda (k v seed)
(let ((r (hashq-ref touch k #f)))
(if r
seed
(begin
(hashq-set! touch k #t)
(cons (cons k v) seed)))))
'()
vhash))))
(define (do-character-convert) #t)
(set! do-character-convert (lambda () #f))
(define (char-convert ch)
(if (do-character-convert)
(let ((l (vhash-assq ch (fluid-ref *conversion*))))
......@@ -43,7 +34,7 @@
ch))
(define (char-conversions->assq)
(vhash->assq (fluid-ref *conversion*)))
(vhash->assoc (fluid-ref *conversion*)))
(define (assq->char-conversions a)
(let lp ((a a) (vhash (fluid-ref *conversion*)))
......@@ -100,7 +91,7 @@
(representation_error character))
(else
(<code> (add-char-conversion ch1- ch2-))))))))
(<define> (current_char_conversion ch1 ch2)
(<let*> ((ch1 (<lookup> ch1))
(ch1- (->ch ch1))
......@@ -134,4 +125,26 @@
((not ch2-)
(representation_error character))
(else
(<=> ch2- ch2*))))))))
\ No newline at end of file
(<=> ch2- ch2*))))))))
(define (str x)
(cond
((symbol? x)
(symbol->string x))
(else
x)))
(define-parser-directive-onfkn char_conversion (char_conv_directive stx l N M)
(match l
(((_ _ "," _)
(or (#:string a _ _) (#:symbol a _ _))
(or (#:symbol b _ _) (#:string b _ _)) _ _)
#`(char_conversion (fluid-ref *current-stack*)
(lambda x #f) (lambda x #t) #,(str a) #,(str b)))
(_
(format #t "COMPILE ERROR: Bad character format in char_conversion at ~a~%" (get-refstr N M)))))
(set! (@ (logic guile-log prolog names) char_conversion)
char_conversion)
(set! (@ (logic guile-log prolog names) char-convert)
char-convert)
......@@ -2,6 +2,7 @@
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog directives)
#:use-module ((logic guile-log prolog util)
#:select ((append . pr-append)))
......
(define-module (logic guile-log prolog conversion)
#:pure
#:use-module (logic guile-log prolog directives)
#:use-module (logic guile-log prolog names)
#:use-module ((guile) #:select ((floor . scm-floor) (ceiling . scm-ceil)
(round . scm-round) (truncate . scm-truncate)
(sin . scm-sin ) (cos . scm-cos)
......
(define-module (logic guile-log prolog directives)
#:use-module (logic guile-log)
#:use-module ((logic guile-log prolog char-conversion)
#:select
(char_conversion do-character-convert))
#:use-module ((logic guile-log prolog goal-transformers)
#:select
( not_less_than_zero evaluable callable modify
static_procedure access private_procedure
end_of_file plus
make-unbound-fkn
atom integer number fail true
))
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog dynamic)
#:use-module (logic guile-log prolog char-conversion)
#:use-module (logic guile-log prolog load)
#:use-module (logic guile-log prolog parser)
#:use-module (logic guile-log prolog run)
......@@ -28,57 +17,27 @@
#:use-module ((logic guile-log)
#:select (<define> <let> <scm> <var?>))
#:use-module (ice-9 match)
#:export (dynamic multifile discontiguous op set_prolog_flag get-flag
set-flag
check-num is-a-num?
operator_specifier current_op
fx fy xf yf xfx yfx xfy
operator_priority
flag_value flag
on off false
towards_zero down
warning chars codes bounded auto_sym max_integer
min_integer integer_rounding_function
debug max_arity unknown double_quotes
current_prolog_flag prolog_flag
initialization local_initialization
clear-directives is-dynamic?
))
#:replace (include)
#:export (dynamic multifile discontiguous op set_prolog_flag get-flag
set-flag
do-character-convert
current_op
current_prolog_flag
initialization local_initialization
clear-directives is-dynamic?
))
(define do-character-convert #f)
(define-syntax-rule (mk-sym a)
(begin
(define a (make-unbound-fkn 'a))
(set-procedure-property! a 'name 'a)))
(mk-sym operator_specifier)
(mk-sym fx)
(mk-sym fy)
(mk-sym xf)
(mk-sym yf)
(mk-sym xfx)
(mk-sym yfx)
(mk-sym xfy)
(mk-sym operator_priority)
(mk-sym flag_value)
(mk-sym flag)
(mk-sym prolog_flag)
(mk-sym on)
(mk-sym off)
(mk-sym false)
(mk-sym towards_zero)
(mk-sym down)
(mk-sym warning)
(mk-sym chars)
(mk-sym codes)
(mk-sym bounded)
(mk-sym auto_sym)
(mk-sym max_integer)
(mk-sym min_integer)
(mk-sym integer_rounding_function)
(mk-sym debug)
(mk-sym max_arity)
(mk-sym unknown)
(mk-sym double_quotes)
(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))))))))
(define (partial-list? x)
(match x
......@@ -118,7 +77,7 @@
(fluid-set! *dynamics* (cons f
(fluid-ref *dynamics*)))
#`(define-dynamic! #,(datum->syntax stx f)))))
((parse-PI err N M) l)))))
((parse-PI err (get-refstr N M)) l)))))
(define (is-dynamic? f)
(member f (fluid-ref *dynamics*)))
......@@ -237,9 +196,10 @@
(((or (#:atom x _ _) (#:string x _ _) (#:symbolic x _ _)) ...)
(prolog-run 1 (op prio (make-spec spec) x))
#f)
(_ (format #t "Bad op/3 directive at (~a,~a)~%" M N) #t)))
(_ (format #t "Bad op/3 directive at ~a~%" (get-refstr N M)) #t)))
(_ (format #t "COMPILE ERROR: Bad op/3 directive at (~a,~a)~%" M N) #t)))
(_ (format #t "COMPILE ERROR: Bad op/3 directive at ~a~%" (get-refstr N M))
#t)))
......@@ -249,7 +209,8 @@
#`(load (ensure_loaded_ #,str)))
((#:atom atm _ _)
#`(load (ensure_loaded_ #,(symbol->string atm))))
(_ (format #t "COMPILE ERROR: Bad ensure_loaded/1 directive at (~a,~a)~%" M N) #t)))
(_ (format #t "COMPILE ERROR: Bad ensure_loaded/1 directive at ~a~%"
(get-refstr N M)) #t)))
(define (str x)
(cond
......@@ -257,16 +218,6 @@
(symbol->string x))
(else
x)))
(define-parser-directive-onfkn char_conversion (char_conv_directive stx l N M)
(match l
(((_ _ "," _)
(or (#:string a _ _) (#:symbol a _ _))
(or (#:symbol b _ _) (#:string b _ _)) _ _)
#`(char_conversion (fluid-ref *current-stack*)
(lambda x #f) (lambda x #t) #,(str a) #,(str b)))
(_
(format #t "COMPILE ERROR: Bad character format in char_conversion at (~a:~a)~%" M N))))
(<define> (local_initialization) <cc>)
(define (initialization . x)
......@@ -376,12 +327,11 @@
(v (if (number? v) v (module-ref (current-module) v))))
(if (check-flags k v #t)
(set-flag k v)
(format #t "COMPILE-ERROR: wrong prolog flag ~a,~a at (~a , ~a)~%"
k v M N)))))
(format #t "COMPILE-ERROR: wrong prolog flag ~a,~a at ~a~%"
k v (get-refstr N M))))))
#f)
(define (mk-err nm) (string-append "at (~a,~a) in " nm ", not a PI list"))
(define (mk-err nm) (string-append "at ~a in " nm ", not a PI list"))
(define-PI dynamic define-dynamic! (mk-err "dynamic"))
(define-PI multifile define-multifile! (mk-err "multifile"))
......@@ -402,4 +352,8 @@
(<=> value ,(get-flag flag))
(domain_error prolog_flag flag)))
(else
(type_error atom flag)))))
\ No newline at end of file
(type_error atom flag)))))
(set! (@@ (logic guile-log prolog names) is-a-num?) is-a-num?)
(set! (@@ (logic guile-log prolog names) check-num) check-num)
(set! (@@ (logic guile-log prolog names) get-flag ) get-flag)
\ No newline at end of file
......@@ -4,14 +4,12 @@
#:use-module (logic guile-log prolog goal)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog var)
#:use-module ((logic guile-log prolog util)
#:select ((member . pr-member)))
#:use-module ((logic guile-log prolog goal-transformers)
#:select (fact modify callable static_procedure true
private_procedure integer atom access
predicate_indicator
not_less_than_zero))
#:use-module ((logic guile-log prolog goal-transformers)
#:select (atom))
#:use-module (logic guile-log)
#:use-module (ice-9 match)
#:re-export (define-dynamic define-dynamic!)
......
......@@ -5,16 +5,13 @@
#:use-module (ice-9 match)
#:use-module (logic guile-log prompts)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog names)
#:replace (error)
#:export (type_error instantiation_error domain_error existence_error
permission_error list/plist? existence_error
*call-expression* representation_error syntax_error
scheme-wrapper evaluation_error))
(define source_sink #f)
(define number #f)
(define integer #f)
(define-syntax fkn-it
(syntax-rules (quote)
((_ 'x) 'x)
......@@ -218,3 +215,6 @@
(lambda (thk) (g (lambda () (catch #t thk h)))))))
(define *call-expression* (gp-make-var #f))
(set! (@@ (logic guile-log prolog names) type_error) type_error)
(set! (@@ (logic guile-log prolog names) existence_error) existence_error)
\ No newline at end of file
......@@ -8,14 +8,11 @@
#:use-module (logic guile-log umatch)
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:export (define-goal-functor define-scm-functor
goal-eval scm-eval if-then-else fff-eval
goal-fkn? get-goal-sym))
(define callable #f)
(define evaluable #f)
(define divide #f)
(define do-print #f)
(define pp
(case-lambda
......@@ -109,8 +106,6 @@
(define (nm s a)
(set-object-propery nm 'prolog-functor-type #:exp))))
(define float #f)
(define-syntax-rule (scm-eval x) (scm-eval* S x))
(define (scm-eval* s x)
(umatch (#:mode - #:status s #:name scm-eval*) ((pp 'scm-eval x))
......
(define-module (logic guile-log prolog goal-transformers)
#:use-module (guile-user)
#:use-module (logic guile-log prolog pre)
#:use-module (logic guile-log prolog parser)
#:use-module (logic guile-log tools)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog directives)
#:use-module (logic guile-log prolog goal)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log prolog directives)
#:use-module ((logic guile-log prolog var)
#:renamer (lambda (x)
(cond
......@@ -25,27 +26,21 @@
'GL:_
x)))
#:use-module (logic guile-log prolog names)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:replace (catch throw)
#:export (call unify_with_occurs_check copy_term
findall bagof setof functor arg
var atom integer float atomic compound nonvar number
source_sink
fact directive
var atom atomic compound nonvar
directive
procedure_name
fail true ! once
make-unbound-fkn
not_less_than_zero evaluable callable modify
static_procedure access private_procedure character_code
predicate_indicator
end_of_file character
! once
-var -atom unary-minus
halt
)
#:re-export(sin cos atan exp log sqrt))
(define do-print #f)
(define pp
(case-lambda
......@@ -223,8 +218,8 @@
; ------------------------------
(define (tr-error op)
(lambda (stx n m . l)
(warn (format #f "int (~a,~a) op ~a should not be translated directly"
m n op))
(warn (format #f "int ~a op ~a should not be translated directly"
(get-refstr n m) op))
#'((fk-error 'op))))
(define (fk-error op)
......@@ -385,7 +380,7 @@ floor(x) (floor x)
(<let> ((f (<lookup> f)))
(cond
((string? f)
(<let> ((g (module-ref (currrent-module) (string->symbol f))))
(<let> ((g (module-ref (current-module) (string->symbol f))))
(if (procedure? g)
(<=> l ,(cons g u))
(existence_error
......@@ -415,7 +410,7 @@ floor(x) (floor x)
(<=> x ,(vector (cons f l))))
((string? f)
(<let> ((g (module-ref (currrent-module) (string->symbol f))))
(<let> ((g (module-ref (current-module) (string->symbol f))))
(if (procedure? g)
(<=> x ,(vector (cons g l)))
(existence_error
......@@ -787,50 +782,6 @@ floor(x) (floor x)
(define p (lambda x #f))
(define ss (fluid-ref *current-stack*))
(define (make-unbound-fkn nm)
(letrec ((warn-message
(format #f "fkn ~a is not evaluable, will fail" f))
(d #f)
(f (lambda k
(match k
(()
(if d
d
(begin
(mk-dyn nm (lambda (x) (set! d x)))
d)))
((x) d)
((a b c . l)
(if d (apply d k)
(apply
(<lambda> l
(<let> ((e (get-flag unknown)))
(cond
((eq? e error)
(existence_error
procedure
(vector `(,divide ,f
,(length l)))))
((eq? e warning)
(<code> (warn warn-message))
<fail>)
((eq? e fail)
<fail>)
(else
(<code>
(error
"Bug in prolog flag 'unknown' implementation"))))))
a b c l)))
(_
(type_error ss p cc evaluable
(vector `(,divide ,f
,(- (length k) 1)))))))))
(set-object-property! f 'prolog-symbol #t)
f))
(<define> (once-f v)
(<let> ((v (<lookup> v)))
(if (<var?> v)
......@@ -843,31 +794,6 @@ floor(x) (floor x)
(<define-guile-log-rule> (once-mac v) (once-f v))
(mk-prolog-term-1 tr-once once once-mac a)
(define-syntax-rule (mk-sym a)
(begin
(define a (make-unbound-fkn 'a))
(set-procedure-property! a 'name 'a)))
(mk-sym character_code)
(mk-sym not_less_than_zero)
(mk-sym evaluable)
(mk-sym callable)
(mk-sym modify)
(mk-sym static_procedure)
(mk-sym private_procedure)
(mk-sym access)
(mk-sym end_of_file)
(mk-sym character)
(mk-sym predicate_indicator)
(mk-sym source_sink)
(set! (@@ (logic guile-log prolog goal-functors) callable) callable)
(set! (@@ (logic guile-log prolog goal-functors) evaluable) evaluable)
(set! (@@ (logic guile-log prolog goal-functors) divide) divide)
(set! (@@ (logic guile-log prolog goal-functors) float) float)
(set! (@@ (logic guile-log prolog error) source_sink) source_sink)
(set! (@@ (logic guile-log prolog error) number) number)
(set! (@@ (logic guile-log prolog error) integer) integer)
(define halt
......@@ -884,4 +810,13 @@ floor(x) (floor x)
(else
(<ret> `(halt ,x))))))
s p cc x))))
(set! (@ (logic guile-log prolog names) float) float)
(set! (@ (logic guile-log prolog names) number) number)
(set! (@ (logic guile-log prolog names) integer) integer)