+16 -15

.depend

reviewed

··· 768 768 utils/warnings.cmi \ 769 769 typing/untypeast.cmi \ 770 770 typing/types.cmi \ 771 771 - typing/typedtreeIter.cmi \ 772 771 typing/typedtree.cmi \ 772 772 + typing/tast_iterator.cmi \ 773 773 typing/subst.cmi \ 774 774 typing/printpat.cmi \ 775 775 typing/predef.cmi \ ··· 790 790 utils/warnings.cmx \ 791 791 typing/untypeast.cmx \ 792 792 typing/types.cmx \ 793 793 - typing/typedtreeIter.cmx \ 794 793 typing/typedtree.cmx \ 794 794 + typing/tast_iterator.cmx \ 795 795 typing/subst.cmx \ 796 796 typing/printpat.cmx \ 797 797 typing/predef.cmx \ ··· 1051 1051 typing/types.cmi \ 1052 1052 typing/path.cmi \ 1053 1053 typing/ident.cmi 1054 1054 + typing/tast_iterator.cmo : \ 1055 1055 + typing/typedtree.cmi \ 1056 1056 + typing/env.cmi \ 1057 1057 + parsing/asttypes.cmi \ 1058 1058 + typing/tast_iterator.cmi 1059 1059 + typing/tast_iterator.cmx : \ 1060 1060 + typing/typedtree.cmx \ 1061 1061 + typing/env.cmx \ 1062 1062 + parsing/asttypes.cmi \ 1063 1063 + typing/tast_iterator.cmi 1064 1064 + typing/tast_iterator.cmi : \ 1065 1065 + typing/typedtree.cmi \ 1066 1066 + typing/env.cmi \ 1067 1067 + parsing/asttypes.cmi 1054 1068 typing/tast_mapper.cmo : \ 1055 1069 typing/typedtree.cmi \ 1056 1070 typing/env.cmi \ ··· 1408 1422 parsing/location.cmi \ 1409 1423 typing/ident.cmi \ 1410 1424 typing/env.cmi \ 1411 1411 - parsing/asttypes.cmi 1412 1412 - typing/typedtreeIter.cmo : \ 1413 1413 - typing/typedtree.cmi \ 1414 1414 - utils/misc.cmi \ 1415 1415 - parsing/asttypes.cmi \ 1416 1416 - typing/typedtreeIter.cmi 1417 1417 - typing/typedtreeIter.cmx : \ 1418 1418 - typing/typedtree.cmx \ 1419 1419 - utils/misc.cmx \ 1420 1420 - parsing/asttypes.cmi \ 1421 1421 - typing/typedtreeIter.cmi 1422 1422 - typing/typedtreeIter.cmi : \ 1423 1423 - typing/typedtree.cmi \ 1424 1425 parsing/asttypes.cmi 1425 1426 typing/typemod.cmo : \ 1426 1427 utils/warnings.cmi \

+20 -3

Changes

reviewed

··· 9 9 iOS and other Darwin targets. 10 10 (Mark Shinwell, review by Nicolas Ojeda Bar and Xavier Leroy) 11 11 12 12 + - #7887: ensure frame table is 8-aligned on ARM64 and PPC64 13 13 + (Xavier Leroy, report by Mark Hayden, review by Mark Shinwell 14 14 + and Gabriel Scherer) 15 15 + 12 16 - #8507: Shorten symbol names of anonymous functions in Flambda mode 13 17 (the directory portions are now hidden) 14 18 (Mark Shinwell, review by Nicolás Ojeda Bär) ··· 83 87 - #2291: Add [Compute_ranges] pass 84 88 (Mark Shinwell, review by Vincent Laviron) 85 89 90 90 + - #2292: Add [Proc.frame_required] and [Proc.prologue_required]. 91 91 + Move tail recursion label creation to [Linearize]. Correctly position 92 92 + [Lprologue] relative to [Iname_for_debugger] operations. 93 93 + (Mark Shinwell, review by Vincent Laviron) 94 94 + 86 95 - #2308: More debugging information on [Cmm] terms 87 96 (Mark Shinwell, review by Stephen Dolan) 97 97 + 98 98 + - #7878, #8542: Replaced TypedtreeIter with tast_iterator 99 99 + (Isaac "Izzy" Avram, review by Gabriel Scherer and Nicolás Ojeda Bär) 88 100 89 101 ### Runtime system: 90 102 91 91 - - #1725: Deprecate Obj.set_tag 92 92 - (Stephen Dolan, review by Gabriel Scherer and Damien Doligez) 103 103 + - #1725, #2279: Deprecate Obj.set_tag and Obj.truncate 104 104 + (Stephen Dolan, review by Gabriel Scherer, Damien Doligez and Xavier Leroy) 93 105 94 106 * #2240: Constify "identifier" in struct custom_operations 95 107 (Cedric Cellier, review by Xavier Leroy) ··· 352 364 - #1525: Make function set_max_indent respect documentation 353 365 (Pierre Weis, Richard Bonichon, review by Florian Angeletti) 354 366 367 367 + - GPR#2202: Correct Hashtbl.MakeSeeded.{add_seq,replace_seq,of_seq} to use 368 368 + functor hash function instead of default hash function. Hashtbl.Make.of_seq 369 369 + shouldn't create randomized hash tables. 370 370 + (David Allsopp, review by Alain Frisch) 371 371 + 355 372 ### Other libraries: 356 373 357 374 - #2222: Set default status in waitpid when pid is zero. Otherwise, ··· 519 536 - #1917: comballoc: ensure object allocation order is preserved 520 537 (Stephen Dolan) 521 538 522 522 - - #6242, #2143: optimize some local functions 539 539 + - #6242, #2143, #8558, #8559: optimize some local functions 523 540 (Alain Frisch, review by Gabriel Scherer) 524 541 525 542 - #2082: New options [-insn-sched] and [-no-insn-sched] to control

+1 -1

Makefile

reviewed

··· 99 99 typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \ 100 100 typing/printtyp.cmo typing/includeclass.cmo \ 101 101 typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \ 102 102 - typing/typedtreeIter.cmo typing/tast_mapper.cmo \ 102 102 + typing/tast_iterator.cmo typing/tast_mapper.cmo \ 103 103 typing/cmt_format.cmo typing/untypeast.cmo \ 104 104 typing/includemod.cmo typing/typetexp.cmo typing/printpat.cmo \ 105 105 typing/parmatch.cmo typing/stypes.cmo \

+6 -3

asmcomp/amd64/emit.mlp

reviewed

··· 82 82 83 83 (* Layout of the stack frame *) 84 84 85 85 + <<<<<<< HEAD 85 86 let stack_threshold_size = Config.stack_threshold * 8 (* bytes *) 86 87 87 88 let frame_required () = 88 89 fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 89 90 91 91 + ======= 92 92 + >>>>>>> 36d299b4aaf7f2d317fbfa148d7f94e720c80730 90 93 let frame_size () = (* includes return address *) 91 94 if frame_required() then begin 92 95 let sz = ··· 509 512 match i.desc with 510 513 | Lend -> () 511 514 | Lprologue -> 515 515 + assert (Proc.prologue_required ()); 512 516 if fp then begin 513 517 I.push rbp; 514 518 cfi_adjust_cfa_offset 8; ··· 521 525 I.sub (int n) rsp; 522 526 cfi_adjust_cfa_offset n; 523 527 end; 524 524 - end; 525 525 - def_label !tailrec_entry_point 528 528 + end 526 529 | Lop(Imove | Ispill | Ireload) -> 527 530 let src = i.arg.(0) and dst = i.res.(0) in 528 531 if src.loc <> dst.loc then ··· 1026 1029 let fundecl fundecl = 1027 1030 function_name := fundecl.fun_name; 1028 1031 fastcode_flag := fundecl.fun_fast; 1029 1029 - tailrec_entry_point := new_label(); 1032 1032 + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; 1030 1033 stack_offset := 0; 1031 1034 call_gc_sites := []; 1032 1035 bound_error_sites := [];

+6

asmcomp/amd64/proc.ml

reviewed

··· 384 384 let num_stack_slots = [| 0; 0 |] 385 385 let contains_calls = ref false 386 386 387 387 + let frame_required () = 388 388 + fp || !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 389 389 + 390 390 + let prologue_required () = 391 391 + frame_required () 392 392 + 387 393 (* Calling the assembler *) 388 394 389 395 let assemble_file infile outfile =

+2 -1

asmcomp/arm/emit.mlp

reviewed

··· 439 439 match i.desc with 440 440 | Lend -> 0 441 441 | Lprologue -> 442 442 + assert (Proc.prologue_required ()); 442 443 let n = frame_size() in 443 444 let num_instrs = 444 445 if n > 0 then begin ··· 928 929 let fundecl fundecl = 929 930 function_name := fundecl.fun_name; 930 931 fastcode_flag := fundecl.fun_fast; 931 931 - tailrec_entry_point := new_label(); 932 932 + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; 932 933 float_literals := []; 933 934 gotrel_literals := []; 934 935 symbol_literals := [];

+9

asmcomp/arm/proc.ml

reviewed

··· 345 345 let num_stack_slots = [| 0; 0; 0 |] 346 346 let contains_calls = ref false 347 347 348 348 + let frame_required () = 349 349 + !contains_calls 350 350 + || num_stack_slots.(0) > 0 351 351 + || num_stack_slots.(1) > 0 352 352 + || num_stack_slots.(2) > 0 353 353 + 354 354 + let prologue_required () = 355 355 + frame_required () 356 356 + 348 357 (* Calling the assembler *) 349 358 350 359 let assemble_file infile outfile =

+5 -4

asmcomp/arm64/emit.mlp

reviewed

