#line 2043 "/home/ubuntu/felix/src/packages/grammar.fdoc"
//$ General functional forms.
syntax functions {
  requires expressions;

  //$ Anonymous function (lamda).
  satom := sadjectives "fun" stvarlist slambda_fun_args fun_return_type "="? scompound =>#
    """
    `(ast_lambda ,_sr (,_3 ,_4 ,(first (first _5)) ,_7))
    """;

  //$ Anonymous function (lamda).
  x[slambda_pri] := sadjectives "fun" stvarlist slambda_fun_args fun_return_type "=>" sexpr =>#
    """
    `(ast_lambda ,_sr (,_3 ,_4 ,(first (first _5)) ((ast_fun_return ,_sr ,_7))))
    """;

  //$ Anonymous function (lamda). Linear
  x[slambda_pri] := sadjectives "fun" stvarlist slambda_fun_args fun_return_type "=>." sexpr =>#
    """
    `(ast_linearlambda ,_sr (,_3 ,_4 ,(first (first _5)) ((ast_fun_return ,_sr ,_7))))
    """;


  //$ Anonymous generator (lamda).
  satom := sadjectives "gen" stvarlist slambda_fun_args fun_return_type "="? scompound =>#
    """
    `(ast_generator ,_sr (,_3 ,_4 ,(first (first _5)) ,_7))
    """;

  //$ Anonymous generator (lamda).
  x[slambda_pri] := sadjectives "gen" stvarlist slambda_fun_args fun_return_type "=>" sexpr =>#
    """
    `(ast_generator ,_sr (,_3 ,_4 ,(first (first _5)) ((ast_fun_return ,_sr ,_7))))
    """;


  //$ Anonymous procedure (lamda).
  satom := sadjectives "proc" stvarlist slambda_fun_args scompound =>#
    """
    `(ast_lambda ,_sr (,_3 ,_4 (ast_void ,_sr) ,_5))
    """;

  //$ Anonymous procedure (lamda).
  satom  := sadjectives "proc" stvarlist scompound =>#
    """
    `(ast_lambda ,_sr (,_3 ((() none)) (ast_void ,_sr) ,_4))
    """;

  //$ Anonymous object constructor (lamda).
  //$ UGLY.
  satom := sadjectives "object" stvarlist slambda_fun_args fun_return_type "="? scompound =>#
    """
    `(ast_object ,_sr (,_3 ,_4 ,(first (first _5)) ,_7))
    """;

  //$ Function adjective (prefix property) inline.
  sadjective := "inline" =># "'InlineFunction";

  //$ Function adjective (prefix property) noinline.
  sadjective := "noinline" =># "'NoInlineFunction";
  //sadjective := "static" =># "'Static";

  //$ Function adjective (prefix property) extern.
  sadjective := "extern" =># "'NoInlineFunction";

  //$ Function adjective (prefix property) virtual.
  //$ In classes only. Specifies an overrideable function.
  sadjective := "virtual" =># "'Virtual";

  //$ Function dependent on its arguments only,
  //$ not dependent on any variables in its enclosing context.
  sadjective := "pure" =># "'Pure";

  //$ Function which fails  to evaluate argument
  //$ if and only if its argument fails,
  //$ i.e. f (error) = error
  sadjective := "strict" =># "'Strict";

  //$ Function which fails  to evaluate argument
  //$ if and only if its argument fails,
  //$ i.e. f (error) = error
  sadjective := "nonstrict" =># "'NonStrict";


  //$ Function may be dependent on variables in its enclosing context.
  sadjective := "impure" =># "'Impure";

  //$ Function returns a result for all argument values.
  sadjective := "total" =># "'Total";

  //$ Function may fail for some argument values.
  //$ Equivalent to a function with a non-tautologous but unknown pre-condition.
  sadjective := "partial" =># "'Partial";

  //$ Specifies a method, in an object definition only.
  sadjective := "method" =># "'Method";

  //$ Specifies function is to be exported under its Felix name.
  //$ Function must be top level and non-polymorphic.
  //$ Top level means the global space or a non-polymorphic class
  //$ nested in a top level space (recursively).
  sadjective := "export" =># "'Export";
  sadjective := "export" sstring =># "`(NamedExport ,_2)";

  sadjectives := sadjective* =># "_1";

  slambda_fun_arg := "(" sparameter_comma_list "when" sexpr ")" =># "`(,_2 (some ,_4))";
  slambda_fun_arg := "(" sparameter_comma_list ")" =># "`(,_2 none)";
  slambda_fun_args := slambda_fun_arg+ =># "_1";

  //$ Function return type specification with post-condition.
  fun_return_type := ":" stypeexpr "expect" sexpr =># "`((,_2 (some ,_4)) ,dflteffects)";
  fun_return_type := ":" "[" stypeexpr "]" stypeexpr "expect" sexpr =># "`((,_5 (some ,_7)) ,_3)";

  //$ Function return type specification without post-condition.
  fun_return_type := ":" stypeexpr =># "`((,_2 none) ,dflteffects)";
  fun_return_type := ":" "[" stypeexpr"]" stypeexpr =># "`((,_5 none) ,_3)";

  //$ Function return postcondition without type.
  fun_return_type := "expect" sexpr =># "`((typ_none (some ,_2)) ,dflteffects)";
  fun_return_type := ":" "[" stypeexpr "]" "expect" sexpr =># "`((typ_none (some ,_6)) ,_3)";

  //$ No return type.
  fun_return_type := ":" "[" stypeexpr "]" =># "`((typ_none none) ,_3)";
  fun_return_type := sepsilon =># "`((typ_none none) ,dflteffects)";

  //$ Object factory return type.
  object_return_type := stypeexpr =># "`(,_1 none)";

  //$ Object invariant
  sfunction := "invariant" sexpr ";" =># "`(ast_invariant, _sr, _2)";

  //$ Function parameter with type and default value.
  private sparameter := sparam_qual sname ":" t[sarrow_pri] "=" x[sor_condition_pri] =># "`(,_sr ,_1 ,_2 ,_4 (some ,_6))";

  //$ Function parameter with type.
  private sparameter := sparam_qual sname ":" t[sarrow_pri] =># "`(,_sr ,_1 ,_2 ,_4 none)";

  //$ Function parameter without type.
  //$ Defaults to polymorphic in unnamed type variable.
  private sparameter := sparam_qual sname =># "`(,_sr ,_1 ,_2 typ_none none)";

  //$ Empty parameter tuple.
  //private sparameter_comma_list = list::commalist0<sparameter>;

  // parameter list including nested params
  private sxparam := sparameter =># "`(Satom ,_1)";
  private sxparam := "(" list::commalist0<sxparam> ")" =># "`(Slist ,_2)";
  private sparameter_comma_list := list::commalist0<sxparam> =># "`(Slist ,_1)";

  //$ Parameter qualifier: val.
  private sparam_qual := "val" =># "'PVal";

  //$ Parameter qualifier: once.
  private sparam_qual := "once" =># "'POnce";

  //$ Parameter qualifier: var.
  private sparam_qual := "var" =># "'PVar";

  //$ Default parameter qualifier is val.
  private sparam_qual := sepsilon =># "'PDef";

  //$ Function tuple parameter with pre-condition.
  sfun_arg :=  "(" sparameter_comma_list "when" sexpr ")" =># "`(,_2 (some ,_4))";

  //$ Function tuple parameter without pre-condition.
  sfun_arg :=  "(" sparameter_comma_list ")" =># "`(,_2 none)";

  //$ Short form function parameter single polymorphic variable.
  sfun_arg :=  sname =># "`(((Satom (,_sr PVal ,_1 typ_none none))) none)";

  //$ Function binder: C function.
  //$ A function with C function type.
  sfun_kind := "cfun" =># "'CFunction";

  //$ Function binder: Generator.
  //$ A function with side effects.
  sfun_kind := "gen" =># "'Generator";

  //$ Function binder: Function.
  //$ A function without side-effects.
  sfun_kind := "fun" =># "'Function";

  stmt := sfunction =># "_1";

  //$ General function definition. Multiple tuple arguments, body is expression.
  //$ Example:
  //$
  //$ inline fun f (x:int when x>0) (y:long when y>0l) : long expect result > 0l => x.long + y;
  sfunction := sadjectives sfun_kind sdeclname sfun_arg* fun_return_type "=>" sexpr ";" =>#
    """
      (begin ;;(display "GENERAL FUNCTION")
      (let ((body `((ast_fun_return ,_sr ,_7))))
      `(ast_curry_effects ,_sr ,(first _3) ,(second _3) ,_4 ,(first _5) ,(second _5) ,(cal_funkind _1 _2) ,_1 ,body))
      )
    """;

  sfunction := sadjectives sfun_kind sdeclname sfun_arg* fun_return_type "=>." sexpr ";" =>#
    """
      (begin ;;(display "LINEAR FUNCTION")
      (let ((body `((ast_fun_return ,_sr ,_7))))
      `(ast_curry_effects ,_sr ,(first _3) ,(second _3) ,_4 ,(first _5) ,(second _5) ,(cal_funkind _1 _2) ,(cons 'LinearFunction _1) ,body))
      )
    """;


  //$ General function definition. Multiple tuple arguments, body of statements.
  //$ inline fun f (x:int when x>0) (y:long when y>0l) : long expect result > 0l { return x.long + y; }
  sfunction := sadjectives sfun_kind sdeclname sfun_arg* fun_return_type "="? scompound =>#
    """
      (begin ;;(display "COMPOUND FUNCTION")
      `(ast_curry_effects ,_sr ,(first _3) ,(second _3) ,_4 ,(first _5) ,(second _5) ,(cal_funkind _1 _2) ,_1 ,_7))
    """;

  //$ Object factory definition with interface type.
  sfunction := "object" sdeclname sfun_arg* "implements" object_return_type "="? scompound =>#
    """
      `(ast_curry ,_sr ,(first _2) ,(second _2) ,_3 ,_5 Object () ,_7)
    """;

  //$ Object factory definition without interface type.
  sfunction := "object" sdeclname sfun_arg*  "="? scompound =>#
    """
      `(ast_curry ,_sr ,(first _2) ,(second _2) ,_3 (typ_none none) Object () ,_5)
    """;

  //$ Object factory definition with inherited methods and
  //$ interface type.
  sfunction :=
    "object" sdeclname sfun_arg* "extends" expr_comma_list
    "implements" object_return_type "="? scompound
  =>#
    """
   (begin ;; (display "object function1\n")
   (let*
     (
       (d `(ast_object ,_sr (,dfltvs (,unitparam) typ_none ,_9)))  ;; extension function
       (a `(ast_apply ,_sr (,d ()))) ;; applied to unit
       (x `(ast_extension ,_sr ,_5 ,a)) ;; actual extension expression
       (retst `(ast_fun_return ,_sr ,x))
       (body `(,retst))
     )
     `(ast_curry ,_sr ,(first _2) ,(second _2) ,_3 ,_7 Function () ,body)
    ))
    """;

  //$ Object factory definition with inherited methods.
  sfunction := "object" sdeclname sfun_arg*  "extends" expr_comma_list "=" scompound =>#
    """
   (begin ;; (display "object function2\n")
   (let*
     (
       (noretype `(typ_none none))
       (d `(ast_object ,_sr (,dfltvs (,unitparam) typ_none ,_7)))  ;; extension function
       (a `(ast_apply ,_sr (,d ()))) ;; applied to unit
       (x `(ast_extension ,_sr ,_5 ,a)) ;; actual extension expression
       (retst `(ast_fun_return ,_sr ,x))
       (body `(,retst))
     )
     `(ast_curry ,_sr ,(first _2) ,(second _2) ,_3 ,noretype Function () ,body)
    ))
    """;


  sopt_cstring := "=" scode_spec =># "`(some ,_2)";
  sopt_cstring := sepsilon =># "'none";

  //$ Short form function definition. Example:
  //$
  //$ fun f : int -> int = | 0 => 0 | _ => 1;
/*
  sfunction := sadjectives sfun_kind sdeclname fun_return_type "=" smatching+ ";" =>#
    """
     (let
       (
        (t (first _4))
        (traint (second _4))
       )
      (begin ;;(display "MATCHING ftype=")(display t)(display "\\n")
      (if (eq? 'typ_arrow (first t))
        (let
          (
            (argt (caadr t))
            (ret (cadadr t))
            (body `((ast_fun_return ,_sr (ast_match ,_sr (,(noi '_a) ,_6)))))
          )
          `(ast_curry ,_sr ,(first _3) ,(second _3)
            (
              (((,_sr PVal _a ,argt none)) none)
            )
            (,ret ,traint)
            ,(cal_funkind _1 _2) ,_1 ,body)
        )
        (begin (display "ERROR MATCHINGS FUNDEF ")(display _sr) 'ERROR)
       )
       )
     )
    """;
*/

  sfunction := sadjectives sfun_kind sdeclname ":" stypeexpr "=" smatching+ ";" =>#
    """
     (let
       (
        (t _5)
       )
      (begin ;;(display "MATCHING ftype=")(display t)(display "\n")
        (let
          (
            (argt `(typ_apply ,_sr (,(nos "dom") ,t)))
            (ret `(typ_apply ,_sr (,(nos "cod") ,t)))
            (body `((ast_fun_return ,_sr (ast_match ,_sr (,(noi '_a) ,_7)))))
          )
          `(ast_curry ,_sr ,(first _3) ,(second _3)
            (
              ((Satom (,_sr PVal _a ,argt none)) none)
            )
            (,ret none)
            ,(cal_funkind _1 _2) ,_1 ,body)
        )
       )
     )
    """;


  sfunction := sadjectives sfun_kind sdeclname "=" sexpr ";" =>#
   """
      (let*
        (
          (traint 'none)
          (t `(ast_apply ,_sr (,(nos "typeof") ,_5)))
          (apl `(ast_apply ,_sr (,_5 ,(noi '_a))))
          (argt `(ast_apply ,_sr (,(nos "dom") ,t)))
          (ret `(ast_apply ,_sr (,(nos "cod") ,t)))
          (body `((ast_fun_return ,_sr ,apl )))
          (result `(ast_curry ,_sr ,(first _3) ,(second _3)
            (
              ((Satom (,_sr PVal _a ,argt none)) none)
            )
            (,ret ,traint)
            ,(cal_funkind _1 _2) ,_1 ,body)
          )
        )
        result
     )
    """;


  //$ Procedure binder.
  sproc_kind := "proc" =># "'Function";

  //$ C procedure binder.
  //$ Procedure has C function type (with void result type).
  sproc_kind := "cproc" =># "'CFunction";

  private sopt_traint_eq:= "expect" sexpr "=" =># "`((some ,_2) ,dflteffects)";
  private sopt_traint_eq:= "=" =># "`(none ,dflteffects)";
  private sopt_traint_eq:= sepsilon =># "`(none ,dflteffects)";

  private sopt_traint_eq:= "expect" sexpr ":" "[" stypeexpr "]" "=" =># "`((some ,_2) ,_5)";
  private sopt_traint_eq:= ":" "[" stypeexpr "]" "=" =># "`(none ,_3)";
  private sopt_traint_eq:= ":" "[" stypeexpr "]" =># "`(none ,_3)";


  private sopt_traint:= "expect" sexpr =># "`((some ,_2) ,dflteffects)";
  private sopt_traint:= sepsilon =># "`(none ,dflteffects)";

  private sopt_traint:= "expect" sexpr ":" "[" stypeexpr "]" =># "`((some ,_2) ,_5)";
  private sopt_traint:= ":" "[" stypeexpr "]" =># "`(none ,_3)";

  //$ Short form constructor function.
  //$ The name of the function must be a type name.
  //$ The return type is taken as the type with the name of the function.
  sfunction := "ctor" stvarlist squalified_name sfun_arg+ sopt_traint_eq scompound =>#
    """
    (let*
      (
        (name (string-append "_ctor_" (base_of_qualified_name _3)))
        (vs _2)
        (ret _3)
        (traint (first _5))
        (effects (second _5))
        (body _6)
        (args _4)
      )
      `(ast_curry_effects ,_sr ,name ,vs ,args (,ret ,traint) ,effects Function () ,body))
    """;
  sfunction := "supertype" stvarlist squalified_name sfun_arg+ sopt_traint_eq scompound =>#
    """
    (let*
      (
        (name (string-append "_supertype_" (base_of_qualified_name _3)))
        (vs _2)
        (ret _3)
        (traint (first _5))
        (effects (second _5))
        (body _6)
        (args _4)
      )
      `(ast_curry_effects ,_sr ,name ,vs ,args (,ret ,traint) ,effects Function (Subtype) ,body))
    """;

  //$ Short form constructor function.
  //$ The name of the function must be a type name.
  //$ The return type is taken as the type with the name of the function.
  sfunction := "ctor" stvarlist squalified_name sfun_arg+ sopt_traint "=>" sexpr ";" =>#
    """
    (let*
      (
        (name (string-append "_ctor_" (base_of_qualified_name _3)))
        (vs _2)
        (ret _3)
        (traint (first _5))
        (effects (second _5))
        (body `((ast_fun_return ,_sr ,_7)))
        (args _4)
      )
      `(ast_curry_effects ,_sr ,name ,vs ,args (,ret ,traint) ,effects Function () ,body))
    """;
  sfunction := "supertype" stvarlist squalified_name sfun_arg+ sopt_traint "=>" sexpr ";" =>#
    """
    (let*
      (
        (name (string-append "_supertype_" (base_of_qualified_name _3)))
        (vs _2)
        (ret _3)
        (traint (first _5))
        (effects (second _5))
        (body `((ast_fun_return ,_sr ,_7)))
        (args _4)
      )
      `(ast_curry_effects ,_sr ,name ,vs ,args (,ret ,traint) ,effects Function (Subtype) ,body))
    """;


  //$ Procedure definition, general form.
  sfunction := sadjectives sproc_kind sdeclname sfun_arg* sopt_traint_eq scompound =>#
    """
      `(ast_curry_effects ,_sr ,(first _3) ,(second _3) ,_4 ((ast_void ,_sr) ,(first _5)) ,(second _5)
         ,(cal_funkind _1 _2) ,_1 ,_6)
    """;

  //$ Procedure definition, short form (one statement).
  sfunction := sadjectives sproc_kind sdeclname sfun_arg* sopt_traint "=>" stmt =>#
    """
      `(ast_curry_effects ,_sr ,(first _3) ,(second _3) ,_4 ((ast_void ,_sr) ,(first _5)) ,(second _5)
         ,(cal_funkind _1 _2) ,_1 (,_7))
    """;

  //$ Routine definition, general form.
  sfunction := sadjectives "routine" sdeclname sfun_arg* sopt_traint_eq scompound =>#
    """
      `(ast_curry_effects ,_sr ,(first _3) ,(second _3) ,_4 (,(noi 'any) ,(first _5)) ,(second _5)
         Function ,_1 ,_6)
    """;

  //$ Routine definition, short form (one statement).
  sfunction := sadjectives "routine" sdeclname sfun_arg* sopt_traint "=>" stmt =>#
    """
      `(ast_curry_effects ,_sr ,(first _3) ,(second _3) ,_4 (,(noi 'any) ,(first _5)) ,(second _5)
         Function ,_1 (,_7))
    """;
}