add srfi library, colors library

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/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?)
@@ -28,15 +30,13 @@
   (display "test > ")
   (display name)
   (display " ... ")
-  (display-color "Ok" 'green)
-  (newline))
+  (displayln-color "Ok" #:fg 'green))
 
 (define (print-failure name)
   (display "test > ")
   (display name)
   (display " ... ")
-  (display-color "FAILED" 'red)
-  (newline))
+  (displayln-color "FAILED" #:fg 'red))
 
 (define-syntax check-equal?
   (syntax-rules ()

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

@@ -271,7 +271,6 @@ pub struct SerializableCompiler {
     pub(crate) macro_env: HashMap<InternedString, SteelMacro>,
     pub(crate) opt_level: OptLevel,
     pub(crate) module_manager: ModuleManager,
-    // pub(crate) mangled_identifiers:
 }
 
 impl SerializableCompiler {
@@ -444,91 +443,7 @@ impl Compiler {
 
         let parsed = parsed?;
 
-        let mut expanded_statements =
-            self.expand_expressions(parsed, path, sources, builtin_modules.clone())?;
-
-        if log_enabled!(log::Level::Debug) {
-            debug!(
-                "Generating instructions for the expression: {:?}",
-                expanded_statements
-                    .iter()
-                    .map(|x| x.to_string())
-                    .collect::<Vec<_>>()
-            );
-        }
-
-        expanded_statements = expanded_statements
-            .into_iter()
-            .map(|x| expand_kernel(x, self.kernel.as_mut(), builtin_modules.clone()))
-            .collect::<Result<Vec<_>>>()?;
-
-        let mut expanded_statements =
-            self.apply_const_evaluation(constants.clone(), expanded_statements, false)?;
-
-        RenameShadowedVariables::rename_shadowed_vars(&mut expanded_statements);
-
-        let mut analysis = Analysis::from_exprs(&expanded_statements);
-        analysis.populate_captures(&expanded_statements);
-
-        let mut semantic = SemanticAnalysis::from_analysis(&mut expanded_statements, analysis);
-
-        // let mut table = HashSet::new();
-
-        // This is definitely broken still
-        semantic
-            .elide_single_argument_lambda_applications()
-            // .lift_pure_local_functions()
-            // .lift_all_local_functions()
-            .replace_non_shadowed_globals_with_builtins(
-                &mut self.macro_env,
-                &mut self.module_manager,
-                &mut self.mangled_identifiers,
-            )
-            .remove_unused_globals_with_prefix("mangler", &self.macro_env, &self.module_manager)
-            .lift_pure_local_functions()
-            .lift_all_local_functions();
-        // This might be sus, lets see!
-        // .replace_mutable_captured_variables_with_boxes();
-
-        // TODO: Just run this... on each module in particular
-        // .remove_unused_globals_with_prefix("mangler");
-
-        debug!("About to expand defines");
-        let mut expanded_statements = flatten_begins_and_expand_defines(expanded_statements);
-
-        let mut analysis = Analysis::from_exprs(&expanded_statements);
-        analysis.populate_captures(&expanded_statements);
-
-        let mut semantic = SemanticAnalysis::from_analysis(&mut expanded_statements, analysis);
-        semantic.refresh_variables();
-
-        semantic.flatten_anonymous_functions();
-
-        semantic.refresh_variables();
-
-        semantic.populate_captures();
-        semantic.populate_captures();
-
-        semantic.replace_mutable_captured_variables_with_boxes();
-
-        if log_enabled!(log::Level::Debug) {
-            debug!(
-                "Successfully expanded defines: {:?}",
-                expanded_statements
-                    .iter()
-                    .map(|x| x.to_string())
-                    .collect::<Vec<_>>()
-            );
-        }
-
-        // TODO - make sure I want to keep this
-        let expanded_statements =
-            MultipleArityFunctions::expand_multiple_arity_functions(expanded_statements);
-
-        let mut expanded_statements =
-            self.apply_const_evaluation(constants, expanded_statements, true)?;
-
-        Ok(expanded_statements)
+        self.lower_expressions_impl(parsed, constants, builtin_modules, path, sources)
     }
 
     pub fn compile_module(
@@ -608,19 +523,14 @@ impl Compiler {
         Ok(results)
     }
 
-    // TODO
-    // figure out how the symbols will work so that a raw program with symbols
-    // can be later pulled in and symbols can be interned correctly
-    fn compile_raw_program(
+    fn lower_expressions_impl(
         &mut self,
         exprs: Vec<ExprKind>,
         constants: ImmutableHashMap<InternedString, SteelVal>,
         builtin_modules: ModuleContainer,
         path: Option<PathBuf>,
         sources: &mut Sources,
-    ) -> Result<RawProgramWithSymbols> {
-        log::debug!(target: "expansion-phase", "Expanding macros -> phase 0");
-
+    ) -> Result<Vec<ExprKind>> {
         let mut expanded_statements =
             self.expand_expressions(exprs, path, sources, builtin_modules.clone())?;
 
@@ -653,8 +563,6 @@ impl Compiler {
 
         let mut semantic = SemanticAnalysis::from_analysis(&mut expanded_statements, analysis);
 
-        // let mut table = HashSet::new();
-
         // This is definitely broken still
         semantic
             .elide_single_argument_lambda_applications()
@@ -677,9 +585,6 @@ impl Compiler {
 
         let mut expanded_statements = flatten_begins_and_expand_defines(expanded_statements);
 
-        // let mut expanded_statements =
-        //     self.apply_const_evaluation(constants.clone(), expanded_statements, false)?;
-
         let mut analysis = Analysis::from_exprs(&expanded_statements);
         analysis.populate_captures(&expanded_statements);
 
@@ -714,34 +619,24 @@ impl Compiler {
 
         log::info!(target: "expansion-phase", "Aggressive constant evaluation with memoization");
 
-        // let expanded_statements = expanded_statements
-        //     .into_iter()
-        //     .flat_map(|x| {
-        //         if let ExprKind::Begin(b) = x {
-        //             b.exprs.into_iter()
-        //         } else {
-        //             vec![x].into_iter()
-        //         }
-        //     })
-        //     .collect();
+        self.apply_const_evaluation(constants, expanded_statements, true)
+    }
 
-        let expanded_statements =
-            self.apply_const_evaluation(constants, expanded_statements, true)?;
-
-        // let expanded_statements = expanded_statements
-        //     .into_iter()
-        //     .flat_map(|x| {
-        //         if let ExprKind::Begin(b) = x {
-        //             b.exprs.into_iter()
-        //         } else {
-        //             vec![x].into_iter()
-        //         }
-        //     })
-        //     .collect();
-
-        // TODO:
-        // Here we're gonna do the constant evaluation pass, using the kernel for execution of the
-        // constant functions w/ memoization:
+    // TODO
+    // figure out how the symbols will work so that a raw program with symbols
+    // can be later pulled in and symbols can be interned correctly
+    fn compile_raw_program(
+        &mut self,
+        exprs: Vec<ExprKind>,
+        constants: ImmutableHashMap<InternedString, SteelVal>,
+        builtin_modules: ModuleContainer,
+        path: Option<PathBuf>,
+        sources: &mut Sources,
+    ) -> Result<RawProgramWithSymbols> {
+        log::debug!(target: "expansion-phase", "Expanding macros -> phase 0");
+
+        let mut expanded_statements =
+            self.lower_expressions_impl(exprs, constants, builtin_modules, path, sources)?;
 
         log::debug!(target: "expansion-phase", "Generating instructions");
 

crates/steel-core/src/primitives/ports.rs

@@ -174,7 +174,7 @@ pub fn write_line(port: &Gc<SteelPort>, line: &SteelVal) -> Result<SteelVal> {
     }
 }
 
-#[function(name = "write")]
+#[function(name = "raw-write")]
 pub fn write(port: &Gc<SteelPort>, line: &SteelVal) -> Result<SteelVal> {
     let line = line.to_string();
     let res = port.write_string(line.as_str());
@@ -186,7 +186,7 @@ pub fn write(port: &Gc<SteelPort>, line: &SteelVal) -> Result<SteelVal> {
     }
 }
 
-#[function(name = "write-char")]
+#[function(name = "raw-write-char")]
 pub fn write_char(port: &Gc<SteelPort>, character: char) -> Result<SteelVal> {
     let res = port.write_char(character);
 
@@ -197,7 +197,7 @@ pub fn write_char(port: &Gc<SteelPort>, character: char) -> Result<SteelVal> {
     }
 }
 
-#[function(name = "write-string")]
+#[function(name = "raw-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())

crates/steel-core/src/primitives/strings.rs

@@ -52,10 +52,16 @@ pub fn string_module() -> BuiltInModule {
         .register_native_fn_definition(STRING_TO_NUMBER_DEFINITION)
         .register_native_fn_definition(NUMBER_TO_STRING_DEFINITION)
         .register_fn("char-upcase", char_upcase)
-        .register_fn("char-whitespace?", char::is_whitespace);
+        .register_fn("char-whitespace?", char::is_whitespace)
+        .register_native_fn_definition(CHAR_EQUALS_DEFINITION);
     module
 }
 
+#[function(name = "char=?", constant = true)]
+pub fn char_equals(left: char, right: char) -> bool {
+    left == right
+}
+
 fn number_to_string_impl(value: &SteelVal, radix: Option<u32>) -> Result<SteelVal> {
     match value {
         SteelVal::IntV(v) => {