··· 606 606 match i.desc with 607 607 | Lend -> () 608 608 | Lprologue -> 609 609 + assert (Proc.prologue_required ()); 609 610 let n = frame_size() in 610 611 if n > 0 then 611 612 emit_stack_adjustment (-n); 612 613 if !contains_calls then begin 613 614 cfi_offset ~reg:30 (* return address *) ~offset:(-8); 614 615 ` str x30, [sp, #{emit_int (n-8)}]\n` 615 615 - end; 616 616 - `{emit_label !tailrec_entry_point}:\n`; 616 616 + end 617 617 | Lop(Imove | Ispill | Ireload) -> 618 618 let src = i.arg.(0) and dst = i.res.(0) in 619 619 if src.loc <> dst.loc then begin ··· 1009 1009 let fundecl fundecl = 1010 1010 function_name := fundecl.fun_name; 1011 1011 fastcode_flag := fundecl.fun_fast; 1012 1012 - tailrec_entry_point := new_label(); 1012 1012 + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; 1013 1013 float_literals := []; 1014 1014 stack_offset := 0; 1015 1015 call_gc_sites := []; ··· 1134 1134 ` .quad 0\n`; (* PR#6329 *) 1135 1135 ` .globl {emit_symbol lbl_end}\n`; 1136 1136 `{emit_symbol lbl_end}:\n`; 1137 1137 - ` .long 0\n`; 1137 1137 + ` .quad 0\n`; 1138 1138 + ` .align 3\n`; (* #7887 *) 1138 1139 let lbl = Compilenv.make_symbol (Some "frametable") in 1139 1140 ` .globl {emit_symbol lbl}\n`; 1140 1141 `{emit_symbol lbl}:\n`;

+8

asmcomp/arm64/proc.ml

reviewed

··· 261 261 let num_stack_slots = [| 0; 0 |] 262 262 let contains_calls = ref false 263 263 264 264 + let frame_required () = 265 265 + !contains_calls 266 266 + || num_stack_slots.(0) > 0 267 267 + || num_stack_slots.(1) > 0 268 268 + 269 269 + let prologue_required () = 270 270 + frame_required () 271 271 + 264 272 (* Calling the assembler *) 265 273 266 274 let assemble_file infile outfile =

+2 -2

asmcomp/i386/emit.mlp

reviewed

··· 473 473 match i.desc with 474 474 | Lend -> () 475 475 | Lprologue -> 476 476 + assert (Proc.prologue_required ()); 476 477 let n = frame_size() - 4 in 477 478 if n > 0 then begin 478 479 I.sub (int n) esp; 479 480 cfi_adjust_cfa_offset n; 480 481 end; 481 481 - def_label !tailrec_entry_point 482 482 | Lop(Imove | Ispill | Ireload) -> 483 483 let src = i.arg.(0) and dst = i.res.(0) in 484 484 if src.loc <> dst.loc then begin ··· 887 887 let fundecl fundecl = 888 888 function_name := fundecl.fun_name; 889 889 fastcode_flag := fundecl.fun_fast; 890 890 - tailrec_entry_point := new_label(); 890 890 + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; 891 891 stack_offset := 0; 892 892 call_gc_sites := []; 893 893 bound_error_sites := [];

+11

asmcomp/i386/proc.ml

reviewed

··· 241 241 let num_stack_slots = [| 0; 0 |] 242 242 let contains_calls = ref false 243 243 244 244 + let frame_required () = 245 245 + let frame_size_at_top_of_function = 246 246 + (* cf. [frame_size] in emit.mlp. *) 247 247 + Misc.align (4*num_stack_slots.(0) + 8*num_stack_slots.(1) + 4) 248 248 + stack_alignment 249 249 + in 250 250 + frame_size_at_top_of_function > 4 251 251 + 252 252 + let prologue_required () = 253 253 + frame_required () 254 254 + 244 255 (* Calling the assembler *) 245 256 246 257 let assemble_file infile outfile =

+62 -9

asmcomp/linearize.ml

reviewed

··· 56 56 fun_fast: bool; 57 57 fun_dbg : Debuginfo.t; 58 58 fun_spacetime_shape : Mach.spacetime_shape option; 59 59 + fun_tailrec_entry_point_label : label; 59 60 } 60 61 61 62 (* Invert a test *) ··· 314 315 copy_instr (Lraise k) i (discard_dead_code n) 315 316 316 317 let add_prologue first_insn = 317 317 - let insn = first_insn in 318 318 - { desc = Lprologue; 319 319 - next = insn; 320 320 - arg = [| |]; 321 321 - res = [| |]; 322 322 - dbg = insn.dbg; 323 323 - live = insn.live; 324 324 - } 318 318 + (* The prologue needs to come after any [Iname_for_debugger] operations that 319 319 + refer to parameters. (Such operations always come in a contiguous 320 320 + block, cf. [Selectgen].) *) 321 321 + let rec skip_naming_ops (insn : instruction) : label * instruction = 322 322 + match insn.desc with 323 323 + | Lop (Iname_for_debugger _) -> 324 324 + let tailrec_entry_point_label, next = skip_naming_ops insn.next in 325 325 + tailrec_entry_point_label, { insn with next; } 326 326 + | _ -> 327 327 + let tailrec_entry_point_label = Cmm.new_label () in 328 328 + let tailrec_entry_point = 329 329 + { desc = Llabel tailrec_entry_point_label; 330 330 + next = insn; 331 331 + arg = [| |]; 332 332 + res = [| |]; 333 333 + dbg = insn.dbg; 334 334 + live = insn.live; 335 335 + } 336 336 + in 337 337 + (* We expect [Lprologue] to expand to at least one instruction---as such, 338 338 + if no prologue is required, we avoid adding the instruction here. 339 339 + The reason is subtle: an empty expansion of [Lprologue] can cause 340 340 + two labels, one either side of the [Lprologue], to point at the same 341 341 + location. This means that we lose the property (cf. [Coalesce_labels]) 342 342 + that we can check if two labels point at the same location by 343 343 + comparing them for equality. This causes trouble when the function 344 344 + whose prologue is in question lands at the top of the object file 345 345 + and we are emitting DWARF debugging information: 346 346 + foo_code_begin: 347 347 + foo: 348 348 + .L1: 349 349 + ; empty prologue 350 350 + .L2: 351 351 + ... 352 352 + If we were to emit a location list entry from L1...L2, not realising 353 353 + that they point at the same location, then the beginning and ending 354 354 + points of the range would be both equal to each other and (relative to 355 355 + "foo_code_begin") equal to zero. This appears to confuse objdump, 356 356 + which seemingly misinterprets the entry as an end-of-list entry 357 357 + (which is encoded with two zero words), then complaining about a 358 358 + "hole in location list" (as it ignores any remaining list entries 359 359 + after the misinterpreted entry). *) 360 360 + if Proc.prologue_required () then 361 361 + let prologue = 362 362 + { desc = Lprologue; 363 363 + next = tailrec_entry_point; 364 364 + arg = [| |]; 365 365 + res = [| |]; 366 366 + dbg = tailrec_entry_point.dbg; 367 367 + live = Reg.Set.empty; (* will not be used *) 368 368 + } 369 369 + in 370 370 + tailrec_entry_point_label, prologue 371 371 + else 372 372 + tailrec_entry_point_label, tailrec_entry_point 373 373 + in 374 374 + skip_naming_ops first_insn 325 375 326 376 let fundecl f = 327 327 - let fun_body = add_prologue (linear f.Mach.fun_body end_instr) in 377 377 + let fun_tailrec_entry_point_label, fun_body = 378 378 + add_prologue (linear f.Mach.fun_body end_instr) 379 379 + in 328 380 { fun_name = f.Mach.fun_name; 329 381 fun_args = Reg.set_of_array f.Mach.fun_args; 330 382 fun_body; 331 383 fun_fast = not (List.mem Cmm.Reduce_code_size f.Mach.fun_codegen_options); 332 384 fun_dbg = f.Mach.fun_dbg; 333 385 fun_spacetime_shape = f.Mach.fun_spacetime_shape; 386 386 + fun_tailrec_entry_point_label; 334 387 }

+1

asmcomp/linearize.mli

reviewed

··· 54 54 fun_fast: bool; 55 55 fun_dbg : Debuginfo.t; 56 56 fun_spacetime_shape : Mach.spacetime_shape option; 57 57 + fun_tailrec_entry_point_label : label; 57 58 } 58 59 59 60 val fundecl: Mach.fundecl -> fundecl

+4 -3

asmcomp/power/emit.mlp

reviewed

··· 527 527 match i.desc with 528 528 | Lend -> () 529 529 | Lprologue -> 530 530 + assert (Proc.prologue_required ()); 530 531 let n = frame_size() in 531 532 if n > 0 then begin 532 533 ` addi 1, 1, {emit_int(-n)}\n`; ··· 541 542 | ELF32 -> () 542 543 | ELF64v1 | ELF64v2 -> 543 544 ` std 2, {emit_int(toc_save_offset())}(1)\n` 544 544 - end; 545 545 - `{emit_label !tailrec_entry_point}:\n` 545 545 + end 546 546 | Lop(Imove | Ispill | Ireload) -> 547 547 let src = i.arg.(0) and dst = i.res.(0) in 548 548 if src.loc <> dst.loc then begin ··· 1007 1007 1008 1008 let fundecl fundecl = 1009 1009 function_name := fundecl.fun_name; 1010 1010 - tailrec_entry_point := new_label(); 1010 1010 + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; 1011 1011 stack_offset := 0; 1012 1012 call_gc_label := 0; 1013 1013 float_literals := []; ··· 1177 1177 ` {emit_string datag} 0\n`; 1178 1178 (* Emit the frame descriptors *) 1179 1179 emit_string data_space; (* not rodata_space because it contains relocations *) 1180 1180 + if ppc64 then ` .align 3\n`; (* #7887 *) 1180 1181 let lbl = Compilenv.make_symbol (Some "frametable") in 1181 1182 declare_global_data lbl; 1182 1183 `{emit_symbol lbl}:\n`;

+20

asmcomp/power/proc.ml

reviewed

··· 341 341 let num_stack_slots = [| 0; 0 |] 342 342 let contains_calls = ref false 343 343 344 344 + (* See [reserved_stack_space] in emit.mlp. *) 345 345 + let reserved_stack_space_required () = 346 346 + match abi with 347 347 + | ELF32 -> false 348 348 + | ELF64v1 | ELF64v2 -> true 349 349 + 350 350 + let frame_required () = 351 351 + let is_elf32 = 352 352 + match abi with 353 353 + | ELF32 -> true 354 354 + | ELF64v1 | ELF64v2 -> false 355 355 + in 356 356 + reserved_stack_space_required () 357 357 + || num_stack_slots.(0) > 0 358 358 + || num_stack_slots.(1) > 0 359 359 + || (!contains_calls && is_elf32) 360 360 + 361 361 + let prologue_required () = 362 362 + frame_required () 363 363 + 344 364 (* Calling the assembler *) 345 365 346 366 let assemble_file infile outfile =

+4

asmcomp/proc.mli

reviewed

··· 67 67 (* Info for laying out the stack frame *) 68 68 val num_stack_slots: int array 69 69 val contains_calls: bool ref 70 70 + val frame_required : unit -> bool 71 71 + 72 72 + (* Function prologues *) 73 73 + val prologue_required : unit -> bool 70 74 71 75 (** For a given register class, the DWARF register numbering for that class. 72 76 Given an allocated register with location [Reg n] and class [reg_class], the

+3 -3

asmcomp/s390x/emit.mlp

reviewed

··· 308 308 match i.desc with 309 309 Lend -> () 310 310 | Lprologue -> 311 311 + assert (Proc.prologue_required ()); 311 312 let n = frame_size() in 312 313 emit_stack_adjust n; 313 314 if !contains_calls then 314 314 - ` stg %r14, {emit_int(n - size_addr)}(%r15)\n`; 315 315 - `{emit_label !tailrec_entry_point}:\n`; 315 315 + ` stg %r14, {emit_int(n - size_addr)}(%r15)\n` 316 316 | Lop(Imove | Ispill | Ireload) -> 317 317 let src = i.arg.(0) and dst = i.res.(0) in 318 318 if src.loc <> dst.loc then begin ··· 648 648 649 649 let fundecl fundecl = 650 650 function_name := fundecl.fun_name; 651 651 - tailrec_entry_point := new_label(); 651 651 + tailrec_entry_point := fundecl.fun_tailrec_entry_point_label; 652 652 stack_offset := 0; 653 653 call_gc_sites := []; 654 654 bound_error_sites := [];

+8

asmcomp/s390x/proc.ml

reviewed

··· 228 228 let num_stack_slots = [| 0; 0 |] 229 229 let contains_calls = ref false 230 230 231 231 + let frame_required () = 232 232 + !contains_calls 233 233 + || num_stack_slots.(0) > 0 234 234 + || num_stack_slots.(1) > 0 235 235 + 236 236 + let prologue_required () = 237 237 + frame_required () 238 238 + 231 239 (* Calling the assembler *) 232 240 233 241 let assemble_file infile outfile =

+1

asmcomp/schedgen.ml

reviewed

··· 393 393 fun_fast = f.fun_fast; 394 394 fun_dbg = f.fun_dbg; 395 395 fun_spacetime_shape = f.fun_spacetime_shape; 396 396 + fun_tailrec_entry_point_label = f.fun_tailrec_entry_point_label; 396 397 } 397 398 end else 398 399 f

+1 -1

bytecomp/simplif.ml

reviewed

··· 282 282 xs ys Ident.Map.empty 283 283 in 284 284 List.fold_right2 285 285 - (fun (y, kind) l r -> Llet (Alias, kind, y, l, r)) 285 285 + (fun (y, kind) l r -> Llet (Strict, kind, y, l, r)) 286 286 ys ls (Lambda.rename env handler) 287 287 with 288 288 | Not_found -> Lstaticraise (i,ls)

+6

bytecomp/translprim.ml

reviewed

··· 104 104 let gen_array_kind = 105 105 if Config.flat_float_array then Pgenarray else Paddrarray 106 106 107 107 + let prim_sys_argv = 108 108 + Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true 109 109 + 107 110 let primitives_table = 108 111 create_hashtable 57 [ 109 112 "%identity", Primitive (Pidentity, 1); ··· 341 344 "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1); 342 345 "%int_as_pointer", Primitive (Pint_as_pointer, 1); 343 346 "%opaque", Primitive (Popaque, 1); 347 347 + "%sys_argv", External prim_sys_argv; 344 348 "%send", Send; 345 349 "%sendself", Send_self; 346 350 "%sendcache", Send_cache; ··· 666 670 match prim, args with 667 671 | Primitive (prim, arity), args when arity = List.length args -> 668 672 Lprim(prim, args, loc) 673 673 + | External prim, args when prim = prim_sys_argv -> 674 674 + Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc) 669 675 | External prim, args -> 670 676 Lprim(Pccall prim, args, loc) 671 677 | Comparison(comp, knd), ([_;_] as args) ->

+7 -7

dune

reviewed

··· 54 54 ident path primitive types btype oprint subst predef datarepr 55 55 cmi_format persistent_env env 56 56 typedtree printtyped ctype printtyp includeclass mtype envaux includecore 57 57 - typedtreeIter tast_mapper cmt_format untypeast includemod 57 57 + tast_iterator tast_mapper cmt_format untypeast includemod 58 58 typetexp printpat parmatch stypes typedecl typeopt rec_check typecore 59 59 typeclass typemod typedecl_variance typedecl_properties typedecl_immediacy 60 60 typedecl_unboxed ··· 88 88 (flags (:standard -principal -nostdlib)) 89 89 (libraries stdlib ocamlcommon) 90 90 (modules_without_implementation 91 91 - cmx_format x86_ast backend_intf inlining_decision_intf 91 91 + cmxs_format cmx_format x86_ast backend_intf inlining_decision_intf 92 92 simplify_boxed_integer_ops_intf) 93 93 (modules 94 94 ;; ASMCOMP 95 95 arch backend_var cmm printcmm reg reg_with_debug_info reg_availability_set 96 96 mach proc clambda printclambda export_info export_info_for_pack compilenv 97 97 closure traverse_for_exported_symbols build_export_info closure_offsets 98 98 - flambda_to_clambda import_approx un_anf afl_instrument strmatch cmmgen 99 99 - interval printmach selectgen spacetime_profiling selection comballoc CSEgen 100 100 - CSE liveness spill split interf coloring linscan reloadgen reload deadcode 101 101 - printlinear linearize available_regs schedgen scheduling 98 98 + flambda_to_clambda import_approx un_anf afl_instrument strmatch cmmgen_state 99 99 + cmmgen interval printmach selectgen spacetime_profiling selection comballoc 100 100 + CSEgen CSE liveness spill split interf coloring linscan reloadgen reload 101 101 + deadcode printlinear linearize available_regs schedgen scheduling 102 102 branch_relaxation_intf branch_relaxation emitaux emit asmgen asmlink 103 103 asmlibrarian asmpackager opterrors optcompile 104 104 ; manual update: mli only files 105 105 - cmx_format 105 105 + cmxs_format cmx_format 106 106 107 107 ; arch specific files: we always include them even though depending on the 108 108 ; target architecture they might not be used.

+1

otherlibs/dynlink/dune

reviewed

··· 19 19 dynlink_platform_intf) 20 20 ; the -33 is specific to the hackery done with dune. 21 21 (flags (:standard -nostdlib -w -33)) 22 22 + (modules_without_implementation dynlink) 22 23 (libraries ocamlcommon stdlib)) 23 24 24 25 (rule

+21

runtime/sys.c

reviewed

··· 396 396 CAMLreturn(res); 397 397 } 398 398 399 399 + CAMLprim value caml_sys_argv(value unit) 400 400 + { 401 401 + CAMLparam0 (); /* unit is unused */ 402 402 + CAMLlocal1 (argv); 403 403 + argv = 404 404 + caml_alloc_array((void *)caml_copy_string_of_os, 405 405 + (char const **)caml_params->main_argv); 406 406 + CAMLreturn(argv); 407 407 + } 408 408 + 409 409 + CAMLprim value caml_sys_modify_argv(value new_argv) 410 410 + { 411 411 + caml_failwith ("caml_sys_modify_argv: not implemented"); 412 412 + return Val_unit; 413 413 + } 414 414 + 415 415 + CAMLprim value caml_sys_executable_name(value unit) 416 416 + { 417 417 + return caml_copy_string_of_os(caml_params->exe_name); 418 418 + } 419 419 + 399 420 void caml_sys_init(char_os * exe_name, char_os **argv) 400 421 { 401 422 caml_failwith ("caml_sys_init: not implemented");

+2

stdlib/.depend

reviewed

··· 137 137 camlinternalLazy.cmi 138 138 camlinternalLazy.cmi : 139 139 camlinternalMod.cmo : \ 140 140 + stdlib__sys.cmi \ 140 141 stdlib__obj.cmi \ 141 142 camlinternalOO.cmi \ 142 143 camlinternalLazy.cmi \ 143 144 stdlib__array.cmi \ 144 145 camlinternalMod.cmi 145 146 camlinternalMod.cmx : \ 147 147 + stdlib__sys.cmx \ 146 148 stdlib__obj.cmx \ 147 149 camlinternalOO.cmx \ 148 150 camlinternalLazy.cmx \

+8 -2

stdlib/camlinternalMod.ml

reviewed

··· 52 52 let rec update_mod shape o n = 53 53 match shape with 54 54 | Function -> 55 55 - assert (Obj.tag n = Obj.closure_tag || Obj.tag n = Obj.infix_tag); 56 56 - overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x)) 55 55 + (* The optimisation below is invalid on bytecode since 56 56 + the RESTART instruction checks the length of closures. 57 57 + See PR#4008 *) 58 58 + if Sys.backend_type = Sys.Native 59 59 + && Obj.tag n = Obj.closure_tag 60 60 + && Obj.size n <= Obj.size o 61 61 + then begin overwrite o n end 62 62 + else overwrite o (Obj.repr (fun x -> (Obj.obj n : _ -> _) x)) 57 63 | Lazy -> 58 64 if Obj.tag n = Obj.lazy_tag then 59 65 Obj.set_field o 0 (Obj.field n 0)

+12

stdlib/ephemeron.ml

reviewed

··· 482 482 let hash (_seed: int) x = H.hash x 483 483 end) 484 484 let create sz = create ~random:false sz 485 485 + let of_seq i = 486 486 + let tbl = create 16 in 487 487 + replace_seq tbl i; 488 488 + tbl 485 489 end 486 490 487 491 end ··· 570 574 let hash (_seed: int) x = H2.hash x 571 575 end) 572 576 let create sz = create ~random:false sz 577 577 + let of_seq i = 578 578 + let tbl = create 16 in 579 579 + replace_seq tbl i; 580 580 + tbl 573 581 end 574 582 575 583 end ··· 670 678 let hash (_seed: int) x = H.hash x 671 679 end) 672 680 let create sz = create ~random:false sz 681 681 + let of_seq i = 682 682 + let tbl = create 16 in 683 683 + replace_seq tbl i; 684 684 + tbl 673 685 end 674 686 end

