use parameter for displayln

cogs/tests/unit-test.scm

@@ -25,12 +25,16 @@
   (set! *FAILED-TO-COMPILE* (+ *FAILED-TO-COMPILE* 1)))
 
 (define (print-success name)
-  (simple-display "test > " name " ... ")
+  (display "test > ")
+  (display name)
+  (display " ... ")
   (display-color "Ok" 'green)
   (newline))
 
 (define (print-failure name)
-  (simple-display "test > " name " ... ")
+  (display "test > ")
+  (display name)
+  (display " ... ")
   (display-color "FAILED" 'red)
   (newline))
 

cogs/threads/test-threads.scm

@@ -14,7 +14,7 @@
   (let ([tasks (map (lambda (_)
                       (spawn-thread! (lambda ()
                                        (time/sleep-ms 2000)
-                                       (displayln (thread::current/id)))))
+                                       (stdout-simple-displayln (thread::current/id)))))
                     (range 0 10))])
     (map (lambda (x) (unwrap-ok (thread-join! x))) tasks)))
 

cogs/threads/threads.scm

@@ -34,14 +34,14 @@
   (define sender (list-ref channels 0))
   (define receiver (list-ref channels 1))
 
-  (CancellableThreadHandle
-   sender
-   (spawn-thread! (lambda ()
-                    (while (not (~> (channel->try-recv receiver) (unwrap-ok)))
-                           (begin
-                             (func)
-                             (time/sleep-ms delay-ms)))
-                    (displayln "Shutting down thread: " (thread::current/id))))))
+  (CancellableThreadHandle sender
+                           (spawn-thread! (lambda ()
+                                            (while (not (~> (channel->try-recv receiver) (unwrap-ok)))
+                                                   (begin
+                                                     (func)
+                                                     (time/sleep-ms delay-ms)))
+                                            (stdout-simple-displayln "Shutting down thread: "
+                                                                     (thread::current/id))))))
 
 ; (let ([tasks (map (lambda (_)
 ;                     (spawn-thread! (lambda ()

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

@@ -2056,7 +2056,7 @@ impl<'a> ModuleBuilder<'a> {
 // pub static PRELUDE_STRING: &str = "";
 
 pub static PRELUDE_STRING: &str = "(require-builtin steel/base) 
+(require \"#%private/steel/control\" (for-syntax \"#%private/steel/control\"))
 (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/primitives/ports.rs

@@ -14,12 +14,18 @@ pub fn port_module() -> BuiltInModule {
     let mut module = BuiltInModule::new("steel/ports");
     module
         .register_native_fn_definition(OPEN_STDIN_DEFINITION)
+        .register_native_fn_definition(OPEN_STDOUT_DEFINITION)
         .register_native_fn_definition(OPEN_INPUT_FILE_DEFINITION)
         .register_native_fn_definition(OPEN_OUTPUT_FILE_DEFINITION)
+        .register_native_fn_definition(OPEN_OUTPUT_STRING_DEFINITION)
         .register_native_fn_definition(WRITE_LINE_DEFINITION)
+        .register_native_fn_definition(WRITE_STRING_DEFINITION)
+        .register_native_fn_definition(WRITE_DEFINITION)
+        .register_native_fn_definition(WRITE_CHAR_DEFINITION)
+        .register_native_fn_definition(FLUSH_OUTPUT_PORT_DEFINITION)
         .register_native_fn_definition(READ_PORT_TO_STRING_DEFINITION)
         .register_native_fn_definition(READ_LINE_TO_STRING_DEFINITION)
-        .register_native_fn_definition(OPEN_STDIN_DEFINITION)
+        .register_native_fn_definition(GET_OUTPUT_STRING_DEFINITION)
         .register_native_fn_definition(IS_INPUT_DEFINITION)
         .register_native_fn_definition(IS_OUTPUT_DEFINITION);
     module
@@ -41,6 +47,13 @@ pub fn open_stdin() -> SteelVal {
     ))))
 }
 
+#[function(name = "stdout")]
+pub fn open_stdout() -> SteelVal {
+    SteelVal::PortV(Gc::new(SteelPort::StdOutput(new_rc_ref_cell(
+        std::io::stdout(),
+    ))))
+}
+
 /// Takes a filename `path` referring to an existing file and returns an input port. Raises an error
 /// if the file does not exist
 ///
@@ -76,6 +89,12 @@ pub fn open_output_file(path: &SteelString) -> Result<SteelVal> {
     Ok(SteelVal::PortV(Gc::new(new_port)))
 }
 
+#[function(name = "open-output-string")]
+pub fn open_output_string() -> Result<SteelVal> {
+    let new_port = SteelPort::new_output_port();
+    Ok(SteelVal::PortV(Gc::new(new_port)))
+}
+
 /// Takes a port and reads the entire content into a string
 ///
 /// (read-port-to-string port) -> string?
@@ -152,3 +171,51 @@ pub fn write_line(port: &Gc<SteelPort>, line: &SteelVal) -> Result<SteelVal> {
         stop!(Generic => "unable to write string to file");
     }
 }
+
+#[function(name = "write")]
+pub fn write(port: &Gc<SteelPort>, line: &SteelVal) -> Result<SteelVal> {
+    let line = line.to_string();
+    let res = port.write_string(line.as_str());
+
+    if res.is_ok() {
+        Ok(SteelVal::Void)
+    } else {
+        stop!(Generic => "unable to write string to port");
+    }
+}
+
+#[function(name = "write-char")]
+pub fn write_char(port: &Gc<SteelPort>, character: char) -> Result<SteelVal> {
+    let res = port.write_char(character);
+
+    if res.is_ok() {
+        Ok(SteelVal::Void)
+    } else {
+        stop!(Generic => "unable to write string to port");
+    }
+}
+
+#[function(name = "write-string")]
+pub fn write_string(port: &Gc<SteelPort>, line: &SteelVal) -> Result<SteelVal> {
+    let res = if let SteelVal::StringV(s) = line {
+        port.write_string(s.as_str())
+    } else {
+        port.write_string(line.to_string().as_str())
+    };
+
+    if res.is_ok() {
+        Ok(SteelVal::Void)
+    } else {
+        stop!(Generic => "unable to write string to port");
+    }
+}
+
+#[function(name = "get-output-string")]
+pub fn get_output_string(port: &Gc<SteelPort>) -> Result<SteelVal> {
+    port.get_output_string().map(SteelVal::from)
+}
+
+#[function(name = "flush-output-port")]
+pub fn flush_output_port(port: &Gc<SteelPort>) -> Result<SteelVal> {
+    port.flush().map(|_| SteelVal::Void)
+}

crates/steel-core/src/scheme/kernel.scm

@@ -111,7 +111,7 @@
     (if transparent?
         `(lambda (obj printer-function)
            (display "(")
-           (printer-function (symbol->string ,(list 'quote struct-name)))
+           (display (symbol->string ,(list 'quote struct-name)))
            ,@(map (lambda (field)
                     `(begin
                        (display " ")

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

@@ -5,6 +5,79 @@
          make-parameter
          continuation?)
 
+;;;;;; Parameters ;;;;;
+
+(struct Parameter (getter value)
+  #:mutable
+  #:printer (lambda (obj printer-function) (simple-display "<procedure:parameter-procedure>"))
+  #:prop:procedure 0)
+
+(define (make-parameter value)
+  (define param (Parameter 'uninitialized value))
+
+  (set-Parameter-getter! param
+                         (case-lambda
+                           [() (Parameter-value param)]
+                           [(new-value) (set-Parameter-value! param new-value)]))
+
+  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))))]))
+
+;;;;;;; Bootstrapping printing functions for various primitive structs
+
+(provide current-input-port
+         current-output-port
+         simple-display
+         simple-displayln
+         newline)
+
+(define current-input-port (make-parameter (stdin)))
+(define current-output-port (make-parameter (stdout)))
+
+(define (simple-display x)
+  (write-string (current-output-port) x))
+
+(define (newline)
+  (write-char (current-output-port) #\newline))
+
+(define (simple-displayln x)
+  (simple-display x)
+  (newline))
+
+;;;;;;;;;;;;;;;;;;;;; Port functions ;;;;;;;;;;;;;;;;;;;;;
+
+(provide call-with-output-string
+         with-output-to-string)
+
+(define (call-with-output-string proc)
+  (define output-string (open-output-string))
+  (proc output-string)
+  (get-output-string output-string))
+
+(define (with-output-to-string proc)
+  (call-with-output-string (lambda (p)
+                             (parameterize ([current-output-port p])
+                               (proc)))))
+
+;;;;;;;;;;;;;;;;;;;;; Dynamic Wind ;;;;;;;;;;;;;;;;;;;;;;;
+
 (define winders '())
 
 (define list-tail drop)
@@ -17,8 +90,6 @@
       (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
@@ -76,58 +147,3 @@
       (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) (simple-display "<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/scheme/modules/reader.scm

@@ -5,23 +5,18 @@
 (define current-input-port (make-parameter (stdin)))
 
 (define (read)
-
   (define value (read-impl))
-
   (if (Ok? value) (Ok->value value) (raise-error (Err->value value))))
 
 (define (read-impl)
 
   (cond
     [(reader.reader-empty? *reader*)
-
      (define next-line (read-line-from-port (current-input-port)))
 
      (cond
        [(string? next-line)
-
         (reader.reader-push-string *reader* next-line)
-
         (reader.reader-read-one *reader*)]
 
        [else
@@ -31,5 +26,4 @@
     ;; The reader is not empty!
     [else
      =>
-
      (reader.reader-read-one *reader*)]))

crates/steel-core/src/scheme/ports.scm

@@ -0,0 +1,18 @@
+(require "#%private/steel/control")
+
+;; Make an opaque port that matches the port interface
+; (struct OpaquePort (is-input write-line-thunk) )
+
+;; Try this out?
+(define current-input-port (make-parameter (stdin)))
+(define current-output-port (make-parameter (stdout)))
+
+(define (custom-simple-display x)
+  (write-string (current-output-port) x))
+
+(define (newline)
+  (write-char (current-output-port) #\newline))
+
+(define (custom-simple-displayln x)
+  (custom-simple-display x)
+  (newline))