heist 0.1.0

data/lib/runtime/stack.rb

@@ -0,0 +1,60 @@
+module Heist
+  class Runtime
+    
+    class Stack < Array
+      attr_reader :value
+      
+      def <<(frame)
+        super
+        clear!(size - 1)
+      end
+      
+      def copy(keep_last = true)
+        copy = self.class.new
+        range = keep_last ? 0..-1 : 0...-1
+        self[range].each do |frame|
+          copy[copy.size] = frame.dup
+        end
+        copy
+      end
+      
+      def fill!(subexpr, value)
+        return self[size] = value if Frame === value
+        return @value = value if empty?
+        last.fill!(subexpr, value)
+      end
+      
+      def clear!(limit = 0)
+        process! while size > limit
+        @value
+      rescue Exception => ex
+        restack!
+        raise ex
+      end
+      
+      def value=(value)
+        @value  = value
+        @unwind = (Stack === @value)
+        @tail   = (Frame === @value)
+        restack!(value) if @unwind
+      end
+      
+    private
+      
+      def process!
+        self.value = last.process!
+        return if empty? or @unwind or not last.complete?
+        @value.replaces(last.target) if @tail
+        fill!(pop.target, @value)
+      end
+      
+      def restack!(stack = [])
+        pop while not empty?
+        stack.each_with_index { |frame, i| self[i] = frame }
+        @value = stack.value if Stack === stack
+      end
+    end
+    
+  end
+end
+

data/lib/runtime/stackless.rb

@@ -0,0 +1,49 @@
+module Heist
+  class Runtime
+    
+    class Stackless
+      def <<(frame)
+        @current = frame
+        @current = process! while incomplete?
+        @current
+      end
+      
+    private
+      
+      def process!
+        expression, scope = @current.expression,
+                            @current.scope
+        
+        if Body === @current
+          expression[0...-1].each { |expr| Heist.evaluate(expr, scope) }
+          return Frame.new(expression.last, scope)
+        end
+        
+        case expression
+        
+          when List then
+            first = Heist.evaluate(expression.first, scope)
+            raise SyntaxError.new("Invalid expression: #{expression}") unless Function === first
+            
+            value = first.call(scope, expression.rest)
+            return value unless Macro::Expansion === value
+            
+            expression.replace(value.expression)
+            return Frame.new(value.expression, scope)
+        
+          when Identifier then
+            scope[expression]
+        
+          else
+            expression
+        end
+      end
+      
+      def incomplete?
+        (Frame === @current) or (Binding === @current)
+      end
+    end
+    
+  end
+end
+

data/lib/stdlib/benchmark.scm

@@ -0,0 +1,12 @@
+(define benchmark (lambda (n fn)
+  (begin
+    (define start (runtime))
+    (define iter (lambda (n)
+      (begin
+        (if (> n 0)
+            (begin (fn)
+                   (iter (- n 1)))))))
+    (iter n)
+    (display (+ n " iterations: " (- (runtime) start)))
+    (newline))))
+

data/lib/stdlib/birdhouse.scm