+15 -3

stdlib/hashtbl.ml

reviewed

··· 570 570 H.equal k key || mem_in_bucket next in 571 571 mem_in_bucket h.data.(key_index h key) 572 572 573 573 + let add_seq tbl i = 574 574 + Seq.iter (fun (k,v) -> add tbl k v) i 575 575 + 576 576 + let replace_seq tbl i = 577 577 + Seq.iter (fun (k,v) -> replace tbl k v) i 578 578 + 579 579 + let of_seq i = 580 580 + let tbl = create 16 in 581 581 + replace_seq tbl i; 582 582 + tbl 583 583 + 573 584 let iter = iter 574 585 let filter_map_inplace = filter_map_inplace 575 586 let fold = fold ··· 578 589 let to_seq = to_seq 579 590 let to_seq_keys = to_seq_keys 580 591 let to_seq_values = to_seq_values 581 581 - let add_seq = add_seq 582 582 - let replace_seq = replace_seq 583 583 - let of_seq = of_seq 584 592 end 585 593 586 594 module Make(H: HashedType): (S with type key = H.t) = ··· 591 599 let hash (_seed: int) x = H.hash x 592 600 end) 593 601 let create sz = create ~random:false sz 602 602 + let of_seq i = 603 603 + let tbl = create 16 in 604 604 + replace_seq tbl i; 605 605 + tbl 594 606 end

+1

stdlib/obj.mli

reviewed

··· 66 66 external new_block : int -> int -> t = "caml_obj_block" 67 67 external dup : t -> t = "caml_obj_dup" 68 68 external truncate : t -> int -> unit = "caml_obj_truncate" 69 69 + [@@ocaml.deprecated] 69 70 external add_offset : t -> Int32.t -> t = "caml_obj_add_offset" 70 71 (* @since 3.12.0 *) 71 72 external with_tag : int -> t -> t = "caml_obj_with_tag"

+1 -1

stdlib/sys.mli

reviewed

··· 20 20 an error. 21 21 *) 22 22 23 23 - val argv : string array 23 23 + external argv : string array = "%sys_argv" 24 24 (** The command line arguments given to the process. 25 25 The first element is the command name used to invoke the program. 26 26 The following elements are the command-line arguments

+3 -2

stdlib/sys.mlp

reviewed

··· 25 25 (* System interface *) 26 26 27 27 external get_config: unit -> string * int * bool = "caml_sys_get_config" 28 28 - external get_argv: unit -> string * string array = "caml_sys_get_argv" 28 28 + external get_executable_name : unit -> string = "caml_sys_executable_name" 29 29 + external argv : string array = "%sys_argv" 29 30 external big_endian : unit -> bool = "%big_endian" 30 31 external word_size : unit -> int = "%word_size" 31 32 external int_size : unit -> int = "%int_size" ··· 35 36 external cygwin : unit -> bool = "%ostype_cygwin" 36 37 external get_backend_type : unit -> backend_type = "%backend_type" 37 38 38 38 - let (executable_name, argv) = get_argv() 39 39 + let executable_name = get_executable_name() 39 40 let (os_type, _, _) = get_config() 40 41 let backend_type = get_backend_type () 41 42 let big_endian = big_endian ()

+4 -2

stdlib/weak.ml

reviewed

··· 204 204 t.table.(t.rover) <- emptybucket; 205 205 t.hashes.(t.rover) <- [| |]; 206 206 end else begin 207 207 - Obj.truncate (Obj.repr bucket) (prev_len + additional_values); 208 208 - Obj.truncate (Obj.repr hbucket) prev_len; 207 207 + let newbucket = weak_create prev_len in 208 208 + blit bucket 0 newbucket 0 prev_len; 209 209 + t.table.(t.rover) <- newbucket; 210 210 + t.hashes.(t.rover) <- Array.sub hbucket 0 prev_len 209 211 end; 210 212 if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1; 211 213 end;

+2 -1

testsuite/tests/basic-modules/main.ml

reviewed

··· 1 1 (* TEST 2 2 - modules = "offset.ml pr6726.ml pr7427.ml" 2 2 + modules = "offset.ml pr6726.ml pr7427.ml pr4008.ml" 3 3 *) 4 4 5 5 (* PR#6435 *) ··· 16 16 17 17 let () = M.test (Offset.M.Set.singleton "42") 18 18 let v = Pr6726.Test.v 19 19 + let v = Pr4008.v 19 20 20 21 (* PR#7427 *) 21 22

+6

testsuite/tests/basic-modules/pr4008.ml

reviewed

··· 1 1 + module rec M : sig 2 2 + val f : int list -> int list 3 3 + end = struct 4 4 + let f = List.map succ 5 5 + end 6 6 + let v = M.f []

+9

testsuite/tests/basic/localfunction.ml

reviewed

··· 21 21 Printf.printf "%i\n%!" !r; 22 22 assert(x1 -. x0 = x2 -. x1) 23 23 (* check that we did not allocated anything between x1 and x2 *) 24 24 + 25 25 + 26 26 + let () = 27 27 + (* #8558 *) 28 28 + let f () = () in 29 29 + let r = ref 0 in 30 30 + let g () = f (incr r) in 31 31 + g (); 32 32 + assert (!r = 1)

-3

testsuite/tests/misc/sorts.ml

reviewed

··· 4164 4164 done; 4165 4165 ;; 4166 4166 4167 4167 - (************************************************************************) 4168 4168 - (* merge sort on lists via arrays *) 4169 4169 - 4170 4167 let array_of_list l len = 4171 4168 match l with 4172 4169 | [] -> [| |]

+1

testsuite/tests/tool-toplevel-invocation/print_args.ml

reviewed

··· 1 1 + Array.iter (fun x -> print_endline (Filename.basename x)) Sys.argv;;

+3

testsuite/tests/tool-toplevel-invocation/print_args.reference

reviewed

··· 1 1 + print_args.ml 2 2 + foo 3 3 + bar

+6

testsuite/tests/tool-toplevel-invocation/test.ml

reviewed

··· 40 40 compiler_output = "${test_build_directory}/working_arg.output" 41 41 *** check-ocaml-output 42 42 43 43 + ** ocaml 44 44 + flags = "${test_source_directory}/print_args.ml foo bar" 45 45 + compiler_reference = "${test_source_directory}/print_args.reference" 46 46 + compiler_output = "${test_build_directory}/print_args.output" 47 47 + *** check-ocaml-output 48 48 + 43 49 *) 44 50 45 51 printf "Test succeeds\n";;

+6 -20

toplevel/opttoploop.ml

reviewed

··· 607 607 | x -> Location.report_exception ppf x; Btype.backtrack snap 608 608 done 609 609 610 610 - (* Execute a script. If [name] is "", read the script from stdin. *) 610 610 + external caml_sys_modify_argv : string array -> unit = 611 611 + "caml_sys_modify_argv" 611 612 612 612 - let override_sys_argv args = 613 613 - let len = Array.length args in 614 614 - if Array.length Sys.argv < len then invalid_arg "Toploop.override_sys_argv"; 615 615 - Array.blit args 0 Sys.argv 0 len; 616 616 - Obj.truncate (Obj.repr Sys.argv) len; 613 613 + let override_sys_argv new_argv = 614 614 + caml_sys_modify_argv new_argv; 617 615 Arg.current := 0 618 616 619 619 - module type SYS = module type of Sys 620 620 - 621 621 - (* The script must see a different value for the "constant" Sys.argv. 622 622 - So, rewrite the module to claim it was always that way *) 623 623 - let hack_argv new_argv = 624 624 - let new_argv = Obj.repr new_argv in 625 625 - let old_argv = Obj.repr Sys.argv in 626 626 - let sys_mod = Obj.repr (module Sys : SYS) in 627 627 - for i = 0 to Obj.size sys_mod - 1 do 628 628 - if Obj.field sys_mod i == old_argv then 629 629 - Obj.set_field sys_mod i new_argv 630 630 - done 617 617 + (* Execute a script. If [name] is "", read the script from stdin. *) 631 618 632 619 let run_script ppf name args = 633 633 - hack_argv args; 634 634 - Arg.current := 0; 620 620 + override_sys_argv args; 635 621 Compmisc.init_path ~dir:(Filename.dirname name) (); 636 622 (* Note: would use [Filename.abspath] here, if we had it. *) 637 623 toplevel_env := Compmisc.initial_env();

+5 -15

toplevel/toploop.ml

reviewed

··· 565 565 | x -> Location.report_exception ppf x; Btype.backtrack snap 566 566 done 567 567 568 568 - (* Execute a script. If [name] is "", read the script from stdin. *) 569 569 - 570 570 - (* The script must see a different value for the "constant" Sys.argv. 571 571 - So, rewrite the module to claim it was always that way *) 572 572 - module type SYS = module type of Sys 568 568 + external caml_sys_modify_argv : string array -> unit = 569 569 + "caml_sys_modify_argv" 573 570 574 574 - let hack_argv new_argv = 575 575 - let new_argv = Obj.repr new_argv in 576 576 - let old_argv = Obj.repr Sys.argv in 577 577 - let sys_mod = Obj.repr (module Sys : SYS) in 578 578 - for i = 0 to Obj.size sys_mod - 1 do 579 579 - if Obj.field sys_mod i == old_argv then 580 580 - Obj.set_field sys_mod i new_argv 581 581 - done; 571 571 + let override_sys_argv new_argv = 572 572 + caml_sys_modify_argv new_argv; 582 573 Arg.current := 0 583 574 584 584 - let override_sys_argv = hack_argv 575 575 + (* Execute a script. If [name] is "", read the script from stdin. *) 585 576 586 577 let run_script ppf name args = 587 587 - (* override_sys_argv args; *) 588 578 override_sys_argv args; 589 579 Compmisc.init_path ~dir:(Filename.dirname name) (); 590 580 (* Note: would use [Filename.abspath] here, if we had it. *)

+24 -26

typing/parmatch.ml

reviewed

··· 2440 2440 2441 2441 let all_rhs_idents exp = 2442 2442 let ids = ref Ident.Set.empty in 2443 2443 - let module Iterator = TypedtreeIter.MakeIterator(struct 2444 2444 - include TypedtreeIter.DefaultIteratorArgument 2445 2445 - let enter_expression exp = match exp.exp_desc with 2446 2446 - | Texp_ident (path, _lid, _descr) -> 2447 2447 - List.iter 2448 2448 - (fun id -> ids := Ident.Set.add id !ids) 2449 2449 - (Path.heads path) 2450 2450 - | _ -> () 2451 2451 - 2452 2443 (* Very hackish, detect unpack pattern compilation 2453 2444 and perform "indirect check for them" *) 2454 2454 - let is_unpack exp = 2445 2445 + let is_unpack exp = 2455 2446 List.exists 2456 2447 (fun attr -> attr.Parsetree.attr_name.txt = "#modulepat") 2457 2457 - exp.exp_attributes 2448 2448 + exp.exp_attributes in 2449 2449 + let open Tast_iterator in 2450 2450 + let expr_iter iter exp = 2451 2451 + (match exp.exp_desc with 2452 2452 + | Texp_ident (path, _lid, _descr) -> 2453 2453 + List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path) 2454 2454 + (* Use default iterator methods for rest of match.*) 2455 2455 + | _ -> Tast_iterator.default_iterator.expr iter exp); 2458 2456 2459 2459 - let leave_expression exp = 2460 2460 - if is_unpack exp then begin match exp.exp_desc with 2461 2461 - | Texp_letmodule 2462 2462 - (id_mod,_,_, 2463 2463 - {mod_desc= 2464 2464 - Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)}, 2465 2465 - _) -> 2466 2466 - assert (Ident.Set.mem id_exp !ids) ; 2467 2467 - if not (Ident.Set.mem id_mod !ids) then begin 2468 2468 - ids := Ident.Set.remove id_exp !ids 2469 2469 - end 2470 2470 - | _ -> assert false 2471 2471 - end 2472 2472 - end) in 2473 2473 - Iterator.iter_expression exp; 2457 2457 + if is_unpack exp then begin match exp.exp_desc with 2458 2458 + | Texp_letmodule 2459 2459 + (id_mod,_,_, 2460 2460 + {mod_desc= 2461 2461 + Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)}, 2462 2462 + _) -> 2463 2463 + assert (Ident.Set.mem id_exp !ids) ; 2464 2464 + if not (Ident.Set.mem id_mod !ids) then begin 2465 2465 + ids := Ident.Set.remove id_exp !ids 2466 2466 + end 2467 2467 + | _ -> assert false 2468 2468 + end 2469 2469 + in 2470 2470 + let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in 2471 2471 + iterator.expr iterator exp; 2474 2472 !ids 2475 2473 2476 2474 let check_ambiguous_bindings =

