dnrops
/
gimp
mirror of https://github.com/GNOME/gimp.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

R5RS compatibility fix for min and max (SourceForge bug #3399331) 

They are required to return inexact when any argument is inexact.
(From a patch by Doug Currie.)  Also de-tabified init.scm file.
This commit is contained in:
Kevin Cozens 2011-08-29 15:21:28 -04:00
parent f524d20360
commit 5d61a737a7
1 changed files with 40 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
plug-ins/script-fu/tinyscheme/init.scm
View File

@ -70,10 +70,21 @@
(define (abs n) (if (>= n 0) n (- n))) (define (abs n) (if (>= n 0) n (- n)))
(define (exact->inexact n) (* n 1.0)) (define (exact->inexact n) (* n 1.0))
(define (<> n1 n2) (not (= n1 n2))) (define (<> n1 n2) (not (= n1 n2)))
; min and max must return inexact if any arg is inexact; use (+ n 0.0)
(define (max . lst) (define (max . lst)
(foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst))) (foldr (lambda (a b)
(if (> a b)
(if (exact? b) a (+ a 0.0))
(if (exact? a) b (+ b 0.0))))
(car lst) (cdr lst)))
(define (min . lst) (define (min . lst)
(foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst))) (foldr (lambda (a b)
(if (< a b)
(if (exact? b) a (+ a 0.0))
(if (exact? a) b (+ b 0.0))))
(car lst) (cdr lst)))
(define (succ x) (+ x 1)) (define (succ x) (+ x 1))
(define (pred x) (- x 1)) (define (pred x) (- x 1))
(define gcd (define gcd
@ -382,16 +393,16 @@
;;Exit the old list. Do deeper ones last. Don't do ;;Exit the old list. Do deeper ones last. Don't do
;;any shared ones. ;;any shared ones.
(define (pop-many) (define (pop-many)
(unless (eq? *active-windings* shared) (unless (eq? *active-windings* shared)
(deactivate-top-winding!) (deactivate-top-winding!)
(pop-many))) (pop-many)))
;;Enter the new list. Do deeper ones first so that the ;;Enter the new list. Do deeper ones first so that the
;;deeper windings will already be active. Don't do any ;;deeper windings will already be active. Don't do any
;;shared ones. ;;shared ones.
(define (push-many new-ws) (define (push-many new-ws)
(unless (eq? new-ws shared) (unless (eq? new-ws shared)
(push-many (cdr new-ws)) (push-many (cdr new-ws))
(activate-winding! (car new-ws)))) (activate-winding! (car new-ws))))
;;Do it. ;;Do it.
(pop-many) (pop-many)
@ -402,20 +413,20 @@
`(define call-with-current-continuation `(define call-with-current-continuation
;;It internally uses the built-in call/cc, so capture it. ;;It internally uses the built-in call/cc, so capture it.
,(let ((old-c/cc call-with-current-continuation)) ,(let ((old-c/cc call-with-current-continuation))
(lambda (func) (lambda (func)
;;Use old call/cc to get the continuation. ;;Use old call/cc to get the continuation.
(old-c/cc (old-c/cc
(lambda (continuation) (lambda (continuation)
;;Call func with not the continuation itself ;;Call func with not the continuation itself
;;but a procedure that adjusts the active ;;but a procedure that adjusts the active
;;windings to what they were when we made ;;windings to what they were when we made
;;this, and only then calls the ;;this, and only then calls the
;;continuation. ;;continuation.
(func (func
(let ((current-ws *active-windings*)) (let ((current-ws *active-windings*))
(lambda (x) (lambda (x)
(set-active-windings! current-ws) (set-active-windings! current-ws)
(continuation x))))))))) (continuation x)))))))))
outer-env) outer-env)
;;We can't just say "define (dynamic-wind before thunk after)" ;;We can't just say "define (dynamic-wind before thunk after)"
;;because the lambda it's defined to lives in this environment, ;;because the lambda it's defined to lives in this environment,
@ -423,13 +434,13 @@
(eval (eval
`(define dynamic-wind `(define dynamic-wind
,(lambda (before thunk after) ,(lambda (before thunk after)
;;Make a new winding ;;Make a new winding
(activate-winding! (make-winding before after)) (activate-winding! (make-winding before after))
(let ((result (thunk))) (let ((result (thunk)))
;;Get rid of the new winding. ;;Get rid of the new winding.
(deactivate-top-winding!) (deactivate-top-winding!)
;;The return value is that of thunk. ;;The return value is that of thunk.
result))) result)))
outer-env))) outer-env)))
(define call/cc call-with-current-continuation) (define call/cc call-with-current-continuation)