X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme-library.scm;h=14aa6f89d619553bc1c0e21c34db0633e1c31e22;hb=bc2450b4b29d6bb8ba5422fb9eb7a75d1b6b5a57;hp=484f500efaa87092da9fa0f3e8097fe64a975a50;hpb=a39894e12a9e84a17411e3bdd5d49fae3369e0d4;p=scheme.forth.jl.git

diff --git a/src/scheme-library.scm b/src/scheme-library.scm
index 484f500..14aa6f8 100644
--- a/src/scheme-library.scm
+++ b/src/scheme-library.scm
@@ -2,10 +2,11 @@
 ;; Standard Library Procedures and Macros ;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;; LISTS
+;; MISC
+
+(define (not x) (if x #f #t))
 
-(define (null? args)
-  (eq? args ()))
+(define (list . args) args)
 
 (define (caar l) (car (car l)))
 (define (cadr l) (car (cdr l)))
@@ -13,12 +14,196 @@
 (define (cddr l) (cdr (cdr l)))
 (define (cadar l) (car (cdr (car l))))
 
+
+;; NUMBERS
+
+; Rational primitives
+
+(define (numerator x)
+  (if (ratnum? x)
+    (rat:numerator x)
+    x))
+
+(define (denominator x)
+  (if (ratnum? x)
+    (rat:denominator x)
+    (if (fixnum? x)
+      1
+      1.0)))
+
+(define (rat:+ x y)
+  (make-rational (fix:+ (fix:* (numerator x) (denominator y))
+                        (fix:* (denominator x) (numerator y)))
+                 (fix:* (denominator x) (denominator y))))
+
+(define (rat:- x y)
+  (make-rational (fix:- (fix:* (numerator x) (denominator y))
+                        (fix:* (denominator x) (numerator y)))
+                 (fix:* (denominator x) (denominator y))))
+
+(define (rat:* x y)
+  (make-rational (fix:* (numerator x) (numerator y))
+                 (fix:* (denominator x) (denominator y))))
+
+(define (rat:/ x y)
+  (make-rational (fix:* (numerator x) (denominator y))
+                 (fix:* (denominator x) (numerator y))))
+
+(define (rat:1/ x)
+  (make-rational (denominator x) (numerator 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))))
+
+; 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))
+
+(define (1+ n)
+  (type-dispatch (cons fix:1+ flo:1+) n))
+
+(define (1- n)
+  (type-dispatch (cons fix:1- flo:1-) n))
+
+(define (apply-to-flonum op x)
+  (if (flonum? x) (op x) x))
+
+(define (round x)
+  (apply-to-flonum flo:round x))
+(define (floor x)
+  (apply-to-flonum flo:floor x))
+(define (ceiling x)
+  (apply-to-flonum flo:ceiling x))
+(define (truncate x)
+  (apply-to-flonum flo:truncate x))
+
+; Binary operations
+
+(define (fix:/ x y) ; Non-standard definition while we don't have rationals
+  (if (fix:= 0 (fix:remainder x y))
+    (fix:quotient x y)
+    (flo:/ (fixnum->flonum x) (fixnum->flonum y))))
+
+(define (pair+ x y) (promote-dispatch (cons fix:+ flo:+) x y))
+(define (pair- x y) (promote-dispatch (cons fix:- flo:-) x y))
+(define (pair* x y) (promote-dispatch (cons fix:* flo:*) x y))
+(define (pair/ x y) (promote-dispatch (cons fix:/ flo:/) x y))
+
+(define (pair> x y) (promote-dispatch (cons fix:> flo:>) x y))
+(define (pair< x y) (promote-dispatch (cons fix:< flo:<) x y))
+(define (pair>= x y) (promote-dispatch (cons fix:>= flo:>=) x y))
+(define (pair<= x y) (promote-dispatch (cons fix:<= flo:<=) x y))
+(define (pair= x y) (promote-dispatch (cons fix:= flo:=) x y))
+
+(define (null? arg)
+  (eq? arg '()))
+
+(define (fold-left proc init l)
+  (if (null? l)
+    init
+    (fold-left proc (proc init (car l)) (cdr l))))
+
+(define (reduce-left proc init l)
+  (if (null? l)
+    init
+    (if (null? (cdr l))
+      (car l)
+      (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l))))))
+
+(define (+ . args)
+  (fold-left pair+ 0 args))
+
+(define (- first . rest)
+  (if (null? rest)
+    (neg first)
+    (pair- first (apply + rest))))
+
+(define (* . args)
+  (fold-left pair* 1 args))
+
+(define (/ first . rest)
+  (if (null? rest)
+    (pair/ 1 first)
+    (pair/ first (apply * rest))))
+
+(define (quotient n1 n2)
+  (fix:quotient n1 n2))
+
+(define (remainder n1 n2)
+  (fix:remainder n1 n2))
+
+(define modulo remainder)
+
+; Relations
+
+(define (test-relation rel l)
+  (if (null? l)
+    #t
+    (if (null? (cdr l))
+      #t
+      (if (rel (car l) (car (cdr l)))
+        (test-relation rel (cdr l))
+        #f))))
+
+(define (= . args)
+  (test-relation pair= args))
+
+(define (> . args)
+  (test-relation pair> args))
+
+(define (< . args)
+  (test-relation pair< args))
+
+(define (>= . args)
+  (test-relation pair>= args))
+
+(define (<= . args)
+  (test-relation pair<= args))
+
+; Numeric tests 
+
+(define (zero? x) (pair= x 0.0))
+(define (positive x) (pair> x 0.0))
+(define (odd? n) (pair= (remainder n 2) 0))
+(define (odd? n) (not (pair= (remainder n 2) 0)))
+
+
+; Current state of the numerical tower
+(define (complex? x) #f)
+(define (real? x) #t)
+(define (rational? x) #t)
+(define (integer? x) (= x (round x)))
+(define (exact? x) (fixnum? x))
+(define (inexact? x) (flonum? x))
+
+;; LISTS
+
 ; Return number of items in list
 (define (length l)
   (define (iter a count)
     (if (null? a)
       count
-      (iter (cdr a) (+ count 1))))
+      (iter (cdr a) (fix:+ count 1))))
   (iter l 0))
 
 ; Join two lists together
@@ -145,15 +330,42 @@
 (define (sum n)
 
   (define (sum-iter total count maxcount)
-    (if (> count maxcount)
+    (if (fix:> count maxcount)
       total
-      (sum-iter (+ total count) (+ count 1) maxcount)))
+      (sum-iter (fix:+ total count) (fix:+ count 1) maxcount)))
   
   (sum-iter 0 1 n))
 
 ; Recursive summation. Use this to compare with tail call
 ; optimized iterative algorithm.
 (define (sum-recurse n)
-  (if (= n 0)
+  (if (fix:= n 0)
     0
-    (+ n (sum-recurse (- n 1)))))
+    (fix:+ n (sum-recurse (fix:- n 1)))))
+
+;; MISC
+
+(define (license)
+  (display
+"This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 3 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program. If not, see http://www.gnu.org/licenses/.
+"))
+
+(define (welcome)
+  (display
+"Welcome to scheme.forth.jl!
+
+Copyright (C) 2016 Tim Vaughan.
+This program comes with ABSOLUTELY NO WARRANTY; for details type '(license)'.
+Use Ctrl-D to exit.
+"))