Merge pull request #1509 from andrew-johnson-4/poly-return-macro-helpers

Poly return macro helpers

Author: andrew-johnson-4

BOOTSTRAP/cli.c

@@ -7,30 +7,33 @@ typed macro macro::set(lhs: lazy, rhs: lazy): lazy = (
    mov(rhs, lhs)
 );
 
+typed macro macro::set(base index: macro::lhs-index, rhs: lazy): lazy = (
+   $"set[]"( base, index, rhs )
+);
+
 #typed macro macro::set(base field: macro::lhs-field, rhs: lazy): lazy = (
 #   macro::concat(l"set.", field) (base, rhs)
 #);
 
-#typed macro macro::set(base index: macro::lhs-index, rhs: lazy): lazy = (
-#   $"set[]"( macro::lhs-as-rhs(base), index, rhs )
-#   macro::concat(l"set.", field) (base, rhs)
-#);
+typed macro macro::lhs-as-rhs(v: macro::variable): lazy = (
+   v
+);
 
-#typed macro macro::lhs-as-rhs(v: macro::variable): lazy = (
-#   v
-#);
+typed macro macro::lhs-as-rhs(base: macro::lhs-address-of): lazy = (
+   &v
+);
 
-#typed macro macro::lhs-as-rhs(_: macro::literal<"&">, v: lazy): lazy = (
-#   &v
-#);
+typed macro macro::lhs-address-of(base: lazy): lazy = (
+   base
+);
 
-#typed macro macro::lhs-as-rhs(base field: macro::lhs-index): lazy = (
-#   macro::concat(l".", field)(base)
-#);
+typed macro macro::lhs-as-rhs(base field: macro::lhs-index): lazy = (
+   macro::concat(l".", field)(base)
+);
 
