[gambit-list] Help with a macro expansion.

Bradley Lucier lucier at math.purdue.edu
Sat Sep 28 13:40:41 EDT 2013


On 09/27/2013 03:15 PM, Marc Feeley wrote:
> When I try compiling your code, I get "result" where you get #!void .  Perhaps you are not showing us the whole code?

Yes, sorry.  I've attached the code, here is the expansion:

firefly:~/programs/gambit/gambit-debug/gambit> gsc -c -expansion 
test-inexact.scm
Expansion:

(define test-inexact-printing
   (lambda ()
     (let ((f2.0 (string->number "2.0")) (f1.0 (string->number "1.0")) 
(f0.5 (string->number "0.5")) (f0.0 (string->number "0.0")))
       (let ((log2 (let ((l2 (log 2))) (lambda (x) (/ (log x) l2)))))
         (let ((float-precision
                (let ((minval (letrec ((do-temp.20 (lambda (f0.5 x) (if 
(zero? (* f0.5 x)) x (let ((x (* f0.5 x))) (if (zero? (* f0.5 x)) x 
(do-temp.20 f0.5 (* f0.5 x))))))))
                                (do-temp.20 f0.5 f1.0)))
                      (mantissa-bits
                       (letrec ((do-temp.19
                                 (lambda (f1.0 f0.5 i eps)
                                   (if (= f1.0 (+ f1.0 eps)) i (let ((i 
(+ i 1)) (eps (* f0.5 eps))) (if (= f1.0 (+ f1.0 eps)) i (do-temp.19 
f1.0 f0.5 (+ i 1) (* f0.5 eps))))))))
                         (do-temp.19 f1.0 f0.5 0 f1.0))))
                  (lambda (x)
                    (apply (lambda (f e)
                             (let ((eps (if (= f1.0 f) (expt f2.0 (+ 1 
(- e mantissa-bits))) (if (zero? f) minval (expt f2.0 (- e 
mantissa-bits)))))) (if (zero? eps) minval eps)))
                           (let ((x x))
                             (if (zero? x)
                                 (list f0.0 0)
                                 (let ((l2 (log2 x)))
                                   (let ((e (floor (log2 x)))) (let ((e 
(if (= l2 e) (inexact->exact e) (+ (inexact->exact e) 1)))) (let ((f (/ 
x (expt 2 e)))) (list f e))))))))))))
           (let ((float-print-test
                  (lambda (float-precision x)
                    (let ((all-ok? ('#<procedure #2 ##box> #t)) (eps 
(float-precision x)))
                      (letrec ((do-temp.3
                                (lambda (x all-ok? eps j)
                                  (if (or (not ('#<procedure #3 ##unbox> 
all-ok?)) (> j 100))
                                      ('#<procedure #3 ##unbox> all-ok?)
                                      (let ((begin-temp.18
                                             (let ((xx (+ x (* j eps))))
                                               (let ((ok? (let ((number xx))
(let ((begin-temp.2 (set! naive-div naive-div-new)))
(let ((result (eqv? number (string->number (number->string number)))))
(let ((begin-temp.1 (set! naive-div naive-div-orig))) result))))))
                                                 (if (not ok?)
                                                     (let 
((begin-temp.17 (display "Number readback failure for ")))
                                                       (let 
((begin-temp.16 (write ('#<procedure #4 ##quasi-list> '+ x ('#<procedure 
#4 ##quasi-list> '* j eps)))))
(let ((begin-temp.15 (newline)))
(let ((begin-temp.14 (display xx)))
(let ((begin-temp.13 (newline)))
(let ((begin-temp.12
(display (let ((begin-temp.5 (set! naive-div naive-div-new)))
(let ((result (string->number (number->string xx))))
(let ((begin-temp.4 (set! naive-div naive-div-orig))) result))))))
(let ((begin-temp.11 (newline)))
(let ((begin-temp.10
(let ((#:g4 ('#<procedure #2 ##box> '())))
(let ((begin-temp.9
(set! naive-div
(lambda (u v)
(let ((result (naive-div-new u v)))
(let ((begin-temp.6
('#<procedure #5 ##set-box!>
#:g4
(cons (list u v result) ('#<procedure #3 ##unbox> #:g4)))))
result))))))
(let ((result (string->number (number->string xx))))
(let ((begin-temp.8 (set! naive-div naive-div-orig)))
(let ((begin-temp.7
(pp (map (lambda (args+result)
(append args+result (list (naive-div-orig (car args+result) (cadr 
args+result)))))
('#<procedure #3 ##unbox> #:g4)))))
#!void)))))))
('#<procedure #5 ##set-box!> all-ok? #f)))))))))
#!void)))))
                                        (do-temp.3 x all-ok? eps (+ j 
1)))))))
                        (do-temp.3 x all-ok? eps -100))))))
             (let ((mult-float-print-test
                    (lambda (float-precision x)
                      (let ((res ('#<procedure #2 ##box> #t)))
                        (let ((begin-temp.0
                               (for-each
                                (lambda (mult) (or (float-print-test 
float-precision (* mult x)) ('#<procedure #5 ##set-box!> res #f)))
                                (map string->number '("1.0" "10.0" 
"100.0" "1.0e20" "1.0e50" "1.0e100" "0.1" "0.01" "0.001" "1.0e-20" 
"1.0e-50" "1.0e-100")))))
                          ('#<procedure #3 ##unbox> res))))))
               (let ((begin-temp.26 (SECTION 6 5 6)))
                 (let ((begin-temp.25 (test #t 'float-print-test 
(float-print-test float-precision f0.0))))
                   (let ((begin-temp.24 (test #t 'mult-float-print-test 
(mult-float-print-test float-precision f1.0))))
                     (let ((begin-temp.23 (test #t 
'mult-float-print-test (mult-float-print-test float-precision 
(string->number "3.0")))))
                       (let ((begin-temp.22 (test #t 
'mult-float-print-test (mult-float-print-test float-precision 
(string->number "7.0")))))
                         (let ((begin-temp.21 (test #t 
'mult-float-print-test (mult-float-print-test float-precision 
(string->number "3.1415926535897931")))))
                           (test #t 'mult-float-print-test 
(mult-float-print-test float-precision (string->number 
"2.7182818284590451"))))))))))))))))


-------------- next part --------------
A non-text attachment was scrubbed...
Name: test-inexact.scm
Type: text/x-scheme
Size: 3545 bytes
Desc: not available
URL: <http://mailman.iro.umontreal.ca/pipermail/gambit-list/attachments/20130928/c878a541/attachment.bin>


More information about the Gambit-list mailing list