From d41fa57ee5c7c03b2922334658c89dde0d006358 Mon Sep 17 00:00:00 2001 From: Matthew Iselin Date: Wed, 1 Apr 2026 10:41:32 -0700 Subject: [PATCH 1/2] language spec update before impl --- docs/language.md | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/docs/language.md b/docs/language.md index 23b7e52..1bf1860 100644 --- a/docs/language.md +++ b/docs/language.md @@ -50,6 +50,13 @@ To type a variable as a signed integer N bits wide, use `iN`: For an unsigned integer, use a `u` prefix instead of `i`. +Type aliases can be used with annotations to create integer types with specific byte orders: + +``` +type be16 = u16 @byte_order(BigEndian); +type le16 = u16 @byte_order(LittleEndian); +``` + ### Floats Use the type `float` for floating-point numbers. @@ -170,6 +177,33 @@ Single-element structs do not require a trailing comma: let Thing thing = { 1234 }; ``` +#### Structure Layout + +To pack a structure in Haven, use the `@layout` annotation: + +``` +type Point = struct @layout(packed) { + i32 x; + i32 y; /* starts at 4th byte of structure - packed layout omits any inter-field padding */ +}; +``` + +To control the layout of a structure in Haven, use the `@offset` annotation: + +``` +type Point = struct { + i32 x @offset(8); /* starts at 8th byte of the structure */ + i32 y @offset(4); /* starts at 4th byte of the structure */ + i32 z; /* fills the available hole at byte 0 of the structure */ + i32 w; /* starts at next available slot in the structure, at 12th byte */ +}; +``` + +Fields that do not have offsets specified will fill available holes in the structure on either side of `@offset`-positioned fields. + +Offsets are not permitted to overlap and compile-time analysis will error if an impossible layout is requested. +Note that adding offsets implies a packed structure layout, even without the annotation. + ### Enums You may define an enum type using two forms. From 5a3b64ffcbf8bb0c11e2f50d07ac5e8b769a471b Mon Sep 17 00:00:00 2001 From: Matthew Iselin Date: Wed, 1 Apr 2026 11:35:47 -0700 Subject: [PATCH 2/2] make directive parsing more generic --- src/bin/lsp/semantic_tokens.ml | 6 +- src/lib/ast/convert.ml | 431 +++++++++++++++++++-------------- src/lib/cst/cst.ml | 27 ++- src/lib/cst/emit.ml | 33 ++- src/lib/cst/locate.ml | 21 +- src/lib/cst/pretty.ml | 15 +- src/lib/lexer/lexer.ml | 84 ++----- src/lib/lexer/pretty.ml | 3 +- src/lib/parser/grammar.mly | 14 +- src/lib/parser/parser.ml | 3 +- 10 files changed, 355 insertions(+), 282 deletions(-) diff --git a/src/bin/lsp/semantic_tokens.ml b/src/bin/lsp/semantic_tokens.ml index a31c8f1..00ea35d 100644 --- a/src/bin/lsp/semantic_tokens.ml +++ b/src/bin/lsp/semantic_tokens.ml @@ -205,7 +205,7 @@ let symbol_is_operator = function | LtEq | GtEq | LShift | RShift | Lt | Gt | Star | Caret | Plus | Minus | Slash | Percent | Equal | Ampersand | Pipe | Bang | Tilde | LParen | RParen | LBrace | RBrace | LBracket | RBracket | Comma | Dot | Semicolon | Colon - | Underscore -> + | Underscore | At -> true let collect_lexical_tokens (parsed : CST.parsed_program) = @@ -219,10 +219,6 @@ let collect_lexical_tokens (parsed : CST.parsed_program) = (loc_of_raw_tok { tok = entry.token; startp = entry.startp; endp = entry.endp }) | Lexer.Raw.Ident _ -> acc - | Lexer.Raw.Directive Assert -> - add_token_for_loc acc ~token_type:"keyword" - (loc_of_raw_tok - { tok = entry.token; startp = entry.startp; endp = entry.endp }) | Lexer.Raw.Numeric_type _ | Vec_type _ | Mat_type _ | Vec_hole_type | Mat_hole_type | Float_type | Void_type | Str_type -> add_token_for_loc acc ~token_type:"type" diff --git a/src/lib/ast/convert.ml b/src/lib/ast/convert.ml index 362dec6..280cf3c 100644 --- a/src/lib/ast/convert.ml +++ b/src/lib/ast/convert.ml @@ -1,5 +1,4 @@ open Haven_core - module Cst = Haven_cst.Cst module Surface = Surface_ast module Core = Core_ast @@ -35,7 +34,6 @@ let mk_surface_arm loc value : Surface.match_arm = { value; loc } let mk_surface_vec loc value : Surface.vec_literal = { value; loc } let mk_surface_mat loc value : Surface.mat_literal = { value; loc } let mk_surface_enum loc value : Surface.enum_literal = { value; loc } - let mk_core loc value : _ Core.node = { value; loc } let mk_core_ident loc value : Core.identifier = { value; loc } let mk_core_expr loc value : Core.expression = { value; loc } @@ -59,7 +57,8 @@ type surface_extension_hooks = { let default_iter_type loc = mk_core_type loc - (Core.NumericType { Haven_token.Token.signedness = Haven_token.Token.Signed; bits = 32 }) + (Core.NumericType + { Haven_token.Token.signedness = Haven_token.Token.Signed; bits = 32 }) let string_of_loc (loc : Loc.t) = let pos = loc.start_pos in @@ -70,22 +69,18 @@ let string_of_loc (loc : Loc.t) = let rec surface_type_has_specialization_hole (ty : Surface.haven_type) = match ty.value with | Surface.VecHoleType | Surface.MatrixHoleType -> true - | Surface.CellType inner - | Surface.PointerType inner - | Surface.BoxType inner -> + | Surface.CellType inner | Surface.PointerType inner | Surface.BoxType inner + -> surface_type_has_specialization_hole inner - | Surface.ArrayType arr -> surface_type_has_specialization_hole arr.value.element + | Surface.ArrayType arr -> + surface_type_has_specialization_hole arr.value.element | Surface.FunctionType fn -> surface_type_has_specialization_hole fn.value.return_type || List.exists surface_type_has_specialization_hole fn.value.param_types | Surface.TemplatedType templ -> List.exists surface_type_has_specialization_hole templ.value.inner - | Surface.NumericType _ - | Surface.VecType _ - | Surface.MatrixType _ - | Surface.FloatType - | Surface.VoidType - | Surface.StringType + | Surface.NumericType _ | Surface.VecType _ | Surface.MatrixType _ + | Surface.FloatType | Surface.VoidType | Surface.StringType | Surface.CustomType _ -> false @@ -96,10 +91,12 @@ let function_has_specialization_param (fn : Surface.function_decl) = fn.value.params.value.params let validate_surface_function_decl (fn : Surface.function_decl) = - if fn.value.return_type = None && not (function_has_specialization_param fn) then + if fn.value.return_type = None && not (function_has_specialization_param fn) + then failwith (Printf.sprintf - "function %s omits its return type, but only specialization functions may infer returns (%s)" + "function %s omits its return type, but only specialization functions \ + may infer returns (%s)" fn.value.name.value (string_of_loc fn.loc)) let rec cst_program_to_surface (program : Cst.program) : Surface.program = @@ -119,7 +116,8 @@ and cst_top_decl_to_surface (decl : Cst.top_decl) : Surface.top_decl = in mk_surface decl.loc value -and cst_function_decl_to_surface (fn : Cst.function_decl) : Surface.function_decl = +and cst_function_decl_to_surface (fn : Cst.function_decl) : + Surface.function_decl = let value = { Surface.public = fn.value.public; @@ -139,7 +137,8 @@ and cst_function_decl_to_surface (fn : Cst.function_decl) : Surface.function_dec and cst_intrinsic_to_surface (intr : Cst.intrinsic) : Surface.intrinsic = let value = { - Surface.name = { value = intr.value.name.value; loc = intr.value.name.loc }; + Surface.name = + { value = intr.value.name.value; loc = intr.value.name.loc }; types = List.map cst_type_to_surface intr.value.types; } in @@ -225,7 +224,8 @@ and cst_type_decl_to_surface (decl : Cst.type_decl) : Surface.type_decl = and cst_type_decl_data_to_surface = function | Cst.TypeDeclAlias ty -> Surface.TypeDeclAlias (cst_type_to_surface ty) - | Cst.TypeDeclStruct s -> Surface.TypeDeclStruct (cst_struct_decl_to_surface s) + | Cst.TypeDeclStruct s -> + Surface.TypeDeclStruct (cst_struct_decl_to_surface s) | Cst.TypeDeclEnum e -> Surface.TypeDeclEnum (cst_enum_decl_to_surface e) | Cst.TypeDeclForward -> Surface.TypeDeclForward @@ -238,7 +238,8 @@ and cst_struct_decl_to_surface (decl : Cst.struct_decl) : Surface.struct_decl = in mk_surface decl.loc value -and cst_struct_field_to_surface (field : Cst.struct_field) : Surface.struct_field = +and cst_struct_field_to_surface (field : Cst.struct_field) : + Surface.struct_field = let value : Surface.struct_field_desc = { Surface.name = cst_identifier_to_surface field.value.name; @@ -256,7 +257,8 @@ and cst_enum_decl_to_surface (decl : Cst.enum_decl) : Surface.enum_decl = in mk_surface decl.loc value -and cst_enum_variant_to_surface (variant : Cst.enum_variant) : Surface.enum_variant = +and cst_enum_variant_to_surface (variant : Cst.enum_variant) : + Surface.enum_variant = let value = { Surface.name = cst_identifier_to_surface variant.value.name; @@ -268,7 +270,8 @@ and cst_enum_variant_to_surface (variant : Cst.enum_variant) : Surface.enum_vari and cst_foreign_to_surface (foreign : Cst.foreign) : Surface.foreign = let value = { - Surface.lib = { value = foreign.value.lib.value; loc = foreign.value.lib.loc }; + Surface.lib = + { value = foreign.value.lib.value; loc = foreign.value.lib.loc }; decls = List.map cst_function_decl_to_surface foreign.value.decls; } in @@ -281,29 +284,30 @@ and cst_block_to_surface (block : Cst.block) : Surface.block = let statements, result = match List.rev lowered_items with | LoweredExpression expr :: rev_prefix -> - ( List.rev_map lowered_item_to_statement rev_prefix, - Some expr ) + (List.rev_map lowered_item_to_statement rev_prefix, Some expr) | rev_items -> (List.rev_map lowered_item_to_statement rev_items, None) in mk_surface_block block.loc { statements; result } -and cst_block_item_to_surface (item : Cst.block_item) : lowered_block_item option = +and cst_block_item_to_surface (item : Cst.block_item) : + lowered_block_item option = match item.value with | Cst.BlockStatement stmt -> Option.map (fun stmt -> LoweredStatement stmt) (cst_statement_to_surface stmt) - | Cst.BlockExpression expr -> Some (LoweredExpression (cst_expr_to_surface expr)) + | Cst.BlockExpression expr -> + Some (LoweredExpression (cst_expr_to_surface expr)) and lowered_item_to_statement = function | LoweredStatement stmt -> stmt - | LoweredExpression expr -> - mk_surface_stmt expr.loc (Surface.Expression expr) + | LoweredExpression expr -> mk_surface_stmt expr.loc (Surface.Expression expr) and cst_statement_to_surface (stmt : Cst.statement) : Surface.statement option = let value = match stmt.value with - | Cst.Expression expr -> Some (Surface.Expression (cst_expr_to_surface expr)) + | Cst.Expression expr -> + Some (Surface.Expression (cst_expr_to_surface expr)) | Cst.Let binding -> Some (Surface.Let @@ -314,19 +318,33 @@ and cst_statement_to_surface (stmt : Cst.statement) : Surface.statement option = name = cst_identifier_to_surface binding.value.name; init_expr = cst_expr_to_surface binding.value.init_expr; })) - | Cst.CompileAssert compile_assert -> - Some - (Surface.CompileAssert - (mk_surface compile_assert.loc - { - Surface.cond = cst_expr_to_surface compile_assert.value.cond; - message = - { - value = compile_assert.value.message.value; - loc = compile_assert.value.message.loc; - }; - })) - | Cst.Return expr -> Some (Surface.Return (Option.map cst_expr_to_surface expr)) + | Cst.Directive directive -> ( + match directive.value with + | DirectiveCall c -> + failwith + (Printf.sprintf "directive calls not yet implemented (for %s)" + c.name.value) + | DirectiveCompileTime compile_time -> ( + match compile_time.name.value with + | "assert" -> + Some + (Surface.CompileAssert + (mk_surface directive.loc + { + Surface.cond = cst_expr_to_surface compile_time.cond; + message = + { + value = compile_time.message.value; + loc = compile_time.message.loc; + }; + })) + | _ -> + (* TODO: this is probably too early to bail, we should store in an "UnknownCompileTimeDirective" or sometihng and bail in a later pass, but works for now *) + failwith + (Printf.sprintf "compile-time directive %s is not known" + compile_time.name.value))) + | Cst.Return expr -> + Some (Surface.Return (Option.map cst_expr_to_surface expr)) | Cst.Defer expr -> Some (Surface.Defer (cst_expr_to_surface expr)) | Cst.Iter iter -> Some @@ -458,7 +476,8 @@ and cst_mat_to_surface (mat : Cst.mat_literal) : Surface.mat_literal = mk_surface_mat mat.loc { Surface.rows = List.map cst_expr_to_surface mat.value.rows } -and cst_enum_literal_to_surface (enum : Cst.enum_literal) : Surface.enum_literal = +and cst_enum_literal_to_surface (enum : Cst.enum_literal) : Surface.enum_literal + = mk_surface_enum enum.loc { Surface.enum_name = cst_identifier_to_surface enum.value.enum_name; @@ -485,7 +504,8 @@ and cst_type_to_surface (ty : Cst.haven_type) : Surface.haven_type = Surface.FunctionType (mk_surface fn.loc { - Surface.param_types = List.map cst_type_to_surface fn.value.param_types; + Surface.param_types = + List.map cst_type_to_surface fn.value.param_types; return_type = cst_type_to_surface fn.value.return_type; vararg = fn.value.vararg; }) @@ -512,7 +532,8 @@ and cst_identifier_to_surface (id : Cst.identifier) : Surface.identifier = mk_surface_ident id.loc id.value and cst_init_to_surface (init : Cst.init_list) : Surface.init_list = - mk_surface init.loc { Surface.exprs = List.map cst_expr_to_surface init.value.exprs } + mk_surface init.loc + { Surface.exprs = List.map cst_expr_to_surface init.value.exprs } and cst_as_expr_to_surface (cast : Cst.as_expr) : Surface.as_expr = mk_surface cast.loc @@ -527,8 +548,13 @@ and cst_if_expr_to_surface (ifx : Cst.if_expr) : Surface.if_expr = | None -> None | Some (Cst.Else block) -> Some (cst_block_to_surface block) | Some (Cst.ElseIf nested_if) -> - let nested_expr = mk_surface_expr nested_if.loc (Surface.If (cst_if_expr_to_surface nested_if)) in - Some (mk_surface_block nested_if.loc { statements = []; result = Some nested_expr }) + let nested_expr = + mk_surface_expr nested_if.loc + (Surface.If (cst_if_expr_to_surface nested_if)) + in + Some + (mk_surface_block nested_if.loc + { statements = []; result = Some nested_expr }) in mk_surface ifx.loc { @@ -551,19 +577,24 @@ and cst_match_arm_to_surface (arm : Cst.match_arm) : Surface.match_arm = expr = cst_expr_to_surface arm.value.expr; } -and cst_match_pattern_to_surface (pat : Cst.match_pattern) : Surface.match_pattern = +and cst_match_pattern_to_surface (pat : Cst.match_pattern) : + Surface.match_pattern = let value = match pat.value with | Cst.PatternDefault -> Surface.PatternDefault - | Cst.PatternLiteral lit -> Surface.PatternLiteral (cst_literal_to_surface lit) - | Cst.PatternEnum enum -> Surface.PatternEnum (cst_pattern_enum_to_surface enum) + | Cst.PatternLiteral lit -> + Surface.PatternLiteral (cst_literal_to_surface lit) + | Cst.PatternEnum enum -> + Surface.PatternEnum (cst_pattern_enum_to_surface enum) in mk_surface_pattern pat.loc value -and cst_pattern_enum_to_surface (enum : Cst.pattern_enum) : Surface.pattern_enum = +and cst_pattern_enum_to_surface (enum : Cst.pattern_enum) : Surface.pattern_enum + = mk_surface enum.loc { - Surface.enum_name = Option.map cst_identifier_to_surface enum.value.enum_name; + Surface.enum_name = + Option.map cst_identifier_to_surface enum.value.enum_name; enum_variant = cst_identifier_to_surface enum.value.enum_variant; binding = List.map cst_pattern_binding_to_surface enum.value.binding; } @@ -647,7 +678,8 @@ let rec surface_type_to_core (ty : Surface.haven_type) : Core.haven_type = Core.FunctionType (mk_core fn.loc { - Core.param_types = List.map surface_type_to_core fn.value.param_types; + Core.param_types = + List.map surface_type_to_core fn.value.param_types; return_type = surface_type_to_core fn.value.return_type; vararg = fn.value.vararg; }) @@ -660,14 +692,17 @@ let rec surface_type_to_core (ty : Surface.haven_type) : Core.haven_type = Core.element = surface_type_to_core arr.value.element; count = surface_literal_to_core - (fun _ -> invalid_arg "array count literals do not contain expressions") + (fun _ -> + invalid_arg + "array count literals do not contain expressions") arr.value.count; }) | Surface.TemplatedType templ -> Core.TemplatedType (mk_core templ.loc { - Core.outer = mk_core_ident templ.value.outer.loc templ.value.outer.value; + Core.outer = + mk_core_ident templ.value.outer.loc templ.value.outer.value; inner = List.map surface_type_to_core templ.value.inner; }) in @@ -685,7 +720,8 @@ and surface_literal_to_core map_expr (lit : Surface.literal) : Core.literal = | Surface.Char c -> Core.Char c | Surface.Matrix mat -> Core.Matrix (surface_mat_to_core map_expr mat) | Surface.Vector vec -> Core.Vector (surface_vec_to_core map_expr vec) - | Surface.Enum enum -> Core.Enum (surface_enum_literal_to_core map_expr enum) + | Surface.Enum enum -> + Core.Enum (surface_enum_literal_to_core map_expr enum) in mk_core_literal lit.loc value @@ -693,18 +729,18 @@ and core_bool_literal_expr loc value = mk_core_expr loc (Core.Literal (mk_core_literal loc (Core.Bool value))) and core_false_expr loc = core_bool_literal_expr loc false - and core_true_expr loc = core_bool_literal_expr loc true -and surface_vec_to_core map_expr (vec : Surface.vec_literal) : Core.vec_literal = - mk_core_vec vec.loc - { Core.elements = List.map map_expr vec.value.elements } +and surface_vec_to_core map_expr (vec : Surface.vec_literal) : Core.vec_literal + = + mk_core_vec vec.loc { Core.elements = List.map map_expr vec.value.elements } -and surface_mat_to_core map_expr (mat : Surface.mat_literal) : Core.mat_literal = - mk_core_mat mat.loc - { Core.rows = List.map map_expr mat.value.rows } +and surface_mat_to_core map_expr (mat : Surface.mat_literal) : Core.mat_literal + = + mk_core_mat mat.loc { Core.rows = List.map map_expr mat.value.rows } -and surface_enum_literal_to_core map_expr (enum : Surface.enum_literal) : Core.enum_literal = +and surface_enum_literal_to_core map_expr (enum : Surface.enum_literal) : + Core.enum_literal = mk_core_enum enum.loc { Core.enum_name = surface_identifier_to_core enum.value.enum_name; @@ -722,7 +758,7 @@ and core_identifier_expr (id : Core.identifier) = and core_binary_expr loc op left right = mk_core_expr loc (Core.Binary (mk_core loc { Core.left; right; op })) -and core_match_arm loc pattern expr = mk_core_arm loc { Core.pattern = pattern; expr } +and core_match_arm loc pattern expr = mk_core_arm loc { Core.pattern; expr } let rec const_int_of_surface_expr (expr : Surface.expression) = match expr.value with @@ -784,14 +820,12 @@ let mk_surface_pointer_type loc inner = let mk_surface_void_type loc = mk_surface_type loc Surface.VoidType -let synthesize_surface_lifecycle_fn - (target : Surface.identifier) - kind loc - (user_params : Surface.param list) - body = +let synthesize_surface_lifecycle_fn (target : Surface.identifier) kind loc + (user_params : Surface.param list) body = let self_ident = mk_surface_ident loc "self" in let target_ty = - mk_surface_type loc (Surface.CustomType { name = mk_surface_ident target.loc target.value }) + mk_surface_type loc + (Surface.CustomType { name = mk_surface_ident target.loc target.value }) in let self_ty = mk_surface_pointer_type loc target_ty in mk_surface loc @@ -805,17 +839,16 @@ let synthesize_surface_lifecycle_fn mk_surface loc { Surface.params = - (mk_surface loc { Surface.name = self_ident; ty = self_ty }) :: user_params; + mk_surface loc { Surface.name = self_ident; ty = self_ty } + :: user_params; vararg = false; }; return_type = Some (mk_surface_void_type loc); vararg = false; } -let merge_surface_extension - (target : Surface.identifier) - (existing : surface_extension_hooks) - (ext : Surface.type_extend) = +let merge_surface_extension (target : Surface.identifier) + (existing : surface_extension_hooks) (ext : Surface.type_extend) = let construct = match (existing.construct, ext.value.construct) with | Some _, Some _ -> @@ -846,10 +879,11 @@ let rec surface_program_to_core st (program : Surface.program) : Core.program = | None -> { construct = None; destruct = None; loc = ext.loc } in let hooks = merge_surface_extension ext.value.target existing ext in - ((ext.value.target.value, hooks) :: List.remove_assoc ext.value.target.value extensions, decls_rev) + ( (ext.value.target.value, hooks) + :: List.remove_assoc ext.value.target.value extensions, + decls_rev ) | _ -> (extensions, decl :: decls_rev)) - ([], []) - program.value.decls + ([], []) program.value.decls in let seen_types = List.filter_map @@ -860,65 +894,72 @@ let rec surface_program_to_core st (program : Surface.program) : Core.program = program.value.decls in st.known_types <- - List.fold_left (fun acc name -> String_set.add name acc) String_set.empty seen_types; + List.fold_left + (fun acc name -> String_set.add name acc) + String_set.empty seen_types; let decls = List.rev decls_rev |> List.concat_map (fun (decl : Surface.top_decl) -> - match decl.value with - | Surface.TDecl ty -> ( - let hooks = List.assoc_opt ty.value.name.value extensions in - (match (hooks, ty.value.data) with - | ( Some { construct; destruct; _ }, - Surface.TypeDeclStruct _ ) - when Option.is_some construct || Option.is_some destruct -> - () - | Some _, _ -> - failwith - (Printf.sprintf - "extend target %s must be a struct in the first-pass lifecycle model" - ty.value.name.value) - | None, _ -> ()); - let construct : Surface.function_decl option = - Option.bind hooks (fun hooks -> - Option.map - (fun (construct : Surface.lifecycle_construct) -> - synthesize_surface_lifecycle_fn ty.value.name "construct" ty.loc - construct.value.params construct.value.body) - hooks.construct) - in - let destruct : Surface.function_decl option = - Option.bind hooks (fun hooks -> - Option.map - (synthesize_surface_lifecycle_fn ty.value.name "destruct" ty.loc []) - hooks.destruct) - in - let ty = - { - ty with - value = { ty.value with construct; destruct }; - } - in - let core_ty = surface_top_decl_to_core st { decl with value = Surface.TDecl ty } in - let lifecycle_fns : Surface.function_decl option list = [ construct; destruct ] in - let extra_fdecls = - List.filter_map - (fun (hook : Surface.function_decl option) -> - Option.map - (fun (fn : Surface.function_decl) -> - mk_core fn.loc (Core.FDecl (surface_function_decl_to_core st fn))) - hook) - lifecycle_fns - in - core_ty :: extra_fdecls) - | Surface.Extend _ -> [] - | _ -> [ surface_top_decl_to_core st decl ]) + match decl.value with + | Surface.TDecl ty -> + let hooks = List.assoc_opt ty.value.name.value extensions in + (match (hooks, ty.value.data) with + | Some { construct; destruct; _ }, Surface.TypeDeclStruct _ + when Option.is_some construct || Option.is_some destruct -> + () + | Some _, _ -> + failwith + (Printf.sprintf + "extend target %s must be a struct in the first-pass \ + lifecycle model" + ty.value.name.value) + | None, _ -> ()); + let construct : Surface.function_decl option = + Option.bind hooks (fun hooks -> + Option.map + (fun (construct : Surface.lifecycle_construct) -> + synthesize_surface_lifecycle_fn ty.value.name "construct" + ty.loc construct.value.params construct.value.body) + hooks.construct) + in + let destruct : Surface.function_decl option = + Option.bind hooks (fun hooks -> + Option.map + (synthesize_surface_lifecycle_fn ty.value.name "destruct" + ty.loc []) + hooks.destruct) + in + let ty = + { ty with value = { ty.value with construct; destruct } } + in + let core_ty = + surface_top_decl_to_core st { decl with value = Surface.TDecl ty } + in + let lifecycle_fns : Surface.function_decl option list = + [ construct; destruct ] + in + let extra_fdecls = + List.filter_map + (fun (hook : Surface.function_decl option) -> + Option.map + (fun (fn : Surface.function_decl) -> + mk_core fn.loc + (Core.FDecl (surface_function_decl_to_core st fn))) + hook) + lifecycle_fns + in + core_ty :: extra_fdecls + | Surface.Extend _ -> [] + | _ -> [ surface_top_decl_to_core st decl ]) in List.iter (fun (name, _) -> if not (List.mem name seen_types) then - failwith (Printf.sprintf "extend target %s does not match any declared type" name)) + failwith + (Printf.sprintf "extend target %s does not match any declared type" + name)) extensions; - mk_core program.loc { Core.decls = decls } + mk_core program.loc { Core.decls } and surface_top_decl_to_core st (decl : Surface.top_decl) : Core.top_decl = let value = @@ -930,18 +971,22 @@ and surface_top_decl_to_core st (decl : Surface.top_decl) : Core.top_decl = | Surface.CImport i -> Core.CImport { value = i.value; loc = i.loc } | Surface.Foreign f -> Core.Foreign (surface_foreign_to_core st f) | Surface.Extend _ -> - failwith "surface extend declarations must be merged before core lowering" + failwith + "surface extend declarations must be merged before core lowering" in mk_core decl.loc value -and surface_function_decl_to_core st (fn : Surface.function_decl) : Core.function_decl = +and surface_function_decl_to_core st (fn : Surface.function_decl) : + Core.function_decl = let value = { Core.public = fn.value.public; impure = fn.value.impure; name = surface_identifier_to_core fn.value.name; definition = - Option.map (surface_block_to_core st ~context:`Value) fn.value.definition; + Option.map + (surface_block_to_core st ~context:`Value) + fn.value.definition; intrinsic = Option.map (surface_intrinsic_to_core st) fn.value.intrinsic; params = surface_param_list_to_core st fn.value.params; return_type = Option.map surface_type_to_core fn.value.return_type; @@ -957,7 +1002,8 @@ and surface_intrinsic_to_core _st (intr : Surface.intrinsic) : Core.intrinsic = types = List.map surface_type_to_core intr.value.types; } -and surface_param_list_to_core st (params : Surface.param_list) : Core.param_list = +and surface_param_list_to_core st (params : Surface.param_list) : + Core.param_list = mk_core params.loc { Core.params = List.map (surface_param_to_core st) params.value.params; @@ -988,17 +1034,21 @@ and surface_type_decl_to_core st (decl : Surface.type_decl) : Core.type_decl = { Core.name = surface_identifier_to_core decl.value.name; data = surface_type_decl_data_to_core st decl.value.data; - construct = Option.map (surface_function_decl_to_core st) decl.value.construct; - destruct = Option.map (surface_function_decl_to_core st) decl.value.destruct; + construct = + Option.map (surface_function_decl_to_core st) decl.value.construct; + destruct = + Option.map (surface_function_decl_to_core st) decl.value.destruct; } and surface_type_decl_data_to_core st = function | Surface.TypeDeclAlias ty -> Core.TypeDeclAlias (surface_type_to_core ty) - | Surface.TypeDeclStruct s -> Core.TypeDeclStruct (surface_struct_decl_to_core st s) + | Surface.TypeDeclStruct s -> + Core.TypeDeclStruct (surface_struct_decl_to_core st s) | Surface.TypeDeclEnum e -> Core.TypeDeclEnum (surface_enum_decl_to_core st e) | Surface.TypeDeclForward -> Core.TypeDeclForward -and surface_struct_decl_to_core st (decl : Surface.struct_decl) : Core.struct_decl = +and surface_struct_decl_to_core st (decl : Surface.struct_decl) : + Core.struct_decl = mk_core decl.loc { Core.fields = List.map (surface_struct_field_to_core st) decl.value.fields; @@ -1007,8 +1057,12 @@ and surface_struct_decl_to_core st (decl : Surface.struct_decl) : Core.struct_de (fun (lifecycle : Surface.struct_lifecycle) -> mk_core lifecycle.loc { - Core.constructor = Option.map surface_identifier_to_core lifecycle.value.constructor; - destructor = Option.map surface_identifier_to_core lifecycle.value.destructor; + Core.constructor = + Option.map surface_identifier_to_core + lifecycle.value.constructor; + destructor = + Option.map surface_identifier_to_core + lifecycle.value.destructor; }) decl.value.lifecycle; } @@ -1040,22 +1094,16 @@ and surface_enum_variant_to_core _st (variant : Surface.enum_variant) : and surface_foreign_to_core st (foreign : Surface.foreign) : Core.foreign = let normalize_foreign_decl (fn : Surface.function_decl) = - { - fn with - value = - { - fn.value with - public = true; - impure = true; - }; - } + { fn with value = { fn.value with public = true; impure = true } } in mk_core foreign.loc { - Core.lib = { value = foreign.value.lib.value; loc = foreign.value.lib.loc }; + Core.lib = + { value = foreign.value.lib.value; loc = foreign.value.lib.loc }; decls = List.map - (fun fn -> surface_function_decl_to_core st (normalize_foreign_decl fn)) + (fun fn -> + surface_function_decl_to_core st (normalize_foreign_decl fn)) foreign.value.decls; } @@ -1066,9 +1114,12 @@ and surface_block_to_core st ~context (block : Surface.block) : Core.block = match (context, block.value.result) with | `Value, result -> mk_core_block block.loc - { Core.statements = statements; result = Option.map (surface_expr_to_core st) result } + { + Core.statements; + result = Option.map (surface_expr_to_core st) result; + } | `Statement, None -> - mk_core_block block.loc { Core.statements = statements; result = None } + mk_core_block block.loc { Core.statements; result = None } | `Statement, Some expr -> let expr_stmt = mk_core_stmt expr.loc (Core.Expression (surface_expr_to_core st expr)) @@ -1076,7 +1127,8 @@ and surface_block_to_core st ~context (block : Surface.block) : Core.block = mk_core_block block.loc { Core.statements = statements @ [ expr_stmt ]; result = None } -and surface_statement_to_core st (stmt : Surface.statement) : Core.statement list = +and surface_statement_to_core st (stmt : Surface.statement) : + Core.statement list = match stmt.value with | Surface.Expression expr -> [ mk_core_stmt stmt.loc (Core.Expression (surface_expr_to_core st expr)) ] @@ -1107,7 +1159,10 @@ and surface_statement_to_core st (stmt : Surface.statement) : Core.statement lis })); ] | Surface.Return expr -> - [ mk_core_stmt stmt.loc (Core.Return (Option.map (surface_expr_to_core st) expr)) ] + [ + mk_core_stmt stmt.loc + (Core.Return (Option.map (surface_expr_to_core st) expr)); + ] | Surface.Defer expr -> [ mk_core_stmt stmt.loc (Core.Defer (surface_expr_to_core st expr)) ] | Surface.While while_stmt -> @@ -1177,35 +1232,45 @@ and lower_iter_statement st loc (iter : Surface.iter_stmt) : Core.statement = let end_ref = core_identifier_expr end_name in let step_ref = core_identifier_expr step_name in let cond = - match Option.bind iter.value.range.value.range_incr const_int_of_surface_expr with + match + Option.bind iter.value.range.value.range_incr const_int_of_surface_expr + with | Some step when step < 0 -> core_binary_expr loc Core.GreaterThanOrEqual index_expr end_ref - | Some _ | None when Option.is_none iter.value.range.value.range_incr -> - core_binary_expr loc Core.LessThanOrEqual index_expr end_ref - | Some _ -> + | (Some _ | None) when Option.is_none iter.value.range.value.range_incr -> core_binary_expr loc Core.LessThanOrEqual index_expr end_ref + | Some _ -> core_binary_expr loc Core.LessThanOrEqual index_expr end_ref | None -> let direction = - core_binary_expr loc Core.LessThan step_ref (core_int_literal_expr loc 0) + core_binary_expr loc Core.LessThan step_ref + (core_int_literal_expr loc 0) in let non_negative_arm = core_match_arm loc - (mk_core_pattern loc (Core.PatternLiteral (mk_core_literal loc (Core.Integer 0)))) + (mk_core_pattern loc + (Core.PatternLiteral (mk_core_literal loc (Core.Integer 0)))) (core_binary_expr loc Core.LessThanOrEqual index_expr end_ref) in let negative_arm = - core_match_arm loc (mk_core_pattern loc Core.PatternDefault) + core_match_arm loc + (mk_core_pattern loc Core.PatternDefault) (core_binary_expr loc Core.GreaterThanOrEqual index_expr end_ref) in mk_core_expr loc - (Core.Match (mk_core loc { Core.expr = direction; arms = [ non_negative_arm; negative_arm ] })) + (Core.Match + (mk_core loc + { + Core.expr = direction; + arms = [ non_negative_arm; negative_arm ]; + })) in let next_value = core_binary_expr loc Core.Add index_expr step_ref in let increment = mk_core_stmt loc (Core.Expression (mk_core_expr loc - (Core.Assign (mk_core loc { Core.target = index_expr; value = next_value })))) + (Core.Assign + (mk_core loc { Core.target = index_expr; value = next_value })))) in let body = surface_block_to_core st ~context:`Statement iter.value.body in let iteration_hint = @@ -1260,7 +1325,8 @@ and surface_expr_to_core st (expr : Surface.expression) : Core.expression = }) | Surface.Literal lit -> Core.Literal (surface_literal_to_core (surface_expr_to_core st) lit) - | Surface.Block block -> Core.Block (surface_block_to_core st ~context:`Value block) + | Surface.Block block -> + Core.Block (surface_block_to_core st ~context:`Value block) | Surface.Identifier id -> Core.Identifier (surface_identifier_to_core id) | Surface.Initializer init -> Core.Initializer @@ -1292,9 +1358,9 @@ and surface_expr_to_core st (expr : Surface.expression) : Core.expression = (mk_core_type inner.loc (Core.CustomType { name = surface_identifier_to_core id })) | Surface.BoxExpr { value = Surface.Call call; loc } - when (match call.value.target.value with + when match call.value.target.value with | Surface.Identifier id -> String_set.mem id.value st.known_types - | _ -> false) -> + | _ -> false -> let ty = match call.value.target.value with | Surface.Identifier id -> @@ -1304,7 +1370,10 @@ and surface_expr_to_core st (expr : Surface.expression) : Core.expression = in Core.BoxConstruct (mk_core loc - { Core.ty; args = List.map (surface_expr_to_core st) call.value.params }) + { + Core.ty; + args = List.map (surface_expr_to_core st) call.value.params; + }) | Surface.BoxExpr inner -> Core.BoxExpr (surface_expr_to_core st inner) | Surface.BoxType ty -> Core.BoxType (surface_type_to_core ty) | Surface.Unbox inner -> Core.Unbox (surface_expr_to_core st inner) @@ -1338,16 +1407,20 @@ and surface_expr_to_core st (expr : Surface.expression) : Core.expression = and lower_if_expr st loc (ifx : Surface.if_expr) : Core.expression_desc = let false_arm = core_match_arm loc - (mk_core_pattern loc (Core.PatternLiteral (mk_core_literal loc (Core.Bool false)))) + (mk_core_pattern loc + (Core.PatternLiteral (mk_core_literal loc (Core.Bool false)))) (match ifx.value.else_branch with - | None -> mk_core_expr loc (Core.Block (mk_core_block loc { statements = []; result = None })) + | None -> + mk_core_expr loc + (Core.Block (mk_core_block loc { statements = []; result = None })) | Some block -> mk_core_expr block.loc (Core.Block (surface_block_to_core st ~context:`Value block))) in let true_arm = core_match_arm loc - (mk_core_pattern loc (Core.PatternLiteral (mk_core_literal loc (Core.Bool true)))) + (mk_core_pattern loc + (Core.PatternLiteral (mk_core_literal loc (Core.Bool true)))) (mk_core_expr ifx.value.then_branch.loc (Core.Block (surface_block_to_core st ~context:`Value ifx.value.then_branch))) @@ -1374,15 +1447,19 @@ and surface_match_pattern_to_core st (pat : Surface.match_pattern) : match pat.value with | Surface.PatternDefault -> Core.PatternDefault | Surface.PatternLiteral lit -> - Core.PatternLiteral (surface_literal_to_core (surface_expr_to_core st) lit) - | Surface.PatternEnum enum -> Core.PatternEnum (surface_pattern_enum_to_core enum) + Core.PatternLiteral + (surface_literal_to_core (surface_expr_to_core st) lit) + | Surface.PatternEnum enum -> + Core.PatternEnum (surface_pattern_enum_to_core enum) in mk_core_pattern pat.loc value -and surface_pattern_enum_to_core (enum : Surface.pattern_enum) : Core.pattern_enum = +and surface_pattern_enum_to_core (enum : Surface.pattern_enum) : + Core.pattern_enum = mk_core enum.loc { - Core.enum_name = Option.map surface_identifier_to_core enum.value.enum_name; + Core.enum_name = + Option.map surface_identifier_to_core enum.value.enum_name; enum_variant = surface_identifier_to_core enum.value.enum_variant; binding = List.map surface_pattern_binding_to_core enum.value.binding; } @@ -1392,7 +1469,8 @@ and surface_pattern_binding_to_core (binding : Surface.pattern_binding) : let value = match binding.value with | Surface.BindingIgnored -> Core.BindingIgnored - | Surface.BindingNamed id -> Core.BindingNamed (surface_identifier_to_core id) + | Surface.BindingNamed id -> + Core.BindingNamed (surface_identifier_to_core id) in mk_core_binding binding.loc value @@ -1400,8 +1478,7 @@ let core_of_surface (parsed : Surface.parsed_program) : Core.parsed_program = let st = fresh_state () in { Core.program = surface_program_to_core st parsed.program } -let core_of_expanded_cst parsed = - core_of_surface (surface_of_cst parsed) +let core_of_expanded_cst parsed = core_of_surface (surface_of_cst parsed) let core_of_cst parsed = let expanded = Imports.expand_cst parsed in diff --git a/src/lib/cst/cst.ml b/src/lib/cst/cst.ml index 3ea3d92..cd5a8b2 100644 --- a/src/lib/cst/cst.ml +++ b/src/lib/cst/cst.ml @@ -152,10 +152,8 @@ and var_decl_desc = { and var_decl = var_decl_desc node and type_decl_desc = { name : identifier; data : type_decl_data } and type_decl = type_decl_desc node - and type_extend_desc = { target : identifier; items : extend_item list } and type_extend = type_extend_desc node - and lifecycle_construct_desc = { params : param list; body : block } and lifecycle_construct = lifecycle_construct_desc node @@ -172,7 +170,12 @@ and type_decl_data = | TypeDeclForward and struct_decl_desc = { fields : struct_field list } -and enum_decl_desc = { generics : identifier list; variants : enum_variant list } + +and enum_decl_desc = { + generics : identifier list; + variants : enum_variant list; +} + and struct_field_desc = { name : identifier; ty : haven_type } and enum_variant_desc = { name : identifier; inner_tys : haven_type list } and struct_decl = struct_decl_desc node @@ -196,13 +199,10 @@ and block_item_desc = and block_item = block_item_desc node -and compile_assert_desc = { cond : expression; message : string node } -and compile_assert = compile_assert_desc node - and statement_desc = | Expression of expression | Let of let_stmt - | CompileAssert of compile_assert + | Directive of directive | Return of expression option | Defer of expression | Iter of iter_stmt @@ -335,6 +335,19 @@ and enum_literal_desc = { and enum_literal = enum_literal_desc node +and directive_desc = + | DirectiveCall of directive_call + | DirectiveCompileTime of directive_compile_time + +and directive = directive_desc node +and directive_call = { name : identifier; args : expression list } + +and directive_compile_time = { + name : identifier; + cond : expression; + message : string node; +} + type parsed_program = { program : program; trivia : trivia_entry list; diff --git a/src/lib/cst/emit.ml b/src/lib/cst/emit.ml index 58b4e46..b1149d9 100644 --- a/src/lib/cst/emit.ml +++ b/src/lib/cst/emit.ml @@ -411,10 +411,8 @@ and emit_statement ~indent ~comments fmt stmt = fprintf fmt " = %a;" (emit_expression ~ctx_prec:0 ~indent ~comments) s.init_expr - | CompileAssert a -> - fprintf fmt "@assert %a, %S;" - (emit_expression ~ctx_prec:0 ~indent ~comments) - a.value.cond a.value.message.value; + | Directive d -> + fprintf fmt "%a;" (emit_directive ~indent ~comments) d; flush_inline_on_line ~line:stmt.loc.start_pos.pos_lnum comments fmt | Return (Some e) -> fprintf fmt "ret %a;" (emit_expression ~ctx_prec:0 ~indent ~comments) e; @@ -492,6 +490,19 @@ and emit_block ~indent ~comments fmt block = ~kind:`Trailing ~separate:false fmt; fprintf fmt "\n%s}" (spaces indent) +and emit_directive ~indent ~comments fmt directive = + match directive.value with + | DirectiveCall c -> + fprintf fmt "%s@%a(%a)" (spaces indent) emit_identifier c.name + (pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt ", ") + (emit_expression ~ctx_prec:0 ~indent ~comments)) + c.args + | DirectiveCompileTime c -> + fprintf fmt "%s@%a %a, %a" (spaces indent) emit_identifier c.name + (emit_expression ~ctx_prec:0 ~indent ~comments) + c.cond emit_string_lit c.message + let emit_param fmt (p : param) = let p = unwrap p in fprintf fmt "%a %a" emit_type p.ty emit_identifier p.name @@ -607,15 +618,21 @@ let emit_extend_item ~comments fmt (item : extend_item) = (match item.value with | ExtendConstruct construct -> if construct.value.params = [] then - fprintf fmt "%sconstruct %a" (spaces 1) (emit_block ~indent:1 ~comments) + fprintf fmt "%sconstruct %a" (spaces 1) + (emit_block ~indent:1 ~comments) construct.value.body else fprintf fmt "%sconstruct(%a) %a" (spaces 1) (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ", ") emit_param) - construct.value.params (emit_block ~indent:1 ~comments) construct.value.body + construct.value.params + (emit_block ~indent:1 ~comments) + construct.value.body | ExtendDestruct block -> - fprintf fmt "%sdestruct %a" (spaces 1) (emit_block ~indent:1 ~comments) block); - emit_comments ~comments ~indent:1 ~loc:item.loc ~kind:`Trailing ~separate:true fmt + fprintf fmt "%sdestruct %a" (spaces 1) + (emit_block ~indent:1 ~comments) + block); + emit_comments ~comments ~indent:1 ~loc:item.loc ~kind:`Trailing ~separate:true + fmt let emit_type_extend ~comments fmt (ext : type_extend) = let ext = unwrap ext in diff --git a/src/lib/cst/locate.ml b/src/lib/cst/locate.ml index 916c9b4..cb5a1c3 100644 --- a/src/lib/cst/locate.ml +++ b/src/lib/cst/locate.ml @@ -98,15 +98,8 @@ let add_if predicate node acc = if predicate node then node :: acc else acc let rec walk_haven_type predicate acc (ty : haven_type) = let acc = add_if predicate (HavenType ty) acc in match ty.value with - | NumericType _ - | VecType _ - | MatrixType _ - | VecHoleType - | MatrixHoleType - | FloatType - | VoidType - | StringType - -> + | NumericType _ | VecType _ | MatrixType _ | VecHoleType | MatrixHoleType + | FloatType | VoidType | StringType -> acc | CustomType _ -> acc | CellType inner -> walk_haven_type predicate acc inner @@ -230,7 +223,7 @@ and walk_statement predicate acc stmt = | Some t -> walk_haven_type predicate acc t in walk_expression predicate acc s.value.init_expr - | CompileAssert a -> walk_expression predicate acc a.value.cond + | Directive d -> walk_directive predicate acc d | Return (Some e) -> walk_expression predicate acc e | Return None -> acc | Defer e -> walk_expression predicate acc e @@ -331,14 +324,18 @@ and walk_top_decl predicate acc decl = match item.value with | ExtendConstruct construct -> walk_block predicate acc construct.value.body - | ExtendDestruct block -> - walk_block predicate acc block) + | ExtendDestruct block -> walk_block predicate acc block) acc e.value.items | Import _ | CImport _ -> acc | Foreign f -> let acc = add_if predicate (Foreign f) acc in List.fold_left (walk_function_decl predicate) acc f.value.decls +and walk_directive predicate acc d = + match d.value with + | DirectiveCall _ -> acc + | DirectiveCompileTime a -> walk_expression predicate acc a.cond + let walk_program predicate acc program = let acc = add_if predicate (Program program) acc in List.fold_left (walk_top_decl predicate) acc program.value.decls diff --git a/src/lib/cst/pretty.ml b/src/lib/cst/pretty.ml index 987ac97..66d34d2 100644 --- a/src/lib/cst/pretty.ml +++ b/src/lib/cst/pretty.ml @@ -194,9 +194,7 @@ and pp_statement fmt stmt = let s = unwrap s in fprintf fmt "@[Let(@,mut=%a,@ name=%a,@ init_expr=%a@,)@]" pp_print_bool s.mut pp_identifier s.name pp_expression s.init_expr - | CompileAssert a -> - fprintf fmt "@[CompileAssert(@,cond=%a,@ message=%S@,)@]" pp_expression - a.value.cond a.value.message.value + | Directive d -> pp_directive fmt d | Return (Some e) -> fprintf fmt "@[Return(@,%a@,)@]" pp_expression e | Return None -> fprintf fmt "Return" | Defer e -> fprintf fmt "@[Defer(@,%a@,)@]" pp_expression e @@ -227,6 +225,17 @@ and pp_block fmt block = (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@,") pp_block_item) block.items +and pp_directive fmt (directive : directive) = + match directive.value with + | DirectiveCall a -> + fprintf fmt "@[Directive(@,name=%a,@,cond=%a@,)@]" pp_identifier + a.name + (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@,") pp_expression) + a.args + | DirectiveCompileTime a -> + fprintf fmt "@[CompileAssert(@,name=%a,@,cond=%a,@ message=%S@,)@]" + pp_identifier a.name pp_expression a.cond a.message.value + let pp_param fmt (p : param) = let p = unwrap p in fprintf fmt "Param(%a, %a)" pp_identifier p.name pp_type p.ty diff --git a/src/lib/lexer/lexer.ml b/src/lib/lexer/lexer.ml index fc723a1..ddb89f6 100644 --- a/src/lib/lexer/lexer.ml +++ b/src/lib/lexer/lexer.ml @@ -50,15 +50,12 @@ type symbol = | Bang | Tilde | Underscore - -type directive = - | Assert + | At module Raw = struct type t = | Trivia of trivia | Ident of string - | Directive of directive | Numeric_type of numeric_type | Vec_type of vec_type | Mat_type of mat_type @@ -97,7 +94,6 @@ let mat_type = ("fmat" | "mat"), nonzero, Star digit, 'x', nonzero, Star digit] let mat_hole_type = [%sedlex.regexp? "mat?"] - let float_type = [%sedlex.regexp? "float"] let void_type = [%sedlex.regexp? "void"] let str_type = [%sedlex.regexp? "str"] @@ -116,7 +112,10 @@ let ident = [%sedlex.regexp? (letter | '_'), Star ident_inner, Star ('-', ident_segment)] let newline = [%sedlex.regexp? "\r\n" | '\n' | '\r'] -let preprocessor_directive = [%sedlex.regexp? '#', Star (Compl ('\n' | '\r')), Opt newline] + +let preprocessor_directive = + [%sedlex.regexp? '#', Star (Compl ('\n' | '\r')), Opt newline] + let whitespace = [%sedlex.regexp? Plus (Chars " \t\012\013")] let line_comment = [%sedlex.regexp? "//", Star (Compl ('\n' | '\r'))] @@ -151,10 +150,7 @@ let push_token buf tok acc = let trim_ascii_whitespace text = let len = String.length text in - let is_space = function - | ' ' | '\t' | '\012' | '\013' -> true - | _ -> false - in + let is_space = function ' ' | '\t' | '\012' | '\013' -> true | _ -> false in let rec find_start i = if i >= len then len else if is_space (String.unsafe_get text i) then find_start (i + 1) @@ -185,9 +181,7 @@ let parse_decimal_prefix text start = let len = String.length text in let rec loop i = if i < len then - match String.unsafe_get text i with - | '0' .. '9' -> loop (i + 1) - | _ -> i + match String.unsafe_get text i with '0' .. '9' -> loop (i + 1) | _ -> i else i in let finish = loop start in @@ -214,9 +208,7 @@ let parse_quoted_string text start = loop (start + 1) let parse_line_directive text = - let body = - text |> strip_trailing_newline |> trim_ascii_whitespace - in + let body = text |> strip_trailing_newline |> trim_ascii_whitespace in let body = if String.length body > 0 && String.unsafe_get body 0 = '#' then String.sub body 1 (String.length body - 1) |> trim_ascii_whitespace @@ -226,14 +218,12 @@ let parse_line_directive text = if String.length body >= 4 && String.equal (String.sub body 0 4) "line" - && - (String.length body = 4 - || - match String.unsafe_get body 4 with - | ' ' | '\t' | '\012' | '\013' -> true - | _ -> false) - then - String.sub body 4 (String.length body - 4) |> trim_ascii_whitespace + && (String.length body = 4 + || + match String.unsafe_get body 4 with + | ' ' | '\t' | '\012' | '\013' -> true + | _ -> false) + then String.sub body 4 (String.length body - 4) |> trim_ascii_whitespace else body in match parse_decimal_prefix body 0 with @@ -275,43 +265,12 @@ let should_split_rshift rest = | Some { tok = EOF; _ } -> true | Some { tok = Symbol sym; _ } -> ( match sym with - | Comma - | Dot - | Semicolon - | Colon - | Star - | Caret - | RParen - | RBrace - | RBracket - | LBracket - | Gt - | Scope -> + | Comma | Dot | Semicolon | Colon | Star | Caret | RParen | RBrace + | RBracket | LBracket | Gt | Scope -> true - | Arrow - | FatArrow - | Walrus - | LogicAnd - | LogicOr - | EqEq - | BangEq - | LtEq - | GtEq - | LShift - | RShift - | LParen - | LBrace - | Lt - | Plus - | Minus - | Slash - | Percent - | Equal - | Ampersand - | Pipe - | Bang - | Tilde - | Underscore -> + | Arrow | FatArrow | Walrus | LogicAnd | LogicOr | EqEq | BangEq | LtEq + | GtEq | LShift | RShift | LParen | LBrace | Lt | Plus | Minus | Slash + | Percent | Equal | Ampersand | Pipe | Bang | Tilde | Underscore | At -> false) | Some _ -> false @@ -319,7 +278,8 @@ let split_closing_rshifts tokens = let gt_of tok = { tok with tok = Symbol Gt } in let rec loop acc = function | [] -> List.rev acc - | ({ tok = Symbol RShift; _ } as tok) :: rest when should_split_rshift rest -> + | ({ tok = Symbol RShift; _ } as tok) :: rest when should_split_rshift rest + -> loop (gt_of tok :: gt_of tok :: acc) rest | tok :: rest -> loop (tok :: acc) rest in @@ -370,7 +330,6 @@ let rec lex buf acc = let text = Sedlexing.Utf8.lexeme buf in lex buf (push_token buf (Numeric_type (numeric_type_of_string text)) acc) | vec_hole_type -> lex buf (push_token buf Vec_hole_type acc) - | assert_directive -> lex buf (push_token buf (Directive Assert) acc) | vec_type -> let text = Sedlexing.Utf8.lexeme buf in lex buf (push_token buf (Vec_type (vec_type_of_string text)) acc) @@ -437,6 +396,7 @@ let rec lex buf acc = | '!' -> lex buf (push_token buf (make_symbol Bang) acc) | '~' -> lex buf (push_token buf (make_symbol Tilde) acc) | '_' -> lex buf (push_token buf (make_symbol Underscore) acc) + | '@' -> lex buf (push_token buf (make_symbol At) acc) | ident -> lex buf (push_token buf (Ident (Sedlexing.Utf8.lexeme buf)) acc) | eof -> let acc = push_token buf EOF acc in diff --git a/src/lib/lexer/pretty.ml b/src/lib/lexer/pretty.ml index 19fa2b5..e03ea9e 100644 --- a/src/lib/lexer/pretty.ml +++ b/src/lib/lexer/pretty.ml @@ -38,6 +38,7 @@ let symbol_tag = function | Bang -> "BANG" | Tilde -> "TILDE" | Underscore -> "UNDERSCORE" + | At -> "AT" let symbol_lexeme = function | Arrow -> "->" @@ -76,6 +77,7 @@ let symbol_lexeme = function | Bang -> "!" | Tilde -> "~" | Underscore -> "_" + | At -> "@" let pp_trivia = function | Whitespace { text; contains_newline } -> @@ -98,7 +100,6 @@ let pp_token (token : Raw.tok) = match token.tok with | Trivia trivia -> pp_trivia trivia | Ident text -> Printf.printf "IDENT %s\n" text - | Directive Assert -> Printf.printf "DIRECTIVE @assert\n" | Numeric_type desc -> Printf.printf "NUMERIC_TYPE %s\n" (numeric_type_to_string desc) | Vec_type desc -> Printf.printf "VEC_TYPE %s\n" (vec_type_to_string desc) diff --git a/src/lib/parser/grammar.mly b/src/lib/parser/grammar.mly index e4d3267..c0f61ec 100644 --- a/src/lib/parser/grammar.mly +++ b/src/lib/parser/grammar.mly @@ -17,7 +17,6 @@ %token MAT_TYPE %token VEC_HOLE_TYPE MAT_HOLE_TYPE %token FLOAT_TYPE VOID_TYPE STR_TYPE -%token ASSERT_DIRECTIVE %token INT_LIT %token FLOAT_LIT %token HEX_LIT OCT_LIT BIN_LIT @@ -27,7 +26,7 @@ %token LOGIC_AND LOGIC_OR EQEQ BANGEQ LE GE %token LSHIFT RSHIFT LPAREN RPAREN LBRACE RBRACE LBRACKET RBRACKET %token LT GT COMMA DOT SEMICOLON COLON STAR CARET -%token PLUS MINUS SLASH PERCENT EQUAL AMP PIPE BANG TILDE UNDERSCORE +%token PLUS MINUS SLASH PERCENT EQUAL AMP PIPE BANG TILDE UNDERSCORE AT %token EOF (* Main keywords *) @@ -181,9 +180,7 @@ stmt_inner: Let (mk_loc $startpos $endpos { mut = m; name = n; ty = Some t; init_expr = mk_expr $startpos(i) $endpos(i) (Initializer i); }) } | LET m=boption(MUT) t=haven_type n=identifier EQUAL e=expr { Let (mk_loc $startpos $endpos { mut = m; name = n; ty = Some t; init_expr = e; }) } - | ASSERT_DIRECTIVE c=expr COMMA m=STRING_LIT { - CompileAssert (mk_loc $startpos $endpos { cond = c; message = mk_id m $startpos(m) $endpos(m) }) - } + | d=directive { Directive d } | RET e=option(expr) { Return e } | DEFER e=expr { Defer e } | ITER r=iter_range v=identifier b=block { Iter (mk_loc $startpos $endpos { range = r; var = v; body = b }) } @@ -359,3 +356,10 @@ builtin_type: | VOID_TYPE { mk_loc $startpos $endpos VoidType } | STR_TYPE { mk_loc $startpos $endpos StringType } ; + +(** DIRECTIVES AND ANNOTATIONS **) + +directive: + | AT i=identifier LPAREN a=separated_nonempty_list(COMMA, expr) RPAREN { mk_loc $startpos $endpos (DirectiveCall { name = i; args = a }) } + | AT i=identifier c=expr COMMA m=STRING_LIT { mk_loc $startpos $endpos (DirectiveCompileTime { name = i; cond = c; message = mk_loc $startpos $endpos m }) } + ; diff --git a/src/lib/parser/parser.ml b/src/lib/parser/parser.ml index 597975a..a8c52c3 100644 --- a/src/lib/parser/parser.ml +++ b/src/lib/parser/parser.ml @@ -87,7 +87,6 @@ let rec next_token st : Grammar.token * Lexing.position * Lexing.position = (* Skip trivia by recursion or a loop *) next_token st | Ident s -> store_token st (keyword_or_ident s, startp, endp) - | Directive Assert -> store_token st (Grammar.ASSERT_DIRECTIVE, startp, endp) | Numeric_type s -> store_token st (Grammar.NUMERIC_TYPE s, startp, endp) | Vec_type s -> store_token st (Grammar.VEC_TYPE s, startp, endp) | Mat_type s -> store_token st (Grammar.MAT_TYPE s, startp, endp) @@ -147,6 +146,7 @@ let rec next_token st : Grammar.token * Lexing.position * Lexing.position = | Bang -> Grammar.BANG | Tilde -> Grammar.TILDE | Underscore -> Grammar.UNDERSCORE + | At -> Grammar.AT in store_token st (tok, startp, endp) | EOF -> store_token st (Grammar.EOF, startp, endp) @@ -174,7 +174,6 @@ let token_to_string = function Printf.sprintf "matrix type %s" (mat_type_to_string desc) | Grammar.VEC_HOLE_TYPE -> "vector specialization type fvec?" | Grammar.MAT_HOLE_TYPE -> "matrix specialization type mat?" - | Grammar.ASSERT_DIRECTIVE -> "@assert" | Grammar.VOID_TYPE -> "void" | Grammar.FLOAT_TYPE -> "float" | Grammar.STR_TYPE -> "str"