number treatment more along iso-prolog spec

parent d4cc782f
......@@ -60,7 +60,7 @@
(define (add-char-conversion ch1 ch2)
(let* ((vhash (fluid-ref *conversion*)))
(if (eq? ch1 ch2)
(let ((l (vhash-assq vhash ch1)))
(let ((l (vhash-assq ch1 vhash)))
(if l
(if (cdr l)
(fluid-set! *conversion*
......
(define-module (logic guile-log prolog conversion)
#:pure
#:use-module ((guile) #:select ((floor . scm-floor) (ceiling . scm-ceil)
#:use-module (logic guile-log prolog directives)
#:use-module ((guile) #:select ((floor . scm-floor) (ceiling . scm-ceil)
(round . scm-round) (truncate . scm-truncate)
define inexact->exact))
#:replace (floor ceiling round truncate))
(sin . scm-sin ) (cos . scm-cos)
(atan . scm-atan ) (log . scm-log)
(exp . scm-exp ) (sqrt . scm-sqrt)
define inexact->exact exact->inexact))
#:replace (floor ceiling round truncate sin cos atan exp log))
(define (floor x) (inexact->exact (scm-floor x)))
(define (ceiling x) (inexact->exact (scm-ceil x)))
(define (round x) (inexact->exact (scm-round x)))
(define (truncate x) (inexact->exact (scm-truncate x)))
(define (floor x) (inexact->exact (scm-floor (is-a-num? x))))
(define (ceiling x) (inexact->exact (scm-ceil (is-a-num? x))))
(define (round x) (inexact->exact (scm-round (is-a-num? x))))
(define (truncate x) (inexact->exact (scm-truncate (is-a-num? x))))
(define (sin x) (exact->inexact (scm-sin (is-a-num? x))))
(define (cos x) (exact->inexact (scm-cos (is-a-num? x))))
(define (atan x) (exact->inexact (scm-atan (is-a-num? x))))
(define (log x) (exact->inexact (scm-log (is-a-num? x))))
(define (exp x) (exact->inexact (scm-exp (is-a-num? x))))
(define (sqrt x) (exact->inexact (scm-sqrt (is-a-num? x))))
......@@ -30,7 +30,7 @@
#: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
......@@ -288,8 +288,8 @@
(define *flags* `((,bounded #f ,false ,true ,false)
(,auto_sym #f ,on ,on ,off)
(,max_integer #f ,(inf))
(,min_integer #f ,(- (inf)))
(,max_integer #f ,(ash 1 60))
(,min_integer #f ,(- (ash 1 60)))
(,integer_rounding_function #f ,towards_zero ,down
,towards_zero)
(,char_conversion #t ,on ,on ,off)
......@@ -309,6 +309,25 @@
((k _ default . _) (set-flag k default))))
*flags*)
(define p (lambda x #f))
(define cc (lambda x #t))
(define (check-num x)
(if (integer? x)
(let ((minI (get-flag min_integer))
(maxI (get-flag max_integer)))
(if (< x minI)
(evaluation_error (fluid-ref *current-stack*) p cc))
(if (> x maxI)
(evaluation_error (fluid-ref *current-stack*) p cc))
x)
x))
(define (is-a-num? x)
(if (number? x)
x
(evaluation_error (fluid-ref *current-stack*) p cc)))
(define (check-flags k v static)
(let ((r (assq k *flags*)))
(if r
......
......@@ -57,6 +57,31 @@
'prolog non-reentrant (fkn-it code)))
H)))))))
(define evaluation_error
(case-lambda
((s p cc)
(abort-to-prompt tag
(lambda ()
(G
(lambda ()
(catch #t
(lambda () (<abort>
s p cc
'prolog non-reentrant
(fkn-it (error evaluation_error 'iso-prolog))))
H))))))
((s p cc x)
(abort-to-prompt tag
(lambda ()
(G
(lambda ()
(catch #t
(lambda () (<abort> s p cc
'prolog non-reentrant
(fkn-it (error (evaluation_error x)
'iso-prolog))))
H))))))))
(define-error (instantiation_error)
(error instantiation_error
'iso-prolog))
......@@ -85,6 +110,7 @@
(error (syntax_error a)
'iso-prolog))
#;
(define-error (evaluation_error a )
(error (evaluation_error a)
'iso-prolog))
......
......@@ -279,21 +279,21 @@
(mk-prolog-biop-not 'xfx "@>=" tr-0ge oge term< a a)
(mk-prolog-biop-not 'xfx "@=<" tr-0le ole term> a a)
;(mk-prolog-is 'xfx "is" tr-is is <r=> v s)
(mk-prolog-biop 'xfx "is" tr-is is <iss> v s)
(mk-prolog-biop 'xfx "is" tr-is is <iss> a s)
(define-syntax-rule (shr x y) (ash x (- y)))
(mk-scheme-biop 'yfx "+" tr-+ plus + s s)
(mk-scheme-biop 'yfx "-" tr-- minus - s s)
(mk-scheme-unop 'fy "-" tr-u- unary-minus - s )
(mk-scheme-biop 'yfx "+" tr-+ plus .+ s s)
(mk-scheme-biop 'yfx "-" tr-- minus .- s s)
(mk-scheme-unop 'fy "-" tr-u- unary-minus .-1 s )
(mk-scheme-unop 'fy "\\" tr-bitnot bitnot lognot s )
(mk-scheme-biop 'yfx "*" tr-* times * s s)
(mk-scheme-biop 'yfx "/" tr-/ divide / s s)
(mk-scheme-biop 'yfx "*" tr-* times .* s s)
(mk-scheme-biop 'yfx "/" tr-/ divide ./ s s)
(mk-scheme-biop 'yfx "//" tr-i/ idivide truncate/ s s)
(mk-scheme-biop 'yfx "rem" tr-rem rem remainder s s)
(mk-scheme-biop 'yfx "mod" tr-mod mod modulo s s)
(mk-scheme-biop 'xfx "**" tr-pow power expt s s)
(mk-scheme-biop 'yfx "<<" tr-shr lshift ash s s)
(mk-scheme-biop 'xfx "**" tr-pow power myexpt s s)
(mk-scheme-biop 'yfx "<<" tr-shr lshift .ash s s)
(mk-scheme-biop 'yfx ">>" tr-shr rshift shr s s)
(mk-scheme-biop 'yfx "/\\" tr-bitand bitand logand s s)
(mk-scheme-biop 'yfx "\\/" tr-bitor bitor logior s s)
......@@ -305,6 +305,21 @@
(mk-prolog-biop-when 'xfx "=:=" tr-equal equal my-equal? s s)
(mk-prolog-biop-when-not 'xfx "=\\=" tr-not-equal notEqual my-equal? s s)
(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 (.-1 x)
(check-num (- (is-a-num? x))))
(define (.* x y)
(check-num (* (is-a-num? x) (is-a-num? y))))
(define (./ x y)
(exact->inexact (/ (is-a-num? x) (is-a-num? y))))
(define (.ash x n)
(check-num (ash (is-a-num? x) (is-a-num? n))))
(define e1 1.000000000001)
(define e2 0.999999999999)
......@@ -313,9 +328,9 @@
(if (< y 0) (set! y (- y)))
(if (and (number? x) (number? y))
(if (inexact? x)
(and (< y (* e1 x)) (> y (* e2 x)))
(and (<= y (* e1 x)) (>= y (* e2 x)))
(if (inexact? y)
(and (< x (* e1 y)) (> x (* e2 y)))
(and (<= x (* e1 y)) (>= x (* e2 y)))
(= x y)))
(= x y)))
......@@ -324,14 +339,14 @@
(> y (* e2 x))
(if (inexact? y)
(< x (* e1 y))
(= x y))))
(<= x y))))
(define (my->= x y)
(if (inexact? x)
(< y (* e1 x))
(if (inexact? y)
(> x (* e2 y))
(= x y))))
(>= x y))))
#| Further supported operators scm functions are
abs(x) (abs x)
......
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