Merge pull request #221 from andrew-johnson-4/booleans

Booleans

Author: andrew-johnson-4

BOOTSTRAP/cli.s

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

Cargo.toml

@@ -1,6 +1,6 @@
 
 nostd: prod
-	./production --nostd -o tmp.s STRICT/cli.lm
+	./production --nostd -o tmp.s tests/strict/match4.lm
 	as -o tmp.o tmp.s
 	ld -o tmp tmp.o
 	./tmp && echo $?

Makefile

@@ -207,7 +207,11 @@ assemble-initialize-data := λ e tt . (
       ( (Literal v) (match (typecheck-datatype tt) (
          ()
          (I8 ( \t '.byte \s v \n ))
-         (U8 ( \t '.byte \s v \n ))
+         (U8 (tail(
+            (if (eq( v True )) (set v '1) ())
+            (if (eq( v False )) (set v '0) ())
+            (\t '.byte \s v \n)
+         )))
          (I16 ( \t '.2byte \s v \n ))
          (U16 ( \t '.2byte \s v \n ))
          (I32 ( \t '.4byte \s v \n ))

PRODUCTION/assemble.lm

@@ -106,7 +106,7 @@ main := (
       ))
    )))
 
-   (set parse-parsed-program (preprocess-apply-macros parse-parsed-program))
+   (set parse-parsed-program (preprocess parse-parsed-program))
    (if config-strict (typecheck parse-parsed-program) ())
 
    (match mode (

PRODUCTION/cli.lm

@@ -182,7 +182,12 @@ compile-expr-strict := λctx e offset used . (tail(
                   (set uid (strict-declare-cstring( lval )))
                   (set e1 (expr::set-expr( (expr::new ()) uid )))
                ) (
-                  (set e1 (expr::set-expr( (expr::new ()) lval )))
+                  (match lval (
+                     ()
+                     (True (set e1 (expr::set-expr( (expr::new ()) '1 ))))
+                     (False (set e1 (expr::set-expr( (expr::new ()) '0 ))))
+                     (_ (set e1 (expr::set-expr( (expr::new ()) lval ))))
+                  ))
                ))
                (set e1 (expr::set-context( e1 ctx )))
                (set e1 (expr::set-offset( e1 offset )))
@@ -202,7 +207,12 @@ compile-expr-strict := λctx e offset used . (tail(
                   (set uid (strict-declare-cstring( lval )))
                   (set e1 (expr::set-expr( (expr::new ()) uid )))
                ) (
-                  (set e1 (expr::set-expr( (expr::new ()) lval )))
+                  (match lval (
+                     ()
+                     (True (set e1 (expr::set-expr( (expr::new ()) '1 ))))
+                     (False (set e1 (expr::set-expr( (expr::new ()) '0 ))))
+                     (_ (set e1 (expr::set-expr( (expr::new ()) lval ))))
+                  ))
                ))
                (set e1 (expr::set-context( e1 ctx )))
                (set e1 (expr::set-offset( e1 offset )))

PRODUCTION/codegen-strict.lm

@@ -1,4 +1,59 @@
 
+preprocess-index-types := ();
+	
+preprocess := λprogram . (tail(
+   (preprocess-index-typedefs program)
+   (preprocess-apply-macros program)
+));
+
+preprocess-index-typedefs := λprogram . (tail(
+   (while program (
+      (preprocess-index-typedef (tail program))
+      (set program (head program))
+   ))
+));
+
+preprocess-index-typedef := λterm . (match term (
+   ()
+   ( (Type( l ds )) (
+      (preprocess-index-indices( ds 0 ))
+   ))
+));
+
+preprocess-index-indices := λdef index . (match def (
+   ()
+   ( (App( (App( tds (Variable '|) )) body )) (tail(
+      (preprocess-index-indices( tds (i2s(inc(s2i index))) ))
+      (preprocess-index-index( body index ))
+   )))
+   ( body (
+      (preprocess-index-index( body index ))
+   ))
+));
+	
+preprocess-index-index := λbody index . (match body (
+   ()
+   ( (Literal tag) (tail(
+      (set preprocess-index-types (preprocess-index-types (tag index)))
+   )))
+   ( (App( (Literal tag) args )) (tail(
+      (set preprocess-index-types (preprocess-index-types (tag index)))
+   )))
+));
+
+preprocess-index-of-tag := λtag . (tail(
+   (local indices)
+   (local index)
+   (set indices preprocess-index-types)
+   (while indices (
+      (if (eq( (head(tail indices)) tag )) (
+         (set index (tail(tail indices)))
+      ) ())
+      (set indices (head indices))
+   ))
+   index
+));
+
 substitute-macro-body := λkvs e . (match e (
    ()
    ((Variable n) (tail(
@@ -48,7 +103,24 @@ try-destructure-macro := λlhs e . (match (lhs e) (
       (if (eq( pl el )) Accept ())
    ))
    ( ( (App( (Literal :Literal:) (Variable pv) )) (Literal el)) (
-      (Accept (KV( pv e )))
+      (if (preprocess-index-of-tag el)
+         ()
+         (Accept (KV( pv e )))
+      )
+   ))
+   ( ( (App( (Literal :Tag:) (Variable pv) )) (Literal el)) (
+      (if (preprocess-index-of-tag el)
+         (Accept (KV( pv
+            (App(
+               (App(
+                  (Literal :)
+                  (Literal (preprocess-index-of-tag el))
+               ))
+               (preprocess-restructure-type(parse-type( Constant+Literal+U64 )))
+            ))
+         )))
+         ()
+      )
    ))
    ( ( (App( (Literal :Variable:) (Variable pv) )) (Variable el)) (
       (Accept (KV( pv e )))

PRODUCTION/preprocess.lm

@@ -47,7 +47,7 @@ fragment push := λ(: src GlobalVariable+Sized<size>). (: (
          \t 'mov \s '0 \[ '%r15 \] , \s '%r15w \n
          \t 'push \s '%r15 \n
       ))
-      (if-eq size 2 (
+      (if-eq size 1 (
          \t 'mov \s '0 \[ '%r15 \] , \s '%r15b \n
          \t 'push \s '%r15 \n
       ))

STDLIB/default-instruction-set.lm

@@ -27,3 +27,7 @@ macro ('match-pats-condition term (:Literal: l)) (
    (==( term l ))
 );
 
+macro ('match-pats-condition term (:Tag: l)) (
+   (==( (.0( term )) l ))
+);
+

STDLIB/default-rules.lm

@@ -6,8 +6,8 @@ import STDLIB/default-stdlib.lm;
 
 import STRICT/utility.lm;
 
-#config-strict                := True;
-#config-preprocess            := True;
+config-strict                := Trueu8;
+config-preprocess            := Trueu8;
 config-target                := 'tmp.s_s;
 
 type CompileMode ModeTokenize | ModeParse | ModeTypecheck | ModeCompile;
@@ -23,24 +23,29 @@ main := λ(: argc U64)(: argv U8[][]).(tail(
          ('--parse_s (set config-mode ModeParse))
          ('--typecheck_s (set config-mode ModeTypecheck))
          ('--compile_s (set config-mode ModeCompile))
-#         ('--strict_s (set config-strict True))
-#         ('--gradual_s (set config-strict False))
-#         ('--macro_s (set config-preprocess True))
-#         ('--nomacro_s (set config-preprocess False))
+         ('--strict_s (set config-strict Trueu8))
+         ('--gradual_s (set config-strict Falseu8))
+         ('--macro_s (set config-preprocess Trueu8))
+         ('--nomacro_s (set config-preprocess Falseu8))
          ('-o_s (tail(
             (set argi (+( argi 1u64 )))
             (set input (SCons(
                (close input)
                (close (SAtom([]( argv argi ))))
             )))
          )))
-         (fp (set input (SCons(
-            (close input)
-            (close (SAtom( fp )))
-         ))))
+         (fp (tail(
+            (print fp)
+            (set input (SCons(
+               (close input)
+               (close (SAtom( fp )))
+            )))
+         )))
       ))
       (set argi (+( argi 1u64 )))
    ))
    (print Input:\s_s)(print input)(print \n_s)
    (print Output:\s_s)(print config-target)(print \n_s)
+   (print Preprocess:\s_s)(print config-preprocess)(print \n_s)
+   (print Strict:\s_s)(print config-strict)(print \n_s)
 ));