Started porting metacircular evaluator from SICP.

[scheme.forth.jl.git] / src / scheme-library.scm

diff --git a/src/scheme-library.scm b/src/scheme-library.scm
index f8c0ec4..cd26932 100644 (file)
--- a/src/scheme-library.scm
+++ b/src/scheme-library.scm
@@ -13,10 +13,65 @@
 (define (cdar l) (cdr (car l)))
 (define (cddr l) (cdr (cdr l)))
 (define (cadar l) (car (cdr (car l))))
 (define (cdar l) (cdr (car l)))
 (define (cddr l) (cdr (cdr l)))
 (define (cadar l) (car (cdr (car l))))

+(define (caddr l) (car (cdr (cdr l))))
+(define (cadddr l) (car (cdr (cdr (cdr l)))))

 
 

+;; FUNCTIONAL PROGRAMMING
+
+(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 (map proc l)
+  (if (null? l)
+    '()
+    (cons (proc (car l)) (map proc (cdr l)))))

 
 ;; NUMBERS
 
 
 ;; 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)
 ; Type dispatch and promotion
 
 (define (type-dispatch ops x)


@@ -83,18 +138,6 @@
 (define (null? arg)
   (eq? arg '()))
 
 (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 (+ . args)
   (fold-left pair+ 0 args))
 


@@ -168,7 +211,7 @@
   (define (iter a count)
     (if (null? a)
       count
   (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
   (iter l 0))
 
 ; Join two lists together


@@ -295,15 +338,42 @@
 (define (sum n)
 
   (define (sum-iter total count maxcount)
 (define (sum n)
 
   (define (sum-iter total count maxcount)

-    (if (> count maxcount)
+    (if (fix:> count maxcount)

       total
       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)
   
   (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
     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.
+"))