@@ -0,0 +1,82 @@
+; A library of combinators, partly inspired by Raymond
+; Smullyan's "To Mock A Mockingbird".
+; 
+; http://en.wikipedia.org/wiki/To_Mock_a_Mockingbird
+; 
+; Each bird is a higher-order function that takes a single
+; function as input and returns a function.
+; 
+; A bird A 'is fond of' bird B if AB = B, that is to say
+; that B is the fixed point of A such that YA = B.
+; 
+; Rule C1: for any pair of birds (A,B) there is some bird
+; C that composes them such that Cf = A(Bf) for all f.
+; 
+; Rule C2: there exists a Mockingbird M where Mf = ff.
+; 
+; These can be used to show every higher-order function
+; has at least one fixed point:
+; 
+;   * For any A there is a C where Cf = A(Mf) for all f
+; 
+;     Cf = A(Mf) for all f. Let f = C
+;     -> CC = A(MC) = A(CC) -> A is fond of CC
+; 
+; If C composes A and M, CC is a fixed point of A and
+; therefore YA = CC = MC where Cf = A(Mf) for all f.
+; 
+; Instead of rule C2, assume this:
+; 
+; Rule C3: a bird is said to be 'agreeable' if, for every
+; other bird B, there exists an f such that Af = Bf.
+; We are given that there exists an agreeable bird A.
+; 
+;   * C1: For any y there exists H such that Hf = y(Af) for all f
+;   * C3: A must agree with H for some input x
+;   * Let f = x
+; 
+;   -> Hx = y(Ax), and Hx = Ax -> y(Ax) = Ax
+; 
+; So any bird y is fond of Ax where A is the agreeable
+; bird, Ax = Hx and H composes y with A.
+
+; B combinator (Bluebird) -- Bfgh = f(gh)
+; Returns a function that composes two others (rule C1)
+(define (B f)
+  (lambda (g)
+    (lambda (h)
+      (f (g h)))))
+
+; M combinator (Mockingbird) -- Mf = ff
+; Returns a function's response to itself (rule C2)
+(define (M f) (f f))
+
+; K combinator (Kestrel) -- Kfg = f
+; Returns its first input
+(define (K f)
+  (lambda (g)
+    (begin g f)))
+
+; Y combinator -- Yf = MC = M(BfM)
+; Returns fixed points of higher order functions, that
+; is to say Yf = f(Yf). It's often used to implement
+; anonymous recursion.
+; 
+; Interestingly, using a lazy evaluator you can write
+; this simply as
+; 
+;     (define (Y f)
+;       (f (Y f)))
+; 
+; and it will work correctly. The following form assumes
+; lazy evaluation but is expressed in terms of results
+; derived above. If using applicative order, the following
+; form should be used:
+; 
+;     (define (Y f)
+;       (M (lambda (g)
+;           (lambda (h)
+;             ((((B f) M) g) h)))))
+(define (Y f)
+  (M ((B f) M)))
+

data/test/arithmetic.scm

@@ -0,0 +1,57 @@
+(assert-equal 486   (+ 137 349))
+(assert-equal 666   (- 1000 334))
+(assert-equal 495   (* 5 99))
+(assert-equal 2     (/ 10 5))
+(assert-equal 12.7  (+ 2.7 10))
+(assert-equal 75    (+ 21 35 12 7))
+(assert-equal 1200  (* 25 4 12))
+(assert-equal 19    (+ (* 3 5) (- 10 6)))
+(assert-equal 57    (+ (* 3 (+ (* 2 4) (+ 3 5))) (+ (- 10 7) 6)))
+(assert-equal 8     (expt 2 3))
+(assert-equal 2     (expt 4 1/2))
+
+(define (sqrt x)
+  (define (square x)
+    (* x x))
+  (define (average x y)
+    (/ (+ x y) 2))
+  (define (good-enough? guess)
+    (< (abs (- (square guess) x)) 0.001))
+  (define (improve guess)
+    (average guess (/ x guess)))
+  (define (sqrt-iter guess)
+    (if (good-enough? guess)
+        guess
+        (sqrt-iter (improve guess))))
+  (sqrt-iter 1.0))
+
+(assert (< (abs (- (sqrt 9) 3)) 0.0001))
+
+; http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_idx_288
+(assert-equal 1 (modulo 13 4))
+(assert-equal 1 (remainder 13 4))
+(assert-equal 3 (modulo -13 4))
+(assert-equal -1 (remainder -13 4))
+(assert-equal -3 (modulo 13 -4))
+(assert-equal 1 (remainder 13 -4))
+(assert-equal -1 (modulo -13 -4))
+(assert-equal -1 (remainder -13 -4))
+(assert-equal -1.0 (remainder -13 -4.0)) ; inexact
+
+(assert-equal 4 (gcd 32 -36))
+(assert-equal 288 (lcm 32 -36))
+(assert-equal 288.0 (lcm 32.0 -36)) ; inexact
+
+(assert-equal -5.0 (floor -4.3))
+(assert-equal -4.0 (ceiling -4.3))
+(assert-equal -4.0 (truncate -4.3))
+(assert-equal -4.0 (round -4.3))
+
+(assert-equal 3.0 (floor 3.5))
+(assert-equal 4.0 (ceiling 3.5))
+(assert-equal 3.0 (truncate 3.5))
+(assert-equal 4.0 (round 3.5)) ; inexact
+
+(assert-equal 4 (round 7/2)) ; exact
+(assert-equal 7 (round 7))
+

