arith bugg fixed plus etc lr
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 17 Aug 2018 13:04:12 +0000 (15:04 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Fri, 17 Aug 2018 13:04:12 +0000 (15:04 +0200)
modules/language/python/compile.scm
modules/language/python/module.scm
modules/language/python/module/_python.scm
modules/language/python/module/decimal.scm
modules/language/python/module/python.scm

index de4299d7bd6dea51da88271236e934c1cd23cdd8..bbeb0690a5296c8d72bd2aedbf94568a5b457feb 100644 (file)
 (define inhibit-finally #f)
 (define decorations (make-fluid '()))
 (define tagis (make-hash-table))
+
+(define (lr as)
+  (lambda (vs x)
+    (define (eval p a b) ((cdr (assoc p as)) a b))
+    (define (expit x)
+      (match x
+       ((#:e e) e)
+       (x (exp vs x))))     
+    (let lp ((x x))
+      (match x
+       ((p a b)
+       (if (assoc p as)
+           (match b
+             ((q c d)
+              (if (assoc q as)
+                  (lp (list q (list #:e (lp (list p a c))) d))
+                  (eval p (expit a) (expit b))))
+             (_ (eval p (expit a) (expit b))))
+           (expit x)))
+       (_ (expit x))))))
+    
+(define (mklr x)
+  (lambda (a b)
+    (list x a b)))
+
+(define (f% s a)
+  (if (string? s)
+      (list (F2 'format) s a)
+      (list (N  'py-mod) s a)))
+
+(define lr+ (lr        `((#:+ . ,(mklr (G '+))) (#:-  . ,(mklr (G '-))))))
+(define lr* (lr `((#:* . ,(mklr (G '*))) (#:/  . ,(mklr (N 'py-/)))
+                 (#:% . ,f%)            (#:// . ,(mklr (N 'py-floordiv))))))
+
+           
 (define-syntax-rule (gen-table x vs (tag code ...) ...)
   (begin
     (hash-set! tagis tag
            
      
  (#:+
-  ((_ . l)
-   (cons '+ (map (g vs exp) l))))
+  (x
+   (lr+ vs x)))
  (#:-
-  ((_ . l)
-   (cons '- (map (g vs exp) l))))
+  (x
+   (lr+ vs x)))
  
  (#:*
-  ((_ . l)
-   (cons '* (map (g vs exp) l))))
+  (x
+   (lr* vs x)))
  
  (#:/
-  ((_ . l)
-   (cons (N 'py-/) (map (g vs exp) l))))
-
+  (x
+   (lr* vs x)))
  (#:%
-  ((_ s a)
-   (let ((s (exp vs s))
-        (a (exp vs a)))
-     (if (string? s)
-        (list (F2 'format) s a)
-        (list (N  'py-mod) s a))))
-  ((_ . l)
-   (cons (N 'py-mod) (map (g vs exp) l))))
+  (x
+   (lr* vs x)))
  
  (#://
-  ((_ . l)
-   (cons (N 'py-floordiv) (map (g vs exp) l))))
+  (x
+   (lr* vs x)))
+
  (#:<<
   ((_ . l)
    (cons (N 'py-lshift) (map (g vs exp) l))))
index 680cf15591e1b515819a88846e8a809570b19e54..51270c20a3bcdcec8e571c494020bb02fc62a26e 100644 (file)
     (lambda (self k)
       (define (fail)
        (raise (AttributeError "getattr in Module")))
-      (let ((k (_k k))
-            (m (_m self)))
-        (let ((x (module-ref m k e)))
-          (if (eq? e x)
-              (fail)
-              x)))))
+      (let ((k (_k k)))
+       (let ((x (module-ref (rawref self '_export) k e)))
+         (if (eq? e x)
+             (let ((x (module-ref (_m self) k e)))
+               (if (eq? e x)
+                   (fail)
+                   x))
+             x)))))
   
   (define __setattr__
     (lambda (self k v)
                         (set! l (cons (symbol->string k) l))))))
        (hash-for-each add h)
         (module-for-each add m)
+       (module-for-each add (rawref self '_export))
        (py-list l))))
        
   
index d9cb1c993b1a8d1968a044b17f916e4aa3d0af7d..46f840e698e1a8d65e431f14d92001e4abb82108 100644 (file)
@@ -9,8 +9,6 @@
   #:use-module (language python exceptions       )
   #:use-module ((language python module string   ) #:select ())
   #:use-module ((language python module io       ) #:select (open))
-  #:use-module ((language python module sys      )
-                #:select ((stdout . _stdout)))
   #:use-module (language python def              ) 
   #:use-module (language python for              )
   #:use-module (language python try              )
 
 (define vars py-dict)
 
-(define print
-  (lam ((= file _stdout) (* l))
-    (if file (set! file (ref file '_port)))
-    (with-output-to-port file
-       (lambda ()
-         (apply
-          (case-lambda
-            (()  ((@ (guile) display) "\n"))
-            ((x) ((@ (guile) display) x    ) (print))
-            (l   ((@ (guile) display) l    ) (print)))
-          l)))))
-
 (define (repr x) ((@ (guile) format) #f "~a" x))
 (define abs     py-abs)
 (define str     pystring)
 (define-python-class Funcobj      ())
 
   
+(define print
+  (lam ((= file #f) (* l))
+       (if file
+          (if (port? file)
+              #t
+              (set! file (ref file '_port)))
+          (set! file (current-output-port)))
+       (with-output-to-port file
+        (lambda ()
+          (apply
+           (case-lambda
+            (()  ((@ (guile) display) "\n"))
+            ((x) ((@ (guile) display) x    ) (print))
+            (l   ((@ (guile) display) l    ) (print)))
+           l)))))
index 0778da187398c979649fde1c5e16fb34d5ea16b7..e58ba348c3d1c4022c9d4c99725b945765e26e41 100644 (file)
@@ -607,7 +607,7 @@ This is the copyright information of the file ported over to scheme
                 (format #f "Cannot convert ~a to Decimal" value))))))
 
 (define-inlinable (divmod x y)
-  (values (quotient x y) (modulo x y)))
+  (values (floor-quotient x y) (floor-remainder x y)))
 
 (define-syntax twix
   (syntax-rules (when let let* if)
@@ -2125,13 +2125,11 @@ This is the copyright information of the file ported over to scheme
         ((norm-op self other ) it it)
         ((norm-op self modulo) it it)
         (let (get-context context))
-        (let () (pk 1))
         ;; deal with NaNs: if there are any sNaNs then first one wins,
         ;; (i.e. behaviour for NaNs is identical to that of fma)
         (let ((self_is_nan   (ref self   '_isnan))
               (other_is_nan  (ref other  '_isnan))
               (modulo_is_nan (ref modulo '_isnan))))
-        (let () (pk 2))
         ((or (bool self_is_nan) (bool other_is_nan) (bool modulo_is_nan)) it
          (cond
           ((= self_is_nan 2)
@@ -2146,7 +2144,7 @@ This is the copyright information of the file ported over to scheme
            (_fix_nan other context))
           (else
            (_fix_nan modulo context))))
-        (let () (pk 3))
+
         ;;check inputs: we apply same restrictions as Python's pow()
         ((not (and ((ref self   '_isinteger))
                    ((ref other  '_isinteger))
@@ -2154,16 +2152,14 @@ This is the copyright information of the file ported over to scheme
          ((cx-error context) InvalidOperation
           (+ "pow() 3rd argument not allowed "
              "unless all arguments are integers")))
-        (let () (pk 4))
         ((< other 0) it
          ((cx-error context) InvalidOperation
           (+ "pow() 2nd argument cannot be "
              "negative when 3rd argument specified")))
-        (let () (pk 5))
         ((not (bool modulo)) it
             ((cx-error context) InvalidOperation
              "pow() 3rd argument cannot be 0"))
-        (let () (pk 6))
+
         ;; additional restriction for decimal: the modulus must be less
         ;; than 10**prec in absolute value
         ((>= ((ref modulo 'adjusted)) (cx-prec context)) it
@@ -2171,7 +2167,7 @@ This is the copyright information of the file ported over to scheme
           (+ "insufficient precision: pow() 3rd "
              "argument must not have more than "
              "precision digits")))
-        (let () (pk 7))
+
         ;; define 0**0 == NaN, for consistency with two-argument pow
         ;; (even though it hurts!)
         ((and (not (bool other)) (not (bool self))) it
@@ -2179,7 +2175,7 @@ This is the copyright information of the file ported over to scheme
           (+ "at least one of pow() 1st argument "
              "and 2nd argument must be nonzero ;"
              "0**0 is not defined")))
-        (let () (pk 8))
+
         ;; compute sign of result
         (let ((sign     (if ((ref other '_iseven))
                             0
@@ -2187,23 +2183,23 @@ This is the copyright information of the file ported over to scheme
               (base     (_WorkRep ((ref self  'to_integral_value))))
               (exponent (_WorkRep ((ref other 'to_integral_value)))))
 
-          (let () (pk 9))
+
           ;; convert modulo to a Python integer, and self and other to
           ;; Decimal integers (i.e. force their exponents to be >= 0)
           (set! modulo (abs (int modulo)))
-          (let () (pk 10))
+
           ;; compute result using integer pow()
           (set! base (guile:modulo
                       (* (guile:modulo (ref base 'int) modulo)
                          (modulo-expt 10 (ref base 'exp) modulo))
                       modulo))
-          (let () (pk 11))
+
           (let lp ((i (ref exponent 'exp)))
             (if (> i 0)
                 (begin
                   (set! base (modulo-expt base 10 modulo))
                   (lp (- i 1)))))
-          (let () (pk 12))
+
           (set! base (modulo-expt base (ref exponent 'int) modulo))
           
           (_dec_from_triple sign (str base) 0)))))
@@ -2665,7 +2661,6 @@ This is the copyright information of the file ported over to scheme
         ;; try for an exact result with precision +1
         (when (eq? ans None)
          (set! ans ((ref self '_power_exact) other (+ prec 1)))
-         (let () (pk 2 0))
          (when (not (eq? ans None))          
            (if (= result_sign 1)
                (set! ans (_dec_from_triple 1  (ref ans '_int)
@@ -6314,7 +6309,7 @@ This is the copyright information of the file ported over to scheme
     ;; is actually an integer approximation to 2**R*y*M, where R is the
     ;; number of reductions performed so far.
 
-    ;; argument reduction; R = number of reductions performed    
+    ;; argument reduction; R = number of reductions performed
     (call-with-values
        (lambda ()
          (let lp ((y (- x M)) (R 0))
@@ -6326,7 +6321,7 @@ This is the copyright information of the file ported over to scheme
                (values y R))))
       (lambda (y R)
        ;; Taylor series with T terms
-       (let* ((T      (- (int (* -10 (floor-quotient (len (str M)) (* 3 L))))))
+       (let* ((T      (- (int (floor-quotient (* -10 (len (str M))) (* 3 L)))))
               (yshift (_rshift_nearest y R))
               (w      (_div_nearest M T)))
          (for ((k : (range (- T 1) 0 -1))) ((w w))
@@ -6399,7 +6394,6 @@ This is the copyright information of the file ported over to scheme
          (call-with-values
              (lambda ()
                ;; compute approximation to f*10**p*log(10), with error < 11.
-               (pk 'log_d log_d)
                (if (not (= f 0))
                    (let ((extra (- (len (str (abs f))) 1)))
                      (if (>= (+ p extra) 0)
@@ -6410,7 +6404,6 @@ This is the copyright information of the file ported over to scheme
                    0))
            (lambda (f_log_ten)
              ;; error in sum < 11+27 = 38; error after division < 0.38 + 0.5 < 1
-             (pk 'log_ten f_log_ten)
              (_div_nearest (+ f_log_ten log_d) 100))))))))
 
 (define-python-class _Log10Memoize ()
@@ -6482,7 +6475,6 @@ This is the copyright information of the file ported over to scheme
       (let* ((T  (- (int (floor-quotient (* -10 (len (str M))) (* 3 L)))))
             (y1 (let ((Mshift (ash M R)))
                   (for ((i : (range (- T 1) 0 -1))) ((y (_div_nearest x T)))
-                       (pk 'y i y)
                        (_div_nearest (* x (+ Mshift y)) (* Mshift i))
                        #:final y)))
                                   
@@ -6492,7 +6484,6 @@ This is the copyright information of the file ported over to scheme
                      (let ((Mshift (ash M (+ k 2))))
                        (_div_nearest (* y (+ y Mshift)) Mshift))
                      #:final y)))
-       (pk '_iexp x M (+ M y2) R T y1)
        (+ M y2)))))
 
 (define _dexp
@@ -6511,9 +6502,8 @@ This is the copyright information of the file ported over to scheme
     = 10**(p-1) the error could be up to 10 ulp."
     ;; we'll call iexp with M = 10**(p+2), giving p+3 digits of precision
     (set! p (+ p 2))
-    (pk '_dexp c e p)
     ;; compute log(10) with extra precision = adjusted exponent of c*10**e
-    (let* ((extra (max 0 (+ e (len (str c)) -1)))
+    (let* ((extra ((@ (guile) max) 0 (+ e (len (str c)) -1)))
           (q     (+ p extra)))
       
       ;; compute quotient c*10**e/(log(10)) = c*10**(e+q)/(log(10)*10**q),
@@ -6530,8 +6520,10 @@ This is the copyright information of the file ported over to scheme
            (set! rem (_div_nearest rem (expt 10 extra)))
 
            ;; error in result of _iexp < 120;  error after division < 0.62
-           (values (_div_nearest (_iexp rem (expt 10 p)) 1000)
-                   (+ quot (- p) 3))))))))
+           (let ((a (_div_nearest (_iexp rem (expt 10 p)) 1000))
+                 (b (+ quot (- p) 3)))
+           (values a b))))))))
+                   
 
 (define _dpower
   (lambda (xc xe yc ye p)
@@ -6548,7 +6540,6 @@ This is the copyright information of the file ported over to scheme
 
     We assume that: x is positive and not equal to 1, and y is nonzero.
     "
-    (pk xc xe yc ye p)
     (let*
        ;; Find b such that 10**(b-1) <= |y| <= 10**b
        ((b   (+ (len (str (abs yc))) ye))
@@ -6573,8 +6564,8 @@ This is the copyright information of the file ported over to scheme
              (lambda ()
                (_dexp ps (- (+ p 1)) (+ p 1)))
            (lambda (coeff exp)       
-             (values (pk 1 (_div_nearest coeff 10))
-                     (pk 2 (+ exp 1)))))))))
+             (values (_div_nearest coeff 10)
+                     (+ exp 1))))))))
 (define _corr (dict '(("1" . 100) ("2" . 70) ("3" . 53) ("4" . 40) ("5" . 31)
                      ("6" . 23 ) ("7" . 16) ("8" . 10) ("9" . 5))))
 (define _log10_lb
index 82c0cab448e3e9c3e0e4600a339266e3f2adb57a..1c15d40c85a4ffae8cc670fc61cc72f34d6700f5 100644 (file)
@@ -9,8 +9,9 @@
     [(_ iface)
      (module-for-each 
       (lambda (name . l)
-        (module-re-export! (current-module) ((@ (guile) list) name)))
-      (resolve-interface 'iface))]
+        (module-re-export! (current-module)
+                          ((@ (guile) list) name)))
+      (module-public-interface (resolve-module 'iface)))]
     [(_ iface _ li)
      (let ((l 'li))
        (module-for-each 
@@ -18,7 +19,7 @@
           (if (not (member name l))
               (module-re-export! (current-module)
                                  ((@ (guile) list) (pk name)))))
-        (resolve-interface 'iface)))]))
+        (module-public-interface (resolve-module 'iface))))]))
 
 (set! (@ (language python module os) path)
   (Module '(path os module python language) '(path os)))