heist 0.1.0 → 0.2.0

data/lib/runtime/stackless.rb

@@ -1,7 +1,26 @@
 module Heist
   class Runtime
     
+    # The +Stackless+ class provides a faster execution model than +Stack+,
+    # as it does not provide fine-grained enough escape points to allow
+    # fully for continuations. Continuations aside, +Stackless+ supports
+    # all the same language features as +Stack+, including using a
+    # trampoline to implement tail call optimisation.
     class Stackless
+
+      # Returns the result of evaluating the +Expression+ in the given
+      # +Frame+ object. This API probably looks a little weird; it's like
+      # this for consistency with the +Stack+ API so the two can be used
+      # interchangeably without changing the implementation of
+      # <tt>Expression#eval</tt>.
+      #
+      # The expression is evaluated by repeatedly calling <tt>Function</tt>s
+      # until a concrete value is returned. Calling a Scheme procedure
+      # returns a +Body+ object that binds its body to the +Scope+ created
+      # by calling the procedure. As functions do not evaluate themselves
+      # we can turn what would be a recursive process into an iterative
+      # one and optimise tail calls. This technique is known as trampolining.
+      #
       def <<(frame)
         @current = frame
         @current = process! while incomplete?
@@ -10,35 +29,58 @@ module Heist
       
     private
       
+      # Process the current +Frame+ or +Body+ on the top of the stack. This
+      # method processes one such object for each call, and we call it
+      # iteratively until the value of <tt>@current</tt> is a concrete value.
+      #
+      # The result of calling a +Function+ (or one of its subclasses) will be
+      # a value (for primitives), a +Body+ or a +Frame+, or a <tt>Macro::Expansion</tt>.
+      # Functions return their bodies rather than evaluating themselves to
+      # allow for trampolining.
+      #
       def process!
         expression, scope = @current.expression,
                             @current.scope
         
+        # For function bodies, evaluate all but the last expression and
+        # return the last expression (the tail call) as a new stack frame
         if Body === @current
-          expression[0...-1].each { |expr| Heist.evaluate(expr, scope) }
-          return Frame.new(expression.last, scope)
+          limit = expression.size - 1
+          expression.each_with_index do |expr, i|
+            return Frame.new(expr, scope) if i == limit
+            Heist.evaluate(expr, scope)
+          end
         end
         
+        # Handle single-expression stack frames
         case expression
         
-          when List then
-            first = Heist.evaluate(expression.first, scope)
+          # If the expression is a list, evaluate the first element and
+          # call the resulting function with the rest of the list
+          when Cons then
+            first = !expression.null? && Heist.evaluate(expression.car, scope)
             raise SyntaxError.new("Invalid expression: #{expression}") unless Function === first
-            
-            value = first.call(scope, expression.rest)
+            value = first.call(scope, expression.cdr)
             return value unless Macro::Expansion === value
             
+            # If the return value is a macro expansion, inline it and
+            # set the expansion up as the next stack frame to run
             expression.replace(value.expression)
             return Frame.new(value.expression, scope)
         
+          # If the expression is an identifier, look up its value in
+          # the current scope
           when Identifier then
             scope[expression]
         
+          # Otherwise, assume the expression is data and return it
           else
             expression
         end
       end
       
+      # Returns +true+ if the current computation is incomplete, that is the
+      # value of <tt>@current</tt> is an expression rather than a value.
       def incomplete?
         (Frame === @current) or (Binding === @current)
       end

data/test/arithmetic.scm

@@ -10,7 +10,7 @@
 (assert-equal 8     (expt 2 3))
 (assert-equal 2     (expt 4 1/2))
 
-(define (sqrt x)
+(define (test-sqrt x)
   (define (square x)
     (* x x))
   (define (average x y)
@@ -25,7 +25,7 @@
         (sqrt-iter (improve guess))))
   (sqrt-iter 1.0))
 
