Fix panics in parser (#96)

* There were some issues with the parser - this should fix those obvious panics
* Tests against some of the r7rs benchmarks
* Adds some more built ins, fixes some issues with the garbage collector
* Remove the dependency on the `colored` crate - that is now a steel library
* Mutable local variables are now expanded to calls to `box`, `unbox`, and `set-box!`

Cargo.toml

@@ -19,7 +19,7 @@ path = "src/main.rs"
 
 [workspace.dependencies]
 # This has to line up with the workspace version above
-steel-core = { path = "./crates/steel-core", version = "0.5.0", features = ["web", "sqlite", "blocking_requests", "dylibs", "markdown", "colors"] }
+steel-core = { path = "./crates/steel-core", version = "0.5.0", features = ["web", "sqlite", "blocking_requests", "dylibs", "markdown"] }
 
 [dependencies]
 once_cell = "1.17.0"

cogs/colors/cog.scm

@@ -0,0 +1,5 @@
+(define package-name 'steel/colors)
+(define version "0.1.0")
+
+;; Core library, requires no dependencies
+(define dependencies '())

cogs/colors/colors.scm

@@ -0,0 +1,49 @@
+(require "srfi/srfi-28/format.scm")
+
+(provide display-color
+         displayln-color)
+
+(define (terminal-command command)
+  (format "~a~a" #\u001B command))
+
+(define (terminal-reset)
+  (terminal-command "[0m"))
+
+(define (terminal-colors bg fg bold? underline?)
+  (terminal-command (format "[~a;~a~a~am"
+                            (case bg
+                              [(black) "40"]
+                              [(red) "41"]
+                              [(green) "42"]
+                              [(yellow) "43"]
+                              [(blue) "44"]
+                              [(magenta) "45"]
+                              [(cyan) "46"]
+                              [(white) "47"]
+                              [(default) "49"])
+                            (case fg
+                              [(black) "30"]
+                              [(red) "31"]
+                              [(green) "32"]
+                              [(yellow) "33"]
+                              [(blue) "34"]
+                              [(magenta) "35"]
+                              [(cyan) "36"]
+                              [(white) "37"]
+                              [(default) "39"])
+                            (if bold? ";1" "")
+                            (if underline? ";4" ""))))
+
+(define (output-color output-method datum #:fg fg #:bg bg)
+  (terminal-colors bg fg #f #f)
+  (output-method datum)
+  (display (terminal-reset)))
+
+(define (display-color datum #:fg [fg 'default] #:bg [bg 'default])
+  (output-color display datum #:fg fg #:bg bg))
+
+(define (displayln-color datum #:fg [fg 'default] #:bg [bg 'default])
+  (display (terminal-colors bg fg #f #f))
+  (display datum)
+  (display (terminal-reset))
+  (newline))

cogs/installer/package.scm

@@ -64,7 +64,7 @@
 (define/contract (install-package-and-log cog-to-install)
   (->/c hash? void?)
   (let ([output-dir (install-package cog-to-install)])
-    (display-color "✅ Installed package to: " 'green)
+    (display "✅ Installed package to: ")
     (displayln output-dir)
     (newline)))
 

cogs/logging/log.scm

@@ -1,59 +1,43 @@
 (require-builtin steel/time)
-(require-builtin steel/strings/colors as colors.)
 
-(provide log! log/info! log/warn! log/debug! log/error!)
+(provide log!
+         log/info!
+         log/warn!
+         log/debug!
+         log/error!)
 
-(define *info* (colors.green "INFO"))
-(define *warn* (colors.yellow "WARN"))
-(define *debug* (colors.blue "DEBUG"))
-(define *error* (colors.red "ERROR"))
-(define *trace* (colors.purple "TRACE"))
-
-; (displayln "LOADING MODULE")
-
-; (define (log! level target arg-list)
-;     (apply displayln (append
-;                     (list 
-;                         (local-time/now! "%Y-%m-%dT%H:%M:%S")
-;                         " ["
-;                         level
-;                         " "
-;                         target
-;                         "] - ")
-;                     arg-list)))
+(define *info* "INFO")
+(define *warn* "WARN")
+(define *debug* "DEBUG")
+(define *error* "ERROR")
+(define *trace* "TRACE")
 
 ;;@doc
 ;; Log directly on the specified level the with arguments, as a list
 (define (log! level arg-list)
-    (apply displayln (append
-                        (list 
-                            (local-time/now! "%Y-%m-%dT%H:%M:%S")
-                            " ["
-                            level
-                            "] - ")
-                        arg-list)))
+  (apply displayln (append (list (local-time/now! "%Y-%m-%dT%H:%M:%S") " [" level "] - ") arg-list)))
 
 ;;@doc
 ;; Log the arguments using the *info* target, i.e. log on INFO
 (define (log/info! . args)
-    (log! *info* args))
+  (log! *info* args))
 
 ;;@doc
 ;; Log the arguments using the *warn* target, i.e. log on WARN
 (define (log/warn! . args)
-    (log! *warn* args))
+  (log! *warn* args))
 
 ;;@doc
 ;; Log the arguments using the *debug* target, i.e. log on DEBUG
 (define (log/debug! . args)
-    (log! *debug* args))
+  (log! *debug* args))
 
 ;;@doc
 ;; Log the arguments using the *error* target, i.e. log on ERROR
 (define (log/error! . args)
-    (log! *error* args))
+  (log! *error* args))
 
 ;;@doc
 ;; Log the arguments using the *trace* target, i.e. log on TRACE
 (define (log/trace! . args)
-    (log! *trace* args))
+  (log! *trace* args))

cogs/srfi/cog.scm

@@ -0,0 +1,5 @@
+(define package-name 'srfi)
+(define version "0.1.0")
+
+;; Core library, requires no dependencies
+(define dependencies '())

cogs/srfi/srfi-28/format.scm

@@ -0,0 +1,56 @@
+; Copyright (C) Scott G. Miller (2002). All Rights Reserved.
+;
+; Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files
+; the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge
+; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to
+; do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+;
+; Modified for use within Steel by Matthew Paras (2023).
+
+(provide format)
+
+(define format
+  (lambda (format-string . objects)
+    (let ([buffer (open-output-string)])
+      (let loop ([format-list (string->list format-string)] [objects objects])
+        (cond
+          [(null? format-list) (get-output-string buffer)]
+          [(char=? (car format-list) #\~)
+           (if (null? (cdr format-list))
+               (error 'format "Incomplete escape sequence")
+               (case (cadr format-list)
+                 [(#\a)
+                  (if (null? objects)
+                      (error 'format "No value for escape sequence")
+                      (begin
+                        (display (car objects) buffer)
+                        (loop (cddr format-list) (cdr objects))))]
+                 [(#\s)
+                  (if (null? objects)
+                      (error 'format "No value for escape sequence")
+                      (begin
+                        (write (car objects) buffer)
+                        (loop (cddr format-list) (cdr objects))))]
+                 [(#\%)
+                  (newline buffer)
+                  (loop (cddr format-list) objects)]
+                 [(#\~)
+                  (write-char #\~ buffer)
+                  (loop (cddr format-list) objects)]
+                 [else (error 'format "Unrecognized escape sequence")]))]
+          [else
+           (write-char (car format-list) buffer)
+           (loop (cdr format-list) objects)])))))
+
+; (displayln (format "Hello, ~a" "World!"))
+; ; => "Hello, World!"
+
+; (displayln (format "Error, list is too short: ~s~%" '(one "two" 3)))
+; ; => "Error, list is too short: (one \"two\" 3))"

cogs/tests/unit-test.scm

@@ -1,3 +1,5 @@
+(require "steel/colors/colors.scm")
+
 (provide test
          (for-syntax check-equal?)
          (for-syntax check-err?)
@@ -25,14 +27,16 @@
   (set! *FAILED-TO-COMPILE* (+ *FAILED-TO-COMPILE* 1)))
 
 (define (print-success name)
-  (simple-display "test > " name " ... ")
-  (display-color "Ok" 'green)
-  (newline))
+  (display "test > ")
+  (display name)
+  (display " ... ")
+  (displayln-color "Ok" #:fg 'green))
 
 (define (print-failure name)
-  (simple-display "test > " name " ... ")
-  (display-color "FAILED" 'red)
-  (newline))
+  (display "test > ")
+  (display name)
+  (display " ... ")
+  (displayln-color "FAILED" #:fg 'red))
 
 (define-syntax check-equal?
   (syntax-rules ()

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/Cargo.toml

@@ -16,7 +16,7 @@ name = "steel"
 [dependencies]
 im-rc = "15.1.0"
 codespan-reporting = "0.11.1"
-logos = "0.12.1"
+# logos = "0.12.1"
 log = "0.4.17"
 
 futures-util = "0.3.28"
@@ -27,7 +27,7 @@ serde = { version = "1.0.152", features = ["derive", "rc"] }
 serde_derive = "1.0.152"
 bincode = "1.3.3"
 pretty = "0.12.1"
-im-lists = "0.5.0"
+im-lists = "0.6.0"
 quickscope = "0.2.0"
 lasso = { version = "0.6.0", features = ["multi-threaded", "serialize"] }
 once_cell = "1.17.0"
@@ -49,8 +49,6 @@ radix_fmt = "1.0.0"
 # For structs
 smallvec = { version = "1.10.0", optional = true }
 
-colored = { version = "2.0.0", optional = true }
-
 # Pretty printing documentation
 termimad = { version = "0.21.0", optional = true }
 
@@ -73,15 +71,13 @@ ureq = { version = "2.6.2", features = ["json"], optional = true }
 [dev-dependencies]
 proptest = "1.1.0"
 criterion = "0.5.1"
-steel-core = { path = ".", features = ["modules"] }
 env_logger = "0.10.0"
 
 [build-dependencies]
 steel-gen = { path = "../steel-gen", version = "0.2.0" }
 
 [features]
 default = ["modules"]
-colors = ["dep:colored"]
 modules = []
 jit = ["dep:cranelift", "dep:cranelift-module", "dep:cranelift-jit"]
 dynamic = []
@@ -100,5 +96,3 @@ without-drop-protection = []
 name = "my_benchmark"
 harness = false
 
-# TODO: Put this in the CI to gather the benchmarks
-# cargo bench --bench my_benchmark -- --output-format bencher | tee output.txt