+510

typing/tast_iterator.ml

reviewed

··· 1 1 + (**************************************************************************) 2 2 + (* *) 3 3 + (* OCaml *) 4 4 + (* *) 5 5 + (* Isaac "Izzy" Avram *) 6 6 + (* *) 7 7 + (* Copyright 2019 Institut National de Recherche en Informatique et *) 8 8 + (* en Automatique. *) 9 9 + (* *) 10 10 + (* All rights reserved. This file is distributed under the terms of *) 11 11 + (* the GNU Lesser General Public License version 2.1, with the *) 12 12 + (* special exception on linking described in the file LICENSE. *) 13 13 + (* *) 14 14 + (**************************************************************************) 15 15 + 16 16 + open Asttypes 17 17 + open Typedtree 18 18 + 19 19 + type iterator = 20 20 + { 21 21 + binding_op: iterator -> binding_op -> unit; 22 22 + case: iterator -> case -> unit; 23 23 + cases: iterator -> case list -> unit; 24 24 + class_declaration: iterator -> class_declaration -> unit; 25 25 + class_description: iterator -> class_description -> unit; 26 26 + class_expr: iterator -> class_expr -> unit; 27 27 + class_field: iterator -> class_field -> unit; 28 28 + class_signature: iterator -> class_signature -> unit; 29 29 + class_structure: iterator -> class_structure -> unit; 30 30 + class_type: iterator -> class_type -> unit; 31 31 + class_type_declaration: iterator -> class_type_declaration -> unit; 32 32 + class_type_field: iterator -> class_type_field -> unit; 33 33 + env: iterator -> Env.t -> unit; 34 34 + expr: iterator -> expression -> unit; 35 35 + extension_constructor: iterator -> extension_constructor -> unit; 36 36 + module_binding: iterator -> module_binding -> unit; 37 37 + module_coercion: iterator -> module_coercion -> unit; 38 38 + module_declaration: iterator -> module_declaration -> unit; 39 39 + module_substitution: iterator -> module_substitution -> unit; 40 40 + module_expr: iterator -> module_expr -> unit; 41 41 + module_type: iterator -> module_type -> unit; 42 42 + module_type_declaration: iterator -> module_type_declaration -> unit; 43 43 + package_type: iterator -> package_type -> unit; 44 44 + pat: iterator -> pattern -> unit; 45 45 + row_field: iterator -> row_field -> unit; 46 46 + object_field: iterator -> object_field -> unit; 47 47 + open_declaration: iterator -> open_declaration -> unit; 48 48 + open_description: iterator -> open_description -> unit; 49 49 + signature: iterator -> signature -> unit; 50 50 + signature_item: iterator -> signature_item -> unit; 51 51 + structure: iterator -> structure -> unit; 52 52 + structure_item: iterator -> structure_item -> unit; 53 53 + typ: iterator -> core_type -> unit; 54 54 + type_declaration: iterator -> type_declaration -> unit; 55 55 + type_declarations: iterator -> (rec_flag * type_declaration list) -> unit; 56 56 + type_extension: iterator -> type_extension -> unit; 57 57 + type_exception: iterator -> type_exception -> unit; 58 58 + type_kind: iterator -> type_kind -> unit; 59 59 + value_binding: iterator -> value_binding -> unit; 60 60 + value_bindings: iterator -> (rec_flag * value_binding list) -> unit; 61 61 + value_description: iterator -> value_description -> unit; 62 62 + with_constraint: iterator -> with_constraint -> unit; 63 63 + } 64 64 + 65 65 + let structure sub {str_items; str_final_env; _} = 66 66 + List.iter (sub.structure_item sub) str_items; 67 67 + sub.env sub str_final_env 68 68 + 69 69 + let class_infos sub f x = 70 70 + List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params; 71 71 + f x.ci_expr 72 72 + 73 73 + let module_type_declaration sub {mtd_type; _} = 74 74 + Option.iter (sub.module_type sub) mtd_type 75 75 + 76 76 + let module_declaration sub {md_type; _} = 77 77 + sub.module_type sub md_type 78 78 + let module_substitution _ _ = () 79 79 + 80 80 + let include_infos f {incl_mod; _} = f incl_mod 81 81 + 82 82 + let class_type_declaration sub x = 83 83 + class_infos sub (sub.class_type sub) x 84 84 + 85 85 + let class_declaration sub x = 86 86 + class_infos sub (sub.class_expr sub) x 87 87 + 88 88 + let structure_item sub {str_desc; str_env; _} = 89 89 + sub.env sub str_env; 90 90 + match str_desc with 91 91 + | Tstr_eval (exp, _) -> sub.expr sub exp 92 92 + | Tstr_value (rec_flag, list) -> sub.value_bindings sub (rec_flag, list) 93 93 + | Tstr_primitive v -> sub.value_description sub v 94 94 + | Tstr_type (rec_flag, list) -> sub.type_declarations sub (rec_flag, list) 95 95 + | Tstr_typext te -> sub.type_extension sub te 96 96 + | Tstr_effect ext -> sub.extension_constructor sub ext 97 97 + | Tstr_exception ext -> sub.type_exception sub ext 98 98 + | Tstr_module mb -> sub.module_binding sub mb 99 99 + | Tstr_recmodule list -> List.iter (sub.module_binding sub) list 100 100 + | Tstr_modtype x -> sub.module_type_declaration sub x 101 101 + | Tstr_class list -> 102 102 + List.iter (fun (cls,_) -> sub.class_declaration sub cls) list 103 103 + | Tstr_class_type list -> 104 104 + List.iter (fun (_, _, cltd) -> sub.class_type_declaration sub cltd) list 105 105 + | Tstr_include incl -> include_infos (sub.module_expr sub) incl 106 106 + | Tstr_open od -> sub.open_declaration sub od 107 107 + | Tstr_attribute _ -> () 108 108 + 109 109 + let value_description sub x = sub.typ sub x.val_desc 110 110 + 111 111 + let label_decl sub {ld_type; _} = sub.typ sub ld_type 112 112 + 113 113 + let constructor_args sub = function 114 114 + | Cstr_tuple l -> List.iter (sub.typ sub) l 115 115 + | Cstr_record l -> List.iter (label_decl sub) l 116 116 + 117 117 + let constructor_decl sub {cd_args; cd_res; _} = 118 118 + constructor_args sub cd_args; 119 119 + Option.iter (sub.typ sub) cd_res 120 120 + 121 121 + let type_kind sub = function 122 122 + | Ttype_abstract -> () 123 123 + | Ttype_variant list -> List.iter (constructor_decl sub) list 124 124 + | Ttype_record list -> List.iter (label_decl sub) list 125 125 + | Ttype_open -> () 126 126 + 127 127 + let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} = 128 128 + List.iter 129 129 + (fun (c1, c2, _) -> 130 130 + sub.typ sub c1; 131 131 + sub.typ sub c2) 132 132 + typ_cstrs; 133 133 + sub.type_kind sub typ_kind; 134 134 + Option.iter (sub.typ sub) typ_manifest; 135 135 + List.iter (fun (c, _) -> sub.typ sub c) typ_params 136 136 + 137 137 + let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list 138 138 + 139 139 + let type_extension sub {tyext_constructors; tyext_params; _} = 140 140 + List.iter (fun (c, _) -> sub.typ sub c) tyext_params; 141 141 + List.iter (sub.extension_constructor sub) tyext_constructors 142 142 + 143 143 + let type_exception sub {tyexn_constructor; _} = 144 144 + sub.extension_constructor sub tyexn_constructor 145 145 + 146 146 + let extension_constructor sub {ext_kind; _} = 147 147 + match ext_kind with 148 148 + | Text_decl (ctl, cto) -> 149 149 + constructor_args sub ctl; 150 150 + Option.iter (sub.typ sub) cto 151 151 + | Text_rebind _ -> () 152 152 + 153 153 + let pat sub {pat_extra; pat_desc; pat_env; _} = 154 154 + let extra = function 155 155 + | Tpat_type _ -> () 156 156 + | Tpat_unpack -> () 157 157 + | Tpat_open (_, _, env) -> sub.env sub env 158 158 + | Tpat_constraint ct -> sub.typ sub ct 159 159 + in 160 160 + sub.env sub pat_env; 161 161 + List.iter (fun (e, _, _) -> extra e) pat_extra; 162 162 + match pat_desc with 163 163 + | Tpat_any -> () 164 164 + | Tpat_var _ -> () 165 165 + | Tpat_constant _ -> () 166 166 + | Tpat_tuple l -> List.iter (sub.pat sub) l 167 167 + | Tpat_construct (_, _, l) -> List.iter (sub.pat sub) l 168 168 + | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po 169 169 + | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l 170 170 + | Tpat_array l -> List.iter (sub.pat sub) l 171 171 + | Tpat_or (p1, p2, _) -> 172 172 + sub.pat sub p1; 173 173 + sub.pat sub p2 174 174 + | Tpat_alias (p, _, _) -> sub.pat sub p 175 175 + | Tpat_lazy p -> sub.pat sub p 176 176 + | Tpat_exception p -> sub.pat sub p 177 177 + 178 178 + let expr sub {exp_extra; exp_desc; exp_env; _} = 179 179 + let extra = function 180 180 + | Texp_constraint cty -> sub.typ sub cty 181 181 + | Texp_coerce (cty1, cty2) -> 182 182 + Option.iter (sub.typ sub) cty1; 183 183 + sub.typ sub cty2 184 184 + | Texp_newtype _ -> () 185 185 + | Texp_poly cto -> Option.iter (sub.typ sub) cto 186 186 + in 187 187 + List.iter (fun (e, _, _) -> extra e) exp_extra; 188 188 + sub.env sub exp_env; 189 189 + match exp_desc with 190 190 + | Texp_ident _ -> () 191 191 + | Texp_constant _ -> () 192 192 + | Texp_let (rec_flag, list, exp) -> 193 193 + sub.value_bindings sub (rec_flag, list); 194 194 + sub.expr sub exp 195 195 + | Texp_function {cases; _} -> sub.cases sub cases 196 196 + | Texp_apply (exp, list) -> 197 197 + sub.expr sub exp; 198 198 + List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list 199 199 + | Texp_match (exp, cases, effs, _) -> 200 200 + sub.expr sub exp; 201 201 + sub.cases sub cases; 202 202 + sub.cases sub effs 203 203 + | Texp_try (exp, cases, effs) -> 204 204 + sub.expr sub exp; 205 205 + sub.cases sub cases; 206 206 + sub.cases sub effs 207 207 + | Texp_tuple list -> List.iter (sub.expr sub) list 208 208 + | Texp_construct (_, _, args) -> List.iter (sub.expr sub) args 209 209 + | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo 210 210 + | Texp_record { fields; extended_expression; _} -> 211 211 + Array.iter (function 212 212 + | _, Kept _ -> () 213 213 + | _, Overridden (_, exp) -> sub.expr sub exp) 214 214 + fields; 215 215 + Option.iter (sub.expr sub) extended_expression; 216 216 + | Texp_field (exp, _, _) -> sub.expr sub exp 217 217 + | Texp_setfield (exp1, _, _, exp2) -> 218 218 + sub.expr sub exp1; 219 219 + sub.expr sub exp2 220 220 + | Texp_array list -> List.iter (sub.expr sub) list 221 221 + | Texp_ifthenelse (exp1, exp2, expo) -> 222 222 + sub.expr sub exp1; 223 223 + sub.expr sub exp2; 224 224 + Option.iter (sub.expr sub) expo 225 225 + | Texp_sequence (exp1, exp2) -> 226 226 + sub.expr sub exp1; 227 227 + sub.expr sub exp2 228 228 + | Texp_while (exp1, exp2) -> 229 229 + sub.expr sub exp1; 230 230 + sub.expr sub exp2 231 231 + | Texp_for (_, _, exp1, exp2, _, exp3) -> 232 232 + sub.expr sub exp1; 233 233 + sub.expr sub exp2; 234 234 + sub.expr sub exp3 235 235 + | Texp_send (exp, _, expo) -> 236 236 + sub.expr sub exp; 237 237 + Option.iter (sub.expr sub) expo 238 238 + | Texp_new _ -> () 239 239 + | Texp_instvar _ -> () 240 240 + | Texp_setinstvar (_, _, _, exp) ->sub.expr sub exp 241 241 + | Texp_override (_, list) -> 242 242 + List.iter (fun (_, _, e) -> sub.expr sub e) list 243 243 + | Texp_letmodule (_, _, _, mexpr, exp) -> 244 244 + sub.module_expr sub mexpr; 245 245 + sub.expr sub exp 246 246 + | Texp_letexception (cd, exp) -> 247 247 + sub.extension_constructor sub cd; 248 248 + sub.expr sub exp 249 249 + | Texp_assert exp -> sub.expr sub exp 250 250 + | Texp_lazy exp -> sub.expr sub exp 251 251 + | Texp_object (cl, _) -> sub.class_structure sub cl 252 252 + | Texp_pack mexpr -> sub.module_expr sub mexpr 253 253 + | Texp_letop {let_ = l; ands; body; _} -> 254 254 + sub.binding_op sub l; 255 255 + List.iter (sub.binding_op sub) ands; 256 256 + sub.case sub body 257 257 + | Texp_unreachable -> () 258 258 + | Texp_extension_constructor _ -> () 259 259 + | Texp_open (od, e) -> 260 260 + sub.open_declaration sub od; 261 261 + sub.expr sub e 262 262 + 263 263 + 264 264 + let package_type sub {pack_fields; _} = 265 265 + List.iter (fun (_, p) -> sub.typ sub p) pack_fields 266 266 + 267 267 + let binding_op sub {bop_exp; _} = sub.expr sub bop_exp 268 268 + 269 269 + let signature sub {sig_items; sig_final_env; _} = 270 270 + sub.env sub sig_final_env; 271 271 + List.iter (sub.signature_item sub) sig_items 272 272 + 273 273 + let signature_item sub {sig_desc; sig_env; _} = 274 274 + sub.env sub sig_env; 275 275 + match sig_desc with 276 276 + | Tsig_value v -> sub.value_description sub v 277 277 + | Tsig_type (rf, tdl) -> sub.type_declarations sub (rf, tdl) 278 278 + | Tsig_typesubst list -> sub.type_declarations sub (Nonrecursive, list) 279 279 + | Tsig_typext te -> sub.type_extension sub te 280 280 + | Tsig_effect ext -> sub.extension_constructor sub ext 281 281 + | Tsig_exception ext -> sub.type_exception sub ext 282 282 + | Tsig_module x -> sub.module_declaration sub x 283 283 + | Tsig_modsubst x -> sub.module_substitution sub x 284 284 + | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list 285 285 + | Tsig_modtype x -> sub.module_type_declaration sub x 286 286 + | Tsig_include incl -> include_infos (sub.module_type sub) incl 287 287 + | Tsig_class list -> List.iter (sub.class_description sub) list 288 288 + | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list 289 289 + | Tsig_open od -> sub.open_description sub od 290 290 + | Tsig_attribute _ -> () 291 291 + 292 292 + let class_description sub x = 293 293 + class_infos sub (sub.class_type sub) x 294 294 + 295 295 + let module_type sub {mty_desc; mty_env; _} = 296 296 + sub.env sub mty_env; 297 297 + match mty_desc with 298 298 + | Tmty_ident _ -> () 299 299 + | Tmty_alias _ -> () 300 300 + | Tmty_signature sg -> sub.signature sub sg 301 301 + | Tmty_functor (_, _, mtype1, mtype2) -> 302 302 + Option.iter (sub.module_type sub) mtype1; 303 303 + sub.module_type sub mtype2 304 304 + | Tmty_with (mtype, list) -> 305 305 + sub.module_type sub mtype; 306 306 + List.iter (fun (_, _, e) -> sub.with_constraint sub e) list 307 307 + | Tmty_typeof mexpr -> sub.module_expr sub mexpr 308 308 + 309 309 + let with_constraint sub = function 310 310 + | Twith_type decl -> sub.type_declaration sub decl 311 311 + | Twith_typesubst decl -> sub.type_declaration sub decl 312 312 + | Twith_module _ -> () 313 313 + | Twith_modsubst _ -> () 314 314 + 315 315 + let open_description sub {open_env; _} = sub.env sub open_env 316 316 + 317 317 + let open_declaration sub {open_expr; open_env; _} = 318 318 + sub.module_expr sub open_expr; 319 319 + sub.env sub open_env 320 320 + 321 321 + let module_coercion sub = function 322 322 + | Tcoerce_none -> () 323 323 + | Tcoerce_functor (c1,c2) -> 324 324 + sub.module_coercion sub c1; 325 325 + sub.module_coercion sub c2 326 326 + | Tcoerce_alias (env, _, c1) -> 327 327 + sub.env sub env; 328 328 + sub.module_coercion sub c1 329 329 + | Tcoerce_structure (l1, l2) -> 330 330 + List.iter (fun (_, c) -> sub.module_coercion sub c) l1; 331 331 + List.iter (fun (_, _ ,c) -> sub.module_coercion sub c) l2 332 332 + | Tcoerce_primitive {pc_env; _} -> sub.env sub pc_env 333 333 + 334 334 + let module_expr sub {mod_desc; mod_env; _} = 335 335 + sub.env sub mod_env; 336 336 + match mod_desc with 337 337 + | Tmod_ident _ -> () 338 338 + | Tmod_structure st -> sub.structure sub st 339 339 + | Tmod_functor (_, _, mtype, mexpr) -> 340 340 + Option.iter (sub.module_type sub) mtype; 341 341 + sub.module_expr sub mexpr 342 342 + | Tmod_apply (mexp1, mexp2, c) -> 343 343 + sub.module_expr sub mexp1; 344 344 + sub.module_expr sub mexp2; 345 345 + sub.module_coercion sub c 346 346 + | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) -> 347 347 + sub.module_expr sub mexpr; 348 348 + sub.module_coercion sub c 349 349 + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, c) -> 350 350 + sub.module_expr sub mexpr; 351 351 + sub.module_type sub mtype; 352 352 + sub.module_coercion sub c 353 353 + | Tmod_unpack (exp, _) -> sub.expr sub exp 354 354 + 355 355 + let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr 356 356 + 357 357 + let class_expr sub {cl_desc; cl_env; _} = 358 358 + sub.env sub cl_env; 359 359 + match cl_desc with 360 360 + | Tcl_constraint (cl, clty, _, _, _) -> 361 361 + sub.class_expr sub cl; 362 362 + Option.iter (sub.class_type sub) clty 363 363 + | Tcl_structure clstr -> sub.class_structure sub clstr 364 364 + | Tcl_fun (_, pat, priv, cl, _) -> 365 365 + sub.pat sub pat; 366 366 + List.iter (fun (_, e) -> sub.expr sub e) priv; 367 367 + sub.class_expr sub cl 368 368 + | Tcl_apply (cl, args) -> 369 369 + sub.class_expr sub cl; 370 370 + List.iter (fun (_, e) -> Option.iter (sub.expr sub) e) args 371 371 + | Tcl_let (rec_flag, value_bindings, ivars, cl) -> 372 372 + sub.value_bindings sub (rec_flag, value_bindings); 373 373 + List.iter (fun (_, e) -> sub.expr sub e) ivars; 374 374 + sub.class_expr sub cl 375 375 + | Tcl_ident (_, _, tyl) -> List.iter (sub.typ sub) tyl 376 376 + | Tcl_open (od, e) -> 377 377 + sub.open_description sub od; 378 378 + sub.class_expr sub e 379 379 + 380 380 + let class_type sub {cltyp_desc; cltyp_env; _} = 381 381 + sub.env sub cltyp_env; 382 382 + match cltyp_desc with 383 383 + | Tcty_signature csg -> sub.class_signature sub csg 384 384 + | Tcty_constr (_, _, list) -> List.iter (sub.typ sub) list 385 385 + | Tcty_arrow (_, ct, cl) -> 386 386 + sub.typ sub ct; 387 387 + sub.class_type sub cl 388 388 + | Tcty_open (od, e) -> 389 389 + sub.open_description sub od; 390 390 + sub.class_type sub e 391 391 + 392 392 + let class_signature sub {csig_self; csig_fields; _} = 393 393 + sub.typ sub csig_self; 394 394 + List.iter (sub.class_type_field sub) csig_fields 395 395 + 396 396 + let class_type_field sub {ctf_desc; _} = 397 397 + match ctf_desc with 398 398 + | Tctf_inherit ct -> sub.class_type sub ct 399 399 + | Tctf_val (_, _, _, ct) -> sub.typ sub ct 400 400 + | Tctf_method (_, _, _, ct) -> sub.typ sub ct 401 401 + | Tctf_constraint (ct1, ct2) -> 402 402 + sub.typ sub ct1; 403 403 + sub.typ sub ct2 404 404 + | Tctf_attribute _ -> () 405 405 + 406 406 + let typ sub {ctyp_desc; ctyp_env; _} = 407 407 + sub.env sub ctyp_env; 408 408 + match ctyp_desc with 409 409 + | Ttyp_any -> () 410 410 + | Ttyp_var _ -> () 411 411 + | Ttyp_arrow (_, ct1, ct2) -> 412 412 + sub.typ sub ct1; 413 413 + sub.typ sub ct2 414 414 + | Ttyp_tuple list -> List.iter (sub.typ sub) list 415 415 + | Ttyp_constr (_, _, list) -> List.iter (sub.typ sub) list 416 416 + | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list 417 417 + | Ttyp_class (_, _, list) -> List.iter (sub.typ sub) list 418 418 + | Ttyp_alias (ct, _) -> sub.typ sub ct 419 419 + | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list 420 420 + | Ttyp_poly (_, ct) -> sub.typ sub ct 421 421 + | Ttyp_package pack -> sub.package_type sub pack 422 422 + 423 423 + let class_structure sub {cstr_self; cstr_fields; _} = 424 424 + sub.pat sub cstr_self; 425 425 + List.iter (sub.class_field sub) cstr_fields 426 426 + 427 427 + let row_field sub {rf_desc; _} = 428 428 + match rf_desc with 429 429 + | Ttag (_, _, list) -> List.iter (sub.typ sub) list 430 430 + | Tinherit ct -> sub.typ sub ct 431 431 + 432 432 + let object_field sub {of_desc; _} = 433 433 + match of_desc with 434 434 + | OTtag (_, ct) -> sub.typ sub ct 435 435 + | OTinherit ct -> sub.typ sub ct 436 436 + 437 437 + let class_field_kind sub = function 438 438 + | Tcfk_virtual ct -> sub.typ sub ct 439 439 + | Tcfk_concrete (_, e) -> sub.expr sub e 440 440 + 441 441 + let class_field sub {cf_desc; _} = match cf_desc with 442 442 + | Tcf_inherit (_, cl, _, _, _) -> sub.class_expr sub cl 443 443 + | Tcf_constraint (cty1, cty2) -> 444 444 + sub.typ sub cty1; 445 445 + sub.typ sub cty2 446 446 + | Tcf_val (_, _, _, k, _) -> class_field_kind sub k 447 447 + | Tcf_method (_, _, k) -> class_field_kind sub k 448 448 + | Tcf_initializer exp -> sub.expr sub exp 449 449 + | Tcf_attribute _ -> () 450 450 + 451 451 + let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list 452 452 + 453 453 + let cases sub l = List.iter (sub.case sub) l 454 454 + 455 455 + let case sub {c_lhs; c_guard; c_rhs} = 456 456 + sub.pat sub c_lhs; 457 457 + Option.iter (sub.expr sub) c_guard; 458 458 + sub.expr sub c_rhs 459 459 + 460 460 + let value_binding sub {vb_pat; vb_expr; _} = 461 461 + sub.pat sub vb_pat; 462 462 + sub.expr sub vb_expr 463 463 + 464 464 + let env _sub _ = () 465 465 + 466 466 + let default_iterator = 467 467 + { 468 468 + binding_op; 469 469 + case; 470 470 + cases; 471 471 + class_declaration; 472 472 + class_description; 473 473 + class_expr; 474 474 + class_field; 475 475 + class_signature; 476 476 + class_structure; 477 477 + class_type; 478 478 + class_type_declaration; 479 479 + class_type_field; 480 480 + env; 481 481 + expr; 482 482 + extension_constructor; 483 483 + module_binding; 484 484 + module_coercion; 485 485 + module_declaration; 486 486 + module_substitution; 487 487 + module_expr; 488 488 + module_type; 489 489 + module_type_declaration; 490 490 + package_type; 491 491 + pat; 492 492 + row_field; 493 493 + object_field; 494 494 + open_declaration; 495 495 + open_description; 496 496 + signature; 497 497 + signature_item; 498 498 + structure; 499 499 + structure_item; 500 500 + typ; 501 501 + type_declaration; 502 502 + type_declarations; 503 503 + type_extension; 504 504 + type_exception; 505 505 + type_kind; 506 506 + value_binding; 507 507 + value_bindings; 508 508 + value_description; 509 509 + with_constraint; 510 510 + }

