Merge pull request #1513 from andrew-johnson-4/start-porting-match-macro

Start porting match macro

Author: andrew-johnson-4

BOOTSTRAP/cli.c

@@ -68,5 +68,26 @@ typed macro macro::while(cond: lazy, body: lazy): lazy = (
 );
 
 typed macro macro::assert(cond: lazy): lazy = (
-   if not(cond) then fail("Assertion Failed", macro::location(cond))
+   if not(cond) then fail("Assertion Failed", macro::location(here))
+);
+
+typed macro macro::match(t: lazy, ps: lazy): lazy = (
+   let uuid(term) = open(t);
+   macro::match-pats( uuid(term), ps );
+);
+
+typed macro macro::match-case(lhs: lazy, rhs: lazy, remainder: lazy): lazy = (
+   lhs; rhs; remainder
+);
+
+typed macro macro::match-pats(term: lazy, remainder: lazy): lazy = (
+   remainder
+);
+
+typed macro macro::match-pats(term: lazy, lhs rhs remainder: macro::match-case): lazy = (
+   scope(if macro::match-arm(lhs,term) then rhs else macro::match-pats(term,remainder))
+);
+
+typed macro macro::match-arm(v: macro::variable, term: lazy): lazy = (
+   (let v = term; true)
 );

PLATFORM/C/LIB/common-macros.lsts

