Adds runtime support for improper lists

benchmarks/bin-trees/bin-trees.scm

@@ -12,66 +12,53 @@
 (struct node (left val right))
 
 ;; Instead of (define-struct leaf (val)):
-(define (leaf val) (node #f val #f))
-(define (leaf? l) (not (node-left l)))
-(define (leaf-val l) node-val)
+(define (leaf val)
+  (node #f val #f))
+(define (leaf? l)
+  (not (node-left l)))
+(define (leaf-val l)
+  node-val)
 
 (define (make item d)
   (if (= d 0)
       (leaf item)
-      (%plain-let ((item2 (* item 2))
-            (d2 (- d 1)))
-        (node (make (- item2 1) d2) 
-              item 
-              (make item2 d2)))))
+      (let ([item2 (* item 2)] [d2 (- d 1)]) (node (make (- item2 1) d2) item (make item2 d2)))))
 
 (define (check t)
-  (if (leaf? t)
-      1
-      (+ 1 (+ (check (node-left t)) 
-                         (check (node-right t))))))
+  (if (leaf? t) 1 (+ 1 (+ (check (node-left t)) (check (node-right t))))))
 
 (define (iterate n m d sum)
-  (if (equal? n m)
-      sum
-      (iterate (+ n 1) m d (+ sum (check (make n d))))))
+  (if (equal? n m) sum (iterate (+ n 1) m d (+ sum (check (make n d))))))
 
+(define (max x y)
+  (if (> x y) x y))
 
 (define (loop d end max-depth min-depth)
-    (if (>= d end)
-        void
-        (begin
-          (let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth))))
-              (displayln iterations " trees of depth " d " check: " (iterate 0 iterations d 0))
-
-
-              )
+  (if (>= d end)
+      void
+      (begin
+        (let ([iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth))])
+          (displayln iterations " trees of depth " d " check: " (iterate 0 iterations d 0)))
         (loop (+ 2 d) end max-depth min-depth))))
 
-
 (define (main n)
-  (let* ((min-depth 4)
-         (max-depth (max (+ min-depth 2) n)))
-    (let ((stretch-depth (+ max-depth 1)))
-        (displayln "stretch tree of depth " stretch-depth " check: " (check (make 0 stretch-depth))))
-    (let ((long-lived-tree (make 0 max-depth)))
+  (let* ([min-depth 4] [max-depth (max (+ min-depth 2) n)])
+    (let ([stretch-depth (+ max-depth 1)])
+      (displayln "stretch tree of depth " stretch-depth " check: " (check (make 0 stretch-depth))))
+    (let ([long-lived-tree (make 0 max-depth)])
       ; (begin
-        ; (define end )
+      ; (define end )
+
+      (loop 4 (add1 max-depth) max-depth min-depth)
 
-        (loop 4 (add1 max-depth) 
-                max-depth min-depth)
-
-                ; )
+      ; )
 
-
-      (displayln "long lived tree of depth " max-depth " check: " (check long-lived-tree))
-
-             )))
+      (displayln "long lived tree of depth " max-depth " check: " (check long-lived-tree)))))
 
 (main 12)
+
 ; (main 21)
 ; (main 21)
 
-
-; (command-line #:args (n) 
+; (command-line #:args (n)
 ;               (main (string->number n)))

cogs/module-tests/export.scm

@@ -0,0 +1,38 @@
+(provide Applesauce
+         bananas
+         foo-bar-baz
+         new-identifier
+         one-more-identifier
+         another-identifier
+         Applesauce-foo
+         Applesauce-bar
+         Applesauce-baz
+         thing-should-not-escape
+
+         my-fun-contracted-function)
+
+(define (bananas)
+  (error "Hello world"))
+
+(define (foo-bar-baz)
+  10)
+
+(define/contract (my-fun-contracted-function x y)
+  (->/c int? int? int?)
+  (+ x y))
+
+(define new-identifier 100)
+
+(define one-more-identifier 'foo-bar-baz)
+(define another-identifier 100)
+
+(define-syntax thing-should-not-escape
+  (syntax-rules ()
+    [(thing-should-not-escape x) (thing-should-not-escape2 x)]))
+
+(define-syntax thing-should-not-escape2
+  (syntax-rules ()
+    [(thing-should-not-escape x) x]))
+
+;; This should be provided!
+(struct Applesauce (foo bar baz))

cogs/module-tests/import.scm

@@ -0,0 +1,17 @@
+(require (prefix-in export. (only-in "export.scm" thing-should-not-escape Applesauce bananas)))
+
+export.Applesauce
+
+export.bananas
+
+(export.thing-should-not-escape 10)
+
+;; Dead code analysis would be nice as well
+;; If we can run constant evaluation over the result without actually
+;; taking the const evaluation branches, we can store the
+;; resulting removed spans and just render them in the LSP
+(cond
+  [(list? 10) (displayln "hello world!")]
+  [else
+   =>
+   (displayln "foo bar")])

crates/steel-core/benches/my_benchmark.rs

@@ -241,6 +241,9 @@ fn binary_trees(c: &mut Criterion) {
 (define (iterate n m d sum)
   (if (equal? n m) sum (iterate (+ n 1) m d (+ sum (check (make n d))))))
 
+(define (max x y)
+  (if (> x y) x y))
+
 (define (loop d end max-depth min-depth)
   (if (>= d end)
       void

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

@@ -50,7 +50,6 @@ pub struct CodeGenerator<'a> {
 fn eval_atom(t: &SyntaxObject) -> Result<SteelVal> {
     match &t.ty {
         TokenType::BooleanLiteral(b) => Ok((*b).into()),
-        // TokenType::Identifier(s) => env.borrow().lookup(&s),
         TokenType::NumberLiteral(n) => Ok(SteelVal::NumV(*n)),
         TokenType::StringLiteral(s) => Ok(SteelVal::StringV(s.into())),
         TokenType::CharacterLiteral(c) => Ok(SteelVal::CharV(*c)),
@@ -642,6 +641,10 @@ impl<'a> VisitorMut for CodeGenerator<'a> {
         self.push(
             LabeledInstruction::builder(OpCode::PUSHCONST)
                 .payload(idx)
+                // TODO: This is a little suspect, we're doing a bunch of stuff twice
+                // that we really don't need. In fact, we probably can get away with just...
+                // embedding the steel val directly here.
+                .list_contents(crate::parser::ast::ExprKind::Quote(Box::new(quote.clone())))
                 .constant(true),
         );