From: Tim Vaughan <tgvaughan@gmail.com>
Date: Fri, 16 Dec 2016 11:20:42 +0000 (+1300)
Subject: Can now make it through first chapter of SICP.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=613b910f0ceb0ec0948a0e0595cd3e82086754cf;p=scheme.forth.jl.git

Can now make it through first chapter of SICP.
---

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 )