-#typed macro macro::lhs-index(base: lazy, field: lazy): lazy = (
-#   base; field
-#);
+typed macro macro::lhs-index(base: lazy, field: lazy): lazy = (
+   base; field
+);
 
 typed macro macro::for(item: lazy, iter: List<?>, loop: lazy): lazy = (
    let uuid(iter-term) = iter;

PLATFORM/C/LIB/common-macros.lsts

@@ -274,7 +274,12 @@ let lsts-parse-typed-macro(tokens: List<Token>): (AST, List<Token>) = (
    lsts-parse-expect(c"(", tokens); tokens = tail(tokens);
    while lsts-parse-head(tokens)!=c")" {
       if not(is(margs,ASTNil)) then { lsts-parse-expect(c",", tokens); tokens = tail(tokens); };
-      (let mbind, tokens) = lsts-parse-atom-without-tail(tokens);
+      (let binding, tokens) = lsts-parse-identifier(tokens);
+      let mbind = mk-var(binding);
+      while lsts-parse-head(tokens) != c":" {
+         (binding, tokens) = lsts-parse-identifier(tokens);
+         mbind = mk-cons(mbind, mk-var(binding));
+      };
       lsts-parse-expect(c":", tokens); tokens = tail(tokens);
       (let mbindt, tokens) = lsts-parse-type(tokens);
       let marg = mk-app(mk-lit(c":"), mk-cons(mbind, mk-atype(mbindt)));
@@ -324,7 +329,7 @@ let lsts-parse-type-conjugate(tokens: List<Token>): Tuple<Type,List<Token>> = (
       lsts-parse-expect(c"?", tokens); tokens = tail(tokens);
       TAny {}
    } else if lsts-is-ident-head(lsts-parse-head(tokens)) && not(lsts-is-type-tag(lsts-parse-head(tokens))) {
-      let varname = lsts-parse-head(tokens); tokens = tail(tokens);
+      (let varname, tokens) = lsts-parse-identifier(tokens);
       TVar { varname }
    } else {
       if not(lsts-is-type-tag(lsts-parse-head(tokens))) {
@@ -1075,13 +1080,13 @@ let lsts-parse-small-expression(tokens: List<Token>): Tuple<AST,List<Token>> = (
          tokens = rhs-rest.second;
          lsts-parse-expect(c"}", tokens); tokens = tail(tokens);
          base = mk-app(
-            Var{ c"macro::while", with-location(mk-token("macro::while"),loc) },
-            mk-cons(
-               c-rest.first,
-               mk-app(
-                  Var{ c"scope", with-location(mk-token("scope"),loc) },
-                  rhs-rest.first
-               )
+            mk-app(
+               Var{ c"while", with-location(mk-token("while"),loc) },
+               c-rest.first
+            ),
+            mk-app(
+               Var{ c"scope", with-location(mk-token("scope"),loc) },
+               rhs-rest.first
             )
          );         
       );

PLUGINS/FRONTEND/LSTS/lsts-parse.lsts

@@ -11,11 +11,9 @@ let std-apply-macro-candidates(tctx: TContext?, mname: CString, margs: AST, cand
       if not(non-zero(t)) {
          (let new-tctx, let mctx) = std-try-destructure-macro(tctx, margs, ctype, mlhs);
          if mctx.is-some then mctx = union(mctx, Some{extract-uuids(mrhs)});
-         if mctx.is-some then t = with-location(substitute(mctx.get-or-panic, mrhs), margs.location);
+         if mctx.is-some then t = with-location-preserve(substitute(mctx.get-or-panic, mrhs), margs.location);
       }
    };
-   if not(non-zero(t)) then fail("Macro Application failed match during destructuring: \{mname}\n");
-   (tctx, t) = std-infer-expr(tctx, t, false, Used, TAny);
    (tctx, t)
 );
 
@@ -44,8 +42,18 @@ let std-try-destructure-macro(tctx: TContext?, margs: AST, mtype: Type, mcandida
                App{left:Lit{key:c":"}, right:App{mstruct=left, right:AType{tt=tt}}} => (
                   if non-zero(std-macro-helper-name(tt))
                   then {
-                     (tctx, let helped) = std-apply-macro(tctx, std-macro-helper-name(tt), margs);
-                     (tctx, std-direct-destructure-macro(helped, mstruct))
+                     let macro-helper = std-macro-helper-name(tt);
+                     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);
+                              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))
                );
                _ => (tctx, no);

SRC/std-apply-macro-candidates.lsts

@@ -7,7 +7,10 @@ let std-apply-macro(tctx: Maybe<TContext>, t: AST): (TContext?, AST) = (
    }
 );
 
-let std-apply-macro(tctx: Maybe<TContext>, mname: CString, margs: AST): (TContext?, AST) = (
+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, strong: Bool): (TContext?, AST) = (
    let row = index-macro-table.lookup(mname, [] :: List<(Type,Type,AST)>);
    let peep-holes = TAny;
    let peeped = TAny;
@@ -42,7 +45,10 @@ let std-apply-macro(tctx: Maybe<TContext>, mname: CString, margs: AST): (TContex
          candidates = [(mtype,mterm)];
       }
    };
-   std-apply-macro-candidates(tctx, mname, margs, candidates);
+   (tctx, let result) = std-apply-macro-candidates(tctx, mname, margs, candidates);
+   if strong && not(non-zero(result)) then exit-error("Failed to Apply Macro: \{mname}", margs);
+   if strong then (tctx, result) = std-infer-expr(tctx, result, false, Used, TAny);
+   (tctx, result)
 );
 
 let std-infer-peeped-arguments(tctx: Maybe<TContext>, t: AST, peep: Type): (Type, AST) = (
@@ -60,6 +66,7 @@ let std-infer-peeped-arguments(tctx: Maybe<TContext>, t: AST, peep: Type): (Type
          }
       );
       TAny{} => (ta, t);
+      TVar{} => (ta, t);
       _ => (
          (_, t) = std-infer-expr(tctx, t, false, Used, TAny);
          (typeof(t), t);

SRC/std-apply-macro.lsts

@@ -0,0 +1,9 @@
+
+let std-destructure-macro(lhs: AST, rhs: AST): AContext? = (
+   let no = None :: AContext?;
+   match (lhs, rhs) {
+      _ => fail("Unexpected std-destructure-macro\nLeft: \{lhs}\nRight: \{rhs}\n");
+   };
+   no
+);
+

SRC/std-destructure-macro.lsts

@@ -3,6 +3,13 @@ let std-direct-destructure-macro(margs: AST, mstruct: AST): AContext? = (
    let no = None :: AContext?;
    match (margs, mstruct) {
       Tuple{ val=first, second:Var{key=key} } => Some{[(key,val)]};
-      _ => (fail("Unexpected Pattern std-direct-destructure-macro:\nargs: \{margs}\nlhs: \{mstruct}\n"); no);
+      Tuple{
+         first:App{is-cons:1_u8, lrest=left, val=right },
+         second:App{is-cons:1_u8, rrest=left, right:Var{key=key} }
+      } => (
+         let ctx = std-direct-destructure-macro(lrest, rrest);
+         if ctx.is-some then Some{cons((key,val), ctx.get-or-panic)} else no;
+      );
+      _ => fail("Unexpected std-direct-destructure-macro\nLeft: \{mstruct}\nRight: \{margs}\n");
    }
 );

SRC/std-direct-destructure-macro.lsts

@@ -52,9 +52,7 @@ let substitute(ctx: AContext, term: AST): AST = (
          for vector s in seq { ret = ret.push(substitute(ctx,s)) };
          Seq{ret}
       );
-      App{is-cons=is-cons,left=left,right=right} => if is-cons
-      then mk-cons(substitute(ctx,left), substitute(ctx,right))
-      else mk-app(substitute(ctx,left), substitute(ctx,right));
+      App{is-cons=is-cons,left=left,right=right} => mk-cons-or-app(is-cons,substitute(ctx,left),substitute(ctx,right));
       Typedef{lhs=lhs,rhs=rhs} => mk-typedef(substitute(ctx,lhs), substitute(ctx,rhs));
       Abs{lhs=lhs,rhs=rhs,tt=tt} => mk-abs(substitute(ctx,lhs), substitute(ctx,rhs), tt);
       Glb{key=key,val=val} => mk-glb(key, substitute(ctx,val));

SRC/substitute.lsts

@@ -24,3 +24,4 @@ let .unroll-seq(t: AST): Vector<AST> = (
       _ => mk-vector(type(AST));
    }
 );
+

SRC/unit-orphans.lsts

@@ -19,3 +19,20 @@ let with-location(term: AST, loc: SourceLocation): AST = (
 let with-location(t: Token, loc: SourceLocation): Token = (
    if non-zero(t.location) then t else Token{ t.skey, t.key, iuid(), loc }
 );
+
+let with-location-preserve(term: AST, loc: SourceLocation): AST = (
+   match term {
+      Var{key=key,token=token} => Var{key,with-location(token,loc)};
+      Lit{key=key,token=token} => Lit{key,with-location(token,loc)};
+      App{is-cons=is-cons,left=left,right=right} => mk-cons-or-app(is-cons,with-location-preserve(left,loc),with-location-preserve(right,loc));
+      Seq{seq=seq} => (
+         let ret = mk-vector(type(AST), seq.length);
+         for vector s in seq { ret = ret.push(with-location-preserve(s,loc)) };
+         Seq{ret}
+      );
+      Abs{lhs=lhs,rhs=rhs,tt=tt} => Abs{close(with-location-preserve(lhs,loc)),close(with-location-preserve(rhs,loc)),tt};
+      Typedef{lhs=lhs,rhs=rhs} => Typedef{close(with-location-preserve(lhs,loc)),close(with-location-preserve(rhs,loc))};
+      Glb{key=key,val=val} => Glb{with-location(key,loc),close(with-location-preserve(val,loc))};
+      _ => term;
+   }
+);