1: %{ 2: (* parser header *) 3: exception EndOfInput 4: open Flx_ast 5: open Flx_mtypes1 6: open Flx_typing 7: open Flx_typing2 8: open Flx_srcref 9: open Flx_print 10: open Flx_charset 11: open Flx_exceptions 12: open List 13: open Flx_util 14: 15: let list_last lst = List.hd (List.rev lst) 16: let generated = ("Generated by Parser",0,0,0,0) 17: let parse_error (s : string) = 18: raise (Flx_exceptions.ParseError "Error parsing input") 19: 20: (* model infix operator as function call *) 21: let apl2 (sri:srcref) (fn : string) (tup:expr_t list) = 22: let sr = rslist tup in 23: `AST_apply 24: ( 25: sr, 26: ( 27: `AST_name (slift sri,fn,[]), 28: `AST_tuple (sr,tup) 29: ) 30: ) 31: 32: (* model prefix operator as function call *) 33: let apl (sri:srcref) (fn : string) (arg:expr_t):expr_t = 34: let sr = src_of_expr arg in 35: `AST_apply 36: ( 37: sr, 38: ( 39: `AST_name (slift sri, fn,[]), 40: arg 41: ) 42: ) 43: 44: (* model unary operator as procedure call *) 45: let call1 (op:string) (sr:range_srcref) (sri:srcref) l = 46: `AST_call 47: ( 48: sr, `AST_name (slift sri, op,[]), l 49: ) 50: 51: (* model unary operator as procedure call *) 52: let call2 (op:string) (sr:range_srcref) (sri:srcref) l r = 53: `AST_call 54: ( 55: sr, 56: `AST_name (slift sri, op,[]), 57: `AST_tuple(sr,[l;r]) 58: ) 59: 60: let mkcurry sr name vs args return_type kind body = 61: `AST_curry (sr,name,vs,args,return_type,kind,body) 62: 63: (* handle curried type functions *) 64: (* type functions cannot have constraints yet .. so just ignore them *) 65: let mktypefun sr name vs args return_type body = 66: let argtyp t = match t with 67: | [] -> failwith "Lambda abstraction requires nonunit parameter" 68: | [x] -> x 69: | x -> `TYP_type_tuple x 70: in 71: let body = 72: let p = ref (List.rev args) in 73: let r = ref return_type in 74: let b = ref body in 75: while !p <> [] do 76: let arg = List.hd !p in 77: p := List.tl !p; 78: b := `TYP_typefun (fst arg, !r, !b); 79: r := `TYP_function(argtyp (List.map snd (fst arg)),!r) 80: done; 81: !b 82: in 83: `AST_type_alias 84: ( 85: sr, 86: name, 87: vs, 88: body 89: ) 90: 91: %} 92: