further improvements

parent 95889b5b
......@@ -3,7 +3,7 @@
#:use-module ((guile) #:select (@ @@ define))
#:pure
#:re-export (prolog-run)
#:export (run_tests run_all_tests unexpected_ball
#:export (run_tests run_all_tests unexpected_ball <--
failure success impl_def undefined))
(compile-prolog-file "inriasuite.pl")
......
......@@ -692,7 +692,7 @@
(lambda ()
(term-init-variables)
(clear-syms)
(let* ((r (prolog-parse-read stx)))
(let* ((r (pp 'parse (prolog-parse-read stx))))
(if (and (pair? r) (pair? (car r)))
(let* ((r (pp 'term (term stx (reverse (car r)))))
(vl (pp 'vl (term-get-variables-list)))
......
......@@ -20,7 +20,7 @@
(vector `(,f ,(fkn-it x) ...)))
((_ x) x)))
(define *debug* #t)
(define *debug* #f)
(define (call-with-eh th . l)
(if *debug*
(call-with-error-handling th)
......
......@@ -87,7 +87,7 @@
(<let> ((f (<lookup> f)))
(<cut>
(<let> ((x (object-property f 'prolog-functor-type)))
(case x
(case x
((#:goal)
(<apply> f cut l))
((#f)
......
......@@ -261,7 +261,8 @@
(<code> (error "Bug in prolog flag 'unknown' implementation"))))))))
(<define> (<iss> x y)
(<let> ((x (<lookup> x)))
(<let> ((x (<lookup> x))
(y (<lookup> y)))
(if (number? x)
(if (number? y)
(if (inexact? x)
......@@ -349,8 +350,8 @@
(mk-scheme-biop 'yfx "/\\" tr-bitand bitand logand s s)
(mk-scheme-biop 'yfx "\\/" tr-bitor bitor logior s s)
(mk-prolog-biop-when 'xfx "<" tr-< lt < s s)
(mk-prolog-biop-when 'xfx ">" tr-> gt > s s)
(mk-prolog-biop-when 'xfx "<" tr-< lt .< s s)
(mk-prolog-biop-when 'xfx ">" tr-> gt .> s s)
(mk-prolog-biop-when 'xfx ">=" tr->= ge my->= s s)
(mk-prolog-biop-when 'xfx "=<" tr-=< le my-<= s s)
(mk-prolog-biop-when 'xfx "=:=" tr-equal equal my-equal? s s)
......@@ -358,6 +359,11 @@
(define (myexpt x y) (exact->inexact (expt x y)))
(define (.< x y)
(check-num (< (is-a-num? x) (is-a-num? y))))
(define (.> x y)
(check-num (> (is-a-num? x) (is-a-num? y))))
(define (.+ x y)
(check-num (+ (is-a-num? x) (is-a-num? y))))
(define (.- x y)
......
......@@ -104,14 +104,12 @@
op)))
(let lp ((ops op-map))
(match ops
((((_ . (? (lambda (x) (equal? x op)))) . f)
((((_ . (? (lambda (x) (equal? x op)))) . f)
. _)
f)
((_ . l)
(lp l))
(_ (warn
(format #f "Could not find unary op ~a at ~a" op (get-refstr N M)))
op)))))
(_ #f)))))
(define (maybe-op op n)
(cond
......
......@@ -166,7 +166,7 @@
(define opsym
(<p-lambda> (c)
(.. (p) (fop c))
(<match> (#:mode - #:name 'opsym) ((ppp 'op p))
(<match> (#:mode - #:name 'opsym) ((pp 'op p))
((_ _ op _)
(<cut> (<and> (<p-cc> (<scm> op))))))))
......@@ -685,9 +685,10 @@
termvar-tok term-binop-tok termop-tok
termstring-tok term-tok scm-tok lam-tok
number qstring dstring atom variable #;symbolic-tok
#;op-tok))
op-tok))
(define e (mk-operator-expression tok symbolic-tok2 *prolog-ops*))
(define e (mk-operator-expression tok (f-or! op-tok symbolic-tok2)
*prolog-ops*))
(set! expr* (<p-lambda> (c) (.. (e 1200))))
(define (read-1 stx x) x)
......
......@@ -46,6 +46,11 @@
(define (@wrapper v li ? s)
(make-namespace v li ? #t))
(define-syntax-rule (opwrap code stx s n m)
(let ((r (op->>fkn s n m)))
(if r
(get-functor-stx stx (op->>fkn s n m))
code)))
(define (fa x) x)
(define x_x #',GL:_)
......@@ -83,20 +88,20 @@
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
#`(unquote #,(compile-lambda stx l s closed?)))
((#:term (and atom (#:atom f . _)) () #f . _)
((#:term (and atom (#:atom f _ _ n m)) () #f . _)
(add-sym mod local? atom)
#`(unquote #,(get-binding mod local? atom stx fa)))
#`(unquote #,(opwrap (get-binding mod local? atom stx fa) stx f n m)))
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym mod local? atom)
(let ((meta (map fget (get.. "," meta))))
#`(unquote (metah #,(get-binding mod local? atom stx fa) #,@meta))))
((#:term (and atom (#:atom f . _)) x #f . _)
((#:term (and atom (#:atom f _ _ n m)) x #f . _)
(add-sym mod local? atom)
#`(unquote
(vector
`(,#,(get-binding mod local? atom stx fa)
`(,#,(opwrap (get-binding mod local? atom stx fa) stx f n m)
#,@(map fget (get.. "," x))))))
((#:term (and atom (#:atom f . _)) x meta . _)
......@@ -118,7 +123,7 @@
((and atom (#:atom v _ _ n m))
(add-sym mod local? atom)
#`(unquote #,(get-binding mod local? atom stx fa)))
#`(unquote #,(opwrap (get-binding mod local? atom stx fa) stx v n m)))
((#:number n . _) n)
......@@ -222,9 +227,9 @@
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
#`(unquote #,(compile-lambda stx l s closed?)))
((#:term (and atom (#:atom f . _)) () #f . _)
((#:term (and atom (#:atom f _ _ n m)) () #f . _)
(add-sym mod local? atom)
#`(unquote #,(get-binding mod local? atom stx fa)))
#`(unquote #,(opwrap (get-binding mod local? atom stx fa) stx f n m)))
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym mod local? atom)
......@@ -232,11 +237,11 @@
#`(unquote (metah #,(get-binding mod local? atom stx fa) #,@meta))))
((#:term (and atom (#:atom f . _)) x #f . _)
((#:term (and atom (#:atom f _ _ n m)) x #f . _)
(add-sym mod local? atom)
#`(unquote
(vector
`(,#,(get-binding mod local? atom stx fa)
`(,#,(opwrap (get-binding mod local? atom stx fa) stx f n m)
#,@(map fget (get.. "," x))))))
((#:term (and atom (#:atom f . _)) x meta . _)
......@@ -262,7 +267,7 @@
((and atom (#:atom v _ _ n m))
(add-sym mod local? atom)
#`(unquote #,(get-binding mod local? atom stx fa)))
#`(unquote #,(opwrap (get-binding mod local? atom stx fa) stx v n m)))
((#:number n . _) n)
(((_ _ "-" _) (#:number n _ _) _ _)
......@@ -325,18 +330,21 @@
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
(compile-lambda stx l s closed?))
((#:term (and atom (#:atom f . _)) () #f . _)
((#:term (and atom (#:atom f _ _ n m)) () #f . _)
(add-sym mod local? atom)
(get-binding mod local? atom stx fa))
(opwrap
(get-binding mod local? atom stx fa)
stx f n m))
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym mod local? atom)
(let ((meta (map fget (get.. "," meta))))
#`(metah (get-binding mod local? atom stx fa) #,@meta)))
((#:term (and atom (#:atom f . _)) x #f . _)
((#:term (and atom (#:atom f _ _ n m)) x #f . _)
(add-sym mod local? atom)
#`#((,#,(get-binding mod local? atom stx fa)
#`#((,#,(opwrap (get-binding mod local? atom stx fa)
stx f n m)
#,@(map fget (get.. "," x)))))
((#:term (and atom (#:atom f . _)) x meta . _)
......@@ -355,7 +363,9 @@
((and atom (#:atom v _ _ n m))
(add-sym mod local? atom)
#`(unquote #,(get-binding mod local? atom stx fa)))
#`(unquote #,(opwrap
(get-binding mod local? atom stx fa)
stx v n m)))
((#:number n . _) n)
(((_ _ "-" _) (#:number n _ _) _ _)
......@@ -453,10 +463,12 @@
#`(unquote #,(compile-lambda stx l s closed?)))
((#:term (and atom (#:atom f . _)) () #f . _)
((#:term (and atom (#:atom f _ _ n m)) () #f . _)
(add-sym mod local? atom)
#`(unquote #,(get-binding mod local? atom stx fa)))
#`(unquote #,(opwrap
(get-binding mod local? atom stx fa)
stx f n m)))
((#:term (and atom (#:atom f . _)) () meta . _)
(add-sym mod local? atom)
(let ((meta (map fget (get.. "," meta))))
......@@ -464,11 +476,12 @@
#,(get-binding mod local? atom stx fa)
#,@meta))))
((#:term (and atom (#:atom f . _)) x #f . _)
((#:term (and atom (#:atom f _ _ n m)) x #f . _)
(add-sym mod local? atom)
#`(unquote
(vector
`(,#,(get-binding mod local? atom stx fa)
`(,#,(opwrap (get-binding mod local? atom stx fa)
stx f n m)
#,@(map fget (get.. "," x))))))
((#:term (and atom (#:atom f . _)) x meta . _)
......@@ -493,7 +506,9 @@
((and atom (#:atom v _ _ n m))
(add-sym mod local? atom)
#`(unquote #,(get-binding mod local? atom stx fa)))
#`(unquote #,(opwrap
(get-binding mod local? atom stx fa)
stx v n m)))
((#:number n . _) n)
(((_ _ "-" _) (#:number n _ _) _ _)
......@@ -509,7 +524,8 @@
(#:termstring (#:string "=.." . _)
(x y) n m)) (=> cont)
(match y
((#:list ((_ _ "," _) (and atom (#:atom a . _)) z _ _))
((#:list ((_ _ "," _)
(and atom (#:atom a . _)) z _ _))
#`(unquote
(vector
`(,#,(get-functor-stx
......
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