more tests

cogs/coop/threads.scm

@@ -6,72 +6,70 @@
 
 ; current-continuation : -> continuation
 (define (current-continuation)
-  (call/cc
-   (lambda (cc)
-     (cc cc))))
+  (call/cc (lambda (cc) (cc cc))))
 
 ; spawn : (-> anything) -> void
 (define (spawn thunk)
-  (let ((cc (current-continuation)))
+  (let ([cc (current-continuation)])
     (if (continuation? cc)
         (set! *thread-queue* (append *thread-queue* (list cc)))
-        (begin 
-               (thunk)
-               (quit)))))
+        (begin
+          (thunk)
+          (quit)))))
 
 ; yield : value -> void
 (define (yield)
-  (let ((cc (current-continuation)))
+  (let ([cc (current-continuation)])
     (if (and (continuation? cc) (pair? *thread-queue*))
-        (let ((next-thread (car *thread-queue*)))
+        (let ([next-thread (car *thread-queue*)])
           (set! *thread-queue* (append (cdr *thread-queue*) (list cc)))
           (next-thread 'resume))
         void)))
 
 ; quit : -> ...
 (define (quit)
   (if (pair? *thread-queue*)
-      (let ((next-thread (car *thread-queue*)))
+      (let ([next-thread (car *thread-queue*)])
         (set! *thread-queue* (cdr *thread-queue*))
         (next-thread 'resume))
       (halt)))
-   
+
 ; start-threads : -> ...
 (define (start-threads)
-  (let ((cc (current-continuation)))
+  (let ([cc (current-continuation)])
     ; (displayln cc)
     (if cc
         (begin
-        ;   (displayln cc)
-          (set! halt (lambda () 
-                        ; (inspect-bytecode cc) 
-                        ; (displayln cc)
-                        (cc #f)))
-        ;   (displayln cc)
+          ; (displayln cc)
+          (set! halt
+                (lambda ()
+                  ; (inspect-bytecode cc)
+                  ; (displayln cc)
+                  (cc #f)))
+          ;   (displayln cc)
           (if (null? *thread-queue*)
               void
               (begin
-                (let ((next-thread (car *thread-queue*)))
+                (let ([next-thread (car *thread-queue*)])
                   (set! *thread-queue* (cdr *thread-queue*))
                   (next-thread 'resume)))))
         void)))
 
-
 ;; Example cooperatively threaded program
 (define counter 10)
 
 (define (make-thread-thunk name)
   (define (loop)
-        (when (< counter 0)
-            (quit))
-        (display "in thread ")
-        (display name)
-        (display "; counter = ")
-        (display counter)
-        (newline)
-        (set! counter (- counter 1))
-        (yield)
-        (loop))
+    (when (< counter 0)
+      (quit))
+    (display "in thread ")
+    (display name)
+    (display "; counter = ")
+    (display counter)
+    (newline)
+    (set! counter (- counter 1))
+    (yield)
+    (loop))
   loop)
 
 (spawn (make-thread-thunk 'a))

cogs/r5rs.scm

@@ -524,12 +524,15 @@
                      (set! y 3)
                      (list x y))))))
 
-(skip-compile
- (check-equal '(a b c)
+; (skip-compile
+(check-equal? "Dyanmic wind"
+              '(a b c)
               (let* ([path '()] [add (lambda (s) (set! path (cons s path)))])
                 (dynamic-wind (lambda () (add 'a)) (lambda () (add 'b)) (lambda () (add 'c)))
                 (reverse path)))
- (check-equal '(connect talk1 disconnect connect talk2 disconnect)
+
+(check-equal? "Dynamic wind more complex"
+              '(connect talk1 disconnect connect talk2 disconnect)
               (let ([path '()] [c #f])
                 (let ([add (lambda (s) (set! path (cons s path)))])
                   (dynamic-wind (lambda () (add 'connect))
@@ -539,17 +542,18 @@
                                                                          'talk1))))
                                 (lambda () (add 'disconnect)))
                   (if (< (length path) 4) (c 'talk2) (reverse path)))))
- ; (check-equal 2
- ;              (let-syntax ([foo (syntax-rules :::
- ;                                  []
- ;                                  [(foo ... args :::) (args ::: ...)])])
- ;                (foo 3 - 5)))
- ; (check-equal
- ;  '(5 4 1 2 3)
- ;  (let-syntax ([foo (syntax-rules ()
- ;                      [(foo args ... penultimate ultimate) (list ultimate penultimate args ...)])])
- ;    (foo 1 2 3 4 5)))
- )
+; (check-equal 2
+;              (let-syntax ([foo (syntax-rules :::
+;                                  []
+;                                  [(foo ... args :::) (args ::: ...)])])
+;                (foo 3 - 5)))
+; (check-equal
+;  '(5 4 1 2 3)
+;  (let-syntax ([foo (syntax-rules ()
+;                      [(foo args ... penultimate ultimate) (list ultimate penultimate args ...)])])
+;    (foo 1 2 3 4 5)))
+
+; )
 
 ;; -------------- Report ------------------
 

cogs/r7rs.scm

@@ -38,6 +38,38 @@
 (set-test-mode!)
 
 (require "lists/lists.scm")
+
+;;;; Parameters
+
+(define location (make-parameter "here"))
+
+(check-equal? "Simple parameterize"
+              "there"
+              (parameterize ([location "there"])
+                (location))) ;; "there"
+
+(check-equal? "parameter keeps original value" "here" (location)) ;; "here"
+
+(check-equal? "Parameter changes multiple times"
+              (list "in a house" "with a mouse" "in a house")
+              (parameterize ([location "in a house"])
+                (list (location)
+                      (parameterize ([location "with a mouse"])
+                        (location))
+                      (location)))) ;; '("in a house" "with a mouse" "in a house")
+
+(check-equal? "parameter keeps original value after" "here" (location)) ;; "here"
+
+(define (would-you-could-you?)
+  (and (not (equal? (location) "here")) (not (equal? (location) "there"))))
+
+(check-equal? "Parameters refer to the same location" #false (would-you-could-you?))
+
+(check-equal? "Parameters refer to the same location, changed to be the same"
+              #true
+              (parameterize ([location "on a bus"])
+                (would-you-could-you?)))
+
 (define r7rs-test-stats (get-test-stats))
 
 (displayln "Passed: " (hash-ref r7rs-test-stats 'success-count))

crates/steel-core/src/compiler/modules.rs

@@ -62,13 +62,17 @@ static MUTABLE_VECTORS_NAME: &str = "steel/mutable-vectors";
 static PRINTING: &str = include_str!("../scheme/print.scm");
 static PRINTING_NAME: &str = "#%private/steel/print";
 
+static DYNAMIC_WIND_NAME: &str = "#%private/steel/control";
+static DYNAMIC_WIND: &str = include_str!("../scheme/modules/parameters.scm");
+
 static BUILT_INS: &[(&str, &str)] = &[
     (OPTION_NAME, OPTION),
     (RESULT_NAME, RESULT),
     (CONTRACT_NAME, CONTRACT),
     (ITERATORS_NAME, ITERATORS),
     (MUTABLE_VECTORS_NAME, MUTABLE_VECTORS),
     (PRINTING_NAME, PRINTING),
+    (DYNAMIC_WIND_NAME, DYNAMIC_WIND),
 ];
 
 pub(crate) const MANGLER_SEPARATOR: &str = "__%#__";
@@ -2023,4 +2027,5 @@ impl<'a> ModuleBuilder<'a> {
 pub static PRELUDE_STRING: &str = "(require-builtin steel/base) 
 (require \"#%private/steel/contract\" (for-syntax \"#%private/steel/contract\"))
 (require \"#%private/steel/print\")
+(require \"#%private/steel/control\" (for-syntax \"#%private/steel/control\"))
 ";

crates/steel-core/src/scheme/modules/parameters.scm

@@ -0,0 +1,133 @@
+(provide dynamic-wind
+         (for-syntax parameterize)
+         call/cc
+         call-with-current-continuation
+         make-parameter
+         continuation?)
+
+(define winders '())
+
+(define list-tail drop)
+
+(struct Pair (left right))
+
+(define common-tail
+  (lambda (x y)
+    (let ([lx (length x)] [ly (length y)])
+      (let loop ([x (if (> lx ly) (list-tail x (- lx ly)) x)]
+                 [y (if (> ly lx) (list-tail y (- ly lx)) y)])
+
+        ; (displayln x y)
+        ; (displayln (equal? x y))
+        (if (equal? x y) x (loop (cdr x) (cdr y)))))))
+
+(define do-wind
+  (lambda (new)
+    (let ([tail (common-tail new winders)])
+      (let f ([ls winders])
+        (when (not (equal? ls tail))
+          (begin
+            ;; TODO: This is wrong!
+            (displayln "FIRST" ls)
+            (set! winders (cdr ls))
+            ((cdar ls))
+            (f (cdr ls)))))
+      (let f ([ls new])
+        (when (not (equal? ls tail))
+          (begin
+            ; (displayln "SECOND" ls)
+            (f (cdr ls))
+            ((Pair-left (car ls)))
+            (set! winders ls)))))))
+
+(struct Continuation (func)
+  #:prop:procedure 0
+  #:printer (lambda (obj printer)
+
+              (simple-display "#<procedure>")))
+
+(define call/cc
+  (lambda (f)
+    (#%prim.call/cc (lambda (k)
+                      (f (let ([save winders])
+                           (Continuation (lambda (x)
+                                           (unless (eq? save winders)
+                                             (do-wind save))
+                                           (k x)))))))))
+
+(define call-with-current-continuation call/cc)
+
+(define (continuation? x)
+  (or (Continuation? x) (#%prim.continuation? x)))
+
+(define dynamic-wind
+  (lambda (in body out)
+    (in)
+    (set! winders (cons (Pair in out) winders))
+
+    (let ([ans* (call-with-exception-handler (lambda (err)
+                                               ;; Catch the exception on the way out
+                                               (set! winders (cdr winders))
+                                               (out)
+                                               (raise-error err)
+
+                                               void)
+                                             (lambda () (body)))])
+      (set! winders (cdr winders))
+      (out)
+      ans*)))
+
+;; TODO: Move these to the tests
+; (let ([path '()] [c #f])
+;   (let ([add (lambda (s) (set! path (cons s path)))])
+;     (dynamic-wind (lambda () (add 'connect))
+;                   (lambda ()
+;                     (add (call/cc (lambda (c0)
+;                                     (set! c c0)
+;                                     'talk1))))
+;                   (lambda () (add 'disconnect)))
+;     (if (< (length path) 4) (c 'talk2) (reverse path))))
+
+; (let ()
+;   (dynamic-wind (lambda () (displayln "PRE"))
+;                 (lambda ()
+;                   (let ()
+
+;                     (dynamic-wind (lambda () (displayln "PRE"))
+;                                   (lambda () (displayln "INNER"))
+;                                   (lambda () (displayln "POST")))
+
+;                     (displayln "HELLO WORLD!")))
+;                 (lambda () (displayln "POST")))
+
+;   (displayln "HELLO WORLD!"))
+
+(struct Parameter (getter value)
+  #:mutable
+  #:printer (lambda (obj printer-function) (printer-function "<procedure:parameter-procedure>"))
+  #:prop:procedure 0)
+
+(define (make-parameter value)
+  (define param (Parameter 'uninitialized value))
+
+  (set-Parameter-getter! param (lambda () (Parameter-value param)))
+
+  param)
+
+(define-syntax parameterize
+  (syntax-rules ()
+    [(parameterize ()
+       body ...)
+     (begin
+       body ...)]
+
+    [(parameterize ([var val] rest ...)
+       body ...)
+
+     (let ([old-value (var)])
+
+       (dynamic-wind (lambda () (set-Parameter-value! var val))
+                     (lambda ()
+                       (parameterize (rest ...)
+                         body ...))
+                     (lambda () (set-Parameter-value! var old-value))))]))

crates/steel-core/src/steel_vm/engine.rs

@@ -938,6 +938,7 @@ impl Engine {
             .run(
                 "(require \"#%private/steel/contract\" (for-syntax \"#%private/steel/contract\"))
                 (require \"#%private/steel/print\")
+                (require \"#%private/steel/control\" (for-syntax \"#%private/steel/control\"))
                 ",
             )
             .unwrap();

src/lib.rs

@@ -215,16 +215,16 @@ pub fn finish(result: Result<(), std::io::Error>) -> ! {
     process::exit(code);
 }
 
-// #[test]
-// fn test_runner() {
-//     let args = Args {
-//         action: None,
-//         default_file: Some(PathBuf::from("cogs/test-runner.scm")),
-//         arguments: vec!["cogs/".to_string()],
-//     };
+#[test]
+fn test_runner() {
+    let args = Args {
+        action: None,
+        default_file: Some(PathBuf::from("cogs/test-runner.scm")),
+        arguments: vec!["cogs/".to_string()],
+    };
 
-//     run(args).unwrap()
-// }
+    run(args).unwrap()
+}
 
 #[test]
 fn r5rs_test_suite() {
@@ -236,3 +236,14 @@ fn r5rs_test_suite() {
 
     run(args).unwrap()
 }
+
+#[test]
+fn r7rs_test_suite() {
+    let args = Args {
+        action: None,
+        default_file: Some(PathBuf::from("cogs/r7rs.scm")),
+        arguments: vec![],
+    };
+
+    run(args).unwrap()
+}