Merge pull request #202 from andrew-johnson-4/strict-compiler-dev-17

Strict compiler dev 17

Author: andrew-johnson-4

Cargo.toml

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

PRODUCTION/codegen-strict.lm

@@ -180,10 +180,12 @@ compile-expr-strict := λctx e offset used . (tail(
             )))
             ( (App( (App( (Literal ':) lval )) ltype )) (tail(
                (set e1 (compile-expr-strict( ctx lval offset Unused )))
+               (set e1 (expr::set-type( e1 (typecheck-lookup e) )))
                e1
             )))
             ( (App( (App( (Variable 'as) lval )) ltype )) (tail(
                (set e1 (compile-expr-strict( ctx lval offset Unused )))
+               (set e1 (expr::set-type( e1 (typecheck-lookup e) )))
                e1
             )))
             ( (App( (Variable 'tail) (App( l r )) )) (tail(
@@ -212,6 +214,7 @@ compile-expr-strict := λctx e offset used . (tail(
             )))
             ( (Variable v) (tail(
                (set e1 (fragment-get-local( ctx v offset )))
+               (set e1 (expr::set-type( e1 (typecheck-lookup e) )))
                e1
             )))
             ( (App (l r)) (tail(
@@ -236,7 +239,7 @@ compile-expr-strict := λctx e offset used . (tail(
                   )))
                   ( _ (
                      (if (eq( used Used )) (
-                        (fail( Raw Cons Cells Are Not Permitted In Strict Mode ))
+                        (fail( Raw Cons Cells Are Not Permitted In Strict Mode \n e ))
                      ) (tail(
                         (set e1 (compile-expr-strict( ctx l offset Unused )))
                         (set e2 (compile-expr-strict( (expr::get-context e1) r (expr::get-offset e1) Used )))

PRODUCTION/fragment.lm

@@ -299,7 +299,7 @@ fragment-destructure-lhs := λ ctx lhs args . (tail(
          (local ctype)
          (set ctype (typecheck-infer-type-compound vtype))
          (local tctx)
-         (set tctx (typecheck-unify-args( (expr::get-type (tail args)) ctype )))
+         (set tctx (typecheck-unify-args( ctype (expr::get-type (tail args)) )))
          (set ctx (fragment-bind-types( ctx tctx )))
          (set ctx ( ctx (vname (tail args)) ))
          ctx
@@ -308,7 +308,7 @@ fragment-destructure-lhs := λ ctx lhs args . (tail(
          (local ctype)
          (set ctype (typecheck-infer-type-compound vtype))
          (local tctx)
-         (set tctx (typecheck-unify-args( (expr::get-type (tail args)) ctype )))
+         (set tctx (typecheck-unify-args( ctype (expr::get-type (tail args)) )))
          (set ctx (fragment-bind-types( ctx tctx )))
          (set ctx ( ctx (vname (tail args)) ))
          (set ctx (fragment-destructure-lhs( ctx inner (head args) )))

PRODUCTION/typecheck.lm

@@ -725,7 +725,7 @@ typecheck-infer-expr := λctx e used . (tail(
          (set asc_t (typecheck-lookup asc))
          (if asc_t (
             (typecheck-ascript( e
-               (typecheck-and( asc_t (typecheck-infer-type-compound tt) ))
+               (typecheck-as( asc_t (typecheck-infer-type-compound tt) ))
             ))
          ) ())
       ))
@@ -885,9 +885,37 @@ typecheck-not-representation := λtt . (match tt (
    ( _ tt )
 ));
 
-typecheck-and := λlt rt . (tail(
+typecheck-as := λlt rt . (tail(
+   (set lt (typecheck-modifiers( lt )))
+   (if lt (
+      (And( lt rt ))
+   ) rt )
+));
+typecheck-modifiers := λtt . (match tt (
    ()
-   (And( lt rt ))
+   ( (And( lt rt )) (tail(
+      (set lt (typecheck-modifiers lt))
+      (set rt (typecheck-modifiers rt))
+      (match (lt rt) (
+         ()
+         ( (() ()) () )
+         ( (() rt) rt )
+         ( (lt ()) lt )
+         ( (lt rt) (And( lt rt )) )
+      ))
+   )))
+   ( LocalVariable tt )
+   ( GlobalVariable tt )
+   ( StackVariable tt )
+   ( Constant tt )
+   ( Literal tt )
+   ( Label tt )
+   ( Reg8 tt )
+   ( Reg16 tt )
+   ( Reg32 tt )
+   ( Reg64 tt )
+   ( (Sized _) tt )
+   ( _ () )
 ));
 
 typecheck-as-return := λrt . (tail(

STDLIB/default-instruction-set.lm

@@ -38,6 +38,15 @@ fragment mov := λ(: src LocalVariable+Sized<size>)(: dst LocalVariable+Sized<si
       )) \[ '%rbp \] \n      
    )))
 ) Nil);
+fragment push := λ(: src GlobalVariable+Sized<size>). (: (
+   (.program (
+      (\t 'mov \s '$ (.expression src) , \s '%r15 \n)
+      (for word-offset in (range( 0 (/( size 8 )) )) (
+         \t 'pushq \s '0 \[ '%r15 \] \n
+         \t 'add \s '$8 , \s '%r15 \n
+      ))
+   ))
+) Nil);
 fragment push := λ(: src LocalVariable+Sized<size>). (: (
    (.program ( for word-offset in (range( 0 (/( size 8 )) )) (
       \t 'pushq \s (+( (.expression src) (*( word-offset 8 )) )) \[ '%rbp \] \n

STDLIB/default-primitives.lm

@@ -108,6 +108,23 @@ fragment + := λ(: l LocalVariable+U64)(: r Constant+U64). (: (
    (.expression( 'r12 ))
 ) Reg64+U64);
 
+fragment + := λ(: l GlobalVariable+U64)(: r Literal+Constant+U64). (: (
+   (.program( \t 'mov \s '$ (.expression l) , \s '%r15 \n \t 'mov \s '0 \[ '%r15 \] , '%r15 \n \t 'add \s '$ (.expression r) , \s '%r15 \n ))
+   (.expression( 'r15 ))
+) Reg64+U64);
+fragment + := λ(: l Literal+Constant+U64)(: r GlobalVariable+U64). (: (
+   (.program( \t 'mov \s '$ (.expression r) , \s '%r15 \n \t 'mov \s '0 \[ '%r15 \] , '%r15 \n \t 'add \s '$ (.expression l) , \s '%r15 \n ))
+   (.expression( 'r15 ))
+) Reg64+U64);
+
+fragment + := λ(: l GlobalVariable+U64)(: r LocalVariable+U64). (: (
+   (.program( \t 'mov \s '$ (.expression l) , \s '%r15 \n
+              \t 'mov \s '0 \[ '%r15 \] , '%r15 \n
+              \t 'mov \s (.expression r) \[ '%rbp \] , '%r14 \n
+              \t 'add \s '%r14 , \s '%r15 \n ))
+   (.expression( 'r15 ))
+) Reg64+U64);
+
 fragment - := λ(: l LocalVariable+U8)(: r Constant+U8). (: (
    (.program( \t 'mov \s (.expression l) \[ '%rbp \] , \s '%r12b \n \t 'sub \s '$ (.expression r) , \s '%r12b \n ))
    (.expression( 'r12b ))
@@ -151,4 +168,20 @@ fragment == := λ(: l U64+Literal+Constant)(: r U64+Reg64). (: (
    ))
    (.expression( 'je ))
 ) BranchConditional);
+fragment == := λ(: l U64+GlobalVariable)(: r U64+Literal+Constant). (: (
+   (.program (
+      \t 'mov \s '$ (.expression l) , '%r15 \n
+      \t 'mov \s '0 \[ '%r15 \] , \s '%r15 \n
+      \t 'cmp \s '$ (.expression r) , '%r15 \n
+   ))
+   (.expression( 'je ))
+) BranchConditional);
+fragment == := λ(: l U64+Literal+Constant)(: r U64+GlobalVariable). (: (
+   (.program (
+      \t 'mov \s '$ (.expression r) , '%r15 \n
+      \t 'mov \s '0 \[ '%r15 \] , \s '%r15 \n
+      \t 'cmp \s '$ (.expression l) , '%r15 \n
+   ))
+   (.expression( 'je ))
+) BranchConditional);
 

STDLIB/default-stdlib.lm

@@ -4,14 +4,29 @@ type S (SNil)
      | (SCons( S[] , S[] ))
      | (SPointer( ?[] ));
 
+close := λ(: x S). (: (tail(
+   ()
+   (as 0u64 S[])
+)) S[]);
+
 print := λ(: x S). (: (tail(
    (if (==( (.0 x) 3u64 )) (
       (print '\[\]_s)
    ) (
       (if (==( (.0 x) 2u64 )) (
          (print (.1 (as x SAtom)))
       ) (
-         (print (.0 x))
+         (if (==( (.0 x) 1u64 )) (tail(
+            (print '\[_s)
+            (print (as (.1 (as x SCons)) U64))
+            (print '\s_s)
+            (print (as (.2 (as x SCons)) U64))
+            (print '\]_s)
+         )) (tail(
+            (print '[_s)
+            (print (as (.1 (as x SPointer)) U64))
+            (print ']_s)
+         )))
       ))
    ))
    ()
@@ -155,3 +170,25 @@ print := λ(: x I8). (: (tail(
    123u8
    123u8
 )) U8);
+
+cons-page-tail := 0u64;
+malloc := λ (: sz U64) . (: (tail(
+   (if (==( cons-page-tail 0u64 )) (tail(
+      (mov( 12u64 RAX ))
+      (mov( 0u64 RDI ))
+      (syscall())
+      (mov( RAX R8 )) #current page break in R8
+      (set cons-page-tail (as R8 U64))
+      # 4 GB
+      (add( 1073741824u64 R8 ))
+      (add( 1073741824u64 R8 ))
+      (add( 1073741824u64 R8 ))
+      (add( 1073741824u64 R8 ))
+      (mov( 12u64 RAX ))
+      (mov( R8 RDI ))
+      (syscall())
+   )) ())
+   (let curr cons-page-tail)
+   (set cons-page-tail (+( cons-page-tail sz )))
+   (as curr ?[])
+)) ?[]);

STRICT/cli.lm

@@ -13,10 +13,19 @@ config-mode              := Compile;
 
 main := λ(: argc U64)(: argv U8[][]).(tail(
 #   (let argi 0u64)
-   (let input SNil)
-#   (let input (SAtom( 'test_s )))
+   (let input_l (SAtom( 'an-atom_s )))
+   (let input_r (SPointer( as 'test_s ?[] )))
+   (let input (SCons(
+      (close( input_l ))
+      (close( input_r ))
+   )))
+   (print input)
+   (print (as (malloc 24u64) U64))
+   (print ',_s)
+   (print (as (malloc 24u64) U64))
+   (print ',_s)
+   (print (as (malloc 24u64) U64))
 #   (while (<( argi argc )) (
-       (print input)
 #      (if (==( ([]( argv argi )) '--tokenize_s )) (
 #         (print '--tokenize_s)
 #      ) (