+69

typing/tast_iterator.mli

reviewed

··· 1 1 + (**************************************************************************) 2 2 + (* *) 3 3 + (* OCaml *) 4 4 + (* *) 5 5 + (* Isaac "Izzy" Avram *) 6 6 + (* *) 7 7 + (* Copyright 2019 Institut National de Recherche en Informatique et *) 8 8 + (* en Automatique. *) 9 9 + (* *) 10 10 + (* All rights reserved. This file is distributed under the terms of *) 11 11 + (* the GNU Lesser General Public License version 2.1, with the *) 12 12 + (* special exception on linking described in the file LICENSE. *) 13 13 + (* *) 14 14 + (**************************************************************************) 15 15 + 16 16 + (** 17 17 + Allows the implementation of typed tree inspection using open recursion 18 18 + *) 19 19 + 20 20 + open Asttypes 21 21 + open Typedtree 22 22 + 23 23 + type iterator = 24 24 + { 25 25 + binding_op: iterator -> binding_op -> unit; 26 26 + case: iterator -> case -> unit; 27 27 + cases: iterator -> case list -> unit; 28 28 + class_declaration: iterator -> class_declaration -> unit; 29 29 + class_description: iterator -> class_description -> unit; 30 30 + class_expr: iterator -> class_expr -> unit; 31 31 + class_field: iterator -> class_field -> unit; 32 32 + class_signature: iterator -> class_signature -> unit; 33 33 + class_structure: iterator -> class_structure -> unit; 34 34 + class_type: iterator -> class_type -> unit; 35 35 + class_type_declaration: iterator -> class_type_declaration -> unit; 36 36 + class_type_field: iterator -> class_type_field -> unit; 37 37 + env: iterator -> Env.t -> unit; 38 38 + expr: iterator -> expression -> unit; 39 39 + extension_constructor: iterator -> extension_constructor -> unit; 40 40 + module_binding: iterator -> module_binding -> unit; 41 41 + module_coercion: iterator -> module_coercion -> unit; 42 42 + module_declaration: iterator -> module_declaration -> unit; 43 43 + module_substitution: iterator -> module_substitution -> unit; 44 44 + module_expr: iterator -> module_expr -> unit; 45 45 + module_type: iterator -> module_type -> unit; 46 46 + module_type_declaration: iterator -> module_type_declaration -> unit; 47 47 + package_type: iterator -> package_type -> unit; 48 48 + pat: iterator -> pattern -> unit; 49 49 + row_field: iterator -> row_field -> unit; 50 50 + object_field: iterator -> object_field -> unit; 51 51 + open_declaration: iterator -> open_declaration -> unit; 52 52 + open_description: iterator -> open_description -> unit; 53 53 + signature: iterator -> signature -> unit; 54 54 + signature_item: iterator -> signature_item -> unit; 55 55 + structure: iterator -> structure -> unit; 56 56 + structure_item: iterator -> structure_item -> unit; 57 57 + typ: iterator -> core_type -> unit; 58 58 + type_declaration: iterator -> type_declaration -> unit; 59 59 + type_declarations: iterator -> (rec_flag * type_declaration list) -> unit; 60 60 + type_extension: iterator -> type_extension -> unit; 61 61 + type_exception: iterator -> type_exception -> unit; 62 62 + type_kind: iterator -> type_kind -> unit; 63 63 + value_binding: iterator -> value_binding -> unit; 64 64 + value_bindings: iterator -> (rec_flag * value_binding list) -> unit; 65 65 + value_description: iterator -> value_description -> unit; 66 66 + with_constraint: iterator -> with_constraint -> unit; 67 67 + } 68 68 + 69 69 + val default_iterator: iterator

