Merge pull request #227 from andrew-johnson-4/back-to-safety

Back to safety

Author: andrew-johnson-4

BOOTSTRAP/cli.s

@@ -1,6 +1,6 @@
 [package]
 name = "lambda_mountain"
-version = "1.11.90"
+version = "1.11.92"
 authors = ["Andrew <andrew@subarctic.org>"]
 license = "MIT"
 description = "Lambda Mountain"

Cargo.toml

@@ -90,8 +90,9 @@ compile-expr-strict := λctx e offset used . (tail(
                   ()
                   ( (Array( x '? )) (
                      (if (typecheck-unify-implies( x U8 )) () (
-                        (set deref True)
-                        (set new-size (typecheck-sizeof x))
+                        (if (typecheck-unify-implies( x '? )) () (
+                           (set deref True)
+                        ))
                      ))
                   ))
                ))
@@ -159,7 +160,7 @@ compile-expr-strict := λctx e offset used . (tail(
             ( (App( (App( (App( (Variable 'if) cond )) t )) f )) (tail(
                (set e1 (compile-expr-strict( ctx cond offset Used )))
                (set e2 (compile-expr-strict( (expr::get-context e1) t (expr::get-offset e1) Used )))
-               (set e3 (compile-expr-strict( (expr::get-context e2) f (expr::get-offset e2) Used )))
+               (set e3 (compile-expr-strict( (expr::get-context e1) f (expr::get-offset e1) Used )))
                (match (expr::get-type e1) (
                   ()
                   (BranchConditional ())
@@ -179,6 +180,7 @@ compile-expr-strict := λctx e offset used . (tail(
                (local label-end)
                (set label-end (uuid()))
                (set e4 (expr::set-prog( e4 (
+                  (expr::get-frame e1)
                   (expr::get-prog e1)
                   \t (expr::get-expr e1) \s label-true-branch \n
                   (expr::get-frame e3)
@@ -190,9 +192,12 @@ compile-expr-strict := λctx e offset used . (tail(
                   (expr::get-prog e2)
                   (expr::get-unframe e2)
                   label-end ': \n
+                  (expr::get-unframe e1)
                ))))
-               (set e4 (expr::set-context( e4 (expr::get-context e3) )))
-               (set e4 (expr::set-offset( e4 (expr::get-offset e3) )))
+               (set e4 (expr::set-context( e4 ctx )))
+               (set e4 (expr::set-offset( e4 offset )))
+               (set e4 (expr::set-frame( e4 () )))
+               (set e4 (expr::set-unframe( e4 () )))
                e4
             )))
             ( (App( (Variable 'label) (Variable label-name) )) (

PRODUCTION/codegen-strict.lm

@@ -199,7 +199,7 @@ typecheck-ascript := λt tt . (tail(
       (set lt (typecheck-lookup t))
       (if lt (
          (if (typecheck-deep-eq( lt tt )) () (
-            fail (TypeAscriptionInequality lt tt)
+            fail (TypeAscriptionInequality lt tt t)
          ))
       ) (
          (set tt (typecheck-sizeall tt))
@@ -821,7 +821,9 @@ typecheck-infer-expr := λctx e used . (tail(
                ()
                ( (Array( x '? )) (
                   (if (typecheck-unify-implies( x U8 )) () (
-                     (set rtype x)
+                     (if (typecheck-unify-implies( x '? )) () (
+                        (set rtype x)
+                     ))
                   ))
                ))
             ))

PRODUCTION/typecheck.lm

@@ -15,74 +15,41 @@ macro ('match-pats( term (ps (lhs rhs)) remainder )) (
    (match-pats(
       term
       ps
-      (if (match-pats-condition( term lhs )) rhs remainder)
+      (match-pats-arm( term lhs rhs remainder ))
    ))
 );
 
-macro ('match-pats-condition( term (:Variable: v) )) (
-   (tail( (let v (maybe-deref term)) (branchtrue()) ))
+macro ('match-pats-arm( term (:Variable: v) rhs remainder )) (
+   if (tail( (let v (maybe-deref term)) (branchtrue()) ))
+      rhs
+      remainder
 );
 
-macro ('match-pats-condition( term (:Literal: l) )) (
-   (tail( (let (uuid v) (maybe-deref term)) (==( (uuid v) l )) ))
+macro ('match-pats-arm( term (:Literal: l) rhs remainder )) (
+   if (tail( (let (uuid v) (maybe-deref term)) (==( (uuid v) l )) ))
+      rhs
+      remainder
 );
 
-macro ('match-pats-condition( term (:Tag: l lt) )) (
-   (tail( (let (uuid v) (maybe-deref term)) (==( (.0( (uuid v) )) l )) ))
+macro ('match-pats-arm( term (:Tag: l lt) rhs remainder )) (
+   if (tail( (let (uuid v) (maybe-deref term)) (==( (.0( (uuid v) )) l )) ))
+      rhs
+      remainder
 );
 
-macro ('match-pats-condition( term ((:Tag: l lt) ( x1 )) )) (tail(
+macro ('match-pats-arm( term ((:Tag: l lt) ( x1 )) rhs remainder )) (tail(
    (let (uuid v) (maybe-deref term) )
-   (let (uuid ok) Trueu8)
    (if (==( (.0( (uuid v) )) l )) (
-      (if (match-pats-condition( (.1( (as (uuid v) lt) )) x1 )) () (set (uuid ok) Falseu8))
-   ) (set (uuid ok) Falseu8))
-   (==( (uuid ok) Trueu8 ))
+      (match-pats-arm( (.1( (as (uuid v) lt) )) x1 rhs remainder )) 
+   ) remainder)
 ));
 
-macro ('match-pats-condition( term ((:Tag: l lt) ( x2 x1 ) ))) (tail(
+macro ('match-pats-arm( term ((:Tag: l lt) ( x2 x1 )) rhs remainder )) (tail(
    (let (uuid v) (maybe-deref term) )
-   (let (uuid ok) Trueu8)
-   (if (==( (.0( (uuid v) )) l )) (tail(
-      (if (match-pats-condition( (.1( (as (uuid v) lt) )) x1 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.2( (as (uuid v) lt) )) x2 )) () (set (uuid ok) Falseu8))
-   )) (set (uuid ok) Falseu8))
-   (==( (uuid ok) Trueu8 ))
-));
-
-macro ('match-pats-condition( term ((:Tag: l lt) ( x3 x2 x1 ) ))) (tail(
-   (let (uuid v) (maybe-deref term) )
-   (let (uuid ok) Trueu8)
-   (if (==( (.0( (uuid v) )) l )) (tail(
-      (if (match-pats-condition( (.1( (as (uuid v) lt) )) x1 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.2( (as (uuid v) lt) )) x2 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.3( (as (uuid v) lt) )) x3 )) () (set (uuid ok) Falseu8))
-   )) (set (uuid ok) Falseu8))
-   (==( (uuid ok) Trueu8 ))
-));
-
-macro ('match-pats-condition( term ((:Tag: l lt) ( x4 x3 x2 x1 ) ))) (tail(
-   (let (uuid v) (maybe-deref term) )
-   (let (uuid ok) Trueu8)
-   (if (==( (.0( (uuid v) )) l )) (tail(
-      (if (match-pats-condition( (.1( (as (uuid v) lt) )) x1 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.2( (as (uuid v) lt) )) x2 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.3( (as (uuid v) lt) )) x3 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.4( (as (uuid v) lt) )) x4 )) () (set (uuid ok) Falseu8))
-   )) (set (uuid ok) Falseu8))
-   (==( (uuid ok) Trueu8 ))
-));
-
-macro ('match-pats-condition( term ((:Tag: l lt) ( x5 x4 x3 x2 x1 ) ))) (tail(
-   (let (uuid v) (maybe-deref term) )
-   (let (uuid ok) Trueu8)
-   (if (==( (.0( (uuid v) )) l )) (tail(
-      (if (match-pats-condition( (.1( (as (uuid v) lt) )) x1 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.2( (as (uuid v) lt) )) x2 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.3( (as (uuid v) lt) )) x3 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.4( (as (uuid v) lt) )) x4 )) () (set (uuid ok) Falseu8))
-      (if (match-pats-condition( (.5( (as (uuid v) lt) )) x5 )) () (set (uuid ok) Falseu8))
-   )) (set (uuid ok) Falseu8))
-   (==( (uuid ok) Trueu8 ))
+   (if (==( (.0( (uuid v) )) l )) (
+      (match-pats-arm( (.1( (as (uuid v) lt) )) x1 (
+         (match-pats-arm( (.2( (as (uuid v) lt) )) x2 rhs remainder ))
+      ) remainder )) 
+   ) remainder)
 ));
 

STDLIB/default-rules.lm

@@ -10,24 +10,25 @@ close := λ(: x S). (: (tail(
    (as R8 S[])
 )) S[]);
 
-print := λ(: x S). (: (match x (
-   ()
-#   ( (SAtom a) (print a) )
-   ( (SCons( l r )) (tail(
-      ()
+print := λ(: x S). (: (tail(
+   (match x (
       ()
-#      (print '\[_s)
-#      (print l)
-#      (print '\s_s)
-#      (print r)
-#      (print '\]_s)
-   )))
-#   ( SNil (print '\[\]_s))
-#   ( (SPointer p) (tail(
-#      (print '[_s)
-#      (print (as p U64))
-#      (print ']_s)
-#   )))
+      (SNil (print '\[\]_s))
+      ( (SAtom a) (print a))
+      ( (SCons( l r )) (tail(
+         (print '\[_s)
+         (print l)
+         (print '\s_s)
+         (print r)
+         (print '\]_s)
+      )))
+      ( (SPointer p) (tail(
+         (print '[_s)
+         (print (as p U64))
+         (print ']_s)
+      )))
+   ))
+   ()
 )) Nil);
 
 fail := λ(: msg Array<U8,?>). (: (tail(

STDLIB/default-stdlib.lm

@@ -11,7 +11,6 @@ main := (tail(
       (2u64 (print 2u64))
       (3u64 (print 3u64))
    ))
-   ()
    (match 2u64 (
       ()
       (1u64 (print 1u64))

tests/strict/match2.lm

@@ -0,0 +1 @@
+()