data/test/benchmarks.scm

@@ -0,0 +1,27 @@
+(load "benchmark")
+
+(define-syntax swap
+  (syntax-rules ()
+    [(swap x y)
+      (let ([temp x])
+        (set! x y)
+        (set! y temp))]))
+
+(define-syntax rotate
+  (syntax-rules ()
+    [(rotate x y)
+      (swap x y)]
+    [(rotate x y z ...)
+      (begin
+        (swap x y)
+        (rotate y z ...))]))
+
+(define-syntax p-let
+  (syntax-rules ()
+    [(p-let (name ...) (value ...) body ...)
+      (let ([name value] ...)
+        body ...)]))
+
+(p-let (a b c d e) (1 2 3 4 5)
+  (benchmark 50 (lambda () (rotate a b c d e))))
+      

data/test/booleans.scm

@@ -0,0 +1,6 @@
+(assert (boolean? #t))
+(assert (not (boolean? "Hello, World!")))
+(assert (not #f))
+(assert (not (not #t)))
+(assert (not (not "Hello, World!")))
+

data/test/closures.scm

@@ -0,0 +1,16 @@
+(define (add n)
+  (lambda (x) (+ x n)))
+      
+(define add4 (add 4))
+(define add7 (add 7))
+
+(assert-equal 15 (add4 11))
+    
+(define (weird x y)
+  (begin
+    (define (+ x y)
+      (* x y))
+    (+ x y)))
+(assert-equal 7 (+ 3 4))
+(assert-equal 12 (weird 3 4))
+

data/test/conditionals.scm

@@ -0,0 +1,55 @@
+(define (abs x)
+  (cond ((> x 0) x)
+        ((= x 0) (define zero 0) zero)
+        ((< x 0) (- x))))
+
+(assert-equal 4 (abs 4))
+(assert-equal 0 (abs 0))
+(assert-equal 13 (abs -13))
+
+(define (abs x)
+  (cond ((< x 0) (- x))
+        (else x)))
+
+(assert-equal 4 (abs 4))
+(assert-equal 0 (abs 0))
+(assert-equal 13 (abs -13))
+
+(define (abs x)
+  (if (< x 0)
+      (- x)
+      x))
+
+(assert-equal 4 (abs 4))
+(assert-equal 0 (abs 0))
+(assert-equal 13 (abs -13))
+
+(define (a-plus-abs-b a b)
+  ((if (> b 0) + -) a b))
+    
+(assert-equal 7 (a-plus-abs-b 3 4))
+(assert-equal 11 (a-plus-abs-b 3 (- 8)))
+
+(define (fact x)
+  (if (= x 0)
+    1
+    (* x
+      (fact (- x 1)))))
+
+(assert-equal 720 (fact 6))
+
+(define x 7)
+(assert-equal #t (and (> x 5) (<= x 10)))
+(assert-equal #t (or (>= x 5) (< x 3)))
+
+(assert-equal 720 (cond ((- 9 3) => fact)))
+
+(assert-equal 'composite (case (* 2 3)
+  ((2 3 5 7) 'prime)
+  ((1 4 6 8 9) 'composite)))
+
+(assert-equal 'consonant (case 'c
+  ((a e i o u) 'vowel)
+  ((w y) 'semivowel)
+  (else 'consonant)))
+

data/test/continuations.scm

@@ -0,0 +1,144 @@
+(define r)
+(define value)
+
+; call/cc returning normally
+(set! value (+ 3 (call/cc (lambda (k) (+ 2 7)))))
+(assert-equal 12 value)
+
+; calling the continuation abandons the current expression
+(set! value (+ 3 (call/cc
+                    (lambda (k)
+                      (set! r k)
+                      (+ 2 (k 7))))))
+(assert-equal 10 value)
+
+; calling a stored continuation aborts the current stack
+(define called #f)
+(begin
+  (r 5)
+  (set! called #t))
+(assert (not called))
+
+; calling call/cc does not unwind the stack
+(begin
+  (call/cc (lambda (k) 3))
+  (set! called #t))
+(assert called)
+
+; expressions before the call/cc have their values fixed
+(define y 2)
+(set! value (+ 1 y (call/cc
+                      (lambda (k)
+                        (set! r k)
+                        (k 1)))))
+(assert-equal 4 value)
+(set! y 5)
+(r 3)
+(assert-equal 6 value)
+
+; expressions after the call/cc are re-evaluated
+(set! y 2)
+(set! value (+ 1 (call/cc
+                    (lambda (k)
+                      (set! r k)
+                      (k 1)))
+                 y))
+(assert-equal 4 value)
+(set! y 5)
+(r 3)
+(assert-equal 9 value)
+
+; more checks for re-evaluation
+(define count-calls 0)
+(begin
+  (set! count-calls (+ count-calls 1))
+  (call/cc
+    (lambda (k)
+      (set! r k)
+      4)))
+(r #t) (r #t) (r #t)
+(assert-equal 1 count-calls)
+(begin
+  (call/cc
+    (lambda (k)
+      (set! r k)
+      4))
+  (set! count-calls (+ count-calls 1)))
+(r #t) (r #t) (r #t)
+(assert-equal 5 count-calls)
+
+; multiple call/cc in the same expression
+; http://sanjaypande.blogspot.com/2004/06/understanding-scheme-continuations.html
+
+(define r1 #f)
+(define r2 #f)
+
+(define (somefunc x y)
+  (+ (* 2 (expt x 2)) (* 3 y) 1))
+
+(set! value
+  (somefunc (call/cc
+               (lambda (c1)
+                 (set! r1 c1)
+                 (c1 1)))
+            (call/cc
+               (lambda (c2)
+                 (set! r2 c2)
+                 (c2 1)))))
+(assert-equal 6 value)
+(r1 5)
+(assert-equal 54 value)
+(r2 5)
+(assert-equal 66 value)
+
+; test that primitive values can be thrown into (if), (and)
+(set! value (if (call/cc
+                  (lambda (k)
+                    (set! r k)
+                    #t))
+                "bees"
+                "honey"))
+(r #t)
+(assert-equal "bees" value)
+(r #f)
+(assert-equal "honey" value)
+
+; test saving the continuation inside a function
+(define before 0)
+(define after 0)
+(define (foo)
+  (set! before (+ before 1))
+  (set! y (call/cc
+            (lambda (k)
+              (set! r k)
+              2)))
+  (set! after (+ after 1))
+  (+ 3 y))
+(set! value (* 5 (foo)))
+(assert-equal 25 value)
+(r 7)
+(assert-equal 50 value)
+(assert-equal 1 before)
+(assert-equal 2 after)
+
+; test integration with macros
+(define-syntax cc-macro
+  (syntax-rules ()
+    [(_ (name ...) (value ...) body ...)
+      (let ((name value) ...)
+        body ...)]))
+
+(define (call-macro)
+  (define not-tail #t)
+  (cc-macro (foo bar) (7 4)
+    (* bar (+ (call/cc
+                (lambda (k)
+                  (set! r k)
+                  foo))
+              foo))))
+(set! value (/ (call-macro)
+               2))
+(assert-equal 28 value)
+(r 3)
+(assert-equal 20 value)
+