-714

typing/typedtreeIter.ml

reviewed

··· 1 1 - (**************************************************************************) 2 2 - (* *) 3 3 - (* OCaml *) 4 4 - (* *) 5 5 - (* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) 6 6 - (* *) 7 7 - (* Copyright 2007 Institut National de Recherche en Informatique et *) 8 8 - (* en Automatique. *) 9 9 - (* *) 10 10 - (* All rights reserved. This file is distributed under the terms of *) 11 11 - (* the GNU Lesser General Public License version 2.1, with the *) 12 12 - (* special exception on linking described in the file LICENSE. *) 13 13 - (* *) 14 14 - (**************************************************************************) 15 15 - 16 16 - (* 17 17 - TODO: 18 18 - - 2012/05/10: Follow camlp4 way of building map and iter using classes 19 19 - and inheritance ? 20 20 - *) 21 21 - 22 22 - open Asttypes 23 23 - open Typedtree 24 24 - 25 25 - module type IteratorArgument = sig 26 26 - 27 27 - val enter_structure : structure -> unit 28 28 - val enter_value_description : value_description -> unit 29 29 - val enter_type_extension : type_extension -> unit 30 30 - val enter_type_exception : type_exception -> unit 31 31 - val enter_extension_constructor : extension_constructor -> unit 32 32 - val enter_pattern : pattern -> unit 33 33 - val enter_expression : expression -> unit 34 34 - val enter_package_type : package_type -> unit 35 35 - val enter_signature : signature -> unit 36 36 - val enter_signature_item : signature_item -> unit 37 37 - val enter_module_type_declaration : module_type_declaration -> unit 38 38 - val enter_module_type : module_type -> unit 39 39 - val enter_module_expr : module_expr -> unit 40 40 - val enter_with_constraint : with_constraint -> unit 41 41 - val enter_class_expr : class_expr -> unit 42 42 - val enter_class_signature : class_signature -> unit 43 43 - val enter_class_declaration : class_declaration -> unit 44 44 - val enter_class_description : class_description -> unit 45 45 - val enter_class_type_declaration : class_type_declaration -> unit 46 46 - val enter_class_type : class_type -> unit 47 47 - val enter_class_type_field : class_type_field -> unit 48 48 - val enter_core_type : core_type -> unit 49 49 - val enter_class_structure : class_structure -> unit 50 50 - val enter_class_field : class_field -> unit 51 51 - val enter_structure_item : structure_item -> unit 52 52 - 53 53 - 54 54 - val leave_structure : structure -> unit 55 55 - val leave_value_description : value_description -> unit 56 56 - val leave_type_extension : type_extension -> unit 57 57 - val leave_type_exception : type_exception -> unit 58 58 - val leave_extension_constructor : extension_constructor -> unit 59 59 - val leave_pattern : pattern -> unit 60 60 - val leave_expression : expression -> unit 61 61 - val leave_package_type : package_type -> unit 62 62 - val leave_signature : signature -> unit 63 63 - val leave_signature_item : signature_item -> unit 64 64 - val leave_module_type_declaration : module_type_declaration -> unit 65 65 - val leave_module_type : module_type -> unit 66 66 - val leave_module_expr : module_expr -> unit 67 67 - val leave_with_constraint : with_constraint -> unit 68 68 - val leave_class_expr : class_expr -> unit 69 69 - val leave_class_signature : class_signature -> unit 70 70 - val leave_class_declaration : class_declaration -> unit 71 71 - val leave_class_description : class_description -> unit 72 72 - val leave_class_type_declaration : class_type_declaration -> unit 73 73 - val leave_class_type : class_type -> unit 74 74 - val leave_class_type_field : class_type_field -> unit 75 75 - val leave_core_type : core_type -> unit 76 76 - val leave_class_structure : class_structure -> unit 77 77 - val leave_class_field : class_field -> unit 78 78 - val leave_structure_item : structure_item -> unit 79 79 - 80 80 - val enter_bindings : rec_flag -> unit 81 81 - val enter_binding : value_binding -> unit 82 82 - val leave_binding : value_binding -> unit 83 83 - val leave_bindings : rec_flag -> unit 84 84 - 85 85 - val enter_type_declarations : rec_flag -> unit 86 86 - val enter_type_declaration : type_declaration -> unit 87 87 - val leave_type_declaration : type_declaration -> unit 88 88 - val leave_type_declarations : rec_flag -> unit 89 89 - 90 90 - end 91 91 - 92 92 - module MakeIterator(Iter : IteratorArgument) : sig 93 93 - 94 94 - val iter_structure : structure -> unit 95 95 - val iter_signature : signature -> unit 96 96 - val iter_structure_item : structure_item -> unit 97 97 - val iter_signature_item : signature_item -> unit 98 98 - val iter_expression : expression -> unit 99 99 - val iter_module_type : module_type -> unit 100 100 - val iter_pattern : pattern -> unit 101 101 - val iter_class_expr : class_expr -> unit 102 102 - 103 103 - end = struct 104 104 - 105 105 - let may_iter f v = 106 106 - match v with 107 107 - None -> () 108 108 - | Some x -> f x 109 109 - 110 110 - 111 111 - let rec iter_structure str = 112 112 - Iter.enter_structure str; 113 113 - List.iter iter_structure_item str.str_items; 114 114 - Iter.leave_structure str 115 115 - 116 116 - 117 117 - and iter_binding vb = 118 118 - Iter.enter_binding vb; 119 119 - iter_pattern vb.vb_pat; 120 120 - iter_expression vb.vb_expr; 121 121 - Iter.leave_binding vb 122 122 - 123 123 - and iter_bindings rec_flag list = 124 124 - Iter.enter_bindings rec_flag; 125 125 - List.iter iter_binding list; 126 126 - Iter.leave_bindings rec_flag 127 127 - 128 128 - and iter_case {c_lhs; c_guard; c_rhs; _} = 129 129 - iter_pattern c_lhs; 130 130 - may_iter iter_expression c_guard; 131 131 - iter_expression c_rhs 132 132 - 133 133 - and iter_cases cases = 134 134 - List.iter iter_case cases 135 135 - 136 136 - and iter_structure_item item = 137 137 - Iter.enter_structure_item item; 138 138 - begin 139 139 - match item.str_desc with 140 140 - Tstr_eval (exp, _attrs) -> iter_expression exp 141 141 - | Tstr_value (rec_flag, list) -> 142 142 - iter_bindings rec_flag list 143 143 - | Tstr_primitive vd -> iter_value_description vd 144 144 - | Tstr_type (rf, list) -> iter_type_declarations rf list 145 145 - | Tstr_typext tyext -> iter_type_extension tyext 146 146 - | Tstr_effect ext -> iter_extension_constructor ext 147 147 - | Tstr_exception ext -> iter_type_exception ext 148 148 - | Tstr_module x -> iter_module_binding x 149 149 - | Tstr_recmodule list -> List.iter iter_module_binding list 150 150 - | Tstr_modtype mtd -> iter_module_type_declaration mtd 151 151 - | Tstr_open od -> iter_module_expr od.open_expr 152 152 - | Tstr_class list -> 153 153 - List.iter (fun (ci, _) -> iter_class_declaration ci) list 154 154 - | Tstr_class_type list -> 155 155 - List.iter 156 156 - (fun (_, _, ct) -> iter_class_type_declaration ct) 157 157 - list 158 158 - | Tstr_include incl -> iter_module_expr incl.incl_mod 159 159 - | Tstr_attribute _ -> 160 160 - () 161 161 - end; 162 162 - Iter.leave_structure_item item 163 163 - 164 164 - and iter_module_binding x = 165 165 - iter_module_expr x.mb_expr 166 166 - 167 167 - and iter_value_description v = 168 168 - Iter.enter_value_description v; 169 169 - iter_core_type v.val_desc; 170 170 - Iter.leave_value_description v 171 171 - 172 172 - and iter_constructor_arguments = function 173 173 - | Cstr_tuple l -> List.iter iter_core_type l 174 174 - | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l 175 175 - 176 176 - and iter_constructor_declaration cd = 177 177 - iter_constructor_arguments cd.cd_args; 178 178 - option iter_core_type cd.cd_res; 179 179 - 180 180 - and iter_type_parameter (ct, _v) = 181 181 - iter_core_type ct 182 182 - 183 183 - and iter_type_declaration decl = 184 184 - Iter.enter_type_declaration decl; 185 185 - List.iter iter_type_parameter decl.typ_params; 186 186 - List.iter (fun (ct1, ct2, _loc) -> 187 187 - iter_core_type ct1; 188 188 - iter_core_type ct2 189 189 - ) decl.typ_cstrs; 190 190 - begin match decl.typ_kind with 191 191 - Ttype_abstract -> () 192 192 - | Ttype_variant list -> 193 193 - List.iter iter_constructor_declaration list 194 194 - | Ttype_record list -> 195 195 - List.iter 196 196 - (fun ld -> 197 197 - iter_core_type ld.ld_type 198 198 - ) list 199 199 - | Ttype_open -> () 200 200 - end; 201 201 - option iter_core_type decl.typ_manifest; 202 202 - Iter.leave_type_declaration decl 203 203 - 204 204 - and iter_type_declarations rec_flag decls = 205 205 - Iter.enter_type_declarations rec_flag; 206 206 - List.iter iter_type_declaration decls; 207 207 - Iter.leave_type_declarations rec_flag 208 208 - 209 209 - and iter_extension_constructor ext = 210 210 - Iter.enter_extension_constructor ext; 211 211 - begin match ext.ext_kind with 212 212 - Text_decl(args, ret) -> 213 213 - iter_constructor_arguments args; 214 214 - option iter_core_type ret 215 215 - | Text_rebind _ -> () 216 216 - end; 217 217 - Iter.leave_extension_constructor ext; 218 218 - 219 219 - and iter_type_extension tyext = 220 220 - Iter.enter_type_extension tyext; 221 221 - List.iter iter_type_parameter tyext.tyext_params; 222 222 - List.iter iter_extension_constructor tyext.tyext_constructors; 223 223 - Iter.leave_type_extension tyext 224 224 - 225 225 - and iter_type_exception tyexn = 226 226 - Iter.enter_type_exception tyexn; 227 227 - iter_extension_constructor tyexn.tyexn_constructor; 228 228 - Iter.leave_type_exception tyexn 229 229 - 230 230 - and iter_pattern pat = 231 231 - Iter.enter_pattern pat; 232 232 - List.iter (fun (cstr, _, _attrs) -> match cstr with 233 233 - | Tpat_type _ -> () 234 234 - | Tpat_unpack -> () 235 235 - | Tpat_open _ -> () 236 236 - | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; 237 237 - begin 238 238 - match pat.pat_desc with 239 239 - Tpat_any -> () 240 240 - | Tpat_var _ -> () 241 241 - | Tpat_alias (pat1, _, _) -> iter_pattern pat1 242 242 - | Tpat_constant _ -> () 243 243 - | Tpat_tuple list -> 244 244 - List.iter iter_pattern list 245 245 - | Tpat_construct (_, _, args) -> 246 246 - List.iter iter_pattern args 247 247 - | Tpat_variant (_, pato, _) -> 248 248 - begin match pato with 249 249 - None -> () 250 250 - | Some pat -> iter_pattern pat 251 251 - end 252 252 - | Tpat_record (list, _closed) -> 253 253 - List.iter (fun (_, _, pat) -> iter_pattern pat) list 254 254 - | Tpat_array list -> List.iter iter_pattern list 255 255 - | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 256 256 - | Tpat_lazy p 257 257 - | Tpat_exception p -> iter_pattern p 258 258 - end; 259 259 - Iter.leave_pattern pat 260 260 - 261 261 - and option f x = match x with None -> () | Some e -> f e 262 262 - 263 263 - and iter_expression exp = 264 264 - Iter.enter_expression exp; 265 265 - List.iter (function (cstr, _, _attrs) -> 266 266 - match cstr with 267 267 - Texp_constraint ct -> 268 268 - iter_core_type ct 269 269 - | Texp_coerce (cty1, cty2) -> 270 270 - option iter_core_type cty1; iter_core_type cty2 271 271 - | Texp_poly cto -> option iter_core_type cto 272 272 - | Texp_newtype _ -> ()) 273 273 - exp.exp_extra; 274 274 - begin 275 275 - match exp.exp_desc with 276 276 - Texp_ident _ -> () 277 277 - | Texp_constant _ -> () 278 278 - | Texp_let (rec_flag, list, exp) -> 279 279 - iter_bindings rec_flag list; 280 280 - iter_expression exp 281 281 - | Texp_function { cases; _ } -> 282 282 - iter_cases cases 283 283 - | Texp_apply (exp, list) -> 284 284 - iter_expression exp; 285 285 - List.iter (fun (_label, expo) -> 286 286 - match expo with 287 287 - None -> () 288 288 - | Some exp -> iter_expression exp 289 289 - ) list 290 290 - | Texp_match (exp, list1, list2, _) -> 291 291 - iter_expression exp; 292 292 - iter_cases list1; 293 293 - iter_cases list2 294 294 - | Texp_try (exp, list1, list2) -> 295 295 - iter_expression exp; 296 296 - iter_cases list1; 297 297 - iter_cases list2 298 298 - | Texp_tuple list -> 299 299 - List.iter iter_expression list 300 300 - | Texp_construct (_, _, args) -> 301 301 - List.iter iter_expression args 302 302 - | Texp_variant (_label, expo) -> 303 303 - begin match expo with 304 304 - None -> () 305 305 - | Some exp -> iter_expression exp 306 306 - end 307 307 - | Texp_record { fields; extended_expression; _ } -> 308 308 - Array.iter (function 309 309 - | _, Kept _ -> () 310 310 - | _, Overridden (_, exp) -> iter_expression exp) 311 311 - fields; 312 312 - begin match extended_expression with 313 313 - None -> () 314 314 - | Some exp -> iter_expression exp 315 315 - end 316 316 - | Texp_field (exp, _, _label) -> 317 317 - iter_expression exp 318 318 - | Texp_setfield (exp1, _, _label, exp2) -> 319 319 - iter_expression exp1; 320 320 - iter_expression exp2 321 321 - | Texp_array list -> 322 322 - List.iter iter_expression list 323 323 - | Texp_ifthenelse (exp1, exp2, expo) -> 324 324 - iter_expression exp1; 325 325 - iter_expression exp2; 326 326 - begin match expo with 327 327 - None -> () 328 328 - | Some exp -> iter_expression exp 329 329 - end 330 330 - | Texp_sequence (exp1, exp2) -> 331 331 - iter_expression exp1; 332 332 - iter_expression exp2 333 333 - | Texp_while (exp1, exp2) -> 334 334 - iter_expression exp1; 335 335 - iter_expression exp2 336 336 - | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> 337 337 - iter_expression exp1; 338 338 - iter_expression exp2; 339 339 - iter_expression exp3 340 340 - | Texp_send (exp, _meth, expo) -> 341 341 - iter_expression exp; 342 342 - begin 343 343 - match expo with 344 344 - None -> () 345 345 - | Some exp -> iter_expression exp 346 346 - end 347 347 - | Texp_new _ -> () 348 348 - | Texp_instvar _ -> () 349 349 - | Texp_setinstvar (_, _, _, exp) -> 350 350 - iter_expression exp 351 351 - | Texp_override (_, list) -> 352 352 - List.iter (fun (_path, _, exp) -> 353 353 - iter_expression exp 354 354 - ) list 355 355 - | Texp_letmodule (_id, _, _, mexpr, exp) -> 356 356 - iter_module_expr mexpr; 357 357 - iter_expression exp 358 358 - | Texp_letexception (cd, exp) -> 359 359 - iter_extension_constructor cd; 360 360 - iter_expression exp 361 361 - | Texp_assert exp -> iter_expression exp 362 362 - | Texp_lazy exp -> iter_expression exp 363 363 - | Texp_object (cl, _) -> 364 364 - iter_class_structure cl 365 365 - | Texp_pack (mexpr) -> 366 366 - iter_module_expr mexpr 367 367 - | Texp_letop{let_; ands; param = _; body; partial = _} -> 368 368 - iter_binding_op let_; 369 369 - List.iter iter_binding_op ands; 370 370 - iter_case body 371 371 - | Texp_unreachable -> 372 372 - () 373 373 - | Texp_extension_constructor _ -> 374 374 - () 375 375 - | Texp_open (od, e) -> 376 376 - iter_module_expr od.open_expr; 377 377 - iter_expression e 378 378 - end; 379 379 - Iter.leave_expression exp; 380 380 - 381 381 - and iter_binding_op bop = 382 382 - iter_expression bop.bop_exp 383 383 - 384 384 - and iter_package_type pack = 385 385 - Iter.enter_package_type pack; 386 386 - List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; 387 387 - Iter.leave_package_type pack; 388 388 - 389 389 - and iter_signature sg = 390 390 - Iter.enter_signature sg; 391 391 - List.iter iter_signature_item sg.sig_items; 392 392 - Iter.leave_signature sg; 393 393 - 394 394 - and iter_signature_item item = 395 395 - Iter.enter_signature_item item; 396 396 - begin 397 397 - match item.sig_desc with 398 398 - Tsig_value vd -> 399 399 - iter_value_description vd 400 400 - | Tsig_type (rf, list) -> 401 401 - iter_type_declarations rf list 402 402 - | Tsig_effect ext -> 403 403 - iter_extension_constructor ext 404 404 - | Tsig_typesubst list -> 405 405 - iter_type_declarations Nonrecursive list 406 406 - | Tsig_exception ext -> 407 407 - iter_type_exception ext 408 408 - | Tsig_typext tyext -> 409 409 - iter_type_extension tyext 410 410 - | Tsig_module md -> 411 411 - iter_module_type md.md_type 412 412 - | Tsig_modsubst _ -> () 413 413 - | Tsig_recmodule list -> 414 414 - List.iter (fun md -> iter_module_type md.md_type) list 415 415 - | Tsig_modtype mtd -> 416 416 - iter_module_type_declaration mtd 417 417 - | Tsig_open _ -> () 418 418 - | Tsig_include incl -> iter_module_type incl.incl_mod 419 419 - | Tsig_class list -> 420 420 - List.iter iter_class_description list 421 421 - | Tsig_class_type list -> 422 422 - List.iter iter_class_type_declaration list 423 423 - | Tsig_attribute _ -> () 424 424 - end; 425 425 - Iter.leave_signature_item item; 426 426 - 427 427 - and iter_module_type_declaration mtd = 428 428 - Iter.enter_module_type_declaration mtd; 429 429 - begin 430 430 - match mtd.mtd_type with 431 431 - | None -> () 432 432 - | Some mtype -> iter_module_type mtype 433 433 - end; 434 434 - Iter.leave_module_type_declaration mtd 435 435 - 436 436 - and iter_class_declaration cd = 437 437 - Iter.enter_class_declaration cd; 438 438 - List.iter iter_type_parameter cd.ci_params; 439 439 - iter_class_expr cd.ci_expr; 440 440 - Iter.leave_class_declaration cd; 441 441 - 442 442 - and iter_class_description cd = 443 443 - Iter.enter_class_description cd; 444 444 - List.iter iter_type_parameter cd.ci_params; 445 445 - iter_class_type cd.ci_expr; 446 446 - Iter.leave_class_description cd; 447 447 - 448 448 - and iter_class_type_declaration cd = 449 449 - Iter.enter_class_type_declaration cd; 450 450 - List.iter iter_type_parameter cd.ci_params; 451 451 - iter_class_type cd.ci_expr; 452 452 - Iter.leave_class_type_declaration cd; 453 453 - 454 454 - and iter_module_type mty = 455 455 - Iter.enter_module_type mty; 456 456 - begin 457 457 - match mty.mty_desc with 458 458 - Tmty_ident _ -> () 459 459 - | Tmty_alias _ -> () 460 460 - | Tmty_signature sg -> iter_signature sg 461 461 - | Tmty_functor (_, _, mtype1, mtype2) -> 462 462 - Misc.may iter_module_type mtype1; iter_module_type mtype2 463 463 - | Tmty_with (mtype, list) -> 464 464 - iter_module_type mtype; 465 465 - List.iter (fun (_path, _, withc) -> 466 466 - iter_with_constraint withc 467 467 - ) list 468 468 - | Tmty_typeof mexpr -> 469 469 - iter_module_expr mexpr 470 470 - end; 471 471 - Iter.leave_module_type mty; 472 472 - 473 473 - and iter_with_constraint cstr = 474 474 - Iter.enter_with_constraint cstr; 475 475 - begin 476 476 - match cstr with 477 477 - Twith_type decl -> iter_type_declaration decl 478 478 - | Twith_module _ -> () 479 479 - | Twith_typesubst decl -> iter_type_declaration decl 480 480 - | Twith_modsubst _ -> () 481 481 - end; 482 482 - Iter.leave_with_constraint cstr; 483 483 - 484 484 - and iter_module_expr mexpr = 485 485 - Iter.enter_module_expr mexpr; 486 486 - begin 487 487 - match mexpr.mod_desc with 488 488 - Tmod_ident _ -> () 489 489 - | Tmod_structure st -> iter_structure st 490 490 - | Tmod_functor (_, _, mtype, mexpr) -> 491 491 - Misc.may iter_module_type mtype; 492 492 - iter_module_expr mexpr 493 493 - | Tmod_apply (mexp1, mexp2, _) -> 494 494 - iter_module_expr mexp1; 495 495 - iter_module_expr mexp2 496 496 - | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> 497 497 - iter_module_expr mexpr 498 498 - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> 499 499 - iter_module_expr mexpr; 500 500 - iter_module_type mtype 501 501 - | Tmod_unpack (exp, _mty) -> 502 502 - iter_expression exp 503 503 - (* iter_module_type mty *) 504 504 - end; 505 505 - Iter.leave_module_expr mexpr; 506 506 - 507 507 - and iter_class_expr cexpr = 508 508 - Iter.enter_class_expr cexpr; 509 509 - begin 510 510 - match cexpr.cl_desc with 511 511 - | Tcl_constraint (cl, None, _, _, _ ) -> 512 512 - iter_class_expr cl; 513 513 - | Tcl_structure clstr -> iter_class_structure clstr 514 514 - | Tcl_fun (_label, pat, priv, cl, _partial) -> 515 515 - iter_pattern pat; 516 516 - List.iter (fun (_id, exp) -> iter_expression exp) priv; 517 517 - iter_class_expr cl 518 518 - 519 519 - | Tcl_apply (cl, args) -> 520 520 - iter_class_expr cl; 521 521 - List.iter (fun (_label, expo) -> 522 522 - match expo with 523 523 - None -> () 524 524 - | Some exp -> iter_expression exp 525 525 - ) args 526 526 - 527 527 - | Tcl_let (rec_flat, bindings, ivars, cl) -> 528 528 - iter_bindings rec_flat bindings; 529 529 - List.iter (fun (_id, exp) -> iter_expression exp) ivars; 530 530 - iter_class_expr cl 531 531 - 532 532 - | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> 533 533 - iter_class_expr cl; 534 534 - iter_class_type clty 535 535 - 536 536 - | Tcl_ident (_, _, tyl) -> 537 537 - List.iter iter_core_type tyl 538 538 - 539 539 - | Tcl_open (_, e) -> 540 540 - iter_class_expr e 541 541 - end; 542 542 - Iter.leave_class_expr cexpr; 543 543 - 544 544 - and iter_class_type ct = 545 545 - Iter.enter_class_type ct; 546 546 - begin 547 547 - match ct.cltyp_desc with 548 548 - Tcty_signature csg -> iter_class_signature csg 549 549 - | Tcty_constr (_path, _, list) -> 550 550 - List.iter iter_core_type list 551 551 - | Tcty_arrow (_label, ct, cl) -> 552 552 - iter_core_type ct; 553 553 - iter_class_type cl 554 554 - | Tcty_open (_, e) -> 555 555 - iter_class_type e 556 556 - end; 557 557 - Iter.leave_class_type ct; 558 558 - 559 559 - and iter_class_signature cs = 560 560 - Iter.enter_class_signature cs; 561 561 - iter_core_type cs.csig_self; 562 562 - List.iter iter_class_type_field cs.csig_fields; 563 563 - Iter.leave_class_signature cs 564 564 - 565 565 - 566 566 - and iter_class_type_field ctf = 567 567 - Iter.enter_class_type_field ctf; 568 568 - begin 569 569 - match ctf.ctf_desc with 570 570 - Tctf_inherit ct -> iter_class_type ct 571 571 - | Tctf_val (_s, _mut, _virt, ct) -> 572 572 - iter_core_type ct 573 573 - | Tctf_method (_s, _priv, _virt, ct) -> 574 574 - iter_core_type ct 575 575 - | Tctf_constraint (ct1, ct2) -> 576 576 - iter_core_type ct1; 577 577 - iter_core_type ct2 578 578 - | Tctf_attribute _ -> () 579 579 - end; 580 580 - Iter.leave_class_type_field ctf 581 581 - 582 582 - and iter_core_type ct = 583 583 - Iter.enter_core_type ct; 584 584 - begin 585 585 - match ct.ctyp_desc with 586 586 - Ttyp_any -> () 587 587 - | Ttyp_var _ -> () 588 588 - | Ttyp_arrow (_label, ct1, ct2) -> 589 589 - iter_core_type ct1; 590 590 - iter_core_type ct2 591 591 - | Ttyp_tuple list -> List.iter iter_core_type list 592 592 - | Ttyp_constr (_path, _, list) -> 593 593 - List.iter iter_core_type list 594 594 - | Ttyp_object (list, _o) -> 595 595 - List.iter iter_object_field list 596 596 - | Ttyp_class (_path, _, list) -> 597 597 - List.iter iter_core_type list 598 598 - | Ttyp_alias (ct, _s) -> 599 599 - iter_core_type ct 600 600 - | Ttyp_variant (list, _bool, _labels) -> 601 601 - List.iter iter_row_field list 602 602 - | Ttyp_poly (_list, ct) -> iter_core_type ct 603 603 - | Ttyp_package pack -> iter_package_type pack 604 604 - end; 605 605 - Iter.leave_core_type ct 606 606 - 607 607 - and iter_class_structure cs = 608 608 - Iter.enter_class_structure cs; 609 609 - iter_pattern cs.cstr_self; 610 610 - List.iter iter_class_field cs.cstr_fields; 611 611 - Iter.leave_class_structure cs; 612 612 - 613 613 - 614 614 - and iter_row_field rf = 615 615 - match rf.rf_desc with 616 616 - | Ttag (_label, _bool, list) -> 617 617 - List.iter iter_core_type list 618 618 - | Tinherit ct -> iter_core_type ct 619 619 - 620 620 - and iter_object_field ofield = 621 621 - match ofield.of_desc with 622 622 - | OTtag (_, ct) | OTinherit ct -> iter_core_type ct 623 623 - 624 624 - and iter_class_field cf = 625 625 - Iter.enter_class_field cf; 626 626 - begin 627 627 - match cf.cf_desc with 628 628 - Tcf_inherit (_ovf, cl, _super, _vals, _meths) -> 629 629 - iter_class_expr cl 630 630 - | Tcf_constraint (cty, cty') -> 631 631 - iter_core_type cty; 632 632 - iter_core_type cty' 633 633 - | Tcf_val (_lab, _, _, Tcfk_virtual cty, _) -> 634 634 - iter_core_type cty 635 635 - | Tcf_val (_lab, _, _, Tcfk_concrete (_, exp), _) -> 636 636 - iter_expression exp 637 637 - | Tcf_method (_lab, _, Tcfk_virtual cty) -> 638 638 - iter_core_type cty 639 639 - | Tcf_method (_lab, _, Tcfk_concrete (_, exp)) -> 640 640 - iter_expression exp 641 641 - | Tcf_initializer exp -> 642 642 - iter_expression exp 643 643 - | Tcf_attribute _ -> () 644 644 - end; 645 645 - Iter.leave_class_field cf; 646 646 - end 647 647 - 648 648 - module DefaultIteratorArgument = struct 649 649 - 650 650 - let enter_structure _ = () 651 651 - let enter_value_description _ = () 652 652 - let enter_type_extension _ = () 653 653 - let enter_type_exception _ = () 654 654 - let enter_extension_constructor _ = () 655 655 - let enter_pattern _ = () 656 656 - let enter_expression _ = () 657 657 - let enter_package_type _ = () 658 658 - let enter_signature _ = () 659 659 - let enter_signature_item _ = () 660 660 - let enter_module_type_declaration _ = () 661 661 - let enter_module_type _ = () 662 662 - let enter_module_expr _ = () 663 663 - let enter_with_constraint _ = () 664 664 - let enter_class_expr _ = () 665 665 - let enter_class_signature _ = () 666 666 - let enter_class_declaration _ = () 667 667 - let enter_class_description _ = () 668 668 - let enter_class_type_declaration _ = () 669 669 - let enter_class_type _ = () 670 670 - let enter_class_type_field _ = () 671 671 - let enter_core_type _ = () 672 672 - let enter_class_structure _ = () 673 673 - let enter_class_field _ = () 674 674 - let enter_structure_item _ = () 675 675 - 676 676 - 677 677 - let leave_structure _ = () 678 678 - let leave_value_description _ = () 679 679 - let leave_type_extension _ = () 680 680 - let leave_type_exception _ = () 681 681 - let leave_extension_constructor _ = () 682 682 - let leave_pattern _ = () 683 683 - let leave_expression _ = () 684 684 - let leave_package_type _ = () 685 685 - let leave_signature _ = () 686 686 - let leave_signature_item _ = () 687 687 - let leave_module_type_declaration _ = () 688 688 - let leave_module_type _ = () 689 689 - let leave_module_expr _ = () 690 690 - let leave_with_constraint _ = () 691 691 - let leave_class_expr _ = () 692 692 - let leave_class_signature _ = () 693 693 - let leave_class_declaration _ = () 694 694 - let leave_class_description _ = () 695 695 - let leave_class_type_declaration _ = () 696 696 - let leave_class_type _ = () 697 697 - let leave_class_type_field _ = () 698 698 - let leave_core_type _ = () 699 699 - let leave_class_structure _ = () 700 700 - let leave_class_field _ = () 701 701 - let leave_structure_item _ = () 702 702 - 703 703 - let enter_binding _ = () 704 704 - let leave_binding _ = () 705 705 - 706 706 - let enter_bindings _ = () 707 707 - let leave_bindings _ = () 708 708 - 709 709 - let enter_type_declaration _ = () 710 710 - let leave_type_declaration _ = () 711 711 - 712 712 - let enter_type_declarations _ = () 713 713 - let leave_type_declarations _ = () 714 714 - end

-99

typing/typedtreeIter.mli

reviewed

··· 1 1 - (**************************************************************************) 2 2 - (* *) 3 3 - (* OCaml *) 4 4 - (* *) 5 5 - (* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) 6 6 - (* *) 7 7 - (* Copyright 2007 Institut National de Recherche en Informatique et *) 8 8 - (* en Automatique. *) 9 9 - (* *) 10 10 - (* All rights reserved. This file is distributed under the terms of *) 11 11 - (* the GNU Lesser General Public License version 2.1, with the *) 12 12 - (* special exception on linking described in the file LICENSE. *) 13 13 - (* *) 14 14 - (**************************************************************************) 15 15 - 16 16 - open Asttypes 17 17 - open Typedtree 18 18 - 19 19 - 20 20 - module type IteratorArgument = sig 21 21 - val enter_structure : structure -> unit 22 22 - val enter_value_description : value_description -> unit 23 23 - val enter_type_extension : type_extension -> unit 24 24 - val enter_type_exception : type_exception -> unit 25 25 - val enter_extension_constructor : extension_constructor -> unit 26 26 - val enter_pattern : pattern -> unit 27 27 - val enter_expression : expression -> unit 28 28 - val enter_package_type : package_type -> unit 29 29 - val enter_signature : signature -> unit 30 30 - val enter_signature_item : signature_item -> unit 31 31 - val enter_module_type_declaration : module_type_declaration -> unit 32 32 - val enter_module_type : module_type -> unit 33 33 - val enter_module_expr : module_expr -> unit 34 34 - val enter_with_constraint : with_constraint -> unit 35 35 - val enter_class_expr : class_expr -> unit 36 36 - val enter_class_signature : class_signature -> unit 37 37 - val enter_class_declaration : class_declaration -> unit 38 38 - val enter_class_description : class_description -> unit 39 39 - val enter_class_type_declaration : class_type_declaration -> unit 40 40 - val enter_class_type : class_type -> unit 41 41 - val enter_class_type_field : class_type_field -> unit 42 42 - val enter_core_type : core_type -> unit 43 43 - val enter_class_structure : class_structure -> unit 44 44 - val enter_class_field : class_field -> unit 45 45 - val enter_structure_item : structure_item -> unit 46 46 - 47 47 - 48 48 - val leave_structure : structure -> unit 49 49 - val leave_value_description : value_description -> unit 50 50 - val leave_type_extension : type_extension -> unit 51 51 - val leave_type_exception : type_exception -> unit 52 52 - val leave_extension_constructor : extension_constructor -> unit 53 53 - val leave_pattern : pattern -> unit 54 54 - val leave_expression : expression -> unit 55 55 - val leave_package_type : package_type -> unit 56 56 - val leave_signature : signature -> unit 57 57 - val leave_signature_item : signature_item -> unit 58 58 - val leave_module_type_declaration : module_type_declaration -> unit 59 59 - val leave_module_type : module_type -> unit 60 60 - val leave_module_expr : module_expr -> unit 61 61 - val leave_with_constraint : with_constraint -> unit 62 62 - val leave_class_expr : class_expr -> unit 63 63 - val leave_class_signature : class_signature -> unit 64 64 - val leave_class_declaration : class_declaration -> unit 65 65 - val leave_class_description : class_description -> unit 66 66 - val leave_class_type_declaration : class_type_declaration -> unit 67 67 - val leave_class_type : class_type -> unit 68 68 - val leave_class_type_field : class_type_field -> unit 69 69 - val leave_core_type : core_type -> unit 70 70 - val leave_class_structure : class_structure -> unit 71 71 - val leave_class_field : class_field -> unit 72 72 - val leave_structure_item : structure_item -> unit 73 73 - 74 74 - val enter_bindings : rec_flag -> unit 75 75 - val enter_binding : value_binding -> unit 76 76 - val leave_binding : value_binding -> unit 77 77 - val leave_bindings : rec_flag -> unit 78 78 - 79 79 - val enter_type_declarations : rec_flag -> unit 80 80 - val enter_type_declaration : type_declaration -> unit 81 81 - val leave_type_declaration : type_declaration -> unit 82 82 - val leave_type_declarations : rec_flag -> unit 83 83 - 84 84 - end 85 85 - 86 86 - module MakeIterator : 87 87 - functor (Iter : IteratorArgument) -> 88 88 - sig 89 89 - val iter_structure : structure -> unit 90 90 - val iter_signature : signature -> unit 91 91 - val iter_structure_item : structure_item -> unit 92 92 - val iter_signature_item : signature_item -> unit 93 93 - val iter_expression : expression -> unit 94 94 - val iter_module_type : module_type -> unit 95 95 - val iter_pattern : pattern -> unit 96 96 - val iter_class_expr : class_expr -> unit 97 97 - end 98 98 - 99 99 - module DefaultIteratorArgument : IteratorArgument