From 613b910f0ceb0ec0948a0e0595cd3e82086754cf Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Sat, 17 Dec 2016 00:20:42 +1300 Subject: [PATCH] Can now make it through first chapter of SICP. --- src/scheme-library.scm | 41 +++++++++++++++++++++------------------ src/scheme-primitives.4th | 5 +++++ 2 files changed, 27 insertions(+), 19 deletions(-) diff --git a/src/scheme-library.scm b/src/scheme-library.scm index e8e9245..f8c0ec4 100644 --- a/src/scheme-library.scm +++ b/src/scheme-library.scm @@ -17,8 +17,30 @@ ;; NUMBERS +; Type dispatch and promotion + +(define (type-dispatch ops x) + (if (flonum? x) + ((cdr ops) x) + ((car ops) x))) + +(define (promote-dispatch ops x y) + (if (flonum? x) + (if (flonum? y) + ((cdr ops) x y) + ((cdr ops) x (fixnum->flonum y))) + (if (flonum? y) + ((cdr ops) (fixnum->flonum x) y) + ((car ops) x y)))) + ; Unary ops +(define (neg x) + (type-dispatch (cons fix:neg flo:neg) x)) + +(define (abs x) + (type-dispatch (cons fix:abs flo:abs) x)) + (define (flo:1+ x) (flo:+ x 1.0)) (define (flo:1- x) (flo:- x 1.0)) @@ -40,22 +62,6 @@ (define (truncate x) (apply-to-flonum flo:truncate x)) -; Type dispatch and promotion - -(define (type-dispatch ops x) - (if (flonum? x) - ((cdr ops) x) - ((car ops) x))) - -(define (promote-dispatch ops x y) - (if (flonum? x) - (if (flonum? y) - ((cdr ops) x y) - ((cdr ops) x (fixnum->flonum y))) - (if (flonum? y) - ((cdr ops) (fixnum->flonum x) y) - ((car ops) x y)))) - ; Binary operations (define (fix:/ x y) ; Non-standard definition while we don't have rationals @@ -74,9 +80,6 @@ (define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y)) (define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y)) -(define (neg x) - (type-dispatch (cons fix:neg flo:neg) x)) - (define (null? arg) (eq? arg '())) diff --git a/src/scheme-primitives.4th b/src/scheme-primitives.4th index 8bcbb97..5ec154b 100644 --- a/src/scheme-primitives.4th +++ b/src/scheme-primitives.4th @@ -219,6 +219,11 @@ swap negate swap ; 1 make-fa-primitive fix:neg +:noname ( fixnum -- -fixnum ) + swap abs swap +; 1 make-fa-primitive fix:abs + + ( Find the GCD of n1 and n2 where n2 < n1. ) : gcd ( n1 n2 -- m ) -- 2.20.1