@@ -4,7 +4,7 @@ cc-blob := λ(: caller-ctx FContext)(: function-name String)(: args AST)(: offse
    # caller context is provided but not propagated
    (let r (mk-fragment()))
 
-   (let f (find-global-callable( function-name (typeof args) )))
+   (let f (find-global-callable( function-name (typeof args) args )))
    (match f (
       ()
       ( (Glb( _ (Abs( lhs rhs tlt )) )) (
@@ -21,7 +21,7 @@ cc-blob := λ(: caller-ctx FContext)(: function-name String)(: args AST)(: offse
 
 cc-blob := λ(: callee-ctx FContext)(: function-name String)(: args-tt Type)(: offset I64)(: blame AST). (: (
    (let r (mk-fragment()))
-   (let f (find-global-callable( function-name args-tt )))
+   (let f (find-global-callable( function-name args-tt blame )))
    (match f (
       ()
       ( (Glb( _ (Abs( lhs rhs tlt )) )) (

PLUGINS/BACKEND/C/cc-blob.lm

@@ -4,7 +4,7 @@ compile-expr := λ(: ctx FContext)(: term AST)(: stack-offset I64)(: used IsUsed
    (match used (
       ()
       ( Return (
-         (let fterm (find-global-callable( 'cdecl::return_s (typeof term) )))
+         (let fterm (find-global-callable( 'cdecl::return_s (typeof term) term )))
          (set e (std-c-compile-call( ctx 'cdecl::return_s fterm term )))
       ))
       ( _ (

PLUGINS/BACKEND/C/compile-expr.lm

@@ -1,6 +1,6 @@
 
 let std-c-compile-call(ctx: FContext, fname: CString, fterm: AST, args: AST): Fragment = (
-   fterm = find-global-callable(fname, typeof(args));
+   fterm = find-global-callable(fname, typeof(args), args);
    if not(non-zero(fterm)) then fail("std-c-compile-call Function was null: \{fterm}\nArguments: \{typeof(args)}\n");
    if typeof(fterm).is-t(c"Blob") {
       let r = mk-fragment();
@@ -21,7 +21,7 @@ let std-c-compile-call(ctx: FContext, fname: CString, fterm: AST, args: AST): Fr
       let inner-ctx = mk-fctx().bind(c"ictx", t1(c"ImplicitContext"), ictx)
                                .bind(c"args", typeof(args), push-args);
       let r = mk-fragment();
-      match find-global-callable(c"primitive::call", t3(c"Cons",t1(c"ImplicitContext"),typeof(args))) {
+      match find-global-callable(c"primitive::call", t3(c"Cons",t1(c"ImplicitContext"),typeof(args)), args) {
          Glb{val:Abs{lhs=lhs, rhs=rhs}} => (
             r = blob-render(inner-ctx, rhs, r, 0);
             r.context = close(ctx);

PLUGINS/BACKEND/C/std-c-compile-call.lsts

@@ -66,7 +66,7 @@ let std-c-compile-expr(ctx: FContext, t: AST, is-stmt: Bool): Fragment = (
                guid = uuid();
                compile-smart-string-index = compile-smart-string-index.bind(val,guid);
                let lit = mk-lit(val); ascript-normal(lit, t1(c"String"));
-               let intern-ss = std-c-compile-call(ctx, c"intern", find-global-callable(c"intern", t1(c"String")), lit);
+               let intern-ss = std-c-compile-call(ctx, c"intern", find-global-callable(c"intern", t1(c"String"), t), lit);
                assemble-header-section = assemble-header-section +
                mangle-c-type(typeof(t)) + SAtom{c" "} + SAtom{guid} + SAtom{c";\n"};
                assemble-string-initializer-section = assemble-string-initializer-section +

PLUGINS/BACKEND/C/std-c-compile-expr.lsts

@@ -296,7 +296,7 @@ let lsts-parse-typed-macro(tokens: List<Token>): (AST, List<Token>) = (
    lsts-parse-expect(c";", tokens); tokens = tail(tokens);
    (mk-glb(
       mk-token(mname),
-      mk-abs(margs, mk-app(mk-lit(c":"), mk-cons(mbody,mk-atype(mrett))), t1(c"TypedMacro"))
+      mk-abs(margs, mk-app(mk-lit(c":"), mk-cons(without-location(mbody),mk-atype(mrett))), t1(c"TypedMacro"))
    ), tokens)
 );
 

PLUGINS/FRONTEND/LSTS/lsts-parse.lsts

@@ -1,5 +1,5 @@
 
-let find-global-callable(fname: CString, arg-types: Type): AST = (
+let find-global-callable(fname: CString, arg-types: Type, blame: AST): AST = (
    arg-types = denormalize-strong(arg-types);
    fname = find-alias(fname, arg-types);
    let match-set = mk-vector(type((Type,AST)), 16);
@@ -24,7 +24,7 @@ let find-global-callable(fname: CString, arg-types: Type): AST = (
       };
       exit(1);
    };
-   if not(non-zero(result)) then fail("Unable to find appropriate global callable: \{fname} \{arg-types}\n");
+   if not(non-zero(result)) then fail("Unable to find appropriate global callable: \{fname} \{arg-types}\nAt: \{blame.location}\n");
    result
 );
 

SRC/find-global-callable.lsts

@@ -2,6 +2,7 @@
 let index-macro-table = {} :: HashtableEq<CString,List<(Type,Type,AST)>>;
 index-macro-table = index-macro-table.bind(c"macro::concat", [] :: List<(Type,Type,AST)>);
 index-macro-table = index-macro-table.bind(c"macro::location", [] :: List<(Type,Type,AST)>);
+index-macro-table = index-macro-table.bind(c"macro::variable", [] :: List<(Type,Type,AST)>);
 
 let bind-new-macro(mname: CString, mterm: AST): Nil = (
    let row = index-macro-table.lookup(mname, [] :: List<(Type,Type,AST)>);

SRC/macro-table.lsts

@@ -46,13 +46,20 @@ let std-try-destructure-macro(tctx: TContext?, margs: AST, mtype: Type, mcandida
                      match margs {
                         App{left:Var{maybe-helper=key}, helper-args=right} => (
                            if macro-helper==maybe-helper {
-                              (tctx, let helped) = std-apply-macro-weak(tctx, macro-helper, helper-args);
+                              (tctx, let helped) = std-apply-macro-weak(tctx, macro-helper, helper-args, Used);
+                              if non-zero(helped)
+                              then (tctx, std-direct-destructure-macro(helped, mstruct))
+                              else (tctx, no)
+                           } else (tctx, no)
+                        );
+                        _ => (
+                           if macro-helper==c"macro::variable" {
+                              (tctx, let helped) = std-apply-macro-weak(tctx, macro-helper, margs, Used);
                               if non-zero(helped)
                               then (tctx, std-direct-destructure-macro(helped, mstruct))
                               else (tctx, no)
                            } else (tctx, no)
                         );
-                        _ => (tctx, no);
                      }
                   } else (tctx, std-direct-destructure-macro(margs, mstruct))
                );

SRC/std-apply-macro-candidates.lsts

@@ -1,14 +1,14 @@
 
-let std-apply-macro(tctx: Maybe<TContext>, t: AST): (TContext?, AST) = (
+let std-apply-macro(tctx: Maybe<TContext>, t: AST, used: IsUsed): (TContext?, AST) = (
    match t {
       App{left:Var{mname=key}, margs=right} => (
-         std-apply-macro(tctx, mname, margs);
+         std-apply-macro(tctx, mname, margs, used);
       );
    }
 );
 
-let std-apply-macro(tctx: Maybe<TContext>, mname: CString, margs: AST): (TContext?, AST) = std-apply-macro(tctx, mname, margs, true);
-let std-apply-macro-weak(tctx: Maybe<TContext>, mname: CString, margs: AST): (TContext?, AST) = std-apply-macro(tctx, mname, margs, false);
+let std-apply-macro(tctx: Maybe<TContext>, mname: CString, margs: AST, used: IsUsed): (TContext?, AST) = std-apply-macro(tctx, mname, margs, used, true);
+let std-apply-macro-weak(tctx: Maybe<TContext>, mname: CString, margs: AST, used: IsUsed): (TContext?, AST) = std-apply-macro(tctx, mname, margs, used, false);
 
 let std-apply-macro-concat(tctx: Maybe<TContext>, mname: CString, margs: AST): (TContext?, AST) = (
    match margs {
@@ -17,14 +17,22 @@ let std-apply-macro-concat(tctx: Maybe<TContext>, mname: CString, margs: AST): (
    }
 );
 
+let std-apply-macro-variable(tctx: Maybe<TContext>, mname: CString, margs: AST): (TContext?, AST) = (
+   match margs {
+      Var{} => (tctx, margs);
+      _ => (tctx, ASTEOF);
+   }
+);
+
 let std-apply-macro-location(tctx: Maybe<TContext>, mname: CString, margs: AST): (TContext?, AST) = (
    (tctx, mk-lit(to-smart-string(margs.location)).ascript(t1(c"SmartString")))
 );
 
-let std-apply-macro(tctx: Maybe<TContext>, mname: CString, margs: AST, strong: Bool): (TContext?, AST) = (
+let std-apply-macro(tctx: Maybe<TContext>, mname: CString, margs: AST, used: IsUsed, strong: Bool): (TContext?, AST) = (
    let result = ASTEOF;
    if mname==c"macro::concat" then (tctx, result) = std-apply-macro-concat(tctx, mname, margs)
    else if mname==c"macro::location" then (tctx, result) = std-apply-macro-location(tctx, mname, margs)
+   else if mname==c"macro::variable" then (tctx, result) = std-apply-macro-variable(tctx, mname, margs)
    else {
       let row = index-macro-table.lookup(mname, [] :: List<(Type,Type,AST)>);
       let peep-holes = TAny;
@@ -63,7 +71,7 @@ let std-apply-macro(tctx: Maybe<TContext>, mname: CString, margs: AST, strong: B
       (tctx, result) = std-apply-macro-candidates(tctx, mname, margs, candidates);
    };
    if strong && not(non-zero(result)) then exit-error("Failed to Apply Macro: \{mname}\nArgs: \{margs}\n", margs);
-   if strong then (tctx, result) = std-infer-expr(tctx, result, false, Used, TAny);
+   if strong then (tctx, result) = std-infer-expr(tctx, result, false, used, TAny);
    (tctx, result)
 );
 

SRC/std-apply-macro.lsts

@@ -66,13 +66,13 @@ let std-infer-expr(tctx: Maybe<TContext>, term: AST, is-scoped: Bool, used: IsUs
       );
       App{left:App{ left:App{ ifv=left:Var{key:c"if"}, cond=right }, t=right }, f=right} => (
          if is-scoped {
-            (let tctx-inner, let new-cond) = std-infer-expr(tctx, cond, false, Used, TAny);
+            (let tctx-inner, let new-cond) = std-infer-expr(tctx, cond, false, Tail, TAny);
             (_, let new-t) = std-infer-expr(tctx-inner, t, false, Tail, TAny);
             (_, let new-f) = std-infer-expr(tctx, f, false, Tail, TAny);
             if not(is(cond,new-cond)) || not(is(t,new-t)) || not(is(f,new-f))
             then { cond = new-cond; t = new-t; f = new-f; term = mk-app(mk-app(mk-app(ifv,new-cond),new-t),new-f) };
          } else {
-            (tctx, let new-cond) = std-infer-expr(tctx, cond, false, Used, TAny);
+            (tctx, let new-cond) = std-infer-expr(tctx, cond, false, Tail, TAny);
             (let tctx-t, let new-t) = std-infer-expr(tctx, t, false, Tail, TAny);
             (_, let new-f) = std-infer-expr(tctx, f, false, Tail, TAny);
             tctx = tctx-t;
@@ -160,7 +160,7 @@ let std-infer-expr(tctx: Maybe<TContext>, term: AST, is-scoped: Bool, used: IsUs
             }};
 
             if index-macro-table.has(var-name-if-var(l)) {
-               (tctx, term) = std-apply-macro(tctx, term);
+               (tctx, term) = std-apply-macro(tctx, term, used);
                is-macro = true;
             } else {
                (tctx, let new-l) = std-infer-expr(tctx, l, false, used, TAny);

SRC/std-infer-expr.lsts

@@ -8,3 +8,13 @@ let .into(tctx: Maybe<TContext>, tt: Type<String>): String = (
 );
 
 let to-smart-string(tctx: Maybe<TContext>): String = tctx.into(type(String));
+
+let .into(ctx: Maybe<AContext>, tt: Type<String>): String = (
+   let result = "";
+   for Tuple{first=first,second=second} in ctx.get-or([] :: AContext) {
+      result = result + "\{first} : \{second}\n";
+   };
+   result
+);
+
+let to-smart-string(ctx: Maybe<AContext>): String = ctx.into(type(String));

SRC/tctx-to-string.lsts

@@ -69,7 +69,7 @@ defof-var := λ(: sloc AST)(: tctx Maybe<TContext>)(: vname String)(: tt Type).
       (if (non-zero found) () (
          (if (.is-arrow kt) (
             (if (non-zero tt) (
-               (set found (find-global-callable( vname tt )))
+               (set found (find-global-callable( vname tt sloc )))
             ) (set found t))
          ) (
             (set found t)

SRC/typeof-var-raw.lm

@@ -5,7 +5,7 @@ let without-location(term: AST): AST = (
    match term {
       Var{key=key,token=token} => Var{key,without-location(token)};
       Lit{key=key,token=token} => Lit{key,without-location(token)};
-      App{left=left,right=right} => App{close(without-location(left)),close(without-location(right))};
+      App{is-cons=is-cons,left=left,right=right} => App{is-cons,close(without-location(left)),close(without-location(right))};
       Seq{seq=seq} => (
          let ret = mk-vector(type(AST), seq.length);
          for vector s in seq { ret = ret.push(without-location(s)) };

SRC/without-location.lsts

@@ -32,6 +32,12 @@ type A = A{a:U64};
 
 macro::assert(true);
 
+(
+   macro::match(123, macro::match-case(
+      x, print(x), fail("Pattern Match Failure",macro::location(here))
+   ));
+);
+
 # match
 
 # for

tests/unit/ast-macros.lsts

@@ -1 +1 @@
-[3,4]20123
+[3,4]20123123