[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