-(assert (< (abs (- (sqrt 9) 3)) 0.0001))
+(assert (< (abs (- (test-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))
@@ -42,6 +42,10 @@
 (assert-equal 288 (lcm 32 -36))
 (assert-equal 288.0 (lcm 32.0 -36)) ; inexact
 
+(assert-equal 3 (numerator (/ 6 4)))
+(assert-equal 2 (denominator (/ 6 4)))
+; (assert-equal 2.0 (denominator (exact->inexact (/ 6 4)))) TODO implement this
+
 (assert-equal -5.0 (floor -4.3))
 (assert-equal -4.0 (ceiling -4.3))
 (assert-equal -4.0 (truncate -4.3))
@@ -55,3 +59,8 @@
 (assert-equal 4 (round 7/2)) ; exact
 (assert-equal 7 (round 7))
 
+(assert-equal 4 (real-part 4+3i))
+(assert-equal 3 (imag-part 4+3i))
+(assert-equal 5 (magnitude 4+3i))
+(assert-equal 4 (magnitude 4))
+

data/test/continuations.scm

@@ -1,5 +1,5 @@
-(define r)
-(define value)
+(define r #f)
+(define value #f)
 
 ; call/cc returning normally
 (set! value (+ 3 (call/cc (lambda (k) (+ 2 7)))))
@@ -142,3 +142,17 @@
 (r 3)
 (assert-equal 20 value)
 
+; continuations should work inside loops
+(set! value (do ((y 10)
+                 (acc 1 (* y acc)))
+                ((= y 1) acc)
+                (set! y (call/cc (lambda (k)
+                                   (set! r k)
+                                   (- y 1))))))
+(r 1)
+(assert-equal 362880 value)
+(r 2)
+(assert-equal 725760 value)
+(r 3)
+(assert-equal 4354560 value)
+

data/test/equivalence.scm

@@ -0,0 +1,34 @@
+(assert (eqv? #t #t))
+(assert (eqv? #f #f))
+(assert (not (eqv? #t #f)))
+
+(assert (symbol? 'foo))
+(assert (eqv? 'foo 'foo))
+(assert (not (eqv? 'foo 'bar)))
+
+(assert (eqv? 42 42))
+(assert (not (eqv? 42 #f)))
+(assert (not (eqv? 42 42.0)))
+
+(assert (eqv? '() '()))
+(assert (not (eqv? '(1 2) '(1 2))))
+(assert (not (eqv? '() '(1 2))))
+
+(assert (eqv? ceil ceiling))
+
+
+; From http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_idx_210
+
+(define gen-counter
+  (lambda ()
+    (let ((n 0))
+      (lambda () (set! n (+ n 1)) n))))
+
+(assert (let ((g (gen-counter)))
+          (eqv? g g)))
+
+(assert (not (eqv? (gen-counter) (gen-counter))))
+
+(assert (let ((x '(a)))
+          (eqv? x x)))
+

data/test/functional.scm

@@ -0,0 +1,4 @@
+(assert-equal 10 (apply + '(1 2 3 4)))
+(assert-equal '(1 4 9 16) (map (lambda (x) (* x x)) '(1 2 3 4)))
+(assert-equal '(5 7 9) (map + '(1 2 3) '(4 5 6)))
+

data/test/lists.scm

@@ -0,0 +1,78 @@
+(assert (eqv? '() '()))
+(assert (not (eqv? '(5) '(5))))
+
+(assert (null? '()))
+(assert (list? '()))
+(assert (not (pair? '())))
+
+(define foo-list (list (+ 3 2) (* 4 5) 6))
+(assert (not (eqv? '(5 20 6) foo-list)))
+(assert (equal? '(5 20 6) foo-list))
+
+(define bar-list (cons 12 foo-list))
+(assert (equal? '(12 5 20 6) bar-list))
+(assert (equal? '(5 20 6) foo-list))
+(assert-equal 4 (length bar-list))
+(assert-equal 3 (length foo-list))
+
+(assert-equal 5 (car foo-list))
+(assert-equal '(20 6) (cdr foo-list))
+(assert-equal 20 (cadr foo-list))
+(assert-equal 6 (caddr foo-list))
+
+(define eggman '(you (walrus (hurt the) one) ((you) love)))
+(assert-equal '(hurt the) (cadadr eggman))
+
+(assert (null? (cdddr eggman)))
+(assert (null? '()))
+(assert (list? eggman))
+(assert (pair? eggman))
+(assert (not (null? eggman)))
+
+(define my-pair (cons 'foo 'bar))
+(assert (pair? my-pair))
+(assert (not (list? my-pair)))
+(assert (not (null? my-pair)))
+
+(set-car! my-pair 27)
+(set-cdr! my-pair (cons 64 '()))
+(assert (list? my-pair))
+(assert (equal? '(27 64) my-pair))
+(assert-equal 2 (length my-pair))
+
+(define (f) (list 'not-a-constant-list))
+(define (g) '(constant-list))
+(assert-equal 3 (set-car! (f) 3))
+(assert-raise ImmutableError (set-car! (g) 3))
+
+(assert-raise SyntaxError ())
+(assert-raise SyntaxError (1 2 3))
+
+(assert-equal (cons 1 2) '(1 . 2))
+(assert-equal (cons 1 (cons 2 3)) '(1 2 . 3))
+
+(assert-equal '(x y)        (append '(x) '(y)))
+(assert-equal '(a b c d)    (append '(a) '(b c d)))
+(assert-equal '(a (b) (c))  (append '(a (b)) '((c))))
+(assert-equal '(a b c . d)  (append '(a b) '(c . d)))
+(assert-equal 'a            (append '() 'a))
+
+(assert-equal '(4 3 2 1) (reverse '(1 2 3 4)))
+(assert-equal '(4 (3 5) 2 1) (reverse '(1 2 (3 5) 4)))
+
+(assert-equal '(3 4) (list-tail '(1 2 3 4) 2))
+
+(assert-equal '(a b c) (memq 'a '(a b c)))
+(assert-equal '(b c) (memq 'b '(a b c)))
+(assert-equal #f (memq 'a '(b c d)))
+(assert-equal #f       (memq   (list 'a) '(b (a) c)))
+(assert-equal '((a) c) (member (list 'a) '(b (a) c)))
+
+(define e '((a 1) (b 2) (c 3)))
+(assert-equal '(a 1) (assq 'a e))
+(assert-equal '(b 2) (assq 'b e))
+(assert-equal #f (assq 'd e))
+(assert-equal #f (assq (list 'a) '(((a)) ((b)) ((c)))))
+(assert-equal '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
+(assert-equal '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
+

data/test/macro-helpers.scm

@@ -7,6 +7,7 @@
 (define-syntax swap (syntax-rules ()
   [(swap x y)
     (let ([temp x])
+      (set! x temp)   ; Force evaluation of temp in lazy mode
       (set! x y)
       (set! y temp))]))
 

data/test/macros.scm

@@ -43,6 +43,34 @@
 
 (assert-equal 8 (dont-rename-else #f 6 8))
 
+; Check that keywords are ignored if locally bound
+; example from R6RS -- http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-14.html#node_sec_11.19
+(assert-equal 'ok (let ((=> #f))
+                    (cond (#t => 'ok))))
+
+; These tests come from tinkering with MZScheme
+(define-syntax keyword-detect (syntax-rules (word)
+  [(_ word) 'keyword]
+  [(_ data) 'data]))
+(assert-equal 'keyword (keyword-detect word))
+(assert-equal 'word (let ([word 4]) (keyword-detect word)))
+(define word 5)
+(assert-equal 'keyword (keyword-detect word))
+(define copy word)
+(assert-equal 'copy (keyword-detect copy))
+
+(define-syntax bad-keyword (syntax-rules (with)
+  [(_ with x)
+    `(,with ,x)]))
+
+(let ([with 16])
+  (assert-raise SyntaxError (bad-keyword with 1)))
+
+(assert-raise UndefinedVariable (bad-keyword with 2))
+
+(define with 16)
+(assert-equal '(16 3) (bad-keyword with 3))
+
 
 ; Test literal matching
 
@@ -55,6 +83,18 @@
 (assert-equal 3 (iffy 7 #f 3))
 
 
+; Test improper patterns
+(define-syntax rest (syntax-rules ()
+  [(_ foo bar . rest)
+    rest]))
+(assert-equal 10 (rest 4 5 + 3 7))
+(let-syntax ([foo (syntax-rules ()
+                    [(_ expr ...)
+                      (list expr ...)])])
+  (assert-equal '(1 2 3) (foo 1 2 3))
+  (assert-raise SyntaxError (foo 1 2 3 . 4)))
+
+
 ; Test input execution - example from R5RS
 
 (define-syntax my-or
@@ -105,6 +145,20 @@
 (assert-equal 13 (one-or-more (+ 2 4) (+ 3 8) (+ 7 6)))
 
 
+; Test that null lists terminators don't count as input
+
+(define-syntax table (syntax-rules ()
+  [(_)
+    '()]
+  [(_ key value rest ...)
+    (cons (cons key value) (table rest ...))]))
+
+(assert-equal (list (cons 1 2) (cons 3 4) (cons 5 6))
+              (table 1 2 3 4 5 6))
+
+(assert-raise SyntaxError (table 1 2 3))
+
+
 ; Test execution scope using (swap)
 (define a 4)
 (define b 7)
@@ -151,6 +205,7 @@
   (syntax-rules ()
     [(swap (x y))
       (let ([temp x])
+        (set! x temp)   ; Force temp in lazy mode
         (set! x y)
         (set! y temp))]))
 
@@ -301,6 +356,7 @@
     (triple-deep (((foo bar) (it)) ((wont) (matter really anyway)))
                  ((5 6) (2)) ((4) (8 7 2))))
 
+
 (define-syntax triple-deep2
   (syntax-rules ()
     [(_ (((name ...) ...) ...) ((value ...) ...) ...)
@@ -313,31 +369,62 @@
                  ((5 6)) ((4) (8 7 2))))
 
 
-; Really nasty nested repetition. PLT won't run this in its entirity
-; due to overuse of infix ellipses, but comparison output for
-; subsets of this macro can be seen in plt-macros.txt
+(define-syntax trial (syntax-rules (with)
+  [(_ ((with (value ...) ...) ...) obj ...)
+    '((obj ((value ...) (value value) ...) ... (obj obj)) ...)]))
+
+(assert-equal '((bar ((4 2 7) (4 4) (2 2) (7 7)) (bar bar)))
+              (trial ((with (4 2 7))) bar))
+(assert-equal '((bar (bar bar)))
+              (trial ((with)) bar))
+(assert-raise MacroTemplateMismatch (trial () bar))
+
+
+(define-syntax trial2 (syntax-rules (with)
+  [(_ (with (value ...) ...) ... obj ...)
+    '((obj ((value ...) (value value) ...) ... (obj obj)) ...)]))
 
-(define-syntax convoluted
-  (syntax-rules (with)
-    [(_ (with (value ...) ...) ... thing ((name ...) ...) obj ...)
-      '((obj ((value ...) (value value) ...) ... (obj obj)) ...
-        (((name name) ... obj obj (obj (name ...))) ...))]))
+(assert-equal '((foo ((a) (a a)) (foo foo))
+                (bar (bar bar)))
+    (trial2 (with (a)) (with) foo bar))
 
-(assert-equal '((foo ((a u) (a a) (u u)) ((j e n k l) (j j) (e e) (n n) (k k) (l l))
-                     (()) ((q c y n) (q q) (c c) (y y) (n n)) (foo foo))
+(assert-equal '((foo ((a) (a a)) (foo foo))
                 (bar (bar bar))
-                (baz ((b) (b b)) ((d f) (d d) (f f)) (baz baz))
-                (what ((k l e) (k k) (l l) (e e)) ((s) (s s)) ((u n) (u u) (n n))
-                      ((f i k w) (f f) (i i) (k k) (w w)) ((p) (p p)) (what what))
-                      (((8 8) (3 3) (2 2) (9 9) foo foo (foo (8 3 2 9)))
-                       ((2 2) (3 3) bar bar (bar (2 3)))
-                       ((1 1) (0 0) (4 4) baz baz (baz (1 0 4)))
-                       ((8 8) (3 3) (2 2) (1 1) (7 7) what what (what (8 3 2 1 7)))))
-    (convoluted (with (a u) (j e n k l) () (q c y n)) (with)
-                (with (b) (d f)) (with (k l e) (s) (u n) (f i k w) (p))
-                thing ((8 3 2 9) (2 3) (1 0 4) (8 3 2 1 7))
-                foo bar baz what))
-
-(assert-raise MacroTemplateMismatch (convoluted (with (a)) (with (b)) thing () foo))
-(assert-raise SyntaxError (convoluted nothing))
+                (baz ((1 2 3) (1 1) (2 2) (3 3)) (baz baz)))
+    (trial2 (with (a)) (with) (with (1 2 3)) foo bar baz))
+
+
+; Test nested macros with keywords and nested splices
+; http://fabiokung.com/2007/10/24/ruby-dsl-to-describe-automata/
+
+(define-syntax automaton (syntax-rules (:)
+  [(_ init-state
+      [state : response ...]
+      ...)
+    (let-syntax ([process-state (syntax-rules (-> accept)
+                    [(_ accept)
+                      (lambda (stream)
+                        (cond [(null? stream) #t]
+                              [else #f]))]
+                    [(... (_ (label -> target) ...))
+                      (lambda (stream)
+                        (cond [(null? stream) #f]
+                              [else (case (car stream)
+                                      [(label) (target (cdr stream))]
+                                      (... ...)
+                                      [else #f])]))])])
+      (letrec ([state (process-state response ...)]
+               ...)
+        init-state))]))
+
+(define cdar-sequence?
+  (automaton init
+             [init : (c -> more)]
+             [more : (a -> more)
+                     (d -> more)
+                     (r -> end)]
+             [end : accept]))
+
+(assert (cdar-sequence? '(c a d a d r)))
+(assert (not (cdar-sequence? '(a c a d r c))))