diff --git a/Makefile b/Makefile index 8fce35c5f..e464c1c9e 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,16 @@ all: dune build +coverage-run: + dune runtest -f src/ --instrument-with bisect_ppx + +coverage-report: + bisect-ppx-report html + @echo "Report should be available in file://$(shell pwd)/_coverage/index.html" + +coverage-summary: + bisect-ppx-report summary --per-file + clean: dune clean rm -f *~ src/*~ issues/*~ diff --git a/_coverage/coverage.css b/_coverage/coverage.css new file mode 100644 index 000000000..35bb22a72 --- /dev/null +++ b/_coverage/coverage.css @@ -0,0 +1,500 @@ +:root, .light:root { + --main-background: #fff; + --code-background: transparent; + --line-numbers-background: rgba(0, 0, 0, 0.025); + --navbar-background: #eee; + + --meter-unvisited-color: #f9c3c3; + --meter-visited-color: #9ed09f; + --meter-separator-color: white; + + --color: #000; + --dirname-color: #bbb; + --stats-color: #aaa; + --underline-color: #ddd; + --visited-color: #eaffea; + --visited-number-color: rgba(64, 192, 64, 0.2); + --unvisited-color: #ffecec; + --unvisited-number-color: rgba(255, 128, 128, 0.5); + --somevisited-color: #ffd; + --highlight-color: #a0fbff; + --line-number-color: rgba(0, 0, 0, 0.4); + --unvisited-margin-color: #d69e9e; + --border: #eee; + --navbar-border: #ddd; + --code-color: #000; + --hljs-link: #6a737d; + --hljs-keyword: #d73a49; + --hljs-regexp: #032f62; + --hljs-title: #900; + --hljs-type: #6f42c1; + --hljs-meta: #22863a; + --hljs-variable: #005cc5; +} + +.dark:root { + --main-background: #202020; + --code-background: #222; + --line-numbers-background: rgba(0, 0, 0, 0.125); + --navbar-background: #202020; + + --meter-unvisited-color: #622; + --meter-visited-color: #252; + --meter-separator-color: black; + + --color: #bebebe; + --dirname-color: #666; + --stats-color: #555; + --underline-color: #444; + --visited-color: #002800; + --visited-number-color: #252; + --unvisited-color: #380000; + --unvisited-number-color: #822; + --somevisited-color: #303000; + --highlight-color: #303e3f; + --line-number-color: rgba(230, 230, 230, 0.3); + --unvisited-margin-color: #622; + --border: #333; + --navbar-border: #333; + --code-color: #ccc; + --hljs-link: #999; + --hljs-keyword: #cda869; + --hljs-regexp: #f9ee98; + --hljs-title: #dcdcaa; + --hljs-type: #ac885b; + --hljs-meta: #82aaff; + --hljs-variable: #cf6a4c; +} + +@media (prefers-color-scheme: dark) { + :root { + --main-background: #202020; + --code-background: #222; + --line-numbers-background: rgba(0, 0, 0, 0.125); + --navbar-background: #202020; + + --meter-unvisited-color: #622; + --meter-visited-color: #252; + --meter-separator-color: black; + + --color: #bebebe; + --dirname-color: #666; + --underline-color: #444; + --visited-color: #002800; + --visited-number-color: #252; + --unvisited-color: #380000; + --unvisited-number-color: #822; + --somevisited-color: #303000; + --highlight-color: #303e3f; + --line-number-color: rgba(230, 230, 230, 0.3); + --unvisited-margin-color: #622; + --border: #333; + --navbar-border: #333; + --code-color: #ccc; + --hljs-link: #999; + --hljs-keyword: #cda869; + --hljs-regexp: #f9ee98; + --hljs-title: #dcdcaa; + --hljs-type: #ac885b; + --hljs-meta: #82aaff; + --hljs-variable: #cf6a4c; + } +} + +body { + margin: 0; + font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; + font-size: 16px; + line-height: 1.5em; + background-color: var(--main-background); +} + +pre { + margin: 0; + font-family: "Fira Code", "Cascadia Code", Consolas, "Liberation Mono", Menlo, Courier, monospace; + font-size: 13px; + color: var(--code-color); + cursor: text; +} + +code { + font-family: inherit; +} + +a { + text-decoration: none; + color: inherit; +} + +a:visited { + color: inherit; +} + +#header { + color: var(--color); +} + +h1 { + display: inline-block; + margin: 1.5em 1.5em 0.75em 1.5em; +} + +.dirname { + color: var(--dirname-color); +} + +h2 { + display: inline-block; + position: relative; + top: -1px; +} + +#footer { + margin: 1em 0 1em 4em; + color: #aaa; + font-size: 12px; +} + +#footer a { + color: #666; + border-bottom: 1px solid #ccc; +} + +#footer a:visited { + color: #666; +} + +#navbar { + position: fixed; + top: 0; + left: 0; + width: 1em; + height: 100%; + background-color: var(--navbar-background); + border-right: 1px solid var(--navbar-border); + cursor: pointer; +} + +#navbar span { + display: block; + position: absolute; + width: 100%; + height: 5px; +} + +#navbar .unvisited, #navbar .some-visited { + background-color: var(--unvisited-margin-color); +} + +#report { + border-top: 1px solid var(--border); + border-bottom: 1px solid var(--border); + overflow: hidden; +} + +#lines-layer { + position: absolute; + z-index: -100; + width: 100%; + background-color: var(--code-background); +} + +#lines-layer span { + display: inline-block; + width: 100%; +} + +a[id] { + display: block; + position: relative; + top: -5.5em; +} + +#lines-layer .unvisited { + background-color: var(--unvisited-color); +} + +#lines-layer .visited { + background-color: var(--visited-color); +} + +#lines-layer .some-visited { + background-color: var(--somevisited-color); +} + +a[id]:target + span { + -webkit-animation: highlight-blank 0.5s; + -moz-animation: highlight-blank 0.5s; + -o-animation: highlight-blank 0.5s; + animation: highlight-blank 0.5s; +} + +a[id]:target + .unvisited { + -webkit-animation: highlight-unvisited 0.5s; + -moz-animation: highlight-unvisited 0.5s; + -o-animation: highlight-unvisited 0.5s; + animation: highlight-unvisited 0.5s; +} + +a[id]:target + .visited { + -webkit-animation: highlight-visited 0.5s; + -moz-animation: highlight-visited 0.5s; + -o-animation: highlight-visited 0.5s; + animation: highlight-visited 0.5s; +} + +a[id]:target + .some-visited { + -webkit-animation: highlight-some-visited 0.5s; + -moz-animation: highlight-some-visited 0.5s; + -o-animation: highlight-some-visited 0.5s; + animation: highlight-some-visited 0.5s; +} + +@-webkit-keyframes highlight-blank { + from { background-color: var(--highlight-color); } + to { background-color: transparent; } +} + +@-moz-keyframes highlight-blank { + from { background-color: var(--highlight-color); } + to { background-color: transparent; } +} + +@-o-keyframes highlight-blank { + from { background-color: var(--highlight-color); } + to { background-color: transparent; } +} + +@keyframes highlight-blank { + from { background-color: var(--highlight-color); } + to { background-color: transparent; } +} + +@-webkit-keyframes highlight-unvisited { + from { background-color: var(--highlight-color); } + to { background-color: var(--unvisited-color); } +} + +@-moz-keyframes highlight-unvisited { + from { background-color: var(--highlight-color); } + to { background-color: var(--unvisited-color); } +} + +@-o-keyframes highlight-unvisited { + from { background-color: var(--highlight-color); } + to { background-color: var(--unvisited-color); } +} + +@keyframes highlight-unvisited { + from { background-color: var(--highlight-color); } + to { background-color: var(--unvisited-color); } +} + +@-webkit-keyframes highlight-visited { + from { background-color: var(--highlight-color); } + to { background-color: var(--visited-color); } +} + +@-moz-keyframes highlight-visited { + from { background-color: var(--highlight-color); } + to { background-color: var(--visited-color); } +} + +@-o-keyframes highlight-visited { + from { background-color: var(--highlight-color); } + to { background-color: var(--visited-color); } +} + +@keyframes highlight-visited { + from { background-color: var(--highlight-color); } + to { background-color: var(--visited-color); } +} + +@-webkit-keyframes highlight-some-visited { + from { background-color: var(--highlight-color); } + to { background-color: var(--somevisited-color); } +} + +@-moz-keyframes highlight-some-visited { + from { background-color: var(--highlight-color); } + to { background-color: var(--somevisited-color); } +} + +@-o-keyframes highlight-some-visited { + from { background-color: var(--highlight-color); } + to { background-color: var(--somevisited-color); } +} + +@keyframes highlight-some-visited { + from { background-color: var(--highlight-color); } + to { background-color: var(--somevisited-color); } +} + +#line-numbers { + float: left; + border-right: 1px solid var(--border); + margin-right: 1em; + color: var(--line-number-color); + background-color: var(--line-numbers-background); + text-align: right; +} + +#line-numbers a { + display: inline-block; + padding-left: 2.35em; + padding-right: 1em; + text-decoration: none; + color: var(--line-number-color); +} + +#line-numbers .unvisited { + background-color: var(--unvisted-number-color); +} + +#line-numbers .visited { + background-color: var(--visted-number-color); +} + +code span[data-count] { + background-color: var(--visited-number-color); +} + +code span[data-count="0"] { + background-color: var(--unvisited-number-color); +} + +#tool-tip { + display: none; + position: fixed; + padding: 0 0.25em; + background-color: black; + color: white; +} + +#tool-tip.visible { + display: block; +} + +#files { + padding: 1.5em 4em; + background-color: var(--code-background); + border-top: 1px solid var(--border); + border-bottom: 1px solid var(--border); +} + +.meter { + display: inline-block; + position: relative; + top: 3px; + width: 5em; + height: 1em; + background-color: var(--meter-unvisited-color); +} + +.covered { + display: inline-block; + position: absolute; + width: 50%; + height: 100%; + background-color: var(--meter-visited-color); + border-right: 1px solid var(--meter-separator-color); +} + +#files div { + display: flex; +} + +summary { + cursor: pointer; + display: flex; +} + +.summary-indicator { + display: inline-block; + width: 1em; + color: var(--color); +} + +/* Adds indentation to the directory tree */ +details > details, details > div { + margin-left: 1em; +} + +details > summary > .summary-indicator { + text-align: center; + font-weight: bold; +} + +details > summary > .summary-indicator::before { + content: "+"; +} + +details[open] > summary > .summary-indicator::before { + content: "-"; +} + +.percentage { + display: inline-block; + min-width: 7.5em; + margin: 0 0.5em; + font-size: 90%; + color: var(--color); +} + +.stats { + display: inline-block; + font-size: 70%; + color: var(--stats-color); +} + +#files a { + text-decoration: none; + border-bottom: 1px solid var(--underline-color); + color: var(--color); +} + +.hljs-link, +.hljs-comment, +.hljs-quote { + color: var(--hljs-link); +} + +.hljs-built_in, +.hljs-builtin-name, +.hljs-keyword, +.hljs-selector-tag, +.hljs-subst { + color: var(--hljs-keyword); +} + +.hljs-number, +.hljs-literal, +.hljs-variable, +.hljs-template-variable, +.hljs-tag .hljs-attr { + color: var(--hljs-variable); +} + +.hljs-regexp, +.hljs-string, +.hljs-doctag { + color: var(--hljs-regexp); +} + +.hljs-title, +.hljs-section, +.hljs-selector-id { + color: var(--hljs-title); +} + +.hljs-type, +.hljs-class .hljs-title { + color: var(--hljs-type); +} + +.hljs-meta, +.hljs-tag, +.hljs-name, +.hljs-attribute { + color: var(--hljs-meta); +} diff --git a/_coverage/coverage.js b/_coverage/coverage.js new file mode 100644 index 000000000..ef2725436 --- /dev/null +++ b/_coverage/coverage.js @@ -0,0 +1,164 @@ +function tool_tip_element() +{ + var element = document.querySelector("#tool-tip"); + if (element === null) { + element = document.createElement("div"); + element.id = "tool-tip"; + document.querySelector("body").appendChild(element); + } + + return element; +}; + +var tool_tip = tool_tip_element(); +var html = document.getElementsByTagName("html")[0]; + +function attach_tool_tip() +{ + document.querySelector("body").onmousemove = function (event) + { + var element = event.target; + if (element.dataset.count === undefined) + element = event.target.parentNode; + + if (element.dataset.count && element.dataset.count !== "0") { + tool_tip.textContent = element.dataset.count; + tool_tip.classList.add("visible"); + + if (event.clientY < html.clientHeight - 48) + tool_tip.style.top = event.clientY + 7 + "px"; + else + tool_tip.style.top = event.clientY - 32 + "px"; + + tool_tip.style.left = event.clientX + 7 + "px"; + } + else + tool_tip.classList.remove("visible"); + } +}; + +attach_tool_tip(); + +function move_line_to_cursor(cursor_y, line_number) +{ + var id = "L" + line_number; + + var line_anchor = + document.querySelector("a[id=" + id + "] + span"); + if (line_anchor === null) + return; + + var line_y = line_anchor.getBoundingClientRect().top + 18; + + var y = window.scrollY; + window.location = "#" + id; + window.scrollTo(0, y + line_y - cursor_y); +}; + +function handle_navbar_clicks() +{ + var line_count = document.querySelectorAll("a[id]").length; + var navbar = document.querySelector("#navbar"); + + if (navbar === null) + return; + + navbar.onclick = function (event) + { + event.preventDefault(); + + var line_number = + Math.floor(event.clientY / navbar.clientHeight * line_count + 1); + + move_line_to_cursor(event.clientY, line_number); + }; +}; + +handle_navbar_clicks(); + +function handle_line_number_clicks() +{ + document.querySelector("body").onclick = function (event) + { + if (event.target.tagName != "A") + return; + + var line_number_location = event.target.href.search(/#L[0-9]+\$/); + if (line_number_location === -1) + return; + + var anchor = event.target.href.slice(line_number_location); + + event.preventDefault(); + + var y = window.scrollY; + window.location = anchor; + window.scrollTo(0, y); + }; +}; + +handle_line_number_clicks(); + +function handle_collapsible_click() +{ + document.querySelectorAll("summary").forEach( + function (summary) + { + summary.onclick = function (event) + { + var details = summary.parentElement; + + var all_open = function (sub_details) { + var all_are_open = true; + for (let details of sub_details) { + all_are_open = + all_are_open && + details.hasAttribute('open'); + } + return all_are_open; + }; + + var all_toggle = function (sub_details, toggle) { + for (let details of sub_details) { + if (toggle) + details.removeAttribute('open'); + else + details.setAttribute('open', ''); + } + }; + + // ctrl-click toggles the state of the folder and all sub-folders, recursively: + // - if all sub-folders are opened, then all sub-folders are closed + // - if at least one sub-folder is closed (or the folder itself), + // then all sub-folders are opened + if (event.ctrlKey) { + var sub_details = Array.prototype.slice.call( + details.querySelectorAll("details") + ); + sub_details.push(details); + all_toggle(sub_details, all_open(sub_details)); + return false; + } + + // shift-click toggles the state of all immediate sub-folders: + // - if the folder is closed, just open it + // - if the folder is opened: + // - if all sub-folders are opened, then all sub-folders are closed + // - if at least one sub-folder is closed, then all sub-folders are opened + if (event.shiftKey && details.hasAttribute('open')) { + details.setAttribute('open', ''); + var sub_details = + Array.prototype.filter.call( + details.querySelectorAll("details"), + function (sub_details) { + return sub_details.parentNode === details; + } + ); + all_toggle(sub_details, all_open(sub_details)); + return false; + } + }; + }); +} + +handle_collapsible_click(); diff --git a/_coverage/highlight.pack.js b/_coverage/highlight.pack.js new file mode 100644 index 000000000..2e55d4915 --- /dev/null +++ b/_coverage/highlight.pack.js @@ -0,0 +1,2 @@ +/*! highlight.js v9.15.8 | BSD3 License | git.io/hljslicense */ +!function(e){var n="object"==typeof window&&window||"object"==typeof self&&self;"undefined"!=typeof exports?e(exports):n&&(n.hljs=e({}),"function"==typeof define&&define.amd&&define([],function(){return n.hljs}))}(function(a){var f=[],u=Object.keys,N={},c={},n=/^(no-?highlight|plain|text)$/i,s=/\blang(?:uage)?-([\w-]+)\b/i,t=/((^(<[^>]+>|\t|)+|(?:\n)))/gm,r={case_insensitive:"cI",lexemes:"l",contains:"c",keywords:"k",subLanguage:"sL",className:"cN",begin:"b",beginKeywords:"bK",end:"e",endsWithParent:"eW",illegal:"i",excludeBegin:"eB",excludeEnd:"eE",returnBegin:"rB",returnEnd:"rE",relevance:"r",variants:"v",IDENT_RE:"IR",UNDERSCORE_IDENT_RE:"UIR",NUMBER_RE:"NR",C_NUMBER_RE:"CNR",BINARY_NUMBER_RE:"BNR",RE_STARTERS_RE:"RSR",BACKSLASH_ESCAPE:"BE",APOS_STRING_MODE:"ASM",QUOTE_STRING_MODE:"QSM",PHRASAL_WORDS_MODE:"PWM",C_LINE_COMMENT_MODE:"CLCM",C_BLOCK_COMMENT_MODE:"CBCM",HASH_COMMENT_MODE:"HCM",NUMBER_MODE:"NM",C_NUMBER_MODE:"CNM",BINARY_NUMBER_MODE:"BNM",CSS_NUMBER_MODE:"CSSNM",REGEXP_MODE:"RM",TITLE_MODE:"TM",UNDERSCORE_TITLE_MODE:"UTM",COMMENT:"C",beginRe:"bR",endRe:"eR",illegalRe:"iR",lexemesRe:"lR",terminators:"t",terminator_end:"tE"},b="",h={classPrefix:"hljs-",tabReplace:null,useBR:!1,languages:void 0};function _(e){return e.replace(/&/g,"&").replace(//g,">")}function E(e){return e.nodeName.toLowerCase()}function v(e,n){var t=e&&e.exec(n);return t&&0===t.index}function l(e){return n.test(e)}function g(e){var n,t={},r=Array.prototype.slice.call(arguments,1);for(n in e)t[n]=e[n];return r.forEach(function(e){for(n in e)t[n]=e[n]}),t}function R(e){var a=[];return function e(n,t){for(var r=n.firstChild;r;r=r.nextSibling)3===r.nodeType?t+=r.nodeValue.length:1===r.nodeType&&(a.push({event:"start",offset:t,node:r}),t=e(r,t),E(r).match(/br|hr|img|input/)||a.push({event:"stop",offset:t,node:r}));return t}(e,0),a}function i(e){if(r&&!e.langApiRestored){for(var n in e.langApiRestored=!0,r)e[n]&&(e[r[n]]=e[n]);(e.c||[]).concat(e.v||[]).forEach(i)}}function m(o){function s(e){return e&&e.source||e}function c(e,n){return new RegExp(s(e),"m"+(o.cI?"i":"")+(n?"g":""))}!function n(t,e){if(!t.compiled){if(t.compiled=!0,t.k=t.k||t.bK,t.k){function r(t,e){o.cI&&(e=e.toLowerCase()),e.split(" ").forEach(function(e){var n=e.split("|");a[n[0]]=[t,n[1]?Number(n[1]):1]})}var a={};"string"==typeof t.k?r("keyword",t.k):u(t.k).forEach(function(e){r(e,t.k[e])}),t.k=a}t.lR=c(t.l||/\w+/,!0),e&&(t.bK&&(t.b="\\b("+t.bK.split(" ").join("|")+")\\b"),t.b||(t.b=/\B|\b/),t.bR=c(t.b),t.endSameAsBegin&&(t.e=t.b),t.e||t.eW||(t.e=/\B|\b/),t.e&&(t.eR=c(t.e)),t.tE=s(t.e)||"",t.eW&&e.tE&&(t.tE+=(t.e?"|":"")+e.tE)),t.i&&(t.iR=c(t.i)),null==t.r&&(t.r=1),t.c||(t.c=[]),t.c=Array.prototype.concat.apply([],t.c.map(function(e){return function(n){return n.v&&!n.cached_variants&&(n.cached_variants=n.v.map(function(e){return g(n,{v:null},e)})),n.cached_variants||n.eW&&[g(n)]||[n]}("self"===e?t:e)})),t.c.forEach(function(e){n(e,t)}),t.starts&&n(t.starts,e);var i=t.c.map(function(e){return e.bK?"\\.?(?:"+e.b+")\\.?":e.b}).concat([t.tE,t.i]).map(s).filter(Boolean);t.t=i.length?c(function(e,n){for(var t=/\[(?:[^\\\]]|\\.)*\]|\(\??|\\([1-9][0-9]*)|\\./,r=0,a="",i=0;i')+n+(t?"":b):n}function o(){E+=null!=l.sL?function(){var e="string"==typeof l.sL;if(e&&!N[l.sL])return _(g);var n=e?C(l.sL,g,!0,f[l.sL]):O(g,l.sL.length?l.sL:void 0);return 0")+'"');return g+=n,n.length||1}var s=B(e);if(!s)throw new Error('Unknown language: "'+e+'"');m(s);var a,l=t||s,f={},E="";for(a=l;a!==s;a=a.parent)a.cN&&(E=c(a.cN,"",!0)+E);var g="",R=0;try{for(var d,p,M=0;l.t.lastIndex=M,d=l.t.exec(n);)p=r(n.substring(M,d.index),d[0]),M=d.index+p;for(r(n.substr(M)),a=l;a.parent;a=a.parent)a.cN&&(E+=b);return{r:R,value:E,language:e,top:l}}catch(e){if(e.message&&-1!==e.message.indexOf("Illegal"))return{r:0,value:_(n)};throw e}}function O(t,e){e=e||h.languages||u(N);var r={r:0,value:_(t)},a=r;return e.filter(B).filter(M).forEach(function(e){var n=C(e,t,!1);n.language=e,n.r>a.r&&(a=n),n.r>r.r&&(a=r,r=n)}),a.language&&(r.second_best=a),r}function d(e){return h.tabReplace||h.useBR?e.replace(t,function(e,n){return h.useBR&&"\n"===e?"
":h.tabReplace?n.replace(/\t/g,h.tabReplace):""}):e}function o(e){var n,t,r,a,i,o=function(e){var n,t,r,a,i=e.className+" ";if(i+=e.parentNode?e.parentNode.className:"",t=s.exec(i))return B(t[1])?t[1]:"no-highlight";for(n=0,r=(i=i.split(/\s+/)).length;n/g,"\n"):n=e,i=n.textContent,r=o?C(o,i,!0):O(i),(t=R(n)).length&&((a=document.createElementNS("http://www.w3.org/1999/xhtml","div")).innerHTML=r.value,r.value=function(e,n,t){var r=0,a="",i=[];function o(){return e.length&&n.length?e[0].offset!==n[0].offset?e[0].offset"}function u(e){a+=""}function s(e){("start"===e.event?c:u)(e.node)}for(;e.length||n.length;){var l=o();if(a+=_(t.substring(r,l[0].offset)),r=l[0].offset,l===e){for(i.reverse().forEach(u);s(l.splice(0,1)[0]),(l=o())===e&&l.length&&l[0].offset===r;);i.reverse().forEach(c)}else"start"===l[0].event?i.push(l[0].node):i.pop(),s(l.splice(0,1)[0])}return a+_(t.substr(r))}(t,R(a),i)),r.value=d(r.value),e.innerHTML=r.value,e.className=function(e,n,t){var r=n?c[n]:t,a=[e.trim()];return e.match(/\bhljs\b/)||a.push("hljs"),-1===e.indexOf(r)&&a.push(r),a.join(" ").trim()}(e.className,o,r.language),e.result={language:r.language,re:r.r},r.second_best&&(e.second_best={language:r.second_best.language,re:r.second_best.r}))}function p(){if(!p.called){p.called=!0;var e=document.querySelectorAll("pre code");f.forEach.call(e,o)}}function B(e){return e=(e||"").toLowerCase(),N[e]||N[c[e]]}function M(e){var n=B(e);return n&&!n.disableAutodetect}return a.highlight=C,a.highlightAuto=O,a.fixMarkup=d,a.highlightBlock=o,a.configure=function(e){h=g(h,e)},a.initHighlighting=p,a.initHighlightingOnLoad=function(){addEventListener("DOMContentLoaded",p,!1),addEventListener("load",p,!1)},a.registerLanguage=function(n,e){var t=N[n]=e(a);i(t),t.aliases&&t.aliases.forEach(function(e){c[e]=n})},a.listLanguages=function(){return u(N)},a.getLanguage=B,a.autoDetection=M,a.inherit=g,a.IR=a.IDENT_RE="[a-zA-Z]\\w*",a.UIR=a.UNDERSCORE_IDENT_RE="[a-zA-Z_]\\w*",a.NR=a.NUMBER_RE="\\b\\d+(\\.\\d+)?",a.CNR=a.C_NUMBER_RE="(-?)(\\b0[xX][a-fA-F0-9]+|(\\b\\d+(\\.\\d*)?|\\.\\d+)([eE][-+]?\\d+)?)",a.BNR=a.BINARY_NUMBER_RE="\\b(0b[01]+)",a.RSR=a.RE_STARTERS_RE="!|!=|!==|%|%=|&|&&|&=|\\*|\\*=|\\+|\\+=|,|-|-=|/=|/|:|;|<<|<<=|<=|<|===|==|=|>>>=|>>=|>=|>>>|>>|>|\\?|\\[|\\{|\\(|\\^|\\^=|\\||\\|=|\\|\\||~",a.BE=a.BACKSLASH_ESCAPE={b:"\\\\[\\s\\S]",r:0},a.ASM=a.APOS_STRING_MODE={cN:"string",b:"'",e:"'",i:"\\n",c:[a.BE]},a.QSM=a.QUOTE_STRING_MODE={cN:"string",b:'"',e:'"',i:"\\n",c:[a.BE]},a.PWM=a.PHRASAL_WORDS_MODE={b:/\b(a|an|the|are|I'm|isn't|don't|doesn't|won't|but|just|should|pretty|simply|enough|gonna|going|wtf|so|such|will|you|your|they|like|more)\b/},a.C=a.COMMENT=function(e,n,t){var r=a.inherit({cN:"comment",b:e,e:n,c:[]},t||{});return r.c.push(a.PWM),r.c.push({cN:"doctag",b:"(?:TODO|FIXME|NOTE|BUG|XXX):",r:0}),r},a.CLCM=a.C_LINE_COMMENT_MODE=a.C("//","$"),a.CBCM=a.C_BLOCK_COMMENT_MODE=a.C("/\\*","\\*/"),a.HCM=a.HASH_COMMENT_MODE=a.C("#","$"),a.NM=a.NUMBER_MODE={cN:"number",b:a.NR,r:0},a.CNM=a.C_NUMBER_MODE={cN:"number",b:a.CNR,r:0},a.BNM=a.BINARY_NUMBER_MODE={cN:"number",b:a.BNR,r:0},a.CSSNM=a.CSS_NUMBER_MODE={cN:"number",b:a.NR+"(%|em|ex|ch|rem|vw|vh|vmin|vmax|cm|mm|in|pt|pc|px|deg|grad|rad|turn|s|ms|Hz|kHz|dpi|dpcm|dppx)?",r:0},a.RM=a.REGEXP_MODE={cN:"regexp",b:/\//,e:/\/[gimuy]*/,i:/\n/,c:[a.BE,{b:/\[/,e:/\]/,r:0,c:[a.BE]}]},a.TM=a.TITLE_MODE={cN:"title",b:a.IR,r:0},a.UTM=a.UNDERSCORE_TITLE_MODE={cN:"title",b:a.UIR,r:0},a.METHOD_GUARD={b:"\\.\\s*"+a.UIR,r:0},a});hljs.registerLanguage("ocaml",function(e){return{aliases:["ml"],k:{keyword:"and as assert asr begin class constraint do done downto else end exception external for fun function functor if in include inherit! inherit initializer land lazy let lor lsl lsr lxor match method!|10 method mod module mutable new object of open! open or private rec sig struct then to try type val! val virtual when while with parser value",built_in:"array bool bytes char exn|5 float int int32 int64 list lazy_t|5 nativeint|5 string unit in_channel out_channel ref",literal:"true false"},i:/\/\/|>>/,l:"[a-z_]\\w*!?",c:[{cN:"literal",b:"\\[(\\|\\|)?\\]|\\(\\)",r:0},e.C("\\(\\*","\\*\\)",{c:["self"]}),{cN:"symbol",b:"'[A-Za-z_](?!')[\\w']*"},{cN:"type",b:"`[A-Z][\\w']*"},{cN:"type",b:"\\b[A-Z][\\w']*",r:0},{b:"[a-z_]\\w*'[\\w']*",r:0},e.inherit(e.ASM,{cN:"string",r:0}),e.inherit(e.QSM,{i:null}),{cN:"number",b:"\\b(0[xX][a-fA-F0-9_]+[Lln]?|0[oO][0-7_]+[Lln]?|0[bB][01_]+[Lln]?|[0-9][0-9_]*([Lln]|(\\.[0-9_]*)?([eE][-+]?[0-9_]+)?)?)",r:0},{b:/[-=]>/}]}});hljs.registerLanguage("reasonml",function(r){var e="~?[a-z$_][0-9a-zA-Z$_]*",a="`?[A-Z$_][0-9a-zA-Z$_]*",c="("+["||","&&","++","**","+.","*","/","*.","/.","...","|>"].map(function(r){return r.split("").map(function(r){return"\\"+r}).join("")}).join("|")+"|==|===)",n="\\s+"+c+"\\s+",t={keyword:"and as asr assert begin class constraint do done downto else end exception externalfor fun function functor if in include inherit initializerland lazy let lor lsl lsr lxor match method mod module mutable new nonrecobject of open or private rec sig struct then to try type val virtual when while with",built_in:"array bool bytes char exn|5 float int int32 int64 list lazy_t|5 nativeint|5 ref string unit ",literal:"true false"},i="\\b(0[xX][a-fA-F0-9_]+[Lln]?|0[oO][0-7_]+[Lln]?|0[bB][01_]+[Lln]?|[0-9][0-9_]*([Lln]|(\\.[0-9_]*)?([eE][-+]?[0-9_]+)?)?)",s={cN:"number",r:0,v:[{b:i},{b:"\\(\\-"+i+"\\)"}]},b={cN:"operator",r:0,b:c},o=[{cN:"identifier",r:0,b:e},b,s],l=[r.QSM,b,{cN:"module",b:"\\b"+a,rB:!0,e:".",c:[{cN:"identifier",b:a,r:0}]}],u=[{cN:"module",b:"\\b"+a,rB:!0,e:".",r:0,c:[{cN:"identifier",b:a,r:0}]}],_={cN:"function",r:0,k:t,v:[{b:"\\s(\\(\\.?.*?\\)|"+e+")\\s*=>",e:"\\s*=>",rB:!0,r:0,c:[{cN:"params",v:[{b:e},{b:"~?[a-z$_][0-9a-zA-Z$_]*(s*:s*[a-z$_][0-9a-z$_]*((s*('?[a-z$_][0-9a-z$_]*s*(,'?[a-z$_][0-9a-z$_]*)*)?s*))?)?(s*:s*[a-z$_][0-9a-z$_]*((s*('?[a-z$_][0-9a-z$_]*s*(,'?[a-z$_][0-9a-z$_]*)*)?s*))?)?"},{b:/\(\s*\)/}]}]},{b:"\\s\\(\\.?[^;\\|]*\\)\\s*=>",e:"\\s=>",rB:!0,r:0,c:[{cN:"params",r:0,v:[{b:e,e:"(,|\\n|\\))",r:0,c:[b,{cN:"typing",b:":",e:"(,|\\n)",rB:!0,r:0,c:u}]}]}]},{b:"\\(\\.\\s"+e+"\\)\\s*=>"}]};l.push(_);var N={cN:"constructor",b:a+"\\(",e:"\\)",i:"\\n",k:t,c:[r.QSM,b,{cN:"params",b:"\\b"+e}]},d={cN:"pattern-match",b:"\\|",rB:!0,k:t,e:"=>",r:0,c:[N,b,{r:0,cN:"constructor",b:a}]},z={cN:"module-access",k:t,rB:!0,v:[{b:"\\b("+a+"\\.)+"+e},{b:"\\b("+a+"\\.)+\\(",e:"\\)",rB:!0,c:[_,{b:"\\(",e:"\\)",skip:!0}].concat(l)},{b:"\\b("+a+"\\.)+{",e:"}"}],c:l};return u.push(z),{aliases:["re"],k:t,i:"(:\\-|:=|\\${|\\+=)",c:[r.C("/\\*","\\*/",{i:"^(\\#,\\/\\/)"}),{cN:"character",b:"'(\\\\[^']+|[^'])'",i:"\\n",r:0},r.QSM,{cN:"literal",b:"\\(\\)",r:0},{cN:"literal",b:"\\[\\|",e:"\\|\\]",r:0,c:o},{cN:"literal",b:"\\[",e:"\\]",r:0,c:o},N,{cN:"operator",b:n,i:"\\-\\->",r:0},s,r.CLCM,d,_,{cN:"module-def",b:"\\bmodule\\s+"+e+"\\s+"+a+"\\s+=\\s+{",e:"}",rB:!0,k:t,r:0,c:[{cN:"module",r:0,b:a},{b:"{",e:"}",skip:!0}].concat(l)},z]}}); \ No newline at end of file diff --git a/_coverage/index.html b/_coverage/index.html new file mode 100644 index 000000000..89478d72a --- /dev/null +++ b/_coverage/index.html @@ -0,0 +1,161 @@ + + + + + Coverage report + + + + + +
+
+ + + + 68% (168 / 245) + + src/weak/weak.ml + +
+
+ + + + 43% (10 / 23) + + src/sys/sys.ml + +
+
+ + + + 65% (17 / 26) + + src/stack/stack.ml + +
+
+ + + + 41% (16 / 39) + + src/semaphore/semaphore.ml + +
+
+ + + + 43% (23 / 53) + + src/queue/queue.ml + +
+
+ + + + 81% (22 / 27) + + src/lazy/lazy.ml + +
+
+ + + + 12% (8 / 64) + + src/io/in_channel.ml + +
+
+ + + + 0% (0 / 8) + + src/io/out_channel.ml + +
+
+ + + + 28% (104 / 364) + + src/hashtbl/hashtbl.ml + +
+
+ + + + 36% (140 / 379) + + src/floatarray/float.ml + +
+
+ + + + 27% (115 / 414) + + src/ephemeron/ephemeron.ml + +
+
+ + + + 24% (25 / 101) + + src/domain/domain.ml + +
+
+ + + + 4% (34 / 792) + + src/bytes/bytescp.ml + +
+
+ + + + 17% (42 / 243) + + src/buffer/buffer.ml + +
+
+ + + + 100% (6 / 6) + + src/atomic/atomic.ml + +
+
+ + + + 28% (109 / 378) + + src/array/array.ml + +
+
+ + diff --git a/_coverage/src/array/array.ml.html b/_coverage/src/array/array.ml.html new file mode 100644 index 000000000..79f4f8bb2 --- /dev/null +++ b/_coverage/src/array/array.ml.html @@ -0,0 +1,1471 @@ + + + + + array.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+174
+175
+176
+177
+178
+179
+180
+181
+182
+183
+184
+185
+186
+187
+188
+189
+190
+191
+192
+193
+194
+195
+196
+197
+198
+199
+200
+201
+202
+203
+204
+205
+206
+207
+208
+209
+210
+211
+212
+213
+214
+215
+216
+217
+218
+219
+220
+221
+222
+223
+224
+225
+226
+227
+228
+229
+230
+231
+232
+233
+234
+235
+236
+237
+238
+239
+240
+241
+242
+243
+244
+245
+246
+247
+248
+249
+250
+251
+252
+253
+254
+255
+256
+257
+258
+259
+260
+261
+262
+263
+264
+265
+266
+267
+268
+269
+270
+271
+272
+273
+274
+275
+276
+277
+278
+279
+280
+281
+282
+283
+284
+285
+286
+287
+288
+289
+290
+291
+292
+293
+294
+295
+296
+297
+298
+299
+300
+301
+302
+303
+304
+305
+306
+307
+308
+309
+310
+311
+312
+313
+314
+315
+316
+317
+318
+319
+320
+321
+322
+323
+324
+325
+326
+327
+328
+329
+330
+331
+332
+333
+334
+335
+336
+337
+338
+339
+340
+341
+342
+343
+344
+345
+346
+347
+348
+349
+350
+351
+352
+353
+354
+355
+356
+357
+358
+359
+360
+361
+362
+363
+364
+365
+366
+367
+368
+369
+370
+371
+372
+373
+374
+375
+376
+377
+378
+379
+380
+381
+382
+383
+384
+385
+386
+387
+388
+389
+390
+391
+392
+393
+394
+395
+396
+397
+398
+399
+400
+401
+402
+403
+404
+405
+406
+407
+408
+409
+410
+411
+412
+413
+414
+415
+416
+417
+418
+419
+420
+421
+422
+423
+424
+425
+426
+427
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* An alias for the type of arrays. *)
+type 'a t = 'a array
+
+(* Array operations *)
+
+external length : 'a array -> int = "%array_length"
+external get: 'a array -> int -> 'a = "%array_safe_get"
+external set: 'a array -> int -> 'a -> unit = "%array_safe_set"
+external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
+external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
+external make: int -> 'a -> 'a array = "caml_make_vect"
+external create: int -> 'a -> 'a array = "caml_make_vect"
+external unsafe_sub : 'a array -> int -> int -> 'a array = "caml_array_sub"
+external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
+external concat : 'a array list -> 'a array = "caml_array_concat"
+external unsafe_blit :
+  'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
+external unsafe_fill :
+  'a array -> int -> int -> 'a -> unit = "caml_array_fill"
+external create_float: int -> float array = "caml_make_float_vect"
+
+module Floatarray = struct
+  external create : int -> floatarray = "caml_floatarray_create"
+  external length : floatarray -> int = "%floatarray_length"
+  external get : floatarray -> int -> float = "%floatarray_safe_get"
+  external set : floatarray -> int -> float -> unit = "%floatarray_safe_set"
+  external unsafe_get : floatarray -> int -> float = "%floatarray_unsafe_get"
+  external unsafe_set : floatarray -> int -> float -> unit
+      = "%floatarray_unsafe_set"
+end
+
+let init l f =
+  if l = 0 then [||] else
+  if l < 0 then invalid_arg "Array.init"
+  (* See #6575. We could also check for maximum array size, but this depends
+     on whether we create a float array or a regular one... *)
+  else
+   let res = create l (f 0) in
+   for i = 1 to pred l do
+     unsafe_set res i (f i)
+   done;
+   res
+
+let make_matrix sx sy init =
+  let res = create sx [||] in
+  for x = 0 to pred sx do
+    unsafe_set res x (create sy init)
+  done;
+  res
+
+let copy a =
+  let l = length a in if l = 0 then [||] else unsafe_sub a 0 l
+
+let append a1 a2 =
+  let l1 = length a1 in
+  if l1 = 0 then copy a2
+  else if length a2 = 0 then unsafe_sub a1 0 l1
+  else append_prim a1 a2
+
+let sub a ofs len =
+  if ofs < 0 || len < 0 || ofs > length a - len
+  then invalid_arg "Array.sub"
+  else unsafe_sub a ofs len
+
+let fill a ofs len v =
+  if ofs < 0 || len < 0 || ofs > length a - len
+  then invalid_arg "Array.fill"
+  else unsafe_fill a ofs len v
+
+let blit a1 ofs1 a2 ofs2 len =
+  if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
+             || ofs2 < 0 || ofs2 > length a2 - len
+  then invalid_arg "Array.blit"
+  else unsafe_blit a1 ofs1 a2 ofs2 len
+
+let iter f a =
+  for i = 0 to length a - 1 do f(unsafe_get a i) done
+
+let iter2 f a b =
+  if length a <> length b then
+    invalid_arg "Array.iter2: arrays must have the same length"
+  else
+    for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done
+
+let map f a =
+  let l = length a in
+  if l = 0 then [||] else begin
+    let r = create l (f(unsafe_get a 0)) in
+    for i = 1 to l - 1 do
+      unsafe_set r i (f(unsafe_get a i))
+    done;
+    r
+  end
+
+let map2 f a b =
+  let la = length a in
+  let lb = length b in
+  if la <> lb then
+    invalid_arg "Array.map2: arrays must have the same length"
+  else begin
+    if la = 0 then [||] else begin
+      let r = create la (f (unsafe_get a 0) (unsafe_get b 0)) in
+      for i = 1 to la - 1 do
+        unsafe_set r i (f (unsafe_get a i) (unsafe_get b i))
+      done;
+      r
+    end
+  end
+
+let iteri f a =
+  for i = 0 to length a - 1 do f i (unsafe_get a i) done
+
+let mapi f a =
+  let l = length a in
+  if l = 0 then [||] else begin
+    let r = create l (f 0 (unsafe_get a 0)) in
+    for i = 1 to l - 1 do
+      unsafe_set r i (f i (unsafe_get a i))
+    done;
+    r
+  end
+
+let to_list a =
+  let rec tolist i res =
+    if i < 0 then res else tolist (i - 1) (unsafe_get a i :: res) in
+  tolist (length a - 1) []
+
+(* Cannot use List.length here because the List module depends on Array. *)
+let rec list_length accu = function
+  | [] -> accu
+  | _::t -> list_length (succ accu) t
+
+let of_list = function
+    [] -> [||]
+  | hd::tl as l ->
+      let a = create (list_length 0 l) hd in
+      let rec fill i = function
+          [] -> a
+        | hd::tl -> unsafe_set a i hd; fill (i+1) tl in
+      fill 1 tl
+
+let fold_left f x a =
+  let r = ref x in
+  for i = 0 to length a - 1 do
+    r := f !r (unsafe_get a i)
+  done;
+  !r
+
+let fold_left_map f acc input_array =
+  let len = length input_array in
+  if len = 0 then (acc, [||]) else begin
+    let acc, elt = f acc (unsafe_get input_array 0) in
+    let output_array = create len elt in
+    let acc = ref acc in
+    for i = 1 to len - 1 do
+      let acc', elt = f !acc (unsafe_get input_array i) in
+      acc := acc';
+      unsafe_set output_array i elt;
+    done;
+    !acc, output_array
+  end
+
+let fold_right f a x =
+  let r = ref x in
+  for i = length a - 1 downto 0 do
+    r := f (unsafe_get a i) !r
+  done;
+  !r
+
+let exists p a =
+  let n = length a in
+  let rec loop i =
+    if i = n then false
+    else if p (unsafe_get a i) then true
+    else loop (succ i) in
+  loop 0
+
+let for_all p a =
+  let n = length a in
+  let rec loop i =
+    if i = n then true
+    else if p (unsafe_get a i) then loop (succ i)
+    else false in
+  loop 0
+
+let for_all2 p l1 l2 =
+  let n1 = length l1
+  and n2 = length l2 in
+  if n1 <> n2 then invalid_arg "Array.for_all2"
+  else let rec loop i =
+    if i = n1 then true
+    else if p (unsafe_get l1 i) (unsafe_get l2 i) then loop (succ i)
+    else false in
+  loop 0
+
+let exists2 p l1 l2 =
+  let n1 = length l1
+  and n2 = length l2 in
+  if n1 <> n2 then invalid_arg "Array.exists2"
+  else let rec loop i =
+    if i = n1 then false
+    else if p (unsafe_get l1 i) (unsafe_get l2 i) then true
+    else loop (succ i) in
+  loop 0
+
+let mem x a =
+  let n = length a in
+  let rec loop i =
+    if i = n then false
+    else if compare (unsafe_get a i) x = 0 then true
+    else loop (succ i) in
+  loop 0
+
+let memq x a =
+  let n = length a in
+  let rec loop i =
+    if i = n then false
+    else if x == (unsafe_get a i) then true
+    else loop (succ i) in
+  loop 0
+
+let find_opt p a =
+  let n = length a in
+  let rec loop i =
+    if i = n then None
+    else
+      let x = unsafe_get a i in
+      if p x then Some x
+      else loop (succ i)
+  in
+  loop 0
+
+let find_map f a =
+  let n = length a in
+  let rec loop i =
+    if i = n then None
+    else
+      match f (unsafe_get a i) with
+      | None -> loop (succ i)
+      | Some _ as r -> r
+  in
+  loop 0
+
+let split x =
+  if x = [||] then [||], [||]
+  else begin
+    let a0, b0 = unsafe_get x 0 in
+    let n = length x in
+    let a = create n a0 in
+    let b = create n b0 in
+    for i = 1 to n - 1 do
+      let ai, bi = unsafe_get x i in
+      unsafe_set a i ai;
+      unsafe_set b i bi
+    done;
+    a, b
+  end
+
+let combine a b =
+  let na = length a in
+  let nb = length b in
+  if na <> nb then invalid_arg "Array.combine";
+  if na = 0 then [||]
+  else begin
+    let x = create na (unsafe_get a 0, unsafe_get b 0) in
+    for i = 1 to na - 1 do
+      unsafe_set x i (unsafe_get a i, unsafe_get b i)
+    done;
+    x
+  end
+
+exception Bottom of int
+let sort cmp a =
+  let maxson l i =
+    let i31 = i+i+i+1 in
+    let x = ref i31 in
+    if i31+2 < l then begin
+      if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1;
+      if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
+      !x
+    end else
+      if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0
+      then i31+1
+      else if i31 < l then i31 else raise (Bottom i)
+  in
+  let rec trickledown l i e =
+    let j = maxson l i in
+    if cmp (get a j) e > 0 then begin
+      set a i (get a j);
+      trickledown l j e;
+    end else begin
+      set a i e;
+    end;
+  in
+  let trickle l i e = try trickledown l i e with Bottom i -> set a i e in
+  let rec bubbledown l i =
+    let j = maxson l i in
+    set a i (get a j);
+    bubbledown l j
+  in
+  let bubble l i = try bubbledown l i with Bottom i -> i in
+  let rec trickleup i e =
+    let father = (i - 1) / 3 in
+    assert (i <> father);
+    if cmp (get a father) e < 0 then begin
+      set a i (get a father);
+      if father > 0 then trickleup father e else set a 0 e;
+    end else begin
+      set a i e;
+    end;
+  in
+  let l = length a in
+  for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
+  for i = l - 1 downto 2 do
+    let e = (get a i) in
+    set a i (get a 0);
+    trickleup (bubble i 0) e;
+  done;
+  if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e)
+
+
+let cutoff = 5
+let stable_sort cmp a =
+  let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+    let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+    let rec loop i1 s1 i2 s2 d =
+      if cmp s1 s2 <= 0 then begin
+        set dst d s1;
+        let i1 = i1 + 1 in
+        if i1 < src1r then
+          loop i1 (get a i1) i2 s2 (d + 1)
+        else
+          blit src2 i2 dst (d + 1) (src2r - i2)
+      end else begin
+        set dst d s2;
+        let i2 = i2 + 1 in
+        if i2 < src2r then
+          loop i1 s1 i2 (get src2 i2) (d + 1)
+        else
+          blit a i1 dst (d + 1) (src1r - i1)
+      end
+    in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
+  in
+  let isortto srcofs dst dstofs len =
+    for i = 0 to len - 1 do
+      let e = (get a (srcofs + i)) in
+      let j = ref (dstofs + i - 1) in
+      while (!j >= dstofs && cmp (get dst !j) e > 0) do
+        set dst (!j + 1) (get dst !j);
+        decr j;
+      done;
+      set dst (!j + 1) e;
+    done;
+  in
+  let rec sortto srcofs dst dstofs len =
+    if len <= cutoff then isortto srcofs dst dstofs len else begin
+      let l1 = len / 2 in
+      let l2 = len - l1 in
+      sortto (srcofs + l1) dst (dstofs + l1) l2;
+      sortto srcofs a (srcofs + l2) l1;
+      merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+    end;
+  in
+  let l = length a in
+  if l <= cutoff then isortto 0 a 0 l else begin
+    let l1 = l / 2 in
+    let l2 = l - l1 in
+    let t = make l2 (get a 0) in
+    sortto l1 t 0 l2;
+    sortto 0 a l2 l1;
+    merge l2 l1 t 0 l2 a 0;
+  end
+
+
+let fast_sort = stable_sort
+
+(** {1 Iterators} *)
+
+let to_seq a =
+  let rec aux i () =
+    if i < length a
+    then
+      let x = unsafe_get a i in
+      Seq.Cons (x, aux (i+1))
+    else Seq.Nil
+  in
+  aux 0
+
+let to_seqi a =
+  let rec aux i () =
+    if i < length a
+    then
+      let x = unsafe_get a i in
+      Seq.Cons ((i,x), aux (i+1))
+    else Seq.Nil
+  in
+  aux 0
+
+let of_rev_list = function
+    [] -> [||]
+  | hd::tl as l ->
+      let len = list_length 0 l in
+      let a = create len hd in
+      let rec fill i = function
+          [] -> a
+        | hd::tl -> unsafe_set a i hd; fill (i-1) tl
+      in
+      fill (len-2) tl
+
+let of_seq i =
+  let l = Seq.fold_left (fun acc x -> x::acc) [] i in
+  of_rev_list l
+
+
+
+ + + diff --git a/_coverage/src/atomic/atomic.ml.html b/_coverage/src/atomic/atomic.ml.html new file mode 100644 index 000000000..5da8952bf --- /dev/null +++ b/_coverage/src/atomic/atomic.ml.html @@ -0,0 +1,113 @@ + + + + + atomic.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                 Stephen Dolan, University of Cambridge                 *)
+(*                                                                        *)
+(*   Copyright 2017-2018 University of Cambridge.                         *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type !'a t
+
+external make : 'a -> 'a t = "%makemutable"
+external get : 'a t -> 'a = "%atomic_load"
+external exchange : 'a t -> 'a -> 'a = "%atomic_exchange"
+external compare_and_set : 'a t -> 'a -> 'a -> bool = "%atomic_cas"
+external fetch_and_add : int t -> int -> int = "%atomic_fetch_add"
+external ignore : 'a -> unit = "%ignore"
+
+let set r x = ignore (exchange r x)
+let incr r = ignore (fetch_and_add r 1)
+let decr r = ignore (fetch_and_add r (-1))
+
+
+
+ + + diff --git a/_coverage/src/buffer/buffer.ml.html b/_coverage/src/buffer/buffer.ml.html new file mode 100644 index 000000000..2d8b4c5b8 --- /dev/null +++ b/_coverage/src/buffer/buffer.ml.html @@ -0,0 +1,1364 @@ + + + + + buffer.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+174
+175
+176
+177
+178
+179
+180
+181
+182
+183
+184
+185
+186
+187
+188
+189
+190
+191
+192
+193
+194
+195
+196
+197
+198
+199
+200
+201
+202
+203
+204
+205
+206
+207
+208
+209
+210
+211
+212
+213
+214
+215
+216
+217
+218
+219
+220
+221
+222
+223
+224
+225
+226
+227
+228
+229
+230
+231
+232
+233
+234
+235
+236
+237
+238
+239
+240
+241
+242
+243
+244
+245
+246
+247
+248
+249
+250
+251
+252
+253
+254
+255
+256
+257
+258
+259
+260
+261
+262
+263
+264
+265
+266
+267
+268
+269
+270
+271
+272
+273
+274
+275
+276
+277
+278
+279
+280
+281
+282
+283
+284
+285
+286
+287
+288
+289
+290
+291
+292
+293
+294
+295
+296
+297
+298
+299
+300
+301
+302
+303
+304
+305
+306
+307
+308
+309
+310
+311
+312
+313
+314
+315
+316
+317
+318
+319
+320
+321
+322
+323
+324
+325
+326
+327
+328
+329
+330
+331
+332
+333
+334
+335
+336
+337
+338
+339
+340
+341
+342
+343
+344
+345
+346
+347
+348
+349
+350
+351
+352
+353
+354
+355
+356
+357
+358
+359
+360
+361
+362
+363
+364
+365
+366
+367
+368
+369
+370
+371
+372
+373
+374
+375
+376
+377
+378
+379
+380
+381
+382
+383
+384
+385
+386
+387
+388
+389
+390
+391
+392
+393
+394
+395
+396
+397
+398
+399
+400
+401
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*    Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt    *)
+(*                                                                        *)
+(*   Copyright 1999 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Extensible buffers *)
+
+(* The [inner_buffer] type ensures that the [length] and [buffer] fields are
+   always synchronized, [length = Bytes.length buffer], even in presence
+   of data races.
+*)
+type inner_buffer = {
+  buffer: bytes;
+  length: int;
+}
+
+type t =
+ {mutable inner : inner_buffer;
+  mutable position : int;
+  initial_buffer : bytes}
+(* Invariants: all parts of the code preserve the invariants that:
+   - [inner.length = Bytes.length inner.buffer]
+   In absence of data races, we also have
+   - [0 <= b.position <= b.inner.length]
+
+   Note in particular that [b.position = b.inner.length] is legal,
+   it means that the buffer is full and will have to be extended
+   before any further addition. *)
+
+let create n =
+ let n = if n < 1 then 1 else n in
+ let n = if n > Sys.max_string_length then Sys.max_string_length else n in
+ let s = Bytes.create n in
+ { inner = { buffer = s; length = n}; position = 0; initial_buffer = s}
+
+let contents b = Bytes.sub_string b.inner.buffer 0 b.position
+let to_bytes b = Bytes.sub b.inner.buffer 0 b.position
+
+let sub b ofs len =
+  if ofs < 0 || len < 0 || ofs > b.position - len
+  then invalid_arg "Buffer.sub"
+  else Bytes.sub_string b.inner.buffer ofs len
+
+
+let blit src srcoff dst dstoff len =
+  if len < 0 || srcoff < 0 || srcoff > src.position - len
+             || dstoff < 0 || dstoff > (Bytes.length dst) - len
+  then invalid_arg "Buffer.blit"
+  else
+    Bytes.blit src.inner.buffer srcoff dst dstoff len
+
+
+let nth b ofs =
+  let position = b.position in
+  let {buffer;length} = b.inner in
+  if ofs < 0 || ofs >= position || position > length then
+   invalid_arg "Buffer.nth"
+  else Bytes.unsafe_get buffer ofs
+
+
+let length b = b.position
+
+let clear b = b.position <- 0
+
+let reset b =
+  b.position <- 0;
+  let inner =
+    { buffer = b.initial_buffer; length = Bytes.length b.initial_buffer }
+  in
+  b.inner <- inner
+
+(* [resize b more] ensures that [b.position + more <= b.inner.length] holds
+   by dynamically extending [b.inner] if necessary -- and thus
+   increasing [b.inner.length].
+*)
+let resize b more =
+  let old_pos = b.position in
+  let old_len = b.inner.length in
+  let new_len = ref old_len in
+  while old_pos + more > !new_len do new_len := 2 * !new_len done;
+  if !new_len > Sys.max_string_length then begin
+    if old_pos + more <= Sys.max_string_length
+    then new_len := Sys.max_string_length
+    else failwith "Buffer.add: cannot grow buffer"
+  end;
+  let new_buffer = Bytes.create !new_len in
+  (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in
+     this tricky function that is slow anyway. *)
+  Bytes.blit b.inner.buffer 0 new_buffer 0 b.position;
+  b.inner <- { buffer = new_buffer; length = !new_len }
+
+(* Note:
+    Some of the functions below have a fast path when the inner
+  buffer doesn't need to be extended.
+    In this case, it is possible to use unsafe accesses on the
+  contents of the [inner] field since its fields are immutable.
+  In presence of data races, we may access the wrong inner buffer, but we
+  will use this buffer safely.
+  As soon as we need to resize the buffer, we fall back to safe accesses.
+*)
+
+let add_char b c =
+  let pos = b.position in
+  let {buffer;length} = b.inner in
+  if pos >= length then (
+    resize b 1;
+    Bytes.set b.inner.buffer b.position c
+  ) else
+    Bytes.unsafe_set buffer pos c;
+  b.position <- pos + 1
+
+let uchar_utf_8_byte_length_max = 4
+let uchar_utf_16_byte_length_max = 4
+
+let rec add_utf_8_uchar b u =
+  let pos = b.position in
+  if pos >= b.inner.length then resize b uchar_utf_8_byte_length_max;
+  let n = Bytes.set_utf_8_uchar b.inner.buffer pos u in
+  if n = 0
+  then (resize b uchar_utf_8_byte_length_max; add_utf_8_uchar b u)
+  else (b.position <- pos + n)
+
+let rec add_utf_16be_uchar b u =
+  let pos = b.position in
+  if pos >= b.inner.length then resize b uchar_utf_16_byte_length_max;
+  let n = Bytes.set_utf_16be_uchar b.inner.buffer pos u in
+  if n = 0
+  then (resize b uchar_utf_16_byte_length_max; add_utf_16be_uchar b u)
+  else (b.position <- pos + n)
+
+let rec add_utf_16le_uchar b u =
+  let pos = b.position in
+  if pos >= b.inner.length then resize b uchar_utf_16_byte_length_max;
+  let n = Bytes.set_utf_16le_uchar b.inner.buffer pos u in
+  if n = 0
+  then (resize b uchar_utf_16_byte_length_max; add_utf_16le_uchar b u)
+  else (b.position <- pos + n)
+
+let add_substring b s offset len =
+  if offset < 0 || len < 0 || offset > String.length s - len
+  then invalid_arg "Buffer.add_substring/add_subbytes";
+  let position = b.position in
+  let {buffer;length} = b.inner in
+  let new_position = position + len in
+  if new_position > length then (
+    resize b len;
+    Bytes.blit_string s offset b.inner.buffer b.position len
+  ) else
+    Bytes.unsafe_blit_string s offset buffer position len;
+  b.position <- new_position
+
+let add_subbytes b s offset len =
+  add_substring b (Bytes.unsafe_to_string s) offset len
+
+let add_string b s =
+  let len = String.length s in
+  let position = b.position in
+  let {buffer; length} = b.inner in
+  let new_position = b.position + len in
+  if new_position > length then (
+    resize b len;
+    Bytes.blit_string s 0 b.inner.buffer b.position len;
+  ) else
+    Bytes.unsafe_blit_string s 0 buffer position len;
+  b.position <- new_position
+
+let add_bytes b s = add_string b (Bytes.unsafe_to_string s)
+
+let add_buffer b bs =
+  add_subbytes b bs.inner.buffer 0 bs.position
+
+(* this (private) function could move into the standard library *)
+let really_input_up_to ic buf ofs len =
+  let rec loop ic buf ~already_read ~ofs ~to_read =
+    if to_read = 0 then already_read
+    else begin
+      let r = input ic buf ofs to_read in
+      if r = 0 then already_read
+      else begin
+        let already_read = already_read + r in
+        let ofs = ofs + r in
+        let to_read = to_read - r in
+        loop ic buf ~already_read ~ofs ~to_read
+      end
+    end
+  in loop ic buf ~already_read:0 ~ofs ~to_read:len
+
+
+let unsafe_add_channel_up_to b ic len =
+  if b.position + len > b.inner.length then resize b len;
+  let n = really_input_up_to ic b.inner.buffer b.position len in
+  b.position <- b.position + n;
+  n
+
+let add_channel b ic len =
+  if len < 0 || len > Sys.max_string_length then   (* PR#5004 *)
+    invalid_arg "Buffer.add_channel";
+  let n = unsafe_add_channel_up_to b ic len in
+  (* It is intentional that a consumer catching End_of_file
+     will see the data written (see #6719, #7136). *)
+  if n < len then raise End_of_file;
+  ()
+
+let output_buffer oc b =
+  output oc b.inner.buffer 0 b.position
+
+let closing = function
+  | '(' -> ')'
+  | '{' -> '}'
+  | _ -> assert false
+
+(* opening and closing: open and close characters, typically ( and )
+   k: balance of opening and closing chars
+   s: the string where we are searching
+   start: the index where we start the search. *)
+let advance_to_closing opening closing k s start =
+  let rec advance k i lim =
+    if i >= lim then raise Not_found else
+    if s.[i] = opening then advance (k + 1) (i + 1) lim else
+    if s.[i] = closing then
+      if k = 0 then i else advance (k - 1) (i + 1) lim
+    else advance k (i + 1) lim in
+  advance k start (String.length s)
+
+let advance_to_non_alpha s start =
+  let rec advance i lim =
+    if i >= lim then lim else
+    match s.[i] with
+    | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> advance (i + 1) lim
+    | _ -> i in
+  advance start (String.length s)
+
+(* We are just at the beginning of an ident in s, starting at start. *)
+let find_ident s start lim =
+  if start >= lim then raise Not_found else
+  match s.[start] with
+  (* Parenthesized ident ? *)
+  | '(' | '{' as c ->
+     let new_start = start + 1 in
+     let stop = advance_to_closing c (closing c) 0 s new_start in
+     String.sub s new_start (stop - start - 1), stop + 1
+  (* Regular ident *)
+  | _ ->
+     let stop = advance_to_non_alpha s (start + 1) in
+     String.sub s start (stop - start), stop
+
+(* Substitute $ident, $(ident), or ${ident} in s,
+    according to the function mapping f. *)
+let add_substitute b f s =
+  let lim = String.length s in
+  let rec subst previous i =
+    if i < lim then begin
+      match s.[i] with
+      | '$' as current when previous = '\\' ->
+         add_char b current;
+         subst ' ' (i + 1)
+      | '$' ->
+         let j = i + 1 in
+         let ident, next_i = find_ident s j lim in
+         add_string b (f ident);
+         subst ' ' next_i
+      | current when previous == '\\' ->
+         add_char b '\\';
+         add_char b current;
+         subst ' ' (i + 1)
+      | '\\' as current ->
+         subst current (i + 1)
+      | current ->
+         add_char b current;
+         subst current (i + 1)
+    end else
+    if previous = '\\' then add_char b previous in
+  subst ' ' 0
+
+let truncate b len =
+    if len < 0 || len > length b then
+      invalid_arg "Buffer.truncate"
+    else
+      b.position <- len
+
+(** {1 Iterators} *)
+
+let to_seq b =
+  let rec aux i () =
+    (* Note that b.position is not a constant and cannot be lifted out of aux *)
+    if i >= b.position then Seq.Nil
+    else
+      let x = Bytes.get b.inner.buffer i in
+      Seq.Cons (x, aux (i+1))
+  in
+  aux 0
+
+let to_seqi b =
+  let rec aux i () =
+    (* Note that b.position is not a constant and cannot be lifted out of aux *)
+    if i >= b.position then Seq.Nil
+    else
+      let x = Bytes.get b.inner.buffer i in
+      Seq.Cons ((i,x), aux (i+1))
+  in
+  aux 0
+
+let add_seq b seq = Seq.iter (add_char b) seq
+
+let of_seq i =
+  let b = create 32 in
+  add_seq b i;
+  b
+
+(** {6 Binary encoding of integers} *)
+
+external unsafe_set_int8 : bytes -> int -> int -> unit = "%bytes_unsafe_set"
+external unsafe_set_int16 : bytes -> int -> int -> unit = "%caml_bytes_set16u"
+external unsafe_set_int32 : bytes -> int -> int32 -> unit = "%caml_bytes_set32u"
+external unsafe_set_int64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64u"
+external set_int8 : bytes -> int -> int -> unit = "%bytes_safe_set"
+external set_int16 : bytes -> int -> int -> unit = "%caml_bytes_set16"
+external set_int32 : bytes -> int -> int32 -> unit = "%caml_bytes_set32"
+external set_int64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64"
+
+external swap16 : int -> int = "%bswap16"
+external swap32 : int32 -> int32 = "%bswap_int32"
+external swap64 : int64 -> int64 = "%bswap_int64"
+
+
+let add_int8 b x =
+  let position = b.position in
+  let {length; buffer} = b.inner in
+  let new_position = position + 1 in
+  if new_position > length then (
+    resize b 1;
+    set_int8 b.inner.buffer b.position x
+  ) else
+    unsafe_set_int8 buffer position x;
+  b.position <- new_position
+
+let add_int16_ne b x =
+  let position = b.position in
+  let {length; buffer} = b.inner in
+  let new_position = position + 2 in
+  if new_position > length then (
+    resize b 2;
+    set_int16 b.inner.buffer b.position x
+  ) else
+    unsafe_set_int16 buffer position x;
+  b.position <- new_position
+
+let add_int32_ne b x =
+  let position = b.position in
+  let {length; buffer} = b.inner in
+  let new_position = position + 4 in
+  if new_position > length then (
+    resize b 4;
+    set_int32 b.inner.buffer b.position x
+  ) else
+    unsafe_set_int32 buffer position x;
+  b.position <- new_position
+
+let add_int64_ne b x =
+  let position = b.position in
+  let {length; buffer} = b.inner in
+  let new_position = position + 8 in
+  if new_position > length then (
+    resize b 8;
+    set_int64 b.inner.buffer b.position x
+  ) else
+    unsafe_set_int64 buffer position x;
+  b.position <- new_position
+
+let add_int16_le b x =
+  add_int16_ne b (if Sys.big_endian then swap16 x else x)
+
+let add_int16_be b x =
+  add_int16_ne b (if Sys.big_endian then x else swap16 x)
+
+let add_int32_le b x =
+  add_int32_ne b (if Sys.big_endian then swap32 x else x)
+
+let add_int32_be b x =
+  add_int32_ne b (if Sys.big_endian then x else swap32 x)
+
+let add_int64_le b x =
+  add_int64_ne b (if Sys.big_endian then swap64 x else x)
+
+let add_int64_be b x =
+  add_int64_ne b (if Sys.big_endian then x else swap64 x)
+
+let add_uint8 = add_int8
+let add_uint16_ne = add_int16_ne
+let add_uint16_le = add_int16_le
+let add_uint16_be = add_int16_be
+
+
+
+ + + diff --git a/_coverage/src/bytes/bytescp.ml.html b/_coverage/src/bytes/bytescp.ml.html new file mode 100644 index 000000000..11af8978a --- /dev/null +++ b/_coverage/src/bytes/bytescp.ml.html @@ -0,0 +1,3013 @@ + + + + + bytescp.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+174
+175
+176
+177
+178
+179
+180
+181
+182
+183
+184
+185
+186
+187
+188
+189
+190
+191
+192
+193
+194
+195
+196
+197
+198
+199
+200
+201
+202
+203
+204
+205
+206
+207
+208
+209
+210
+211
+212
+213
+214
+215
+216
+217
+218
+219
+220
+221
+222
+223
+224
+225
+226
+227
+228
+229
+230
+231
+232
+233
+234
+235
+236
+237
+238
+239
+240
+241
+242
+243
+244
+245
+246
+247
+248
+249
+250
+251
+252
+253
+254
+255
+256
+257
+258
+259
+260
+261
+262
+263
+264
+265
+266
+267
+268
+269
+270
+271
+272
+273
+274
+275
+276
+277
+278
+279
+280
+281
+282
+283
+284
+285
+286
+287
+288
+289
+290
+291
+292
+293
+294
+295
+296
+297
+298
+299
+300
+301
+302
+303
+304
+305
+306
+307
+308
+309
+310
+311
+312
+313
+314
+315
+316
+317
+318
+319
+320
+321
+322
+323
+324
+325
+326
+327
+328
+329
+330
+331
+332
+333
+334
+335
+336
+337
+338
+339
+340
+341
+342
+343
+344
+345
+346
+347
+348
+349
+350
+351
+352
+353
+354
+355
+356
+357
+358
+359
+360
+361
+362
+363
+364
+365
+366
+367
+368
+369
+370
+371
+372
+373
+374
+375
+376
+377
+378
+379
+380
+381
+382
+383
+384
+385
+386
+387
+388
+389
+390
+391
+392
+393
+394
+395
+396
+397
+398
+399
+400
+401
+402
+403
+404
+405
+406
+407
+408
+409
+410
+411
+412
+413
+414
+415
+416
+417
+418
+419
+420
+421
+422
+423
+424
+425
+426
+427
+428
+429
+430
+431
+432
+433
+434
+435
+436
+437
+438
+439
+440
+441
+442
+443
+444
+445
+446
+447
+448
+449
+450
+451
+452
+453
+454
+455
+456
+457
+458
+459
+460
+461
+462
+463
+464
+465
+466
+467
+468
+469
+470
+471
+472
+473
+474
+475
+476
+477
+478
+479
+480
+481
+482
+483
+484
+485
+486
+487
+488
+489
+490
+491
+492
+493
+494
+495
+496
+497
+498
+499
+500
+501
+502
+503
+504
+505
+506
+507
+508
+509
+510
+511
+512
+513
+514
+515
+516
+517
+518
+519
+520
+521
+522
+523
+524
+525
+526
+527
+528
+529
+530
+531
+532
+533
+534
+535
+536
+537
+538
+539
+540
+541
+542
+543
+544
+545
+546
+547
+548
+549
+550
+551
+552
+553
+554
+555
+556
+557
+558
+559
+560
+561
+562
+563
+564
+565
+566
+567
+568
+569
+570
+571
+572
+573
+574
+575
+576
+577
+578
+579
+580
+581
+582
+583
+584
+585
+586
+587
+588
+589
+590
+591
+592
+593
+594
+595
+596
+597
+598
+599
+600
+601
+602
+603
+604
+605
+606
+607
+608
+609
+610
+611
+612
+613
+614
+615
+616
+617
+618
+619
+620
+621
+622
+623
+624
+625
+626
+627
+628
+629
+630
+631
+632
+633
+634
+635
+636
+637
+638
+639
+640
+641
+642
+643
+644
+645
+646
+647
+648
+649
+650
+651
+652
+653
+654
+655
+656
+657
+658
+659
+660
+661
+662
+663
+664
+665
+666
+667
+668
+669
+670
+671
+672
+673
+674
+675
+676
+677
+678
+679
+680
+681
+682
+683
+684
+685
+686
+687
+688
+689
+690
+691
+692
+693
+694
+695
+696
+697
+698
+699
+700
+701
+702
+703
+704
+705
+706
+707
+708
+709
+710
+711
+712
+713
+714
+715
+716
+717
+718
+719
+720
+721
+722
+723
+724
+725
+726
+727
+728
+729
+730
+731
+732
+733
+734
+735
+736
+737
+738
+739
+740
+741
+742
+743
+744
+745
+746
+747
+748
+749
+750
+751
+752
+753
+754
+755
+756
+757
+758
+759
+760
+761
+762
+763
+764
+765
+766
+767
+768
+769
+770
+771
+772
+773
+774
+775
+776
+777
+778
+779
+780
+781
+782
+783
+784
+785
+786
+787
+788
+789
+790
+791
+792
+793
+794
+795
+796
+797
+798
+799
+800
+801
+802
+803
+804
+805
+806
+807
+808
+809
+810
+811
+812
+813
+814
+815
+816
+817
+818
+819
+820
+821
+822
+823
+824
+825
+826
+827
+828
+829
+830
+831
+832
+833
+834
+835
+836
+837
+838
+839
+840
+841
+842
+843
+844
+845
+846
+847
+848
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Byte sequence operations *)
+
+(* WARNING: Some functions in this file are duplicated in string.ml for
+   efficiency reasons. When you modify the one in this file you need to
+   modify its duplicate in string.ml.
+   These functions have a "duplicated" comment above their definition.
+*)
+
+external length : bytes -> int = "%bytes_length"
+external string_length : string -> int = "%string_length"
+external get : bytes -> int -> char = "%bytes_safe_get"
+external set : bytes -> int -> char -> unit = "%bytes_safe_set"
+external create : int -> bytes = "caml_create_bytes"
+external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
+external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
+external unsafe_fill : bytes -> int -> int -> char -> unit
+                     = "caml_fill_bytes" [@@noalloc]
+external unsafe_to_string : bytes -> string = "%bytes_to_string"
+external unsafe_of_string : string -> bytes = "%bytes_of_string"
+
+external unsafe_blit : bytes -> int -> bytes -> int -> int -> unit
+                     = "caml_blit_bytes" [@@noalloc]
+external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit
+                     = "caml_blit_string" [@@noalloc]
+
+let make n c =
+  let s = create n in
+  unsafe_fill s 0 n c;
+  s
+
+let init n f =
+  let s = create n in
+  for i = 0 to n - 1 do
+    unsafe_set s i (f i)
+  done;
+  s
+
+let empty = create 0
+
+let copy s =
+  let len = length s in
+  let r = create len in
+  unsafe_blit s 0 r 0 len;
+  r
+
+let to_string b = unsafe_to_string (copy b)
+let of_string s = copy (unsafe_of_string s)
+
+let sub s ofs len =
+  if ofs < 0 || len < 0 || ofs > length s - len
+  then invalid_arg "String.sub / Bytes.sub"
+  else begin
+    let r = create len in
+    unsafe_blit s ofs r 0 len;
+    r
+  end
+
+let sub_string b ofs len = unsafe_to_string (sub b ofs len)
+
+(* addition with an overflow check *)
+let (++) a b =
+  let c = a + b in
+  match a < 0, b < 0, c < 0 with
+  | true , true , false
+  | false, false, true  -> invalid_arg "Bytes.extend" (* overflow *)
+  | _ -> c
+
+let extend s left right =
+  let len = length s ++ left ++ right in
+  let r = create len in
+  let (srcoff, dstoff) = if left < 0 then -left, 0 else 0, left in
+  let cpylen = Int.min (length s - srcoff) (len - dstoff) in
+  if cpylen > 0 then unsafe_blit s srcoff r dstoff cpylen;
+  r
+
+let fill s ofs len c =
+  if ofs < 0 || len < 0 || ofs > length s - len
+  then invalid_arg "String.fill / Bytes.fill"
+  else unsafe_fill s ofs len c
+
+let blit s1 ofs1 s2 ofs2 len =
+  if len < 0 || ofs1 < 0 || ofs1 > length s1 - len
+             || ofs2 < 0 || ofs2 > length s2 - len
+  then invalid_arg "Bytes.blit"
+  else unsafe_blit s1 ofs1 s2 ofs2 len
+
+let blit_string s1 ofs1 s2 ofs2 len =
+  if len < 0 || ofs1 < 0 || ofs1 > string_length s1 - len
+             || ofs2 < 0 || ofs2 > length s2 - len
+  then invalid_arg "String.blit / Bytes.blit_string"
+  else unsafe_blit_string s1 ofs1 s2 ofs2 len
+
+(* duplicated in string.ml *)
+let iter f a =
+  for i = 0 to length a - 1 do f(unsafe_get a i) done
+
+(* duplicated in string.ml *)
+let iteri f a =
+  for i = 0 to length a - 1 do f i (unsafe_get a i) done
+
+let ensure_ge (x:int) y = if x >= y then x else invalid_arg "Bytes.concat"
+
+let rec sum_lengths acc seplen = function
+  | [] -> acc
+  | hd :: [] -> length hd + acc
+  | hd :: tl -> sum_lengths (ensure_ge (length hd + seplen + acc) acc) seplen tl
+
+let rec unsafe_blits dst pos sep seplen = function
+    [] -> dst
+  | hd :: [] ->
+    unsafe_blit hd 0 dst pos (length hd); dst
+  | hd :: tl ->
+    unsafe_blit hd 0 dst pos (length hd);
+    unsafe_blit sep 0 dst (pos + length hd) seplen;
+    unsafe_blits dst (pos + length hd + seplen) sep seplen tl
+
+let concat sep = function
+    [] -> empty
+  | l -> let seplen = length sep in
+          unsafe_blits
+            (create (sum_lengths 0 seplen l))
+            0 sep seplen l
+
+let cat s1 s2 =
+  let l1 = length s1 in
+  let l2 = length s2 in
+  let r = create (l1 + l2) in
+  unsafe_blit s1 0 r 0 l1;
+  unsafe_blit s2 0 r l1 l2;
+  r
+
+
+external char_code: char -> int = "%identity"
+external char_chr: int -> char = "%identity"
+
+let is_space = function
+  | ' ' | '\012' | '\n' | '\r' | '\t' -> true
+  | _ -> false
+
+let trim s =
+  let len = length s in
+  let i = ref 0 in
+  while !i < len && is_space (unsafe_get s !i) do
+    incr i
+  done;
+  let j = ref (len - 1) in
+  while !j >= !i && is_space (unsafe_get s !j) do
+    decr j
+  done;
+  if !j >= !i then
+    sub s !i (!j - !i + 1)
+  else
+    empty
+
+let unsafe_escape s =
+  (* We perform two passes on the input sequence, one to compute the
+     result size and one to write the result.
+
+     #11508, #11509: This logic would be incorrect in presence of
+     concurrent modification to the input, making the use of
+     [unsafe_set] below memory-unsafe.
+
+     Precondition: This function may be safely called on:
+     - an immutable byte sequence
+     - a uniquely-owned byte sequence (the function takes ownership)
+
+     In either case we return a uniquely-owned byte sequence.
+  *)
+  let n = ref 0 in
+  for i = 0 to length s - 1 do
+    n := !n +
+      (match unsafe_get s i with
+       | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
+       | ' ' .. '~' -> 1
+       | _ -> 4)
+  done;
+  if !n = length s then s
+  else begin
+    let s' = create !n in
+    n := 0;
+    for i = 0 to length s - 1 do
+      begin match unsafe_get s i with
+      | ('\"' | '\\') as c ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c
+      | '\n' ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n'
+      | '\t' ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't'
+      | '\r' ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r'
+      | '\b' ->
+          unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b'
+      | (' ' .. '~') as c -> unsafe_set s' !n c
+      | c ->
+          let a = char_code c in
+          unsafe_set s' !n '\\';
+          incr n;
+          unsafe_set s' !n (char_chr (48 + a / 100));
+          incr n;
+          unsafe_set s' !n (char_chr (48 + (a / 10) mod 10));
+          incr n;
+          unsafe_set s' !n (char_chr (48 + a mod 10));
+      end;
+      incr n
+    done;
+    s'
+  end
+
+let escaped b =
+  let b = copy b in
+  (* We copy our input to obtain a uniquely-owned byte sequence [b]
+     to satisfy [unsafe_escape]'s precondition *)
+  unsafe_escape b
+
+let map f s =
+  let l = length s in
+  if l = 0 then s else begin
+    let r = create l in
+    for i = 0 to l - 1 do unsafe_set r i (f (unsafe_get s i)) done;
+    r
+  end
+
+let mapi f s =
+  let l = length s in
+  if l = 0 then s else begin
+    let r = create l in
+    for i = 0 to l - 1 do unsafe_set r i (f i (unsafe_get s i)) done;
+    r
+  end
+
+let fold_left f x a =
+  let r = ref x in
+  for i = 0 to length a - 1 do
+    r := f !r (unsafe_get a i)
+  done;
+  !r
+
+let fold_right f a x =
+  let r = ref x in
+  for i = length a - 1 downto 0 do
+    r := f (unsafe_get a i) !r
+  done;
+  !r
+
+let exists p s =
+  let n = length s in
+  let rec loop i =
+    if i = n then false
+    else if p (unsafe_get s i) then true
+    else loop (succ i) in
+  loop 0
+
+let for_all p s =
+  let n = length s in
+  let rec loop i =
+    if i = n then true
+    else if p (unsafe_get s i) then loop (succ i)
+    else false in
+  loop 0
+
+let uppercase_ascii s = map Char.uppercase_ascii s
+let lowercase_ascii s = map Char.lowercase_ascii s
+
+let apply1 f s =
+  if length s = 0 then s else begin
+    let r = copy s in
+    unsafe_set r 0 (f(unsafe_get s 0));
+    r
+  end
+
+let capitalize_ascii s = apply1 Char.uppercase_ascii s
+let uncapitalize_ascii s = apply1 Char.lowercase_ascii s
+
+(* duplicated in string.ml *)
+let starts_with ~prefix s =
+  let len_s = length s
+  and len_pre = length prefix in
+  let rec aux i =
+    if i = len_pre then true
+    else if unsafe_get s i <> unsafe_get prefix i then false
+    else aux (i + 1)
+  in len_s >= len_pre && aux 0
+
+(* duplicated in string.ml *)
+let ends_with ~suffix s =
+  let len_s = length s
+  and len_suf = length suffix in
+  let diff = len_s - len_suf in
+  let rec aux i =
+    if i = len_suf then true
+    else if unsafe_get s (diff + i) <> unsafe_get suffix i then false
+    else aux (i + 1)
+  in diff >= 0 && aux 0
+
+(* duplicated in string.ml *)
+let rec index_rec s lim i c =
+  if i >= lim then raise Not_found else
+  if unsafe_get s i = c then i else index_rec s lim (i + 1) c
+
+(* duplicated in string.ml *)
+let index s c = index_rec s (length s) 0 c
+
+(* duplicated in string.ml *)
+let rec index_rec_opt s lim i c =
+  if i >= lim then None else
+  if unsafe_get s i = c then Some i else index_rec_opt s lim (i + 1) c
+
+(* duplicated in string.ml *)
+let index_opt s c = index_rec_opt s (length s) 0 c
+
+(* duplicated in string.ml *)
+let index_from s i c =
+  let l = length s in
+  if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else
+  index_rec s l i c
+
+(* duplicated in string.ml *)
+let index_from_opt s i c =
+  let l = length s in
+  if i < 0 || i > l then
+    invalid_arg "String.index_from_opt / Bytes.index_from_opt"
+  else
+    index_rec_opt s l i c
+
+(* duplicated in string.ml *)
+let rec rindex_rec s i c =
+  if i < 0 then raise Not_found else
+  if unsafe_get s i = c then i else rindex_rec s (i - 1) c
+
+(* duplicated in string.ml *)
+let rindex s c = rindex_rec s (length s - 1) c
+
+(* duplicated in string.ml *)
+let rindex_from s i c =
+  if i < -1 || i >= length s then
+    invalid_arg "String.rindex_from / Bytes.rindex_from"
+  else
+    rindex_rec s i c
+
+(* duplicated in string.ml *)
+let rec rindex_rec_opt s i c =
+  if i < 0 then None else
+  if unsafe_get s i = c then Some i else rindex_rec_opt s (i - 1) c
+
+(* duplicated in string.ml *)
+let rindex_opt s c = rindex_rec_opt s (length s - 1) c
+
+(* duplicated in string.ml *)
+let rindex_from_opt s i c =
+  if i < -1 || i >= length s then
+    invalid_arg "String.rindex_from_opt / Bytes.rindex_from_opt"
+  else
+    rindex_rec_opt s i c
+
+
+(* duplicated in string.ml *)
+let contains_from s i c =
+  let l = length s in
+  if i < 0 || i > l then
+    invalid_arg "String.contains_from / Bytes.contains_from"
+  else
+    try ignore (index_rec s l i c); true with Not_found -> false
+
+
+(* duplicated in string.ml *)
+let contains s c = contains_from s 0 c
+
+(* duplicated in string.ml *)
+let rcontains_from s i c =
+  if i < 0 || i >= length s then
+    invalid_arg "String.rcontains_from / Bytes.rcontains_from"
+  else
+    try ignore (rindex_rec s i c); true with Not_found -> false
+
+
+type t = bytes
+
+let compare (x: t) (y: t) = Stdlib.compare x y
+external equal : t -> t -> bool = "caml_bytes_equal" [@@noalloc]
+
+(* duplicated in string.ml *)
+let split_on_char sep s =
+  let r = ref [] in
+  let j = ref (length s) in
+  for i = length s - 1 downto 0 do
+    if unsafe_get s i = sep then begin
+      r := sub s (i + 1) (!j - i - 1) :: !r;
+      j := i
+    end
+  done;
+  sub s 0 !j :: !r
+
+(** {1 Iterators} *)
+
+let to_seq s =
+  let rec aux i () =
+    if i = length s then Seq.Nil
+    else
+      let x = get s i in
+      Seq.Cons (x, aux (i+1))
+  in
+  aux 0
+
+let to_seqi s =
+  let rec aux i () =
+    if i = length s then Seq.Nil
+    else
+      let x = get s i in
+      Seq.Cons ((i,x), aux (i+1))
+  in
+  aux 0
+
+let of_seq i =
+  let n = ref 0 in
+  let buf = ref (make 256 '\000') in
+  let resize () =
+    (* resize *)
+    let new_len = Int.min (2 * length !buf) Sys.max_string_length in
+    if length !buf = new_len then failwith "Bytes.of_seq: cannot grow bytes";
+    let new_buf = make new_len '\000' in
+    blit !buf 0 new_buf 0 !n;
+    buf := new_buf
+  in
+  Seq.iter
+    (fun c ->
+       if !n = length !buf then resize();
+       set !buf !n c;
+       incr n)
+    i;
+  sub !buf 0 !n
+
+(** {6 Binary encoding/decoding of integers} *)
+
+(* The get_ functions are all duplicated in string.ml *)
+
+external unsafe_get_uint8 : bytes -> int -> int = "%bytes_unsafe_get"
+external unsafe_get_uint16_ne : bytes -> int -> int = "%caml_bytes_get16u"
+external get_uint8 : bytes -> int -> int = "%bytes_safe_get"
+external get_uint16_ne : bytes -> int -> int = "%caml_bytes_get16"
+external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32"
+external get_int64_ne : bytes -> int -> int64 = "%caml_bytes_get64"
+
+external unsafe_set_uint8 : bytes -> int -> int -> unit = "%bytes_unsafe_set"
+external unsafe_set_uint16_ne : bytes -> int -> int -> unit
+                              = "%caml_bytes_set16u"
+external set_int8 : bytes -> int -> int -> unit = "%bytes_safe_set"
+external set_int16_ne : bytes -> int -> int -> unit = "%caml_bytes_set16"
+external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_bytes_set32"
+external set_int64_ne : bytes -> int -> int64 -> unit = "%caml_bytes_set64"
+external swap16 : int -> int = "%bswap16"
+external swap32 : int32 -> int32 = "%bswap_int32"
+external swap64 : int64 -> int64 = "%bswap_int64"
+
+let unsafe_get_uint16_le b i =
+  if Sys.big_endian
+  then swap16 (unsafe_get_uint16_ne b i)
+  else unsafe_get_uint16_ne b i
+
+let unsafe_get_uint16_be b i =
+  if Sys.big_endian
+  then unsafe_get_uint16_ne b i
+  else swap16 (unsafe_get_uint16_ne b i)
+
+let get_int8 b i =
+  ((get_uint8 b i) lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)
+
+let get_uint16_le b i =
+  if Sys.big_endian then swap16 (get_uint16_ne b i)
+  else get_uint16_ne b i
+
+let get_uint16_be b i =
+  if not Sys.big_endian then swap16 (get_uint16_ne b i)
+  else get_uint16_ne b i
+
+let get_int16_ne b i =
+  ((get_uint16_ne b i) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
+
+let get_int16_le b i =
+  ((get_uint16_le b i) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
+
+let get_int16_be b i =
+  ((get_uint16_be b i) lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)
+
+let get_int32_le b i =
+  if Sys.big_endian then swap32 (get_int32_ne b i)
+  else get_int32_ne b i
+
+let get_int32_be b i =
+  if not Sys.big_endian then swap32 (get_int32_ne b i)
+  else get_int32_ne b i
+
+let get_int64_le b i =
+  if Sys.big_endian then swap64 (get_int64_ne b i)
+  else get_int64_ne b i
+
+let get_int64_be b i =
+  if not Sys.big_endian then swap64 (get_int64_ne b i)
+  else get_int64_ne b i
+
+let unsafe_set_uint16_le b i x =
+  if Sys.big_endian
+  then unsafe_set_uint16_ne b i (swap16 x)
+  else unsafe_set_uint16_ne b i x
+
+let unsafe_set_uint16_be b i x =
+  if Sys.big_endian
+  then unsafe_set_uint16_ne b i x else
+  unsafe_set_uint16_ne b i (swap16 x)
+
+let set_int16_le b i x =
+  if Sys.big_endian then set_int16_ne b i (swap16 x)
+  else set_int16_ne b i x
+
+let set_int16_be b i x =
+  if not Sys.big_endian then set_int16_ne b i (swap16 x)
+  else set_int16_ne b i x
+
+let set_int32_le b i x =
+  if Sys.big_endian then set_int32_ne b i (swap32 x)
+  else set_int32_ne b i x
+
+let set_int32_be b i x =
+  if not Sys.big_endian then set_int32_ne b i (swap32 x)
+  else set_int32_ne b i x
+
+let set_int64_le b i x =
+  if Sys.big_endian then set_int64_ne b i (swap64 x)
+  else set_int64_ne b i x
+
+let set_int64_be b i x =
+  if not Sys.big_endian then set_int64_ne b i (swap64 x)
+  else set_int64_ne b i x
+
+let set_uint8 = set_int8
+let set_uint16_ne = set_int16_ne
+let set_uint16_be = set_int16_be
+let set_uint16_le = set_int16_le
+
+(* UTF codecs and validations *)
+
+let dec_invalid = Uchar.utf_decode_invalid
+let[@inline] dec_ret n u = Uchar.utf_decode n (Uchar.unsafe_of_int u)
+
+(* In case of decoding error, if we error on the first byte, we
+   consume the byte, otherwise we consume the [n] bytes preceding
+   the erroring byte.
+
+   This means that if a client uses decodes without caring about
+   validity it naturally replace bogus data with Uchar.rep according
+   to the WHATWG Encoding standard. Other schemes are possible by
+   consulting the number of used bytes on invalid decodes. For more
+   details see https://hsivonen.fi/broken-utf-8/
+
+   For this reason in [get_utf_8_uchar] we gradually check the next
+   byte is available rather than doing it immediately after the
+   first byte. Contrast with [is_valid_utf_8]. *)
+
+(* UTF-8 *)
+
+let[@inline] not_in_x80_to_xBF b = b lsr 6 <> 0b10
+let[@inline] not_in_xA0_to_xBF b = b lsr 5 <> 0b101
+let[@inline] not_in_x80_to_x9F b = b lsr 5 <> 0b100
+let[@inline] not_in_x90_to_xBF b = b < 0x90 || 0xBF < b
+let[@inline] not_in_x80_to_x8F b = b lsr 4 <> 0x8
+
+let[@inline] utf_8_uchar_2 b0 b1 =
+  ((b0 land 0x1F) lsl 6) lor
+  ((b1 land 0x3F))
+
+let[@inline] utf_8_uchar_3 b0 b1 b2 =
+  ((b0 land 0x0F) lsl 12) lor
+  ((b1 land 0x3F) lsl 6) lor
+  ((b2 land 0x3F))
+
+let[@inline] utf_8_uchar_4 b0 b1 b2 b3 =
+  ((b0 land 0x07) lsl 18) lor
+  ((b1 land 0x3F) lsl 12) lor
+  ((b2 land 0x3F) lsl 6) lor
+  ((b3 land 0x3F))
+
+let get_utf_8_uchar b i =
+  let b0 = get_uint8 b i in (* raises if [i] is not a valid index. *)
+  let get = unsafe_get_uint8 in
+  let max = length b - 1 in
+  match Char.unsafe_chr b0 with (* See The Unicode Standard, Table 3.7 *)
+  | '\x00' .. '\x7F' -> dec_ret 1 b0
+  | '\xC2' .. '\xDF' ->
+      let i = i + 1 in if i > max then dec_invalid 1 else
+      let b1 = get b i in if not_in_x80_to_xBF b1 then dec_invalid 1 else
+      dec_ret 2 (utf_8_uchar_2 b0 b1)
+  | '\xE0' ->
+      let i = i + 1 in if i > max then dec_invalid 1 else
+      let b1 = get b i in if not_in_xA0_to_xBF b1 then dec_invalid 1 else
+      let i = i + 1 in if i > max then dec_invalid 2 else
+      let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
+      dec_ret 3 (utf_8_uchar_3 b0 b1 b2)
+  | '\xE1' .. '\xEC' | '\xEE' .. '\xEF' ->
+      let i = i + 1 in if i > max then dec_invalid 1 else
+      let b1 = get b i in if not_in_x80_to_xBF b1 then dec_invalid 1 else
+      let i = i + 1 in if i > max then dec_invalid 2 else
+      let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
+      dec_ret 3 (utf_8_uchar_3 b0 b1 b2)
+  | '\xED' ->
+      let i = i + 1 in if i > max then dec_invalid 1 else
+      let b1 = get b i in if not_in_x80_to_x9F b1 then dec_invalid 1 else
+      let i = i + 1 in if i > max then dec_invalid 2 else
+      let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
+      dec_ret 3 (utf_8_uchar_3 b0 b1 b2)
+  | '\xF0' ->
+      let i = i + 1 in if i > max then dec_invalid 1 else
+      let b1 = get b i in if not_in_x90_to_xBF b1 then dec_invalid 1 else
+      let i = i + 1 in if i > max then dec_invalid 2 else
+      let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
+      let i = i + 1 in if i > max then dec_invalid 3 else
+      let b3 = get b i in if not_in_x80_to_xBF b3 then dec_invalid 3 else
+      dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3)
+  | '\xF1' .. '\xF3' ->
+      let i = i + 1 in if i > max then dec_invalid 1 else
+      let b1 = get b i in if not_in_x80_to_xBF b1 then dec_invalid 1 else
+      let i = i + 1 in if i > max then dec_invalid 2 else
+      let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
+      let i = i + 1 in if i > max then dec_invalid 3 else
+      let b3 = get b i in if not_in_x80_to_xBF b3 then dec_invalid 3 else
+      dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3)
+  | '\xF4' ->
+      let i = i + 1 in if i > max then dec_invalid 1 else
+      let b1 = get b i in if not_in_x80_to_x8F b1 then dec_invalid 1 else
+      let i = i + 1 in if i > max then dec_invalid 2 else
+      let b2 = get b i in if not_in_x80_to_xBF b2 then dec_invalid 2 else
+      let i = i + 1 in if i > max then dec_invalid 3 else
+      let b3 = get b i in if not_in_x80_to_xBF b3 then dec_invalid 3 else
+      dec_ret 4 (utf_8_uchar_4 b0 b1 b2 b3)
+  | _ -> dec_invalid 1
+
+let set_utf_8_uchar b i u =
+  let set = unsafe_set_uint8 in
+  let max = length b - 1 in
+  match Uchar.to_int u with
+  | u when u < 0 -> assert false
+  | u when u <= 0x007F ->
+      set_uint8 b i u;
+      1
+  | u when u <= 0x07FF ->
+      let last = i + 1 in
+      if last > max then 0 else
+      (set_uint8 b i (0xC0 lor (u lsr 6));
+       set b last (0x80 lor (u land 0x3F));
+       2)
+  | u when u <= 0xFFFF ->
+      let last = i + 2 in
+      if last > max then 0 else
+      (set_uint8 b i (0xE0 lor (u lsr 12));
+       set b (i + 1) (0x80 lor ((u lsr 6) land 0x3F));
+       set b last (0x80 lor (u land 0x3F));
+       3)
+  | u when u <= 0x10FFFF ->
+      let last = i + 3 in
+      if last > max then 0 else
+      (set_uint8 b i (0xF0 lor (u lsr 18));
+       set b (i + 1) (0x80 lor ((u lsr 12) land 0x3F));
+       set b (i + 2) (0x80 lor ((u lsr 6) land 0x3F));
+       set b last (0x80 lor (u land 0x3F));
+       4)
+  | _ -> assert false
+
+let is_valid_utf_8 b =
+  let rec loop max b i =
+    if i > max then true else
+    let get = unsafe_get_uint8 in
+    match Char.unsafe_chr (get b i) with
+    | '\x00' .. '\x7F' -> loop max b (i + 1)
+    | '\xC2' .. '\xDF' ->
+        let last = i + 1 in
+        if last > max
+        || not_in_x80_to_xBF (get b last)
+        then false
+        else loop max b (last + 1)
+    | '\xE0' ->
+        let last = i + 2 in
+        if last > max
+        || not_in_xA0_to_xBF (get b (i + 1))
+        || not_in_x80_to_xBF (get b last)
+        then false
+        else loop max b (last + 1)
+    | '\xE1' .. '\xEC' | '\xEE' .. '\xEF' ->
+        let last = i + 2 in
+        if last > max
+        || not_in_x80_to_xBF (get b (i + 1))
+        || not_in_x80_to_xBF (get b last)
+        then false
+        else loop max b (last + 1)
+    | '\xED' ->
+        let last = i + 2 in
+        if last > max
+        || not_in_x80_to_x9F (get b (i + 1))
+        || not_in_x80_to_xBF (get b last)
+        then false
+        else loop max b (last + 1)
+    | '\xF0' ->
+        let last = i + 3 in
+        if last > max
+        || not_in_x90_to_xBF (get b (i + 1))
+        || not_in_x80_to_xBF (get b (i + 2))
+        || not_in_x80_to_xBF (get b last)
+        then false
+        else loop max b (last + 1)
+    | '\xF1' .. '\xF3' ->
+        let last = i + 3 in
+        if last > max
+        || not_in_x80_to_xBF (get b (i + 1))
+        || not_in_x80_to_xBF (get b (i + 2))
+        || not_in_x80_to_xBF (get b last)
+        then false
+        else loop max b (last + 1)
+    | '\xF4' ->
+        let last = i + 3 in
+        if last > max
+        || not_in_x80_to_x8F (get b (i + 1))
+        || not_in_x80_to_xBF (get b (i + 2))
+        || not_in_x80_to_xBF (get b last)
+        then false
+        else loop max b (last + 1)
+    | _ -> false
+  in
+  loop (length b - 1) b 0
+
+(* UTF-16BE *)
+
+let get_utf_16be_uchar b i =
+  let get = unsafe_get_uint16_be in
+  let max = length b - 1 in
+  if i < 0 || i > max then invalid_arg "index out of bounds" else
+  if i = max then dec_invalid 1 else
+  match get b i with
+  | u when u < 0xD800 || u > 0xDFFF -> dec_ret 2 u
+  | u when u > 0xDBFF -> dec_invalid 2
+  | hi -> (* combine [hi] with a low surrogate *)
+      let last = i + 3 in
+      if last > max then dec_invalid (max - i + 1) else
+      match get b (i + 2) with
+      | u when u < 0xDC00 || u > 0xDFFF -> dec_invalid 2 (* retry here *)
+      | lo ->
+          let u = (((hi land 0x3FF) lsl 10) lor (lo land 0x3FF)) + 0x10000 in
+          dec_ret 4 u
+
+let set_utf_16be_uchar b i u =
+  let set = unsafe_set_uint16_be in
+  let max = length b - 1 in
+  if i < 0 || i > max then invalid_arg "index out of bounds" else
+  match Uchar.to_int u with
+  | u when u < 0 -> assert false
+  | u when u <= 0xFFFF ->
+      let last = i + 1 in
+      if last > max then 0 else (set b i u; 2)
+  | u when u <= 0x10FFFF ->
+      let last = i + 3 in
+      if last > max then 0 else
+      let u' = u - 0x10000 in
+      let hi = (0xD800 lor (u' lsr 10)) in
+      let lo = (0xDC00 lor (u' land 0x3FF)) in
+      set b i hi; set b (i + 2) lo; 4
+  | _ -> assert false
+
+let is_valid_utf_16be b =
+  let rec loop max b i =
+    let get = unsafe_get_uint16_be in
+    if i > max then true else
+    if i = max then false else
+    match get b i with
+    | u when u < 0xD800 || u > 0xDFFF -> loop max b (i + 2)
+    | u when u > 0xDBFF -> false
+    | _hi ->
+        let last = i + 3 in
+        if last > max then false else
+        match get b (i + 2) with
+        | u when u < 0xDC00 || u > 0xDFFF -> false
+        | _lo -> loop max b (i + 4)
+  in
+  loop (length b - 1) b 0
+
+(* UTF-16LE *)
+
+let get_utf_16le_uchar b i =
+  let get = unsafe_get_uint16_le in
+  let max = length b - 1 in
+  if i < 0 || i > max then invalid_arg "index out of bounds" else
+  if i = max then dec_invalid 1 else
+  match get b i with
+  | u when u < 0xD800 || u > 0xDFFF -> dec_ret 2 u
+  | u when u > 0xDBFF -> dec_invalid 2
+  | hi -> (* combine [hi] with a low surrogate *)
+      let last = i + 3 in
+      if last > max then dec_invalid (max - i + 1) else
+      match get b (i + 2) with
+      | u when u < 0xDC00 || u > 0xDFFF -> dec_invalid 2 (* retry here *)
+      | lo ->
+          let u = (((hi land 0x3FF) lsl 10) lor (lo land 0x3FF)) + 0x10000 in
+          dec_ret 4 u
+
+let set_utf_16le_uchar b i u =
+  let set = unsafe_set_uint16_le in
+  let max = length b - 1 in
+  if i < 0 || i > max then invalid_arg "index out of bounds" else
+  match Uchar.to_int u with
+  | u when u < 0 -> assert false
+  | u when u <= 0xFFFF ->
+      let last = i + 1 in
+      if last > max then 0 else (set b i u; 2)
+  | u when u <= 0x10FFFF ->
+      let last = i + 3 in
+      if last > max then 0 else
+      let u' = u - 0x10000 in
+      let hi = (0xD800 lor (u' lsr 10)) in
+      let lo = (0xDC00 lor (u' land 0x3FF)) in
+      set b i hi; set b (i + 2) lo; 4
+  | _ -> assert false
+
+let is_valid_utf_16le b =
+  let rec loop max b i =
+    let get = unsafe_get_uint16_le in
+    if i > max then true else
+    if i = max then false else
+    match get b i with
+    | u when u < 0xD800 || u > 0xDFFF -> loop max b (i + 2)
+    | u when u > 0xDBFF -> false
+    | _hi ->
+        let last = i + 3 in
+        if last > max then false else
+        match get b (i + 2) with
+        | u when u < 0xDC00 || u > 0xDFFF -> false
+        | _lo -> loop max b (i + 4)
+  in
+  loop (length b - 1) b 0
+
+
+
+ + + diff --git a/_coverage/src/domain/domain.ml.html b/_coverage/src/domain/domain.ml.html new file mode 100644 index 000000000..686a484bb --- /dev/null +++ b/_coverage/src/domain/domain.ml.html @@ -0,0 +1,875 @@ + + + + + domain.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+174
+175
+176
+177
+178
+179
+180
+181
+182
+183
+184
+185
+186
+187
+188
+189
+190
+191
+192
+193
+194
+195
+196
+197
+198
+199
+200
+201
+202
+203
+204
+205
+206
+207
+208
+209
+210
+211
+212
+213
+214
+215
+216
+217
+218
+219
+220
+221
+222
+223
+224
+225
+226
+227
+228
+229
+230
+231
+232
+233
+234
+235
+236
+237
+238
+239
+240
+241
+242
+243
+244
+245
+246
+247
+248
+249
+250
+251
+252
+253
+254
+255
+256
+257
+258
+259
+260
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*      KC Sivaramakrishnan, Indian Institute of Technology, Madras       *)
+(*                 Stephen Dolan, University of Cambridge                 *)
+(*                   Tom Kelly, OCaml Labs Consultancy                    *)
+(*                                                                        *)
+(*   Copyright 2019 Indian Institute of Technology, Madras                *)
+(*   Copyright 2014 University of Cambridge                               *)
+(*   Copyright 2021 OCaml Labs Consultancy Ltd                            *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Raw = struct
+  (* Low-level primitives provided by the runtime *)
+  type t = private int
+  external spawn : (unit -> unit) -> Mutex.t -> t
+    = "caml_domain_spawn"
+  external self : unit -> t
+    = "caml_ml_domain_id"
+  external cpu_relax : unit -> unit
+    = "caml_ml_domain_cpu_relax"
+  external get_recommended_domain_count: unit -> int
+    = "caml_recommended_domain_count" [@@noalloc]
+end
+
+let cpu_relax () = Raw.cpu_relax ()
+
+type id = Raw.t
+
+type 'a state =
+| Running
+| Finished of ('a, exn) result
+
+type 'a t = {
+  domain : Raw.t;
+  term_mutex: Mutex.t;
+  term_condition: Condition.t;
+  term_state: 'a state ref (* protected by [term_mutex] *)
+}
+
+module DLS = struct
+
+  type dls_state = Obj.t array
+
+  let unique_value = Obj.repr (ref 0)
+
+  external get_dls_state : unit -> dls_state = "%dls_get"
+
+  external set_dls_state : dls_state -> unit =
+    "caml_domain_dls_set" [@@noalloc]
+
+  let create_dls () =
+    let st = Array.make 8 unique_value in
+    set_dls_state st
+
+  let _ = create_dls ()
+
+  type 'a key = int * (unit -> 'a)
+
+  let key_counter = Atomic.make 0
+
+  type key_initializer =
+    KI: 'a key * ('a -> 'a) -> key_initializer
+
+  let parent_keys = Atomic.make ([] : key_initializer list)
+
+  let rec add_parent_key ki =
+    let l = Atomic.get parent_keys in
+    if not (Atomic.compare_and_set parent_keys l (ki :: l))
+    then add_parent_key ki
+
+  let new_key ?split_from_parent init_orphan =
+    let idx = Atomic.fetch_and_add key_counter 1 in
+    let k = (idx, init_orphan) in
+    begin match split_from_parent with
+    | None -> ()
+    | Some split -> add_parent_key (KI(k, split))
+    end;
+    k
+
+  (* If necessary, grow the current domain's local state array such that [idx]
+   * is a valid index in the array. *)
+  let maybe_grow idx =
+    let st = get_dls_state () in
+    let sz = Array.length st in
+    if idx < sz then st
+    else begin
+      let rec compute_new_size s =
+        if idx < s then s else compute_new_size (2 * s)
+      in
+      let new_sz = compute_new_size sz in
+      let new_st = Array.make new_sz unique_value in
+      Array.blit st 0 new_st 0 sz;
+      set_dls_state new_st;
+      new_st
+    end
+
+  let set (idx, _init) x =
+    let st = maybe_grow idx in
+    (* [Sys.opaque_identity] ensures that flambda does not look at the type of
+     * [x], which may be a [float] and conclude that the [st] is a float array.
+     * We do not want OCaml's float array optimisation kicking in here. *)
+    st.(idx) <- Obj.repr (Sys.opaque_identity x)
+
+  let get (idx, init) =
+    let st = maybe_grow idx in
+    let v = st.(idx) in
+    if v == unique_value then
+      let v' = Obj.repr (init ()) in
+      st.(idx) <- (Sys.opaque_identity v');
+      Obj.magic v'
+    else Obj.magic v
+
+  let get_initial_keys () : (int * Obj.t) list =
+    List.map
+      (fun (KI ((idx, _) as k, split)) ->
+           (idx, Obj.repr (split (get k))))
+      (Atomic.get parent_keys)
+
+  let set_initial_keys (l: (int * Obj.t) list) =
+    List.iter
+      (fun (idx, v) ->
+        let st = maybe_grow idx in st.(idx) <- v)
+      l
+
+end
+
+(******** Identity **********)
+
+let get_id { domain; _ } = domain
+
+let self () = Raw.self ()
+
+let is_main_domain () = (self () :> int) = 0
+
+(******** Callbacks **********)
+
+(* first spawn, domain startup and at exit functionality *)
+let first_domain_spawned = Atomic.make false
+
+let first_spawn_function = ref (fun () -> ())
+
+let before_first_spawn f =
+  if Atomic.get first_domain_spawned then
+    raise (Invalid_argument "first domain already spawned")
+  else begin
+    let old_f = !first_spawn_function in
+    let new_f () = old_f (); f () in
+    first_spawn_function := new_f
+  end
+
+let do_before_first_spawn () =
+  if not (Atomic.get first_domain_spawned) then begin
+    Atomic.set first_domain_spawned true;
+    !first_spawn_function();
+    (* Release the old function *)
+    first_spawn_function := (fun () -> ())
+  end
+
+let at_exit_key = DLS.new_key (fun () -> (fun () -> ()))
+
+let at_exit f =
+  let old_exit : unit -> unit = DLS.get at_exit_key in
+  let new_exit () =
+    (* The domain termination callbacks ([at_exit]) are run in
+       last-in-first-out (LIFO) order in order to be symmetric with the domain
+       creation callbacks ([at_each_spawn]) which run in first-in-fisrt-out
+       (FIFO) order. *)
+    f (); old_exit ()
+  in
+  DLS.set at_exit_key new_exit
+
+let do_at_exit () =
+  let f : unit -> unit = DLS.get at_exit_key in
+  f ()
+
+let _ = Stdlib.do_domain_local_at_exit := do_at_exit
+
+(******* Creation and Termination ********)
+
+let spawn f =
+  do_before_first_spawn ();
+  let pk = DLS.get_initial_keys () in
+
+  (* The [term_mutex] and [term_condition] are used to
+     synchronize with the joining domains *)
+  let term_mutex = Mutex.create () in
+  let term_condition = Condition.create () in
+  let term_state = ref Running in
+
+  let body () =
+    let result =
+      match
+        DLS.create_dls ();
+        DLS.set_initial_keys pk;
+        let res = f () in
+        res
+      with
+      | x -> Ok x
+      | exception ex -> Error ex
+    in
+
+    let result' =
+      (* Run the [at_exit] callbacks when the domain computation either
+         terminates normally or exceptionally. *)
+      match do_at_exit () with
+      | () -> result
+      | exception ex ->
+          begin match result with
+          | Ok _ ->
+              (* If the domain computation terminated normally, but the
+                 [at_exit] callbacks raised an exception, then return the
+                 exception. *)
+              Error ex
+          | Error _ ->
+              (* If both the domain computation and the [at_exit] callbacks
+                 raised exceptions, then ignore the exception from the
+                 [at_exit] callbacks and return the original exception. *)
+              result
+          end
+    in
+
+    (* Synchronize with joining domains *)
+    Mutex.lock term_mutex;
+    match !term_state with
+    | Running ->
+        term_state := Finished result';
+        Condition.broadcast term_condition;
+    | Finished _ ->
+        failwith "internal error: Am I already finished?"
+    (* [term_mutex] is unlocked in the runtime after the cleanup functions on
+       the C side are finished. *)
+  in
+  { domain = Raw.spawn body term_mutex;
+    term_mutex;
+    term_condition;
+    term_state }
+
+let join { term_mutex; term_condition; term_state; _ } =
+  Mutex.lock term_mutex;
+  let rec loop () =
+    match !term_state with
+    | Running ->
+        Condition.wait term_condition term_mutex;
+        loop ()
+    | Finished res ->
+        Mutex.unlock term_mutex;
+        res
+  in
+  match loop () with
+  | Ok x -> x
+  | Error ex -> raise ex
+
+let recommended_domain_count = Raw.get_recommended_domain_count
+
+
+
+ + + diff --git a/_coverage/src/ephemeron/ephemeron.ml.html b/_coverage/src/ephemeron/ephemeron.ml.html new file mode 100644 index 000000000..531641f07 --- /dev/null +++ b/_coverage/src/ephemeron/ephemeron.ml.html @@ -0,0 +1,2473 @@ + + + + + ephemeron.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+174
+175
+176
+177
+178
+179
+180
+181
+182
+183
+184
+185
+186
+187
+188
+189
+190
+191
+192
+193
+194
+195
+196
+197
+198
+199
+200
+201
+202
+203
+204
+205
+206
+207
+208
+209
+210
+211
+212
+213
+214
+215
+216
+217
+218
+219
+220
+221
+222
+223
+224
+225
+226
+227
+228
+229
+230
+231
+232
+233
+234
+235
+236
+237
+238
+239
+240
+241
+242
+243
+244
+245
+246
+247
+248
+249
+250
+251
+252
+253
+254
+255
+256
+257
+258
+259
+260
+261
+262
+263
+264
+265
+266
+267
+268
+269
+270
+271
+272
+273
+274
+275
+276
+277
+278
+279
+280
+281
+282
+283
+284
+285
+286
+287
+288
+289
+290
+291
+292
+293
+294
+295
+296
+297
+298
+299
+300
+301
+302
+303
+304
+305
+306
+307
+308
+309
+310
+311
+312
+313
+314
+315
+316
+317
+318
+319
+320
+321
+322
+323
+324
+325
+326
+327
+328
+329
+330
+331
+332
+333
+334
+335
+336
+337
+338
+339
+340
+341
+342
+343
+344
+345
+346
+347
+348
+349
+350
+351
+352
+353
+354
+355
+356
+357
+358
+359
+360
+361
+362
+363
+364
+365
+366
+367
+368
+369
+370
+371
+372
+373
+374
+375
+376
+377
+378
+379
+380
+381
+382
+383
+384
+385
+386
+387
+388
+389
+390
+391
+392
+393
+394
+395
+396
+397
+398
+399
+400
+401
+402
+403
+404
+405
+406
+407
+408
+409
+410
+411
+412
+413
+414
+415
+416
+417
+418
+419
+420
+421
+422
+423
+424
+425
+426
+427
+428
+429
+430
+431
+432
+433
+434
+435
+436
+437
+438
+439
+440
+441
+442
+443
+444
+445
+446
+447
+448
+449
+450
+451
+452
+453
+454
+455
+456
+457
+458
+459
+460
+461
+462
+463
+464
+465
+466
+467
+468
+469
+470
+471
+472
+473
+474
+475
+476
+477
+478
+479
+480
+481
+482
+483
+484
+485
+486
+487
+488
+489
+490
+491
+492
+493
+494
+495
+496
+497
+498
+499
+500
+501
+502
+503
+504
+505
+506
+507
+508
+509
+510
+511
+512
+513
+514
+515
+516
+517
+518
+519
+520
+521
+522
+523
+524
+525
+526
+527
+528
+529
+530
+531
+532
+533
+534
+535
+536
+537
+538
+539
+540
+541
+542
+543
+544
+545
+546
+547
+548
+549
+550
+551
+552
+553
+554
+555
+556
+557
+558
+559
+560
+561
+562
+563
+564
+565
+566
+567
+568
+569
+570
+571
+572
+573
+574
+575
+576
+577
+578
+579
+580
+581
+582
+583
+584
+585
+586
+587
+588
+589
+590
+591
+592
+593
+594
+595
+596
+597
+598
+599
+600
+601
+602
+603
+604
+605
+606
+607
+608
+609
+610
+611
+612
+613
+614
+615
+616
+617
+618
+619
+620
+621
+622
+623
+624
+625
+626
+627
+628
+629
+630
+631
+632
+633
+634
+635
+636
+637
+638
+639
+640
+641
+642
+643
+644
+645
+646
+647
+648
+649
+650
+651
+652
+653
+654
+655
+656
+657
+658
+659
+660
+661
+662
+663
+664
+665
+666
+667
+668
+669
+670
+671
+672
+673
+674
+675
+676
+677
+678
+679
+680
+681
+682
+683
+684
+685
+686
+687
+688
+689
+690
+691
+692
+693
+694
+695
+696
+697
+698
+699
+700
+701
+702
+703
+704
+705
+706
+707
+708
+709
+710
+711
+712
+713
+714
+715
+716
+717
+718
+719
+720
+721
+722
+723
+724
+725
+726
+727
+728
+729
+730
+731
+732
+733
+734
+735
+736
+737
+738
+739
+740
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Damien Doligez, projet Para, INRIA Rocquencourt            *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+module type SeededS = sig
+
+  type key
+  type !'a t
+  val create : ?random (*thwart tools/sync_stdlib_docs*) : bool -> int -> 'a t
+  val clear : 'a t -> unit
+  val reset : 'a t -> unit
+  val copy : 'a t -> 'a t
+  val add : 'a t -> key -> 'a -> unit
+  val remove : 'a t -> key -> unit
+  val find : 'a t -> key -> 'a
+  val find_opt : 'a t -> key -> 'a option
+  val find_all : 'a t -> key -> 'a list
+  val replace : 'a t -> key -> 'a -> unit
+  val mem : 'a t -> key -> bool
+  val length : 'a t -> int
+  val stats : 'a t -> Hashtbl.statistics
+  val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+  val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+  val of_seq : (key * 'a) Seq.t -> 'a t
+  val clean: 'a t -> unit
+  val stats_alive: 'a t -> Hashtbl.statistics
+    (** same as {!stats} but only count the alive bindings *)
+end
+
+module type S = sig
+
+  type key
+  type !'a t
+  val create : int -> 'a t
+  val clear : 'a t -> unit
+  val reset : 'a t -> unit
+  val copy : 'a t -> 'a t
+  val add : 'a t -> key -> 'a -> unit
+  val remove : 'a t -> key -> unit
+  val find : 'a t -> key -> 'a
+  val find_opt : 'a t -> key -> 'a option
+  val find_all : 'a t -> key -> 'a list
+  val replace : 'a t -> key -> 'a -> unit
+  val mem : 'a t -> key -> bool
+  val length : 'a t -> int
+  val stats : 'a t -> Hashtbl.statistics
+  val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+  val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+  val of_seq : (key * 'a) Seq.t -> 'a t
+  val clean: 'a t -> unit
+  val stats_alive: 'a t -> Hashtbl.statistics
+    (** same as {!stats} but only count the alive bindings *)
+end
+
+module GenHashTable = struct
+
+  type equal =
+  | ETrue | EFalse
+  | EDead (** the garbage collector reclaimed the data *)
+
+  module MakeSeeded(H: sig
+    type t
+    type 'a container
+    val create: t -> 'a -> 'a container
+    val seeded_hash: int -> t -> int
+    val equal: 'a container -> t -> equal
+    val get_data: 'a container -> 'a option
+    val set_key_data: 'a container -> t -> 'a -> unit
+    val check_key: 'a container -> bool
+  end) : SeededS with type key = H.t
+  = struct
+
+    type 'a t =
+      { mutable size: int;                  (* number of entries *)
+        mutable data: 'a bucketlist array;  (* the buckets *)
+        seed: int;                          (* for randomization *)
+        initial_size: int;                  (* initial array size *)
+      }
+
+    and 'a bucketlist =
+    | Empty
+    | Cons of int (* hash of the key *) * 'a H.container * 'a bucketlist
+
+    (** the hash of the key is kept in order to test the equality of the hash
+      before the key. Same reason as for Weak.Make *)
+
+    type key = H.t
+
+    let rec power_2_above x n =
+      if x >= n then x
+      else if x * 2 > Sys.max_array_length then x
+      else power_2_above (x * 2) n
+
+    let prng = lazy (Random.State.make_self_init())
+
+    let create ?(random = (Hashtbl.is_randomized ())) initial_size =
+      let s = power_2_above 16 initial_size in
+      let seed = if random then Random.State.bits (Lazy.force prng) else 0 in
+      { initial_size = s; size = 0; seed = seed; data = Array.make s Empty }
+
+    let clear h =
+      h.size <- 0;
+      let len = Array.length h.data in
+      for i = 0 to len - 1 do
+        h.data.(i) <- Empty
+      done
+
+    let reset h =
+      let len = Array.length h.data in
+      if len = h.initial_size then
+        clear h
+      else begin
+        h.size <- 0;
+        h.data <- Array.make h.initial_size Empty
+      end
+
+    let copy h = { h with data = Array.copy h.data }
+
+    let key_index h hkey =
+      hkey land (Array.length h.data - 1)
+
+    let clean h =
+      let rec do_bucket = function
+        | Empty ->
+            Empty
+        | Cons(_, c, rest) when not (H.check_key c) ->
+            h.size <- h.size - 1;
+            do_bucket rest
+        | Cons(hkey, c, rest) ->
+            Cons(hkey, c, do_bucket rest)
+      in
+      let d = h.data in
+      for i = 0 to Array.length d - 1 do
+        d.(i) <- do_bucket d.(i)
+      done
+
+    (** resize is the only function to do the actual cleaning of dead keys
+        (remove does it just because it could).
+
+        The goal is to:
+
+        - not resize infinitely when the actual number of alive keys is
+        bounded but keys are continuously added. That would happen if
+        this function always resize.
+        - not call this function after each addition, that would happen if this
+        function don't resize even when only one key is dead.
+
+        So the algorithm:
+        - clean the keys before resizing
+        - if the number of remaining keys is less than half the size of the
+        array, don't resize.
+        - if it is more, resize.
+
+        The second problem remains if the table reaches {!Sys.max_array_length}.
+
+    *)
+    let resize h =
+      let odata = h.data in
+      let osize = Array.length odata in
+      let nsize = osize * 2 in
+      clean h;
+      if nsize < Sys.max_array_length && h.size >= osize lsr 1 then begin
+        let ndata = Array.make nsize Empty in
+        h.data <- ndata;       (* so that key_index sees the new bucket count *)
+        let rec insert_bucket = function
+            Empty -> ()
+          | Cons(hkey, data, rest) ->
+              insert_bucket rest; (* preserve original order of elements *)
+              let nidx = key_index h hkey in
+              ndata.(nidx) <- Cons(hkey, data, ndata.(nidx)) in
+        for i = 0 to osize - 1 do
+          insert_bucket odata.(i)
+        done
+      end
+
+    let add h key info =
+      let hkey = H.seeded_hash h.seed key in
+      let i = key_index h hkey in
+      let container = H.create key info in
+      let bucket = Cons(hkey, container, h.data.(i)) in
+      h.data.(i) <- bucket;
+      h.size <- h.size + 1;
+      if h.size > Array.length h.data lsl 1 then resize h
+
+    let remove h key =
+      let hkey = H.seeded_hash h.seed key in
+      let rec remove_bucket = function
+        | Empty -> Empty
+        | Cons(hk, c, next) when hkey = hk ->
+            begin match H.equal c key with
+            | ETrue -> h.size <- h.size - 1; next
+            | EFalse -> Cons(hk, c, remove_bucket next)
+            | EDead ->
+                (* The dead key is automatically removed. It is acceptable
+                    for this function since it already removes a binding *)
+                h.size <- h.size - 1;
+                remove_bucket next
+            end
+        | Cons(hk,c,next) -> Cons(hk, c, remove_bucket next) in
+      let i = key_index h hkey in
+      h.data.(i) <- remove_bucket h.data.(i)
+
+    (** {!find} don't remove dead keys because it would be surprising for
+        the user that a read-only function mutates the state (eg. concurrent
+        access). Same for {!mem}.
+    *)
+    let rec find_rec key hkey = function
+      | Empty ->
+          raise Not_found
+      | Cons(hk, c, rest) when hkey = hk  ->
+          begin match H.equal c key with
+          | ETrue ->
+              begin match H.get_data c with
+              | None ->
+                  (* This case is not impossible because the gc can run between
+                      H.equal and H.get_data *)
+                  find_rec key hkey rest
+              | Some d -> d
+              end
+          | EFalse -> find_rec key hkey rest
+          | EDead ->
+              find_rec key hkey rest
+          end
+      | Cons(_, _, rest) ->
+          find_rec key hkey rest
+
+    let find h key =
+      let hkey = H.seeded_hash h.seed key in
+      (* TODO inline 3 iterations *)
+      find_rec key hkey (h.data.(key_index h hkey))
+
+    let rec find_rec_opt key hkey = function
+      | Empty ->
+          None
+      | Cons(hk, c, rest) when hkey = hk  ->
+          begin match H.equal c key with
+          | ETrue ->
+              begin match H.get_data c with
+              | None ->
+                  (* This case is not impossible because the gc can run between
+                      H.equal and H.get_data *)
+                  find_rec_opt key hkey rest
+              | Some _ as d -> d
+              end
+          | EFalse -> find_rec_opt key hkey rest
+          | EDead ->
+              find_rec_opt key hkey rest
+          end
+      | Cons(_, _, rest) ->
+          find_rec_opt key hkey rest
+
+    let find_opt h key =
+      let hkey = H.seeded_hash h.seed key in
+      (* TODO inline 3 iterations *)
+      find_rec_opt key hkey (h.data.(key_index h hkey))
+
+    let find_all h key =
+      let hkey = H.seeded_hash h.seed key in
+      let rec find_in_bucket = function
+      | Empty -> []
+      | Cons(hk, c, rest) when hkey = hk  ->
+          begin match H.equal c key with
+          | ETrue -> begin match H.get_data c with
+              | None ->
+                  find_in_bucket rest
+              | Some d -> d::find_in_bucket rest
+            end
+          | EFalse -> find_in_bucket rest
+          | EDead ->
+              find_in_bucket rest
+          end
+      | Cons(_, _, rest) ->
+          find_in_bucket rest in
+      find_in_bucket h.data.(key_index h hkey)
+
+
+    let replace h key info =
+      let hkey = H.seeded_hash h.seed key in
+      let rec replace_bucket = function
+        | Empty -> raise Not_found
+        | Cons(hk, c, next) when hkey = hk ->
+            begin match H.equal c key with
+            | ETrue -> H.set_key_data c key info
+            | EFalse | EDead -> replace_bucket next
+            end
+        | Cons(_,_,next) -> replace_bucket next
+      in
+      let i = key_index h hkey in
+      let l = h.data.(i) in
+      try
+        replace_bucket l
+      with Not_found ->
+        let container = H.create key info in
+        h.data.(i) <- Cons(hkey, container, l);
+        h.size <- h.size + 1;
+        if h.size > Array.length h.data lsl 1 then resize h
+
+    let mem h key =
+      let hkey = H.seeded_hash h.seed key in
+      let rec mem_in_bucket = function
+      | Empty ->
+          false
+      | Cons(hk, c, rest) when hk = hkey ->
+          begin match H.equal c key with
+          | ETrue -> true
+          | EFalse | EDead -> mem_in_bucket rest
+          end
+      | Cons(_hk, _c, rest) -> mem_in_bucket rest in
+      mem_in_bucket h.data.(key_index h hkey)
+
+    let length h = h.size
+
+    let rec bucket_length accu = function
+      | Empty -> accu
+      | Cons(_, _, rest) -> bucket_length (accu + 1) rest
+
+    let stats h =
+      let mbl =
+        Array.fold_left (fun m b -> Int.max m (bucket_length 0 b)) 0 h.data in
+      let histo = Array.make (mbl + 1) 0 in
+      Array.iter
+        (fun b ->
+           let l = bucket_length 0 b in
+           histo.(l) <- histo.(l) + 1)
+        h.data;
+      { Hashtbl.num_bindings = h.size;
+        num_buckets = Array.length h.data;
+        max_bucket_length = mbl;
+        bucket_histogram = histo }
+
+    let rec bucket_length_alive accu = function
+      | Empty -> accu
+      | Cons(_, c, rest) when H.check_key c ->
+          bucket_length_alive (accu + 1) rest
+      | Cons(_, _, rest) -> bucket_length_alive accu rest
+
+    let stats_alive h =
+      let size = ref 0 in
+      let mbl =
+        Array.fold_left
+          (fun m b -> Int.max m (bucket_length_alive 0 b)) 0 h.data
+      in
+      let histo = Array.make (mbl + 1) 0 in
+      Array.iter
+        (fun b ->
+           let l = bucket_length_alive 0 b in
+           size := !size + l;
+           histo.(l) <- histo.(l) + 1)
+        h.data;
+      { Hashtbl.num_bindings = !size;
+        num_buckets = Array.length h.data;
+        max_bucket_length = mbl;
+        bucket_histogram = histo }
+
+    let add_seq tbl i =
+      Seq.iter (fun (k,v) -> add tbl k v) i
+
+    let replace_seq tbl i =
+      Seq.iter (fun (k,v) -> replace tbl k v) i
+
+    let of_seq i =
+      let tbl = create 16 in
+      replace_seq tbl i;
+      tbl
+
+  end
+end
+
+module ObjEph = Obj.Ephemeron
+
+let _obj_opt : Obj.t option -> 'a option = fun x ->
+  match x with
+  | None -> x
+  | Some v -> Some (Obj.obj v)
+
+(** The previous function is typed so this one is also correct *)
+let obj_opt : Obj.t option -> 'a option = fun x -> Obj.magic x
+
+
+module K1 = struct
+  type ('k,'d) t = ObjEph.t
+
+  let create () : ('k,'d) t = ObjEph.create 1
+
+  let get_key (t:('k,'d) t) : 'k option = obj_opt (ObjEph.get_key t 0)
+  let set_key (t:('k,'d) t) (k:'k) : unit = ObjEph.set_key t 0 (Obj.repr k)
+  let check_key (t:('k,'d) t) : bool = ObjEph.check_key t 0
+
+  let get_data (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data t)
+  let set_data (t:('k,'d) t) (d:'d) : unit = ObjEph.set_data t (Obj.repr d)
+  let unset_data (t:('k,'d) t) : unit = ObjEph.unset_data t
+
+  let make key data =
+    let eph = create () in
+    set_data eph data;
+    set_key eph key;
+    eph
+
+  let query eph key =
+    match get_key eph with
+    | None -> None
+    | Some k when k == key -> get_data eph
+    | Some _ -> None
+
+  module MakeSeeded (H:Hashtbl.SeededHashedType) =
+    GenHashTable.MakeSeeded(struct
+      type 'a container = (H.t,'a) t
+      type t = H.t
+      let create k d =
+        let c = create () in
+        set_data c d;
+        set_key c k;
+        c
+      let seeded_hash = H.seeded_hash
+      let equal c k =
+        (* {!get_key_copy} is not used because the equality of the user can be
+            the physical equality *)
+        match get_key c with
+        | None -> GenHashTable.EDead
+        | Some k' ->
+            if H.equal k k' then GenHashTable.ETrue else GenHashTable.EFalse
+      let get_data = get_data
+      let set_key_data c k d =
+        unset_data c;
+        set_key c k;
+        set_data c d
+      let check_key = check_key
+    end)
+
+  module Make(H: Hashtbl.HashedType): (S with type key = H.t) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let seeded_hash (_seed: int) x = H.hash x
+      end)
+    let create sz = create ~random:false sz
+    let of_seq i =
+      let tbl = create 16 in
+      replace_seq tbl i;
+      tbl
+  end
+
+  module Bucket = struct
+
+    type nonrec ('k, 'd) t = ('k, 'd) t list ref
+    let k1_make = make
+    let make () = ref []
+    let add b k d = b := k1_make k d :: !b
+
+    let test_key k e =
+      match get_key e with
+      | Some x when x == k -> true
+      | _ -> false
+
+    let remove b k =
+      let rec loop l acc =
+        match l with
+        | [] -> ()
+        | h :: t when test_key k h -> b := List.rev_append acc t
+        | h :: t -> loop t (h :: acc)
+      in
+      loop !b []
+
+    let find b k =
+      match List.find_opt (test_key k) !b with
+      | Some e -> get_data e
+      | None -> None
+
+    let length b = List.length !b
+    let clear b = b := []
+
+  end
+
+end
+
+module K2 = struct
+  type ('k1, 'k2, 'd) t = ObjEph.t
+
+  let create () : ('k1,'k2,'d) t = ObjEph.create 2
+
+  let get_key1 (t:('k1,'k2,'d) t) : 'k1 option = obj_opt (ObjEph.get_key t 0)
+  let set_key1 (t:('k1,'k2,'d) t) (k:'k1) : unit =
+    ObjEph.set_key t 0 (Obj.repr k)
+  let check_key1 (t:('k1,'k2,'d) t) : bool = ObjEph.check_key t 0
+
+  let get_key2 (t:('k1,'k2,'d) t) : 'k2 option = obj_opt (ObjEph.get_key t 1)
+  let set_key2 (t:('k1,'k2,'d) t) (k:'k2) : unit =
+    ObjEph.set_key t 1 (Obj.repr k)
+  let check_key2 (t:('k1,'k2,'d) t) : bool = ObjEph.check_key t 1
+
+  let get_data (t:('k1,'k2,'d) t) : 'd option = obj_opt (ObjEph.get_data t)
+  let set_data (t:('k1,'k2,'d) t) (d:'d) : unit =
+    ObjEph.set_data t (Obj.repr d)
+  let unset_data (t:('k1,'k2,'d) t) : unit = ObjEph.unset_data t
+
+  let make key1 key2 data =
+    let eph = create () in
+    set_data eph data;
+    set_key1 eph key1;
+    set_key2 eph key2;
+    ignore (Sys.opaque_identity key1);
+    eph
+
+  let query eph key1 key2 =
+    match get_key1 eph with
+    | None -> None
+    | Some k when k == key1 ->
+        begin match get_key2 eph with
+        | None -> None
+        | Some k when k == key2 -> get_data eph
+        | Some _ -> None
+        end
+    | Some _ -> None
+
+  module MakeSeeded
+      (H1:Hashtbl.SeededHashedType)
+      (H2:Hashtbl.SeededHashedType) =
+    GenHashTable.MakeSeeded(struct
+      type 'a container = (H1.t,H2.t,'a) t
+      type t = H1.t * H2.t
+      let create (k1,k2) d =
+        let c = create () in
+        set_data c d;
+        set_key1 c k1; set_key2 c k2;
+        c
+      let seeded_hash seed (k1,k2) =
+        H1.seeded_hash seed k1 + H2.seeded_hash seed k2 * 65599
+      let equal c (k1,k2) =
+        match get_key1 c, get_key2 c with
+        | None, _ | _ , None -> GenHashTable.EDead
+        | Some k1', Some k2' ->
+            if H1.equal k1 k1' && H2.equal k2 k2'
+            then GenHashTable.ETrue else GenHashTable.EFalse
+      let get_data = get_data
+      let set_key_data c (k1,k2) d =
+        unset_data c;
+        set_key1 c k1; set_key2 c k2;
+        set_data c d
+      let check_key c = check_key1 c && check_key2 c
+    end)
+
+  module Make(H1: Hashtbl.HashedType)(H2: Hashtbl.HashedType):
+    (S with type key = H1.t * H2.t) =
+  struct
+    include MakeSeeded
+        (struct
+          type t = H1.t
+          let equal = H1.equal
+          let seeded_hash (_seed: int) x = H1.hash x
+        end)
+        (struct
+          type t = H2.t
+          let equal = H2.equal
+          let seeded_hash (_seed: int) x = H2.hash x
+        end)
+    let create sz = create ~random:false sz
+    let of_seq i =
+      let tbl = create 16 in
+      replace_seq tbl i;
+      tbl
+  end
+
+  module Bucket = struct
+
+    type nonrec ('k1, 'k2, 'd) t = ('k1, 'k2, 'd) t list ref
+    let k2_make = make
+    let make () = ref []
+    let add b k1 k2 d = b := k2_make k1 k2 d :: !b
+
+    let test_keys k1 k2 e =
+      match get_key1 e, get_key2 e with
+      | Some x1, Some x2 when x1 == k1 && x2 == k2 -> true
+      | _ -> false
+
+    let remove b k1 k2 =
+      let rec loop l acc =
+        match l with
+        | [] -> ()
+        | h :: t when test_keys k1 k2 h -> b := List.rev_append acc t
+        | h :: t -> loop t (h :: acc)
+      in
+      loop !b []
+
+    let find b k1 k2 =
+      match List.find_opt (test_keys k1 k2) !b with
+      | Some e -> get_data e
+      | None -> None
+
+    let length b = List.length !b
+    let clear b = b := []
+
+  end
+
+end
+
+module Kn = struct
+  type ('k,'d) t = ObjEph.t
+
+  let create n : ('k,'d) t = ObjEph.create n
+  let length (k:('k,'d) t) : int = ObjEph.length k
+
+  let get_key (t:('k,'d) t) (n:int) : 'k option = obj_opt (ObjEph.get_key t n)
+  let set_key (t:('k,'d) t) (n:int) (k:'k) : unit =
+    ObjEph.set_key t n (Obj.repr k)
+  let check_key (t:('k,'d) t) (n:int) : bool = ObjEph.check_key t n
+
+  let get_data (t:('k,'d) t) : 'd option = obj_opt (ObjEph.get_data t)
+  let set_data (t:('k,'d) t) (d:'d) : unit = ObjEph.set_data t (Obj.repr d)
+  let unset_data (t:('k,'d) t) : unit = ObjEph.unset_data t
+
+  let make keys data =
+    let l = Array.length keys in
+    let eph = create l in
+    set_data eph data;
+    for i = 0 to l - 1 do set_key eph i keys.(i) done;
+    eph
+
+  let query eph keys =
+    let l = length eph in
+    try
+      if l <> Array.length keys then raise Exit;
+      for i = 0 to l - 1 do
+        match get_key eph i with
+        | None -> raise Exit
+        | Some k when k == keys.(i) -> ()
+        | Some _ -> raise Exit
+      done;
+      get_data eph
+    with Exit -> None
+
+  module MakeSeeded (H:Hashtbl.SeededHashedType) =
+    GenHashTable.MakeSeeded(struct
+      type 'a container = (H.t,'a) t
+      type t = H.t array
+      let create k d =
+        let c = create (Array.length k) in
+        set_data c d;
+        for i=0 to Array.length k -1 do
+          set_key c i k.(i);
+        done;
+        c
+      let seeded_hash seed k =
+        let h = ref 0 in
+        for i=0 to Array.length k -1 do
+          h := H.seeded_hash seed k.(i) * 65599 + !h;
+        done;
+        !h
+      let equal c k =
+        let len  = Array.length k in
+        let len' = length c in
+        if len != len' then GenHashTable.EFalse
+        else
+          let rec equal_array k c i =
+            if i < 0 then GenHashTable.ETrue
+            else
+              match get_key c i with
+              | None -> GenHashTable.EDead
+              | Some ki ->
+                  if H.equal k.(i) ki
+                  then equal_array k c (i-1)
+                  else GenHashTable.EFalse
+          in
+          equal_array k c (len-1)
+      let get_data = get_data
+      let set_key_data c k d =
+        unset_data c;
+        for i=0 to Array.length k -1 do
+          set_key c i k.(i);
+        done;
+        set_data c d
+      let check_key c =
+        let rec check c i =
+          i < 0 || (check_key c i && check c (i-1)) in
+        check c (length c - 1)
+    end)
+
+  module Make(H: Hashtbl.HashedType): (S with type key = H.t array) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let seeded_hash (_seed: int) x = H.hash x
+      end)
+    let create sz = create ~random:false sz
+    let of_seq i =
+      let tbl = create 16 in
+      replace_seq tbl i;
+      tbl
+  end
+
+  module Bucket = struct
+
+    type nonrec ('k, 'd) t = ('k, 'd) t list ref
+    let kn_make = make
+    let make () = ref []
+    let add b k d = b := kn_make k d :: !b
+
+    let test_keys k e =
+      try
+        if length e <> Array.length k then raise Exit;
+        for i = 0 to Array.length k - 1 do
+          match get_key e i with
+          | Some x when x == k.(i) -> ()
+          | _ -> raise Exit
+        done;
+        true
+      with Exit -> false
+
+    let remove b k =
+      let rec loop l acc =
+        match l with
+        | [] -> ()
+        | h :: t when test_keys k h -> b := List.rev_append acc t
+        | h :: t -> loop t (h :: acc)
+      in
+      loop !b []
+
+    let find b k =
+      match List.find_opt (test_keys k) !b with
+      | Some e -> get_data e
+      | None -> None
+
+    let length b = List.length !b
+    let clear b = b := []
+
+  end
+
+end
+
+
+
+ + + diff --git a/_coverage/src/floatarray/float.ml.html b/_coverage/src/floatarray/float.ml.html new file mode 100644 index 000000000..90cda3c93 --- /dev/null +++ b/_coverage/src/floatarray/float.ml.html @@ -0,0 +1,1732 @@ + + + + + float.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+174
+175
+176
+177
+178
+179
+180
+181
+182
+183
+184
+185
+186
+187
+188
+189
+190
+191
+192
+193
+194
+195
+196
+197
+198
+199
+200
+201
+202
+203
+204
+205
+206
+207
+208
+209
+210
+211
+212
+213
+214
+215
+216
+217
+218
+219
+220
+221
+222
+223
+224
+225
+226
+227
+228
+229
+230
+231
+232
+233
+234
+235
+236
+237
+238
+239
+240
+241
+242
+243
+244
+245
+246
+247
+248
+249
+250
+251
+252
+253
+254
+255
+256
+257
+258
+259
+260
+261
+262
+263
+264
+265
+266
+267
+268
+269
+270
+271
+272
+273
+274
+275
+276
+277
+278
+279
+280
+281
+282
+283
+284
+285
+286
+287
+288
+289
+290
+291
+292
+293
+294
+295
+296
+297
+298
+299
+300
+301
+302
+303
+304
+305
+306
+307
+308
+309
+310
+311
+312
+313
+314
+315
+316
+317
+318
+319
+320
+321
+322
+323
+324
+325
+326
+327
+328
+329
+330
+331
+332
+333
+334
+335
+336
+337
+338
+339
+340
+341
+342
+343
+344
+345
+346
+347
+348
+349
+350
+351
+352
+353
+354
+355
+356
+357
+358
+359
+360
+361
+362
+363
+364
+365
+366
+367
+368
+369
+370
+371
+372
+373
+374
+375
+376
+377
+378
+379
+380
+381
+382
+383
+384
+385
+386
+387
+388
+389
+390
+391
+392
+393
+394
+395
+396
+397
+398
+399
+400
+401
+402
+403
+404
+405
+406
+407
+408
+409
+410
+411
+412
+413
+414
+415
+416
+417
+418
+419
+420
+421
+422
+423
+424
+425
+426
+427
+428
+429
+430
+431
+432
+433
+434
+435
+436
+437
+438
+439
+440
+441
+442
+443
+444
+445
+446
+447
+448
+449
+450
+451
+452
+453
+454
+455
+456
+457
+458
+459
+460
+461
+462
+463
+464
+465
+466
+467
+468
+469
+470
+471
+472
+473
+474
+475
+476
+477
+478
+479
+480
+481
+482
+483
+484
+485
+486
+487
+488
+489
+490
+491
+492
+493
+494
+495
+496
+497
+498
+499
+500
+501
+502
+503
+504
+505
+506
+507
+508
+509
+510
+511
+512
+513
+514
+515
+516
+517
+518
+519
+520
+521
+522
+523
+524
+525
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                        Nicolas Ojeda Bar, LexiFi                       *)
+(*                                                                        *)
+(*   Copyright 2018 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+external neg : float -> float = "%negfloat"
+external add : float -> float -> float = "%addfloat"
+external sub : float -> float -> float = "%subfloat"
+external mul : float -> float -> float = "%mulfloat"
+external div : float -> float -> float = "%divfloat"
+external rem : float -> float -> float = "caml_fmod_float" "fmod"
+  [@@unboxed] [@@noalloc]
+external fma : float -> float -> float -> float = "caml_fma_float" "caml_fma"
+  [@@unboxed] [@@noalloc]
+external abs : float -> float = "%absfloat"
+
+let zero = 0.
+let one = 1.
+let minus_one = -1.
+let infinity = Stdlib.infinity
+let neg_infinity = Stdlib.neg_infinity
+let nan = Stdlib.nan
+let is_finite (x: float) = x -. x = 0.
+let is_infinite (x: float) = 1. /. x = 0.
+let is_nan (x: float) = x <> x
+
+let pi = 0x1.921fb54442d18p+1
+let max_float = Stdlib.max_float
+let min_float = Stdlib.min_float
+let epsilon = Stdlib.epsilon_float
+external of_int : int -> float = "%floatofint"
+external to_int : float -> int = "%intoffloat"
+external of_string : string -> float = "caml_float_of_string"
+let of_string_opt = Stdlib.float_of_string_opt
+let to_string = Stdlib.string_of_float
+type fpclass = Stdlib.fpclass =
+    FP_normal
+  | FP_subnormal
+  | FP_zero
+  | FP_infinite
+  | FP_nan
+external classify_float : (float [@unboxed]) -> fpclass =
+  "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
+external pow : float -> float -> float = "caml_power_float" "pow"
+  [@@unboxed] [@@noalloc]
+external sqrt : float -> float = "caml_sqrt_float" "sqrt"
+  [@@unboxed] [@@noalloc]
+external cbrt : float -> float = "caml_cbrt_float" "caml_cbrt"
+  [@@unboxed] [@@noalloc]
+external exp : float -> float = "caml_exp_float" "exp" [@@unboxed] [@@noalloc]
+external exp2 : float -> float = "caml_exp2_float" "caml_exp2"
+  [@@unboxed] [@@noalloc]
+external log : float -> float = "caml_log_float" "log" [@@unboxed] [@@noalloc]
+external log10 : float -> float = "caml_log10_float" "log10"
+  [@@unboxed] [@@noalloc]
+external log2 : float -> float = "caml_log2_float" "caml_log2"
+  [@@unboxed] [@@noalloc]
+external expm1 : float -> float = "caml_expm1_float" "caml_expm1"
+  [@@unboxed] [@@noalloc]
+external log1p : float -> float = "caml_log1p_float" "caml_log1p"
+  [@@unboxed] [@@noalloc]
+external cos : float -> float = "caml_cos_float" "cos" [@@unboxed] [@@noalloc]
+external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc]
+external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc]
+external acos : float -> float = "caml_acos_float" "acos"
+  [@@unboxed] [@@noalloc]
+external asin : float -> float = "caml_asin_float" "asin"
+  [@@unboxed] [@@noalloc]
+external atan : float -> float = "caml_atan_float" "atan"
+  [@@unboxed] [@@noalloc]
+external atan2 : float -> float -> float = "caml_atan2_float" "atan2"
+  [@@unboxed] [@@noalloc]
+external hypot : float -> float -> float
+               = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc]
+external cosh : float -> float = "caml_cosh_float" "cosh"
+  [@@unboxed] [@@noalloc]
+external sinh : float -> float = "caml_sinh_float" "sinh"
+  [@@unboxed] [@@noalloc]
+external tanh : float -> float = "caml_tanh_float" "tanh"
+  [@@unboxed] [@@noalloc]
+external acosh : float -> float = "caml_acosh_float" "caml_acosh"
+  [@@unboxed] [@@noalloc]
+external asinh : float -> float = "caml_asinh_float" "caml_asinh"
+  [@@unboxed] [@@noalloc]
+external atanh : float -> float = "caml_atanh_float" "caml_atanh"
+  [@@unboxed] [@@noalloc]
+external erf : float -> float = "caml_erf_float" "caml_erf"
+  [@@unboxed] [@@noalloc]
+external erfc : float -> float = "caml_erfc_float" "caml_erfc"
+  [@@unboxed] [@@noalloc]
+external trunc : float -> float = "caml_trunc_float" "caml_trunc"
+  [@@unboxed] [@@noalloc]
+external round : float -> float = "caml_round_float" "caml_round"
+  [@@unboxed] [@@noalloc]
+external ceil : float -> float = "caml_ceil_float" "ceil"
+  [@@unboxed] [@@noalloc]
+external floor : float -> float = "caml_floor_float" "floor"
+[@@unboxed] [@@noalloc]
+
+let is_integer x = x = trunc x && is_finite x
+
+external next_after : float -> float -> float
+  = "caml_nextafter_float" "caml_nextafter" [@@unboxed] [@@noalloc]
+
+let succ x = next_after x infinity
+let pred x = next_after x neg_infinity
+
+external copy_sign : float -> float -> float
+                  = "caml_copysign_float" "caml_copysign"
+                  [@@unboxed] [@@noalloc]
+external sign_bit : (float [@unboxed]) -> bool
+  = "caml_signbit_float" "caml_signbit" [@@noalloc]
+
+external frexp : float -> float * int = "caml_frexp_float"
+external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
+  "caml_ldexp_float" "caml_ldexp_float_unboxed" [@@noalloc]
+external modf : float -> float * float = "caml_modf_float"
+type t = float
+external compare : float -> float -> int = "%compare"
+let equal x y = compare x y = 0
+
+let[@inline] min (x: float) (y: float) =
+  if y > x || (not(sign_bit y) && sign_bit x) then
+    if is_nan y then y else x
+  else if is_nan x then x else y
+
+let[@inline] max (x: float) (y: float) =
+  if y > x || (not(sign_bit y) && sign_bit x) then
+    if is_nan x then x else y
+  else if is_nan y then y else x
+
+let[@inline] min_max (x: float) (y: float) =
+  if is_nan x || is_nan y then (nan, nan)
+  else if y > x || (not(sign_bit y) && sign_bit x) then (x, y) else (y, x)
+
+let[@inline] min_num (x: float) (y: float) =
+  if y > x || (not(sign_bit y) && sign_bit x) then
+    if is_nan x then y else x
+  else if is_nan y then x else y
+
+let[@inline] max_num (x: float) (y: float) =
+  if y > x || (not(sign_bit y) && sign_bit x) then
+    if is_nan y then x else y
+  else if is_nan x then y else x
+
+let[@inline] min_max_num (x: float) (y: float) =
+  if is_nan x then (y,y)
+  else if is_nan y then (x,x)
+  else if y > x || (not(sign_bit y) && sign_bit x) then (x,y) else (y,x)
+
+external seeded_hash_param : int -> int -> int -> float -> int
+                           = "caml_hash" [@@noalloc]
+let hash x = seeded_hash_param 10 100 0 x
+
+module Array = struct
+
+  type t = floatarray
+
+  external length : t -> int = "%floatarray_length"
+  external get : t -> int -> float = "%floatarray_safe_get"
+  external set : t -> int -> float -> unit = "%floatarray_safe_set"
+  external create : int -> t = "caml_floatarray_create"
+  external unsafe_get : t -> int -> float = "%floatarray_unsafe_get"
+  external unsafe_set : t -> int -> float -> unit = "%floatarray_unsafe_set"
+
+  let unsafe_fill a ofs len v =
+    for i = ofs to ofs + len - 1 do unsafe_set a i v done
+
+  external unsafe_blit: t -> int -> t -> int -> int -> unit =
+    "caml_floatarray_blit" [@@noalloc]
+
+  let check a ofs len msg =
+    if ofs < 0 || len < 0 || ofs + len < 0 || ofs + len > length a then
+      invalid_arg msg
+
+  let make n v =
+    let result = create n in
+    unsafe_fill result 0 n v;
+    result
+
+  let init l f =
+    if l < 0 then invalid_arg "Float.Array.init"
+    else
+      let res = create l in
+      for i = 0 to l - 1 do
+        unsafe_set res i (f i)
+      done;
+      res
+
+  let append a1 a2 =
+    let l1 = length a1 in
+    let l2 = length a2 in
+    let result = create (l1 + l2) in
+    unsafe_blit a1 0 result 0 l1;
+    unsafe_blit a2 0 result l1 l2;
+    result
+
+  (* next 3 functions: modified copy of code from string.ml *)
+  let ensure_ge (x:int) y =
+    if x >= y then x else invalid_arg "Float.Array.concat"
+
+  let rec sum_lengths acc = function
+    | [] -> acc
+    | hd :: tl -> sum_lengths (ensure_ge (length hd + acc) acc) tl
+
+  let concat l =
+    let len = sum_lengths 0 l in
+    let result = create len in
+    let rec loop l i =
+      match l with
+      | [] -> assert (i = len)
+      | hd :: tl ->
+        let hlen = length hd in
+        unsafe_blit hd 0 result i hlen;
+        loop tl (i + hlen)
+    in
+    loop l 0;
+    result
+
+  let sub a ofs len =
+    check a ofs len "Float.Array.sub";
+    let result = create len in
+    unsafe_blit a ofs result 0 len;
+    result
+
+  let copy a =
+    let l = length a in
+    let result = create l in
+    unsafe_blit a 0 result 0 l;
+    result
+
+  let fill a ofs len v =
+    check a ofs len "Float.Array.fill";
+    unsafe_fill a ofs len v
+
+  let blit src sofs dst dofs len =
+    check src sofs len "Float.array.blit";
+    check dst dofs len "Float.array.blit";
+    unsafe_blit src sofs dst dofs len
+
+  let to_list a =
+    List.init (length a) (unsafe_get a)
+
+  let of_list l =
+    let result = create (List.length l) in
+    let rec fill i l =
+      match l with
+      | [] -> result
+      | h :: t -> unsafe_set result i h; fill (i + 1) t
+    in
+    fill 0 l
+
+  (* duplicated from array.ml *)
+  let iter f a =
+    for i = 0 to length a - 1 do f (unsafe_get a i) done
+
+  (* duplicated from array.ml *)
+  let iter2 f a b =
+    if length a <> length b then
+      invalid_arg "Float.Array.iter2: arrays must have the same length"
+    else
+      for i = 0 to length a - 1 do f (unsafe_get a i) (unsafe_get b i) done
+
+  let map f a =
+    let l = length a in
+    let r = create l in
+    for i = 0 to l - 1 do
+      unsafe_set r i (f (unsafe_get a i))
+    done;
+    r
+
+  let map2 f a b =
+    let la = length a in
+    let lb = length b in
+    if la <> lb then
+      invalid_arg "Float.Array.map2: arrays must have the same length"
+    else begin
+      let r = create la in
+      for i = 0 to la - 1 do
+        unsafe_set r i (f (unsafe_get a i) (unsafe_get b i))
+      done;
+      r
+    end
+
+  (* duplicated from array.ml *)
+  let iteri f a =
+    for i = 0 to length a - 1 do f i (unsafe_get a i) done
+
+  let mapi f a =
+    let l = length a in
+    let r = create l in
+    for i = 0 to l - 1 do
+      unsafe_set r i (f i (unsafe_get a i))
+    done;
+    r
+
+  (* duplicated from array.ml *)
+  let fold_left f x a =
+    let r = ref x in
+    for i = 0 to length a - 1 do
+      r := f !r (unsafe_get a i)
+    done;
+    !r
+
+  (* duplicated from array.ml *)
+  let fold_right f a x =
+    let r = ref x in
+    for i = length a - 1 downto 0 do
+      r := f (unsafe_get a i) !r
+    done;
+    !r
+
+  (* duplicated from array.ml *)
+  let exists p a =
+    let n = length a in
+    let rec loop i =
+      if i = n then false
+      else if p (unsafe_get a i) then true
+      else loop (i + 1) in
+    loop 0
+
+  (* duplicated from array.ml *)
+  let for_all p a =
+    let n = length a in
+    let rec loop i =
+      if i = n then true
+      else if p (unsafe_get a i) then loop (i + 1)
+      else false in
+    loop 0
+
+  (* duplicated from array.ml *)
+  let mem x a =
+    let n = length a in
+    let rec loop i =
+      if i = n then false
+      else if compare (unsafe_get a i) x = 0 then true
+      else loop (i + 1)
+    in
+    loop 0
+
+  (* mostly duplicated from array.ml, but slightly different *)
+  let mem_ieee x a =
+    let n = length a in
+    let rec loop i =
+      if i = n then false
+      else if x = (unsafe_get a i) then true
+      else loop (i + 1)
+    in
+    loop 0
+
+  (* duplicated from array.ml *)
+  exception Bottom of int
+  let sort cmp a =
+    let maxson l i =
+      let i31 = i+i+i+1 in
+      let x = ref i31 in
+      if i31+2 < l then begin
+        if cmp (get a i31) (get a (i31+1)) < 0 then x := i31+1;
+        if cmp (get a !x) (get a (i31+2)) < 0 then x := i31+2;
+        !x
+      end else
+        if i31+1 < l && cmp (get a i31) (get a (i31+1)) < 0
+        then i31+1
+        else if i31 < l then i31 else raise (Bottom i)
+    in
+    let rec trickledown l i e =
+      let j = maxson l i in
+      if cmp (get a j) e > 0 then begin
+        set a i (get a j);
+        trickledown l j e;
+      end else begin
+        set a i e;
+      end;
+    in
+    let trickle l i e = try trickledown l i e with Bottom i -> set a i e in
+    let rec bubbledown l i =
+      let j = maxson l i in
+      set a i (get a j);
+      bubbledown l j
+    in
+    let bubble l i = try bubbledown l i with Bottom i -> i in
+    let rec trickleup i e =
+      let father = (i - 1) / 3 in
+      assert (i <> father);
+      if cmp (get a father) e < 0 then begin
+        set a i (get a father);
+        if father > 0 then trickleup father e else set a 0 e;
+      end else begin
+        set a i e;
+      end;
+    in
+    let l = length a in
+    for i = (l + 1) / 3 - 1 downto 0 do trickle l i (get a i); done;
+    for i = l - 1 downto 2 do
+      let e = (get a i) in
+      set a i (get a 0);
+      trickleup (bubble i 0) e;
+    done;
+    if l > 1 then (let e = (get a 1) in set a 1 (get a 0); set a 0 e)
+
+  (* duplicated from array.ml, except for the call to [create] *)
+  let cutoff = 5
+  let stable_sort cmp a =
+    let merge src1ofs src1len src2 src2ofs src2len dst dstofs =
+      let src1r = src1ofs + src1len and src2r = src2ofs + src2len in
+      let rec loop i1 s1 i2 s2 d =
+        if cmp s1 s2 <= 0 then begin
+          set dst d s1;
+          let i1 = i1 + 1 in
+          if i1 < src1r then
+            loop i1 (get a i1) i2 s2 (d + 1)
+          else
+            blit src2 i2 dst (d + 1) (src2r - i2)
+        end else begin
+          set dst d s2;
+          let i2 = i2 + 1 in
+          if i2 < src2r then
+            loop i1 s1 i2 (get src2 i2) (d + 1)
+          else
+            blit a i1 dst (d + 1) (src1r - i1)
+        end
+      in loop src1ofs (get a src1ofs) src2ofs (get src2 src2ofs) dstofs;
+    in
+    let isortto srcofs dst dstofs len =
+      for i = 0 to len - 1 do
+        let e = (get a (srcofs + i)) in
+        let j = ref (dstofs + i - 1) in
+        while (!j >= dstofs && cmp (get dst !j) e > 0) do
+          set dst (!j + 1) (get dst !j);
+          decr j;
+        done;
+        set dst (!j + 1) e;
+      done;
+    in
+    let rec sortto srcofs dst dstofs len =
+      if len <= cutoff then isortto srcofs dst dstofs len else begin
+        let l1 = len / 2 in
+        let l2 = len - l1 in
+        sortto (srcofs + l1) dst (dstofs + l1) l2;
+        sortto srcofs a (srcofs + l2) l1;
+        merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs;
+      end;
+    in
+    let l = length a in
+    if l <= cutoff then isortto 0 a 0 l else begin
+      let l1 = l / 2 in
+      let l2 = l - l1 in
+      let t = create l2 in
+      sortto l1 t 0 l2;
+      sortto 0 a l2 l1;
+      merge l2 l1 t 0 l2 a 0;
+    end
+
+  let fast_sort = stable_sort
+
+  (* duplicated from array.ml *)
+  let to_seq a =
+    let rec aux i () =
+      if i < length a
+      then
+        let x = unsafe_get a i in
+        Seq.Cons (x, aux (i+1))
+      else Seq.Nil
+    in
+    aux 0
+
+  (* duplicated from array.ml *)
+  let to_seqi a =
+    let rec aux i () =
+      if i < length a
+      then
+        let x = unsafe_get a i in
+        Seq.Cons ((i,x), aux (i+1))
+      else Seq.Nil
+    in
+    aux 0
+
+  (* mostly duplicated from array.ml *)
+  let of_rev_list l =
+    let len = List.length l in
+    let a = create len in
+    let rec fill i = function
+        [] -> a
+      | hd::tl -> unsafe_set a i hd; fill (i-1) tl
+    in
+    fill (len-1) l
+
+  (* duplicated from array.ml *)
+  let of_seq i =
+    let l = Seq.fold_left (fun acc x -> x::acc) [] i in
+    of_rev_list l
+
+
+  let map_to_array f a =
+    let l = length a in
+    if l = 0 then [| |] else begin
+      let r = Array.make l (f (unsafe_get a 0)) in
+      for i = 1 to l - 1 do
+        Array.unsafe_set r i (f (unsafe_get a i))
+      done;
+      r
+    end
+
+  let map_from_array f a =
+    let l = Array.length a in
+    let r = create l in
+    for i = 0 to l - 1 do
+      unsafe_set r i (f (Array.unsafe_get a i))
+    done;
+    r
+
+end
+
+module ArrayLabels = Array
+
+
+
+ + + diff --git a/_coverage/src/hashtbl/hashtbl.ml.html b/_coverage/src/hashtbl/hashtbl.ml.html new file mode 100644 index 000000000..2c27ce389 --- /dev/null +++ b/_coverage/src/hashtbl/hashtbl.ml.html @@ -0,0 +1,2134 @@ + + + + + hashtbl.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+174
+175
+176
+177
+178
+179
+180
+181
+182
+183
+184
+185
+186
+187
+188
+189
+190
+191
+192
+193
+194
+195
+196
+197
+198
+199
+200
+201
+202
+203
+204
+205
+206
+207
+208
+209
+210
+211
+212
+213
+214
+215
+216
+217
+218
+219
+220
+221
+222
+223
+224
+225
+226
+227
+228
+229
+230
+231
+232
+233
+234
+235
+236
+237
+238
+239
+240
+241
+242
+243
+244
+245
+246
+247
+248
+249
+250
+251
+252
+253
+254
+255
+256
+257
+258
+259
+260
+261
+262
+263
+264
+265
+266
+267
+268
+269
+270
+271
+272
+273
+274
+275
+276
+277
+278
+279
+280
+281
+282
+283
+284
+285
+286
+287
+288
+289
+290
+291
+292
+293
+294
+295
+296
+297
+298
+299
+300
+301
+302
+303
+304
+305
+306
+307
+308
+309
+310
+311
+312
+313
+314
+315
+316
+317
+318
+319
+320
+321
+322
+323
+324
+325
+326
+327
+328
+329
+330
+331
+332
+333
+334
+335
+336
+337
+338
+339
+340
+341
+342
+343
+344
+345
+346
+347
+348
+349
+350
+351
+352
+353
+354
+355
+356
+357
+358
+359
+360
+361
+362
+363
+364
+365
+366
+367
+368
+369
+370
+371
+372
+373
+374
+375
+376
+377
+378
+379
+380
+381
+382
+383
+384
+385
+386
+387
+388
+389
+390
+391
+392
+393
+394
+395
+396
+397
+398
+399
+400
+401
+402
+403
+404
+405
+406
+407
+408
+409
+410
+411
+412
+413
+414
+415
+416
+417
+418
+419
+420
+421
+422
+423
+424
+425
+426
+427
+428
+429
+430
+431
+432
+433
+434
+435
+436
+437
+438
+439
+440
+441
+442
+443
+444
+445
+446
+447
+448
+449
+450
+451
+452
+453
+454
+455
+456
+457
+458
+459
+460
+461
+462
+463
+464
+465
+466
+467
+468
+469
+470
+471
+472
+473
+474
+475
+476
+477
+478
+479
+480
+481
+482
+483
+484
+485
+486
+487
+488
+489
+490
+491
+492
+493
+494
+495
+496
+497
+498
+499
+500
+501
+502
+503
+504
+505
+506
+507
+508
+509
+510
+511
+512
+513
+514
+515
+516
+517
+518
+519
+520
+521
+522
+523
+524
+525
+526
+527
+528
+529
+530
+531
+532
+533
+534
+535
+536
+537
+538
+539
+540
+541
+542
+543
+544
+545
+546
+547
+548
+549
+550
+551
+552
+553
+554
+555
+556
+557
+558
+559
+560
+561
+562
+563
+564
+565
+566
+567
+568
+569
+570
+571
+572
+573
+574
+575
+576
+577
+578
+579
+580
+581
+582
+583
+584
+585
+586
+587
+588
+589
+590
+591
+592
+593
+594
+595
+596
+597
+598
+599
+600
+601
+602
+603
+604
+605
+606
+607
+608
+609
+610
+611
+612
+613
+614
+615
+616
+617
+618
+619
+620
+621
+622
+623
+624
+625
+626
+627
+628
+629
+630
+631
+632
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Hash tables *)
+
+(* We do dynamic hashing, and resize the table and rehash the elements
+   when the load factor becomes too high. *)
+
+type ('a, 'b) t =
+  { mutable size: int;                        (* number of entries *)
+    mutable data: ('a, 'b) bucketlist array;  (* the buckets *)
+    seed: int;                        (* for randomization *)
+    mutable initial_size: int;                (* initial array size *)
+  }
+
+and ('a, 'b) bucketlist =
+    Empty
+  | Cons of { mutable key: 'a;
+              mutable data: 'b;
+              mutable next: ('a, 'b) bucketlist }
+
+(* The sign of initial_size encodes the fact that a traversal is
+   ongoing or not.
+
+   This disables the efficient in place implementation of resizing.
+*)
+
+let ongoing_traversal h =
+  Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
+  || h.initial_size < 0
+
+let flip_ongoing_traversal h =
+  h.initial_size <- - h.initial_size
+
+(* To pick random seeds if requested *)
+
+let randomized_default =
+  let params =
+    try Sys.getenv "OCAMLRUNPARAM" with Not_found ->
+    try Sys.getenv "CAMLRUNPARAM" with Not_found -> "" in
+  String.contains params 'R'
+
+let randomized = Atomic.make randomized_default
+
+let randomize () = Atomic.set randomized true
+let is_randomized () = Atomic.get randomized
+
+let prng_key = Domain.DLS.new_key Random.State.make_self_init
+
+(* Functions which appear before the functorial interface must either be
+   independent of the hash function or take it as a parameter (see #2202 and
+   code below the functor definitions. *)
+
+(* Creating a fresh, empty table *)
+
+let rec power_2_above x n =
+  if x >= n then x
+  else if x * 2 > Sys.max_array_length then x
+  else power_2_above (x * 2) n
+
+let create ?(random = Atomic.get randomized) initial_size =
+  let s = power_2_above 16 initial_size in
+  let seed =
+    if random then Random.State.bits (Domain.DLS.get prng_key) else 0
+  in
+  { initial_size = s; size = 0; seed = seed; data = Array.make s Empty }
+
+let clear h =
+  if h.size > 0 then begin
+    h.size <- 0;
+    Array.fill h.data 0 (Array.length h.data) Empty
+  end
+
+let reset h =
+  let len = Array.length h.data in
+  if Obj.size (Obj.repr h) < 4 (* compatibility with old hash tables *)
+    || len = abs h.initial_size then
+    clear h
+  else begin
+    h.size <- 0;
+    h.data <- Array.make (abs h.initial_size) Empty
+  end
+
+let copy_bucketlist = function
+  | Empty -> Empty
+  | Cons {key; data; next} ->
+      let rec loop prec = function
+        | Empty -> ()
+        | Cons {key; data; next} ->
+            let r = Cons {key; data; next} in
+            begin match prec with
+            | Empty -> assert false
+            | Cons prec ->  prec.next <- r
+            end;
+            loop r next
+      in
+      let r = Cons {key; data; next} in
+      loop r next;
+      r
+
+let copy h = { h with data = Array.map copy_bucketlist h.data }
+
+let length h = h.size
+
+let insert_all_buckets indexfun inplace odata ndata =
+  let nsize = Array.length ndata in
+  let ndata_tail = Array.make nsize Empty in
+  let rec insert_bucket = function
+    | Empty -> ()
+    | Cons {key; data; next} as cell ->
+        let cell =
+          if inplace then cell
+          else Cons {key; data; next = Empty}
+        in
+        let nidx = indexfun key in
+        begin match ndata_tail.(nidx) with
+        | Empty -> ndata.(nidx) <- cell;
+        | Cons tail -> tail.next <- cell;
+        end;
+        ndata_tail.(nidx) <- cell;
+        insert_bucket next
+  in
+  for i = 0 to Array.length odata - 1 do
+    insert_bucket odata.(i)
+  done;
+  if inplace then
+    for i = 0 to nsize - 1 do
+      match ndata_tail.(i) with
+      | Empty -> ()
+      | Cons tail -> tail.next <- Empty
+    done
+
+let resize indexfun h =
+  let odata = h.data in
+  let osize = Array.length odata in
+  let nsize = osize * 2 in
+  if nsize < Sys.max_array_length then begin
+    let ndata = Array.make nsize Empty in
+    let inplace = not (ongoing_traversal h) in
+    h.data <- ndata;          (* so that indexfun sees the new bucket count *)
+    insert_all_buckets (indexfun h) inplace odata ndata
+  end
+
+let iter f h =
+  let rec do_bucket = function
+    | Empty ->
+        ()
+    | Cons{key; data; next} ->
+        f key data; do_bucket next in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    let d = h.data in
+    for i = 0 to Array.length d - 1 do
+      do_bucket d.(i)
+    done;
+    if not old_trav then flip_ongoing_traversal h;
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
+
+let rec filter_map_inplace_bucket f h i prec = function
+  | Empty ->
+      begin match prec with
+      | Empty -> h.data.(i) <- Empty
+      | Cons c -> c.next <- Empty
+      end
+  | (Cons ({key; data; next} as c)) as slot ->
+      begin match f key data with
+      | None ->
+          h.size <- h.size - 1;
+          filter_map_inplace_bucket f h i prec next
+      | Some data ->
+          begin match prec with
+          | Empty -> h.data.(i) <- slot
+          | Cons c -> c.next <- slot
+          end;
+          c.data <- data;
+          filter_map_inplace_bucket f h i slot next
+      end
+
+let filter_map_inplace f h =
+  let d = h.data in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    for i = 0 to Array.length d - 1 do
+      filter_map_inplace_bucket f h i Empty h.data.(i)
+    done;
+    if not old_trav then flip_ongoing_traversal h
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
+
+let fold f h init =
+  let rec do_bucket b accu =
+    match b with
+      Empty ->
+        accu
+    | Cons{key; data; next} ->
+        do_bucket next (f key data accu) in
+  let old_trav = ongoing_traversal h in
+  if not old_trav then flip_ongoing_traversal h;
+  try
+    let d = h.data in
+    let accu = ref init in
+    for i = 0 to Array.length d - 1 do
+      accu := do_bucket d.(i) !accu
+    done;
+    if not old_trav then flip_ongoing_traversal h;
+    !accu
+  with exn when not old_trav ->
+    flip_ongoing_traversal h;
+    raise exn
+
+type statistics = {
+  num_bindings: int;
+  num_buckets: int;
+  max_bucket_length: int;
+  bucket_histogram: int array
+}
+
+let rec bucket_length accu = function
+  | Empty -> accu
+  | Cons{next} -> bucket_length (accu + 1) next
+
+let stats h =
+  let mbl =
+    Array.fold_left (fun m b -> Int.max m (bucket_length 0 b)) 0 h.data in
+  let histo = Array.make (mbl + 1) 0 in
+  Array.iter
+    (fun b ->
+      let l = bucket_length 0 b in
+      histo.(l) <- histo.(l) + 1)
+    h.data;
+  { num_bindings = h.size;
+    num_buckets = Array.length h.data;
+    max_bucket_length = mbl;
+    bucket_histogram = histo }
+
+(** {1 Iterators} *)
+
+let to_seq tbl =
+  (* capture current array, so that even if the table is resized we
+     keep iterating on the same array *)
+  let tbl_data = tbl.data in
+  (* state: index * next bucket to traverse *)
+  let rec aux i buck () = match buck with
+    | Empty ->
+        if i = Array.length tbl_data
+        then Seq.Nil
+        else aux(i+1) tbl_data.(i) ()
+    | Cons {key; data; next} ->
+        Seq.Cons ((key, data), aux i next)
+  in
+  aux 0 Empty
+
+let to_seq_keys m = Seq.map fst (to_seq m)
+
+let to_seq_values m = Seq.map snd (to_seq m)
+
+(* Functorial interface *)
+
+module type HashedType =
+  sig
+    type t
+    val equal: t -> t -> bool
+    val hash: t -> int
+  end
+
+module type SeededHashedType =
+  sig
+    type t
+    val equal: t -> t -> bool
+    val seeded_hash: int -> t -> int
+  end
+
+module type S =
+  sig
+    type key
+    type !'a t
+    val create: int -> 'a t
+    val clear : 'a t -> unit
+    val reset : 'a t -> unit
+    val copy: 'a t -> 'a t
+    val add: 'a t -> key -> 'a -> unit
+    val remove: 'a t -> key -> unit
+    val find: 'a t -> key -> 'a
+    val find_opt: 'a t -> key -> 'a option
+    val find_all: 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter: (key -> 'a -> unit) -> 'a t -> unit
+    val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
+    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length: 'a t -> int
+    val stats: 'a t -> statistics
+    val to_seq : 'a t -> (key * 'a) Seq.t
+    val to_seq_keys : _ t -> key Seq.t
+    val to_seq_values : 'a t -> 'a Seq.t
+    val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+    val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+    val of_seq : (key * 'a) Seq.t -> 'a t
+  end
+
+module type SeededS =
+  sig
+    type key
+    type !'a t
+    val create : ?random:bool -> int -> 'a t
+    val clear : 'a t -> unit
+    val reset : 'a t -> unit
+    val copy : 'a t -> 'a t
+    val add : 'a t -> key -> 'a -> unit
+    val remove : 'a t -> key -> unit
+    val find : 'a t -> key -> 'a
+    val find_opt: 'a t -> key -> 'a option
+    val find_all : 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val filter_map_inplace: (key -> 'a -> 'a option) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length : 'a t -> int
+    val stats: 'a t -> statistics
+    val to_seq : 'a t -> (key * 'a) Seq.t
+    val to_seq_keys : _ t -> key Seq.t
+    val to_seq_values : 'a t -> 'a Seq.t
+    val add_seq : 'a t -> (key * 'a) Seq.t -> unit
+    val replace_seq : 'a t -> (key * 'a) Seq.t -> unit
+    val of_seq : (key * 'a) Seq.t -> 'a t
+  end
+
+module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) =
+  struct
+    type key = H.t
+    type 'a hashtbl = (key, 'a) t
+    type 'a t = 'a hashtbl
+    let create = create
+    let clear = clear
+    let reset = reset
+    let copy = copy
+
+    let key_index h key =
+      (H.seeded_hash h.seed key) land (Array.length h.data - 1)
+
+    let add h key data =
+      let i = key_index h key in
+      let bucket = Cons{key; data; next=h.data.(i)} in
+      h.data.(i) <- bucket;
+      h.size <- h.size + 1;
+      if h.size > Array.length h.data lsl 1 then resize key_index h
+
+    let rec remove_bucket h i key prec = function
+      | Empty ->
+          ()
+      | (Cons {key=k; next}) as c ->
+          if H.equal k key
+          then begin
+            h.size <- h.size - 1;
+            match prec with
+            | Empty -> h.data.(i) <- next
+            | Cons c -> c.next <- next
+          end
+          else remove_bucket h i key c next
+
+    let remove h key =
+      let i = key_index h key in
+      remove_bucket h i key Empty h.data.(i)
+
+    let rec find_rec key = function
+      | Empty ->
+          raise Not_found
+      | Cons{key=k; data; next} ->
+          if H.equal key k then data else find_rec key next
+
+    let find h key =
+      match h.data.(key_index h key) with
+      | Empty -> raise Not_found
+      | Cons{key=k1; data=d1; next=next1} ->
+          if H.equal key k1 then d1 else
+          match next1 with
+          | Empty -> raise Not_found
+          | Cons{key=k2; data=d2; next=next2} ->
+              if H.equal key k2 then d2 else
+              match next2 with
+              | Empty -> raise Not_found
+              | Cons{key=k3; data=d3; next=next3} ->
+                  if H.equal key k3 then d3 else find_rec key next3
+
+    let rec find_rec_opt key = function
+      | Empty ->
+          None
+      | Cons{key=k; data; next} ->
+          if H.equal key k then Some data else find_rec_opt key next
+
+    let find_opt h key =
+      match h.data.(key_index h key) with
+      | Empty -> None
+      | Cons{key=k1; data=d1; next=next1} ->
+          if H.equal key k1 then Some d1 else
+          match next1 with
+          | Empty -> None
+          | Cons{key=k2; data=d2; next=next2} ->
+              if H.equal key k2 then Some d2 else
+              match next2 with
+              | Empty -> None
+              | Cons{key=k3; data=d3; next=next3} ->
+                  if H.equal key k3 then Some d3 else find_rec_opt key next3
+
+    let find_all h key =
+      let rec find_in_bucket = function
+      | Empty ->
+          []
+      | Cons{key=k; data=d; next} ->
+          if H.equal k key
+          then d :: find_in_bucket next
+          else find_in_bucket next in
+      find_in_bucket h.data.(key_index h key)
+
+    let rec replace_bucket key data = function
+      | Empty ->
+          true
+      | Cons ({key=k; next} as slot) ->
+          if H.equal k key
+          then (slot.key <- key; slot.data <- data; false)
+          else replace_bucket key data next
+
+    let replace h key data =
+      let i = key_index h key in
+      let l = h.data.(i) in
+      if replace_bucket key data l then begin
+        h.data.(i) <- Cons{key; data; next=l};
+        h.size <- h.size + 1;
+        if h.size > Array.length h.data lsl 1 then resize key_index h
+      end
+
+    let mem h key =
+      let rec mem_in_bucket = function
+      | Empty ->
+          false
+      | Cons{key=k; next} ->
+          H.equal k key || mem_in_bucket next in
+      mem_in_bucket h.data.(key_index h key)
+
+    let add_seq tbl i =
+      Seq.iter (fun (k,v) -> add tbl k v) i
+
+    let replace_seq tbl i =
+      Seq.iter (fun (k,v) -> replace tbl k v) i
+
+    let of_seq i =
+      let tbl = create 16 in
+      replace_seq tbl i;
+      tbl
+
+    let iter = iter
+    let filter_map_inplace = filter_map_inplace
+    let fold = fold
+    let length = length
+    let stats = stats
+    let to_seq = to_seq
+    let to_seq_keys = to_seq_keys
+    let to_seq_values = to_seq_values
+  end
+
+module Make(H: HashedType): (S with type key = H.t) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let seeded_hash (_seed: int) x = H.hash x
+      end)
+    let create sz = create ~random:false sz
+    let of_seq i =
+      let tbl = create 16 in
+      replace_seq tbl i;
+      tbl
+  end
+
+(* Polymorphic hash function-based tables *)
+(* Code included below the functorial interface to guard against accidental
+   use - see #2202 *)
+
+external seeded_hash_param :
+  int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+
+let hash x = seeded_hash_param 10 100 0 x
+let hash_param n1 n2 x = seeded_hash_param n1 n2 0 x
+let seeded_hash seed x = seeded_hash_param 10 100 seed x
+
+let key_index h key =
+  if Obj.size (Obj.repr h) >= 4
+  then (seeded_hash_param 10 100 h.seed key) land (Array.length h.data - 1)
+  else invalid_arg "Hashtbl: unsupported hash table format"
+
+let add h key data =
+  let i = key_index h key in
+  let bucket = Cons{key; data; next=h.data.(i)} in
+  h.data.(i) <- bucket;
+  h.size <- h.size + 1;
+  if h.size > Array.length h.data lsl 1 then resize key_index h
+
+let rec remove_bucket h i key prec = function
+  | Empty ->
+      ()
+  | (Cons {key=k; next}) as c ->
+      if compare k key = 0
+      then begin
+        h.size <- h.size - 1;
+        match prec with
+        | Empty -> h.data.(i) <- next
+        | Cons c -> c.next <- next
+      end
+      else remove_bucket h i key c next
+
+let remove h key =
+  let i = key_index h key in
+  remove_bucket h i key Empty h.data.(i)
+
+let rec find_rec key = function
+  | Empty ->
+      raise Not_found
+  | Cons{key=k; data; next} ->
+      if compare key k = 0 then data else find_rec key next
+
+let find h key =
+  match h.data.(key_index h key) with
+  | Empty -> raise Not_found
+  | Cons{key=k1; data=d1; next=next1} ->
+      if compare key k1 = 0 then d1 else
+      match next1 with
+      | Empty -> raise Not_found
+      | Cons{key=k2; data=d2; next=next2} ->
+          if compare key k2 = 0 then d2 else
+          match next2 with
+          | Empty -> raise Not_found
+          | Cons{key=k3; data=d3; next=next3} ->
+              if compare key k3 = 0 then d3 else find_rec key next3
+
+let rec find_rec_opt key = function
+  | Empty ->
+      None
+  | Cons{key=k; data; next} ->
+      if compare key k = 0 then Some data else find_rec_opt key next
+
+let find_opt h key =
+  match h.data.(key_index h key) with
+  | Empty -> None
+  | Cons{key=k1; data=d1; next=next1} ->
+      if compare key k1 = 0 then Some d1 else
+      match next1 with
+      | Empty -> None
+      | Cons{key=k2; data=d2; next=next2} ->
+          if compare key k2 = 0 then Some d2 else
+          match next2 with
+          | Empty -> None
+          | Cons{key=k3; data=d3; next=next3} ->
+              if compare key k3 = 0 then Some d3 else find_rec_opt key next3
+
+let find_all h key =
+  let rec find_in_bucket = function
+  | Empty ->
+      []
+  | Cons{key=k; data; next} ->
+      if compare k key = 0
+      then data :: find_in_bucket next
+      else find_in_bucket next in
+  find_in_bucket h.data.(key_index h key)
+
+let rec replace_bucket key data = function
+  | Empty ->
+      true
+  | Cons ({key=k; next} as slot) ->
+      if compare k key = 0
+      then (slot.key <- key; slot.data <- data; false)
+      else replace_bucket key data next
+
+let replace h key data =
+  let i = key_index h key in
+  let l = h.data.(i) in
+  if replace_bucket key data l then begin
+    h.data.(i) <- Cons{key; data; next=l};
+    h.size <- h.size + 1;
+    if h.size > Array.length h.data lsl 1 then resize key_index h
+  end
+
+let mem h key =
+  let rec mem_in_bucket = function
+  | Empty ->
+      false
+  | Cons{key=k; next} ->
+      compare k key = 0 || mem_in_bucket next in
+  mem_in_bucket h.data.(key_index h key)
+
+let add_seq tbl i =
+  Seq.iter (fun (k,v) -> add tbl k v) i
+
+let replace_seq tbl i =
+  Seq.iter (fun (k,v) -> replace tbl k v) i
+
+let of_seq i =
+  let tbl = create 16 in
+  replace_seq tbl i;
+  tbl
+
+let rebuild ?(random = Atomic.get randomized) h =
+  let s = power_2_above 16 (Array.length h.data) in
+  let seed =
+    if random then Random.State.bits (Domain.DLS.get prng_key)
+    else if Obj.size (Obj.repr h) >= 4 then h.seed
+    else 0 in
+  let h' = {
+    size = h.size;
+    data = Array.make s Empty;
+    seed = seed;
+    initial_size = if Obj.size (Obj.repr h) >= 4 then h.initial_size else s
+  } in
+  insert_all_buckets (key_index h') false h.data h'.data;
+  h'
+
+
+
+ + + diff --git a/_coverage/src/io/in_channel.ml.html b/_coverage/src/io/in_channel.ml.html new file mode 100644 index 000000000..3f6ae193b --- /dev/null +++ b/_coverage/src/io/in_channel.ml.html @@ -0,0 +1,603 @@ + + + + + in_channel.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = in_channel
+
+type open_flag = Stdlib.open_flag =
+  | Open_rdonly
+  | Open_wronly
+  | Open_append
+  | Open_creat
+  | Open_trunc
+  | Open_excl
+  | Open_binary
+  | Open_text
+  | Open_nonblock
+
+let stdin = Stdlib.stdin
+let open_bin = Stdlib.open_in_bin
+let open_text = Stdlib.open_in
+let open_gen = Stdlib.open_in_gen
+
+let with_open openfun s f =
+  let ic = openfun s in
+  Fun.protect ~finally:(fun () -> Stdlib.close_in_noerr ic)
+    (fun () -> f ic)
+
+let with_open_bin s f =
+  with_open Stdlib.open_in_bin s f
+
+let with_open_text s f =
+  with_open Stdlib.open_in s f
+
+let with_open_gen flags perm s f =
+  with_open (Stdlib.open_in_gen flags perm) s f
+
+let seek = Stdlib.LargeFile.seek_in
+let pos = Stdlib.LargeFile.pos_in
+let length = Stdlib.LargeFile.in_channel_length
+let close = Stdlib.close_in
+let close_noerr = Stdlib.close_in_noerr
+
+let input_char ic =
+  match Stdlib.input_char ic with
+  | c -> Some c
+  | exception End_of_file -> None
+
+let input_byte ic =
+  match Stdlib.input_byte ic with
+  | n -> Some n
+  | exception End_of_file -> None
+
+let input_line ic =
+  match Stdlib.input_line ic with
+  | s -> Some s
+  | exception End_of_file -> None
+
+let input = Stdlib.input
+
+let really_input ic buf pos len =
+  match Stdlib.really_input ic buf pos len with
+  | () -> Some ()
+  | exception End_of_file -> None
+
+let really_input_string ic len =
+  match Stdlib.really_input_string ic len with
+  | s -> Some s
+  | exception End_of_file -> None
+
+(* Read up to [len] bytes into [buf], starting at [ofs]. Return total bytes
+   read. *)
+let read_upto ic buf ofs len =
+  let rec loop ofs len =
+    if len = 0 then ofs
+    else begin
+      let r = Stdlib.input ic buf ofs len in
+      if r = 0 then
+        ofs
+      else
+        loop (ofs + r) (len - r)
+    end
+  in
+  loop ofs len - ofs
+
+(* Best effort attempt to return a buffer with >= (ofs + n) bytes of storage,
+   and such that it coincides with [buf] at indices < [ofs].
+
+   The returned buffer is equal to [buf] itself if it already has sufficient
+   free space.
+
+   The returned buffer may have *fewer* than [ofs + n] bytes of storage if this
+   number is > [Sys.max_string_length]. However the returned buffer will
+   *always* have > [ofs] bytes of storage. In the limiting case when [ofs = len
+   = Sys.max_string_length] (so that it is not possible to resize the buffer at
+   all), an exception is raised. *)
+
+let ensure buf ofs n =
+  let len = Bytes.length buf in
+  if len >= ofs + n then buf
+  else begin
+    let new_len = ref len in
+    while !new_len < ofs + n do
+      new_len := 2 * !new_len + 1
+    done;
+    let new_len = !new_len in
+    let new_len =
+      if new_len <= Sys.max_string_length then
+        new_len
+      else if ofs < Sys.max_string_length then
+        Sys.max_string_length
+      else
+        failwith "In_channel.input_all: channel content \
+                  is larger than maximum string length"
+    in
+    let new_buf = Bytes.create new_len in
+    Bytes.blit buf 0 new_buf 0 ofs;
+    new_buf
+  end
+
+let input_all ic =
+  let chunk_size = 65536 in (* IO_BUFFER_SIZE *)
+  let initial_size =
+    try
+      Stdlib.in_channel_length ic - Stdlib.pos_in ic
+    with Sys_error _ ->
+      -1
+  in
+  let initial_size = if initial_size < 0 then chunk_size else initial_size in
+  let initial_size =
+    if initial_size <= Sys.max_string_length then
+      initial_size
+    else
+      Sys.max_string_length
+  in
+  let buf = Bytes.create initial_size in
+  let nread = read_upto ic buf 0 initial_size in
+  if nread < initial_size then (* EOF reached, buffer partially filled *)
+    Bytes.sub_string buf 0 nread
+  else begin (* nread = initial_size, maybe EOF reached *)
+    match Stdlib.input_char ic with
+    | exception End_of_file ->
+        (* EOF reached, buffer is completely filled *)
+        Bytes.unsafe_to_string buf
+    | c ->
+        (* EOF not reached *)
+        let rec loop buf ofs =
+          let buf = ensure buf ofs chunk_size in
+          let rem = Bytes.length buf - ofs in
+          (* [rem] can be < [chunk_size] if buffer size close to
+             [Sys.max_string_length] *)
+          let r = read_upto ic buf ofs rem in
+          if r < rem then (* EOF reached *)
+            Bytes.sub_string buf 0 (ofs + r)
+          else (* r = rem *)
+            loop buf (ofs + rem)
+        in
+        let buf = ensure buf nread (chunk_size + 1) in
+        Bytes.set buf nread c;
+        loop buf (nread + 1)
+  end
+
+let set_binary_mode = Stdlib.set_binary_mode_in
+
+
+
+ + + diff --git a/_coverage/src/io/out_channel.ml.html b/_coverage/src/io/out_channel.ml.html new file mode 100644 index 000000000..ce6ade7fe --- /dev/null +++ b/_coverage/src/io/out_channel.ml.html @@ -0,0 +1,239 @@ + + + + + out_channel.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+31
+32
+33
+34
+35
+36
+37
+38
+39
+40
+41
+42
+43
+44
+45
+46
+47
+48
+49
+50
+51
+52
+53
+54
+55
+56
+57
+58
+59
+60
+61
+62
+63
+64
+65
+66
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = out_channel
+
+type open_flag = Stdlib.open_flag =
+  | Open_rdonly
+  | Open_wronly
+  | Open_append
+  | Open_creat
+  | Open_trunc
+  | Open_excl
+  | Open_binary
+  | Open_text
+  | Open_nonblock
+
+let stdout = Stdlib.stdout
+let stderr = Stdlib.stderr
+let open_bin = Stdlib.open_out_bin
+let open_text = Stdlib.open_out
+let open_gen = Stdlib.open_out_gen
+
+let with_open openfun s f =
+  let oc = openfun s in
+  Fun.protect ~finally:(fun () -> Stdlib.close_out_noerr oc)
+    (fun () -> f oc)
+
+let with_open_bin s f =
+  with_open Stdlib.open_out_bin s f
+
+let with_open_text s f =
+  with_open Stdlib.open_out s f
+
+let with_open_gen flags perm s f =
+  with_open (Stdlib.open_out_gen flags perm) s f
+
+let seek = Stdlib.LargeFile.seek_out
+let pos = Stdlib.LargeFile.pos_out
+let length = Stdlib.LargeFile.out_channel_length
+let close = Stdlib.close_out
+let close_noerr = Stdlib.close_out_noerr
+let flush = Stdlib.flush
+let flush_all = Stdlib.flush_all
+let output_char = Stdlib.output_char
+let output_byte = Stdlib.output_byte
+let output_string = Stdlib.output_string
+let output_bytes = Stdlib.output_bytes
+let output = Stdlib.output
+let output_substring = Stdlib.output_substring
+let set_binary_mode = Stdlib.set_binary_mode_out
+
+external set_buffered : t -> bool -> unit = "caml_ml_set_buffered"
+
+external is_buffered : t -> bool = "caml_ml_is_buffered"
+
+
+
+ + + diff --git a/_coverage/src/lazy/lazy.ml.html b/_coverage/src/lazy/lazy.ml.html new file mode 100644 index 000000000..5cf2925c9 --- /dev/null +++ b/_coverage/src/lazy/lazy.ml.html @@ -0,0 +1,277 @@ + + + + + lazy.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+31
+32
+33
+34
+35
+36
+37
+38
+39
+40
+41
+42
+43
+44
+45
+46
+47
+48
+49
+50
+51
+52
+53
+54
+55
+56
+57
+58
+59
+60
+61
+62
+63
+64
+65
+66
+67
+68
+69
+70
+71
+72
+73
+74
+75
+76
+77
+78
+79
+80
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Damien Doligez, projet Para, INRIA Rocquencourt            *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Module [Lazy]: deferred computations *)
+
+
+(*
+   WARNING: some purple magic is going on here.  Do not take this file
+   as an example of how to program in OCaml.
+*)
+
+
+(* We make use of two special tags provided by the runtime:
+   [lazy_tag] and [forward_tag].
+
+   A value of type ['a Lazy.t] can be one of three things:
+   1. A block of size 1 with tag [lazy_tag].  Its field is a closure of
+      type [unit -> 'a] that computes the value.
+   2. A block of size 1 with tag [forward_tag].  Its field is the value
+      of type ['a] that was computed.
+   3. Anything else except a float.  This has type ['a] and is the value
+      that was computed.
+   Exceptions are stored in format (1).
+   The GC will magically change things from (2) to (3) according to its
+   fancy.
+
+   If OCaml was configured with the -flat-float-array option (which is
+   currently the default), the following is also true:
+   We cannot use representation (3) for a [float Lazy.t] because
+   [caml_make_array] assumes that only a [float] value can have tag
+   [Double_tag].
+
+   We have to use the built-in type constructor [lazy_t] to
+   let the compiler implement the special typing and compilation
+   rules for the [lazy] keyword.
+*)
+
+type 'a t = 'a CamlinternalLazy.t
+
+exception Undefined = CamlinternalLazy.Undefined
+external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward"
+external force : 'a t -> 'a = "%lazy_force"
+
+let force_val l = CamlinternalLazy.force_gen ~only_val:true l
+
+let from_fun (f : unit -> 'arg) =
+  let x = Obj.new_block Obj.lazy_tag 1 in
+  Obj.set_field x 0 (Obj.repr f);
+  (Obj.obj x : 'arg t)
+
+let from_val (v : 'arg) =
+  let t = Obj.tag (Obj.repr v) in
+  if t = Obj.forward_tag || t = Obj.lazy_tag ||
+     t = Obj.forcing_tag || t = Obj.double_tag then begin
+    make_forward v
+  end else begin
+    (Obj.magic v : 'arg t)
+  end
+
+let is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag
+
+let map f x =
+  lazy (f (force x))
+
+let map_val f x =
+  if is_val x
+  then from_val (f (force x))
+  else lazy (f (force x))
+
+
+
+ + + diff --git a/_coverage/src/queue/queue.ml.html b/_coverage/src/queue/queue.ml.html new file mode 100644 index 000000000..c3f9757ff --- /dev/null +++ b/_coverage/src/queue/queue.ml.html @@ -0,0 +1,554 @@ + + + + + queue.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*         Francois Pottier, projet Cristal, INRIA Rocquencourt           *)
+(*                  Jeremie Dimino, Jane Street Europe                    *)
+(*                                                                        *)
+(*   Copyright 2002 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+exception Empty
+
+type 'a cell =
+  | Nil
+  | Cons of { content: 'a; mutable next: 'a cell }
+
+type 'a t = {
+  mutable length: int;
+  mutable first: 'a cell;
+  mutable last: 'a cell
+}
+
+let create () = {
+  length = 0;
+  first = Nil;
+  last = Nil
+}
+
+let clear q =
+  q.length <- 0;
+  q.first <- Nil;
+  q.last <- Nil
+
+let add x q =
+  let cell = Cons {
+    content = x;
+    next = Nil
+  } in
+  match q.last with
+  | Nil ->
+    q.length <- 1;
+    q.first <- cell;
+    q.last <- cell
+  | Cons last ->
+    q.length <- q.length + 1;
+    last.next <- cell;
+    q.last <- cell
+
+let push =
+  add
+
+let peek q =
+  match q.first with
+  | Nil -> raise Empty
+  | Cons { content } -> content
+
+let peek_opt q =
+  match q.first with
+  | Nil -> None
+  | Cons { content } -> Some content
+
+let top =
+  peek
+
+let take q =
+  match q.first with
+  | Nil -> raise Empty
+  | Cons { content; next = Nil } ->
+    clear q;
+    content
+  | Cons { content; next } ->
+    q.length <- q.length - 1;
+    q.first <- next;
+    content
+
+let take_opt q =
+  match q.first with
+  | Nil -> None
+  | Cons { content; next = Nil } ->
+    clear q;
+    Some content
+  | Cons { content; next } ->
+    q.length <- q.length - 1;
+    q.first <- next;
+    Some content
+
+let pop =
+  take
+
+let copy =
+  let rec copy q_res prev cell =
+    match cell with
+    | Nil -> q_res.last <- prev; q_res
+    | Cons { content; next } ->
+      let res = Cons { content; next = Nil } in
+      begin match prev with
+      | Nil -> q_res.first <- res
+      | Cons p -> p.next <- res
+      end;
+      copy q_res res next
+  in
+  fun q -> copy { length = q.length; first = Nil; last = Nil } Nil q.first
+
+let is_empty q =
+  q.length = 0
+
+let length q =
+  q.length
+
+let iter =
+  let rec iter f cell =
+    match cell with
+    | Nil -> ()
+    | Cons { content; next } ->
+      f content;
+      iter f next
+  in
+  fun f q -> iter f q.first
+
+let fold =
+  let rec fold f accu cell =
+    match cell with
+    | Nil -> accu
+    | Cons { content; next } ->
+      let accu = f accu content in
+      fold f accu next
+  in
+  fun f accu q -> fold f accu q.first
+
+let transfer q1 q2 =
+  if q1.length > 0 then
+    match q2.last with
+    | Nil ->
+      q2.length <- q1.length;
+      q2.first <- q1.first;
+      q2.last <- q1.last;
+      clear q1
+    | Cons last ->
+      q2.length <- q2.length + q1.length;
+      last.next <- q1.first;
+      q2.last <- q1.last;
+      clear q1
+
+(** {1 Iterators} *)
+
+let to_seq q =
+  let rec aux c () = match c with
+    | Nil -> Seq.Nil
+    | Cons { content=x; next; } -> Seq.Cons (x, aux next)
+  in
+  aux q.first
+
+let add_seq q i = Seq.iter (fun x -> push x q) i
+
+let of_seq g =
+  let q = create() in
+  add_seq q g;
+  q
+
+
+
+ + + diff --git a/_coverage/src/semaphore/semaphore.ml.html b/_coverage/src/semaphore/semaphore.ml.html new file mode 100644 index 000000000..ff22f7914 --- /dev/null +++ b/_coverage/src/semaphore/semaphore.ml.html @@ -0,0 +1,308 @@ + + + + + semaphore.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+31
+32
+33
+34
+35
+36
+37
+38
+39
+40
+41
+42
+43
+44
+45
+46
+47
+48
+49
+50
+51
+52
+53
+54
+55
+56
+57
+58
+59
+60
+61
+62
+63
+64
+65
+66
+67
+68
+69
+70
+71
+72
+73
+74
+75
+76
+77
+78
+79
+80
+81
+82
+83
+84
+85
+86
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Xavier Leroy, Collège de France and INRIA Paris               *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Semaphores *)
+
+type sem = {
+  mut: Mutex.t;                         (* protects [v] *)
+  mutable v: int;                       (* the current value *)
+  nonzero: Condition.t                  (* signaled when [v > 0] *)
+}
+
+module Counting = struct
+
+type t = sem
+
+let make v =
+  if v < 0 then invalid_arg "Semaphore.Counting.init: wrong initial value";
+  { mut = Mutex.create(); v; nonzero = Condition.create() }
+
+let release s =
+  Mutex.lock s.mut;
+  if s.v < max_int then begin
+    s.v <- s.v + 1;
+    Condition.signal s.nonzero;
+    Mutex.unlock s.mut
+  end else begin
+    Mutex.unlock s.mut;
+    raise (Sys_error "Semaphore.Counting.release: overflow")
+  end
+
+let acquire s =
+  Mutex.lock s.mut;
+  while s.v = 0 do Condition.wait s.nonzero s.mut done;
+  s.v <- s.v - 1;
+  Mutex.unlock s.mut
+
+let try_acquire s =
+  Mutex.lock s.mut;
+  let ret = if s.v = 0 then false else (s.v <- s.v - 1; true) in
+  Mutex.unlock s.mut;
+  ret
+
+let get_value s = s.v
+
+end
+
+module Binary = struct
+
+type t = sem
+
+let make b =
+  { mut = Mutex.create();
+    v = if b then 1 else 0;
+    nonzero = Condition.create() }
+
+let release s =
+  Mutex.lock s.mut;
+  s.v <- 1;
+  Condition.signal s.nonzero;
+  Mutex.unlock s.mut
+
+let acquire s =
+  Mutex.lock s.mut;
+  while s.v = 0 do Condition.wait s.nonzero s.mut done;
+  s.v <- 0;
+  Mutex.unlock s.mut
+
+let try_acquire s =
+  Mutex.lock s.mut;
+  let ret = if s.v = 0 then false else (s.v <- 0; true) in
+  Mutex.unlock s.mut;
+  ret
+
+end
+
+
+
+ + + diff --git a/_coverage/src/stack/stack.ml.html b/_coverage/src/stack/stack.ml.html new file mode 100644 index 000000000..ca8c7116b --- /dev/null +++ b/_coverage/src/stack/stack.ml.html @@ -0,0 +1,238 @@ + + + + + stack.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+31
+32
+33
+34
+35
+36
+37
+38
+39
+40
+41
+42
+43
+44
+45
+46
+47
+48
+49
+50
+51
+52
+53
+54
+55
+56
+57
+58
+59
+60
+61
+62
+63
+64
+65
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type 'a t = { mutable c : 'a list; mutable len : int; }
+
+exception Empty
+
+let create () = { c = []; len = 0; }
+
+let clear s = s.c <- []; s.len <- 0
+
+let copy s = { c = s.c; len = s.len; }
+
+let push x s = s.c <- x :: s.c; s.len <- s.len + 1
+
+let pop s =
+  match s.c with
+  | hd::tl -> s.c <- tl; s.len <- s.len - 1; hd
+  | []     -> raise Empty
+
+let pop_opt s =
+  match s.c with
+  | hd::tl -> s.c <- tl; s.len <- s.len - 1; Some hd
+  | []     -> None
+
+let top s =
+  match s.c with
+  | hd::_ -> hd
+  | []    -> raise Empty
+
+let top_opt s =
+  match s.c with
+  | hd::_ -> Some hd
+  | []    -> None
+
+let is_empty s = (s.c = [])
+
+let length s = s.len
+
+let iter f s = List.iter f s.c
+
+let fold f acc s = List.fold_left f acc s.c
+
+(** {1 Iterators} *)
+
+let to_seq s = List.to_seq s.c
+
+let add_seq q i = Seq.iter (fun x -> push x q) i
+
+let of_seq g =
+  let s = create() in
+  add_seq s g;
+  s
+
+
+
+ + + diff --git a/_coverage/src/sys/sys.ml.html b/_coverage/src/sys/sys.ml.html new file mode 100644 index 000000000..be62af580 --- /dev/null +++ b/_coverage/src/sys/sys.ml.html @@ -0,0 +1,565 @@ + + + + + sys.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+174
+
+
(* stdlib/sys.ml.  Generated from sys.ml.in by configure. *)
+#3 "sys.ml.in"
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type backend_type =
+  | Native
+  | Bytecode
+  | Other of string
+(* System interface *)
+
+external get_config: unit -> string * int * bool = "caml_sys_get_config"
+external get_executable_name : unit -> string = "caml_sys_executable_name"
+external argv : string array = "%sys_argv"
+external big_endian : unit -> bool = "%big_endian"
+external word_size : unit -> int = "%word_size"
+external int_size : unit -> int = "%int_size"
+external max_wosize : unit -> int = "%max_wosize"
+external unix : unit -> bool = "%ostype_unix"
+external win32 : unit -> bool = "%ostype_win32"
+external cygwin : unit -> bool = "%ostype_cygwin"
+external get_backend_type : unit -> backend_type = "%backend_type"
+
+let executable_name = get_executable_name()
+let (os_type, _, _) = get_config()
+let backend_type = get_backend_type ()
+let big_endian = big_endian ()
+let word_size = word_size ()
+let int_size = int_size ()
+let unix = unix ()
+let win32 = win32 ()
+let cygwin = cygwin ()
+let max_array_length = max_wosize ()
+let max_floatarray_length = max_array_length / (64 / word_size)
+let max_string_length = word_size / 8 * max_array_length - 1
+external runtime_variant : unit -> string = "caml_runtime_variant"
+external runtime_parameters : unit -> string = "caml_runtime_parameters"
+
+external file_exists: string -> bool = "caml_sys_file_exists"
+external is_directory : string -> bool = "caml_sys_is_directory"
+external remove: string -> unit = "caml_sys_remove"
+external rename : string -> string -> unit = "caml_sys_rename"
+external getenv: string -> string = "caml_sys_getenv"
+
+let getenv_opt s =
+  (* TODO: expose a non-raising primitive directly. *)
+  try Some (getenv s)
+  with Not_found -> None
+
+external command: string -> int = "caml_sys_system_command"
+external time: unit -> (float [@unboxed]) =
+  "caml_sys_time" "caml_sys_time_unboxed" [@@noalloc]
+external chdir: string -> unit = "caml_sys_chdir"
+external mkdir: string -> int -> unit = "caml_sys_mkdir"
+external rmdir: string -> unit = "caml_sys_rmdir"
+external getcwd: unit -> string = "caml_sys_getcwd"
+external readdir : string -> string array = "caml_sys_read_directory"
+
+let interactive = ref false
+
+type signal_behavior =
+    Signal_default
+  | Signal_ignore
+  | Signal_handle of (int -> unit)
+
+external signal : int -> signal_behavior -> signal_behavior
+                = "caml_install_signal_handler"
+
+let set_signal sig_num sig_beh = ignore(signal sig_num sig_beh)
+
+let sigabrt = -1
+let sigalrm = -2
+let sigfpe = -3
+let sighup = -4
+let sigill = -5
+let sigint = -6
+let sigkill = -7
+let sigpipe = -8
+let sigquit = -9
+let sigsegv = -10
+let sigterm = -11
+let sigusr1 = -12
+let sigusr2 = -13
+let sigchld = -14
+let sigcont = -15
+let sigstop = -16
+let sigtstp = -17
+let sigttin = -18
+let sigttou = -19
+let sigvtalrm = -20
+let sigprof = -21
+let sigbus = -22
+let sigpoll = -23
+let sigsys = -24
+let sigtrap = -25
+let sigurg = -26
+let sigxcpu = -27
+let sigxfsz = -28
+
+exception Break
+
+let catch_break on =
+  if on then
+    set_signal sigint (Signal_handle(fun _ -> raise Break))
+  else
+    set_signal sigint Signal_default
+
+
+external enable_runtime_warnings: bool -> unit =
+  "caml_ml_enable_runtime_warnings"
+external runtime_warnings_enabled: unit -> bool =
+  "caml_ml_runtime_warnings_enabled"
+
+(* The version string is found in file ../VERSION *)
+
+let ocaml_version = "5.0.0"
+
+let development_version = false
+
+type extra_prefix = Plus | Tilde
+
+type extra_info = extra_prefix * string
+
+type ocaml_release_info = {
+  major : int;
+  minor : int;
+  patchlevel : int;
+  extra : extra_info option
+}
+
+let ocaml_release = {
+  major = 5;
+  minor = 0;
+  patchlevel = 0;
+  extra = None
+}
+
+(* Optimization *)
+
+external opaque_identity : 'a -> 'a = "%opaque"
+
+module Immediate64 = struct
+  module type Non_immediate = sig
+    type t
+  end
+  module type Immediate = sig
+    type t [@@immediate]
+  end
+
+  module Make(Immediate : Immediate)(Non_immediate : Non_immediate) = struct
+    type t [@@immediate64]
+    type 'a repr =
+      | Immediate : Immediate.t repr
+      | Non_immediate : Non_immediate.t repr
+    external magic : _ repr -> t repr = "%identity"
+    let repr =
+      if word_size = 64 then
+        magic Immediate
+      else
+        magic Non_immediate
+  end
+end
+
+
+
+ + + diff --git a/_coverage/src/weak/weak.ml.html b/_coverage/src/weak/weak.ml.html new file mode 100644 index 000000000..b3b465aed --- /dev/null +++ b/_coverage/src/weak/weak.ml.html @@ -0,0 +1,1215 @@ + + + + + weak.ml — Coverage report + + + + + + + + +
+
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+
+
+
+ 
+  1
+  2
+  3
+  4
+  5
+  6
+  7
+  8
+  9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+ 16
+ 17
+ 18
+ 19
+ 20
+ 21
+ 22
+ 23
+ 24
+ 25
+ 26
+ 27
+ 28
+ 29
+ 30
+ 31
+ 32
+ 33
+ 34
+ 35
+ 36
+ 37
+ 38
+ 39
+ 40
+ 41
+ 42
+ 43
+ 44
+ 45
+ 46
+ 47
+ 48
+ 49
+ 50
+ 51
+ 52
+ 53
+ 54
+ 55
+ 56
+ 57
+ 58
+ 59
+ 60
+ 61
+ 62
+ 63
+ 64
+ 65
+ 66
+ 67
+ 68
+ 69
+ 70
+ 71
+ 72
+ 73
+ 74
+ 75
+ 76
+ 77
+ 78
+ 79
+ 80
+ 81
+ 82
+ 83
+ 84
+ 85
+ 86
+ 87
+ 88
+ 89
+ 90
+ 91
+ 92
+ 93
+ 94
+ 95
+ 96
+ 97
+ 98
+ 99
+100
+101
+102
+103
+104
+105
+106
+107
+108
+109
+110
+111
+112
+113
+114
+115
+116
+117
+118
+119
+120
+121
+122
+123
+124
+125
+126
+127
+128
+129
+130
+131
+132
+133
+134
+135
+136
+137
+138
+139
+140
+141
+142
+143
+144
+145
+146
+147
+148
+149
+150
+151
+152
+153
+154
+155
+156
+157
+158
+159
+160
+161
+162
+163
+164
+165
+166
+167
+168
+169
+170
+171
+172
+173
+174
+175
+176
+177
+178
+179
+180
+181
+182
+183
+184
+185
+186
+187
+188
+189
+190
+191
+192
+193
+194
+195
+196
+197
+198
+199
+200
+201
+202
+203
+204
+205
+206
+207
+208
+209
+210
+211
+212
+213
+214
+215
+216
+217
+218
+219
+220
+221
+222
+223
+224
+225
+226
+227
+228
+229
+230
+231
+232
+233
+234
+235
+236
+237
+238
+239
+240
+241
+242
+243
+244
+245
+246
+247
+248
+249
+250
+251
+252
+253
+254
+255
+256
+257
+258
+259
+260
+261
+262
+263
+264
+265
+266
+267
+268
+269
+270
+271
+272
+273
+274
+275
+276
+277
+278
+279
+280
+281
+282
+283
+284
+285
+286
+287
+288
+289
+290
+291
+292
+293
+294
+295
+296
+297
+298
+299
+300
+301
+302
+303
+304
+305
+306
+307
+308
+309
+310
+311
+312
+313
+314
+315
+316
+317
+318
+319
+320
+321
+322
+323
+324
+325
+326
+327
+328
+329
+330
+331
+332
+333
+334
+335
+336
+337
+338
+339
+340
+341
+342
+343
+344
+345
+346
+347
+348
+349
+350
+351
+352
+353
+354
+355
+356
+357
+358
+359
+360
+361
+362
+363
+364
+365
+366
+367
+368
+369
+370
+371
+372
+373
+374
+375
+
+
(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Damien Doligez, projet Para, INRIA Rocquencourt            *)
+(*                                                                        *)
+(*   Copyright 1997 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Weak array operations *)
+
+type !'a t
+
+external create : int -> 'a t = "caml_weak_create"
+
+(** number of additional values in a weak pointer
+ *    - Link
+ *    - Data *)
+let additional_values = 2 (* CAML_EPHE_FIRST_KEY in weak.h *)
+
+let create l =
+  if not (0 <= l && l <= Obj.Ephemeron.max_ephe_length) then
+    invalid_arg("Weak.create");
+  create l
+
+
+let length x = Obj.size(Obj.repr x) - additional_values
+
+let raise_if_invalid_offset e o msg =
+  if not (0 <= o && o < length e) then
+    invalid_arg(msg)
+
+external set' : 'a t -> int -> 'a -> unit = "caml_ephe_set_key"
+external unset : 'a t -> int -> unit = "caml_ephe_unset_key"
+let set e o x =
+  raise_if_invalid_offset e o "Weak.set";
+  match x with
+  | None -> unset e o
+  | Some x -> set' e o x
+
+external get : 'a t -> int -> 'a option = "caml_weak_get"
+let get e o =
+  raise_if_invalid_offset e o "Weak.get";
+  get e o
+
+external get_copy : 'a t -> int -> 'a option = "caml_weak_get_copy"
+let get_copy e o =
+  raise_if_invalid_offset e o "Weak.get_copy";
+  get_copy e o
+
+external check : 'a t -> int -> bool = "caml_weak_check"
+let check e o =
+  raise_if_invalid_offset e o "Weak.check";
+  check e o
+
+external blit : 'a t -> int -> 'a t -> int -> int -> unit = "caml_weak_blit"
+
+(* blit: src srcoff dst dstoff len *)
+let blit e1 o1 e2 o2 l =
+  if l < 0 || o1 < 0 || o1 > length e1 - l
+     || o2 < 0 || o2 > length e2 - l
+  then invalid_arg "Weak.blit"
+  else if l <> 0 then blit e1 o1 e2 o2 l
+
+let fill ar ofs len x =
+  if ofs < 0 || len < 0 || ofs > length ar - len
+  then raise (Invalid_argument "Weak.fill")
+  else begin
+    for i = ofs to (ofs + len - 1) do
+      set ar i x
+    done
+  end
+
+
+(** Weak hash tables *)
+
+module type S = sig
+  type data
+  type t
+  val create : int -> t
+  val clear : t -> unit
+  val merge : t -> data -> data
+  val add : t -> data -> unit
+  val remove : t -> data -> unit
+  val find : t -> data -> data
+  val find_opt : t -> data -> data option
+  val find_all : t -> data -> data list
+  val mem : t -> data -> bool
+  val iter : (data -> unit) -> t -> unit
+  val fold : (data -> 'a -> 'a) -> t -> 'a -> 'a
+  val count : t -> int
+  val stats : t -> int * int * int * int * int * int
+end
+
+module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct
+
+  type 'a weak_t = 'a t
+  let weak_create = create
+  let emptybucket = weak_create 0
+
+  type data = H.t
+
+  type t = {
+    mutable table : data weak_t array;
+    mutable hashes : int array array;
+    mutable limit : int;               (* bucket size limit *)
+    mutable oversize : int;            (* number of oversize buckets *)
+    mutable rover : int;               (* for internal bookkeeping *)
+  }
+
+  let get_index t h = (h land max_int) mod (Array.length t.table)
+
+  let limit = 7
+  let over_limit = 2
+
+  let create sz =
+    let sz = if sz < 7 then 7 else sz in
+    let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in
+    {
+      table = Array.make sz emptybucket;
+      hashes = Array.make sz [| |];
+      limit = limit;
+      oversize = 0;
+      rover = 0;
+    }
+
+  let clear t =
+    for i = 0 to Array.length t.table - 1 do
+      t.table.(i) <- emptybucket;
+      t.hashes.(i) <- [| |];
+    done;
+    t.limit <- limit;
+    t.oversize <- 0
+
+
+  let fold f t init =
+    let rec fold_bucket i b accu =
+      if i >= length b then accu else
+      match get b i with
+      | Some v -> fold_bucket (i+1) b (f v accu)
+      | None -> fold_bucket (i+1) b accu
+    in
+    Array.fold_right (fold_bucket 0) t.table init
+
+
+  let iter f t =
+    let rec iter_bucket i b =
+      if i >= length b then () else
+      match get b i with
+      | Some v -> f v; iter_bucket (i+1) b
+      | None -> iter_bucket (i+1) b
+    in
+    Array.iter (iter_bucket 0) t.table
+
+
+  let iter_weak f t =
+    let rec iter_bucket i j b =
+      if i >= length b then () else
+      match check b i with
+      | true -> f b t.hashes.(j) i; iter_bucket (i+1) j b
+      | false -> iter_bucket (i+1) j b
+    in
+    Array.iteri (iter_bucket 0) t.table
+
+
+  let rec count_bucket i b accu =
+    if i >= length b then accu else
+    count_bucket (i+1) b (accu + (if check b i then 1 else 0))
+
+
+  let count t =
+    Array.fold_right (count_bucket 0) t.table 0
+
+
+  let next_sz n = Int.min (3 * n / 2 + 3) Sys.max_array_length
+  let prev_sz n = ((n - 3) * 2 + 2) / 3
+
+  let test_shrink_bucket t =
+    let bucket = t.table.(t.rover) in
+    let hbucket = t.hashes.(t.rover) in
+    let len = length bucket in
+    let prev_len = prev_sz len in
+    let live = count_bucket 0 bucket 0 in
+    if live <= prev_len then begin
+      let rec loop i j =
+        if j >= prev_len then begin
+          if check bucket i then loop (i + 1) j
+          else if check bucket j then begin
+            blit bucket j bucket i 1;
+            hbucket.(i) <- hbucket.(j);
+            loop (i + 1) (j - 1);
+          end else loop i (j - 1);
+        end;
+      in
+      loop 0 (length bucket - 1);
+      if prev_len = 0 then begin
+        t.table.(t.rover) <- emptybucket;
+        t.hashes.(t.rover) <- [| |];
+      end else begin
+        let newbucket = weak_create prev_len in
+        blit bucket 0 newbucket 0 prev_len;
+        t.table.(t.rover) <- newbucket;
+        t.hashes.(t.rover) <- Array.sub hbucket 0 prev_len
+      end;
+      if len > t.limit && prev_len <= t.limit then t.oversize <- t.oversize - 1;
+    end;
+    t.rover <- (t.rover + 1) mod (Array.length t.table)
+
+
+  let rec resize t =
+    let oldlen = Array.length t.table in
+    let newlen = next_sz oldlen in
+    if newlen > oldlen then begin
+      let newt = create newlen in
+      let add_weak ob oh oi =
+        let setter nb ni _ = blit ob oi nb ni 1 in
+        let h = oh.(oi) in
+        add_aux newt setter None h (get_index newt h);
+      in
+      iter_weak add_weak t;
+      t.table <- newt.table;
+      t.hashes <- newt.hashes;
+      t.limit <- newt.limit;
+      t.oversize <- newt.oversize;
+      t.rover <- t.rover mod Array.length newt.table;
+    end else begin
+      t.limit <- max_int;             (* maximum size already reached *)
+      t.oversize <- 0;
+    end
+
+  and add_aux t setter d h index =
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then begin
+        let newsz =
+          Int.min (3 * sz / 2 + 3) (Sys.max_array_length - additional_values)
+        in
+        if newsz <= sz then failwith "Weak.Make: hash bucket cannot grow more";
+        let newbucket = weak_create newsz in
+        let newhashes = Array.make newsz 0 in
+        blit bucket 0 newbucket 0 sz;
+        Array.blit hashes 0 newhashes 0 sz;
+        setter newbucket sz d;
+        newhashes.(sz) <- h;
+        t.table.(index) <- newbucket;
+        t.hashes.(index) <- newhashes;
+        if sz <= t.limit && newsz > t.limit then begin
+          t.oversize <- t.oversize + 1;
+          for _i = 0 to over_limit do test_shrink_bucket t done;
+        end;
+        if t.oversize > Array.length t.table / over_limit then resize t;
+      end else if check bucket i then begin
+        loop (i + 1)
+      end else begin
+        setter bucket i d;
+        hashes.(i) <- h;
+      end;
+    in
+    loop 0
+
+
+  let add t d =
+    let h = H.hash d in
+    add_aux t set (Some d) h (get_index t h)
+
+
+  let find_or t d ifnotfound =
+    let h = H.hash d in
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then ifnotfound h index
+      else if h = hashes.(i) then begin
+        match get_copy bucket i with
+        | Some v when H.equal v d
+           -> begin match get bucket i with
+              | Some v -> v
+              | None -> loop (i + 1)
+              end
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
+    in
+    loop 0
+
+
+  let merge t d =
+    find_or t d (fun h index -> add_aux t set (Some d) h index; d)
+
+
+  let find t d = find_or t d (fun _h _index -> raise Not_found)
+
+  let find_opt t d =
+    let h = H.hash d in
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then None
+      else if h = hashes.(i) then begin
+        match get_copy bucket i with
+        | Some v when H.equal v d
+           -> begin match get bucket i with
+              | Some _ as v -> v
+              | None -> loop (i + 1)
+              end
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
+    in
+    loop 0
+
+
+  let find_shadow t d iffound ifnotfound =
+    let h = H.hash d in
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i =
+      if i >= sz then ifnotfound
+      else if h = hashes.(i) then begin
+        match get_copy bucket i with
+        | Some v when H.equal v d -> iffound bucket i
+        | _ -> loop (i + 1)
+      end else loop (i + 1)
+    in
+    loop 0
+
+
+  let remove t d = find_shadow t d (fun w i -> set w i None) ()
+
+
+  let mem t d = find_shadow t d (fun _w _i -> true) false
+
+
+  let find_all t d =
+    let h = H.hash d in
+    let index = get_index t h in
+    let bucket = t.table.(index) in
+    let hashes = t.hashes.(index) in
+    let sz = length bucket in
+    let rec loop i accu =
+      if i >= sz then accu
+      else if h = hashes.(i) then begin
+        match get_copy bucket i with
+        | Some v when H.equal v d
+           -> begin match get bucket i with
+              | Some v -> loop (i + 1) (v :: accu)
+              | None -> loop (i + 1) accu
+              end
+        | _ -> loop (i + 1) accu
+      end else loop (i + 1) accu
+    in
+    loop 0 []
+
+
+  let stats t =
+    let len = Array.length t.table in
+    let lens = Array.map length t.table in
+    Array.sort compare lens;
+    let totlen = Array.fold_left ( + ) 0 lens in
+    (len, count t, totlen, lens.(0), lens.(len/2), lens.(len-1))
+
+
+end
+
+
+
+ + + diff --git a/dune-project b/dune-project index 2e5e33a9f..fb0efecfa 100644 --- a/dune-project +++ b/dune-project @@ -21,7 +21,8 @@ the multicore run-time of OCaml 5.0.") (qcheck-core (>= "0.20")) (ppx_deriving_qcheck (>= "0.2.0")) (qcheck-lin (= :version)) - (qcheck-stm (= :version)))) + (qcheck-stm (= :version)) + (bisect_ppx :with-test))) (package (name qcheck-stm) diff --git a/multicoretests.opam b/multicoretests.opam index 08cf5a4b8..a26fcdf98 100644 --- a/multicoretests.opam +++ b/multicoretests.opam @@ -27,6 +27,7 @@ depends: [ "ppx_deriving_qcheck" {>= "0.2.0"} "qcheck-lin" {= version} "qcheck-stm" {= version} + "bisect_ppx" {with-test} "odoc" {with-doc} ] build: [ diff --git a/src/array/dune b/src/array/dune index 91892dbe7..475855943 100644 --- a/src/array/dune +++ b/src/array/dune @@ -4,7 +4,7 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries array qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -14,7 +14,7 @@ (modules lin_tests) (package multicoretests) (flags (:standard -w -27)) - (libraries qcheck-lin.domain) + (libraries array qcheck-lin.domain) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) ; (action (run %{test} --verbose)) (action (echo "Skipping src/array/%{test} from the test suite\n\n")) @@ -24,6 +24,18 @@ (name lin_tests_dsl) (modules lin_tests_dsl) (package multicoretests) - (libraries qcheck-lin.domain) + (libraries array qcheck-lin.domain) (action (run %{test} --verbose)) ) + +(rule + (target array.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name array) + (modules array) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/atomic/dune b/src/atomic/dune index b9ab37456..4972bd9ef 100644 --- a/src/atomic/dune +++ b/src/atomic/dune @@ -6,7 +6,7 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries atomic qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -18,7 +18,7 @@ (modules lin_tests) (package multicoretests) (flags (:standard -w -27)) - (libraries qcheck-lin.domain) + (libraries atomic qcheck-lin.domain) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) ; (action (run %{test} --verbose)) (action (echo "Skipping src/atomic/%{test} from the test suite\n\n")) @@ -28,6 +28,18 @@ (name lin_tests_dsl) (modules lin_tests_dsl) (package multicoretests) - (libraries qcheck-lin.domain) + (libraries atomic qcheck-lin.domain) (action (run %{test} --verbose)) ) + +(rule + (target atomic.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name atomic) + (modules atomic) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/bigarray/dune b/src/bigarray/dune index 5016d76d8..d73354734 100644 --- a/src/bigarray/dune +++ b/src/bigarray/dune @@ -4,7 +4,7 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries bigarray qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) ; (action (run %{test} --verbose)) (action (echo "Skipping src/bigarray/%{test} from the test suite\n\n")) @@ -14,6 +14,18 @@ (name lin_tests_dsl) (modules lin_tests_dsl) (package multicoretests) - (libraries qcheck-lin.domain) + (libraries bigarray qcheck-lin.domain) (action (run %{test} --verbose)) ) + +(rule + (target bigarray.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name bigarray) + (modules bigarray) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/buffer/dune b/src/buffer/dune index 725058f70..a0c7109e7 100644 --- a/src/buffer/dune +++ b/src/buffer/dune @@ -4,7 +4,19 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries buffer qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) + +(rule + (target buffer.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name buffer) + (modules buffer) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/bytes/dune b/src/bytes/dune index d20e3c6e8..49bcd2f66 100644 --- a/src/bytes/dune +++ b/src/bytes/dune @@ -4,7 +4,7 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries bytescp qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -13,6 +13,18 @@ (name lin_tests_dsl) (modules lin_tests_dsl) (package multicoretests) - (libraries qcheck-lin.domain qcheck-lin.thread) + (libraries bytescp qcheck-lin.domain qcheck-lin.thread) (action (run %{test} --verbose)) ) + +(rule + (target bytescp.ml) + (action (copy %{ocaml-config:standard_library}/bytes.ml %{target})) +) + +(library + (name bytescp) + (modules bytescp) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/bytes/stm_tests.ml b/src/bytes/stm_tests.ml index 5f4355640..7a33d3deb 100644 --- a/src/bytes/stm_tests.ml +++ b/src/bytes/stm_tests.ml @@ -16,7 +16,7 @@ struct [@@deriving show { with_path = false }] type state = char list - type sut = Bytes.t + type sut = Bytescp.t let arb_cmd s = let int_gen = Gen.(oneof [small_nat; int_bound (List.length s - 1)]) in @@ -48,20 +48,20 @@ struct else s | To_seq -> s - let init_sut () = Bytes.make byte_size 'a' + let init_sut () = Bytescp.make byte_size 'a' let cleanup _ = () let precond c _s = match c with | _ -> true let run c b = match c with - | Length -> Res (int, Bytes.length b) - | Get i -> Res (result char exn, protect (Bytes.get b) i) - | Set (i,c) -> Res (result unit exn, protect (Bytes.set b i) c) - | Sub (i,l) -> Res (result (bytes) exn, protect (Bytes.sub b i) l) - | Copy -> Res (bytes, Bytes.copy b) - | Fill (i,l,c) -> Res (result unit exn, protect (Bytes.fill b i l) c) - | To_seq -> Res (seq char, List.to_seq (List.of_seq (Bytes.to_seq b))) + | Length -> Res (int, Bytescp.length b) + | Get i -> Res (result char exn, protect (Bytescp.get b) i) + | Set (i,c) -> Res (result unit exn, protect (Bytescp.set b i) c) + | Sub (i,l) -> Res (result (bytes) exn, protect (Bytescp.sub b i) l) + | Copy -> Res (bytes, Bytescp.copy b) + | Fill (i,l,c) -> Res (result unit exn, protect (Bytescp.fill b i l) c) + | To_seq -> Res (seq char, List.to_seq (List.of_seq (Bytescp.to_seq b))) let postcond c (s: char list) res = match c, res with | Length, Res ((Int,_),i) -> i = List.length s @@ -76,8 +76,8 @@ struct | Sub (i,l), Res ((Result (Bytes,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "String.sub / Bytes.sub") - else r = Ok (Bytes.of_seq (List.to_seq (List.filteri (fun j _ -> i <= j && j <= i+l-1) s))) - | Copy, Res ((Bytes,_),r) -> r = Bytes.of_seq (List.to_seq s) + else r = Ok (Bytescp.of_seq (List.to_seq (List.filteri (fun j _ -> i <= j && j <= i+l-1) s))) + | Copy, Res ((Bytes,_),r) -> r = Bytescp.of_seq (List.to_seq s) | Fill (i,l,_), Res ((Result (Unit,Exn),_), r) -> if i < 0 || l < 0 || i+l > List.length s then r = Error (Invalid_argument "String.fill / Bytes.fill" ) diff --git a/src/domain/dune b/src/domain/dune index 35630838d..d0417a673 100644 --- a/src/domain/dune +++ b/src/domain/dune @@ -6,7 +6,7 @@ (name domain_joingraph) (modules domain_joingraph) (package multicoretests) - (libraries util qcheck-core qcheck-core.runner) + (libraries domain util qcheck-core qcheck-core.runner) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -15,7 +15,19 @@ (name domain_spawntree) (modules domain_spawntree) (package multicoretests) - (libraries util qcheck-core qcheck-core.runner) + (libraries domain util qcheck-core qcheck-core.runner) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) + +(rule + (target domain.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name domain) + (modules domain) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/ephemeron/dune b/src/ephemeron/dune index 27f1f7f1b..df982d1cb 100644 --- a/src/ephemeron/dune +++ b/src/ephemeron/dune @@ -4,7 +4,7 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries ephemeron qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -13,6 +13,18 @@ (name lin_tests_dsl) (modules lin_tests_dsl) (package multicoretests) - (libraries qcheck-lin.domain qcheck-lin.thread) + (libraries ephemeron qcheck-lin.domain qcheck-lin.thread) (action (run %{test} --verbose)) ) + +(rule + (target ephemeron.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name ephemeron) + (modules ephemeron) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/floatarray/dune b/src/floatarray/dune index eb4811ff2..ac667e1dd 100644 --- a/src/floatarray/dune +++ b/src/floatarray/dune @@ -4,7 +4,7 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries float qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -13,6 +13,18 @@ (name lin_tests_dsl) (modules lin_tests_dsl) (package multicoretests) - (libraries qcheck-lin.domain) + (libraries float qcheck-lin.domain) (action (run %{test} --verbose)) ) + +(rule + (target float.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name float) + (modules float) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/hashtbl/dune b/src/hashtbl/dune index b3373a377..5a7f3e487 100644 --- a/src/hashtbl/dune +++ b/src/hashtbl/dune @@ -4,7 +4,7 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries hashtbl qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -14,7 +14,7 @@ (modules lin_tests) (package multicoretests) (flags (:standard -w -27)) - (libraries qcheck-lin.domain) + (libraries hashtbl qcheck-lin.domain) (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)) ; (action (run %{test} --verbose)) (action (echo "Skipping src/hashtbl/%{test} from the test suite\n\n")) @@ -24,6 +24,18 @@ (name lin_tests_dsl) (modules lin_tests_dsl) (package multicoretests) - (libraries qcheck-lin.domain) + (libraries hashtbl qcheck-lin.domain) (action (run %{test} --verbose)) ) + +(rule + (target hashtbl.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name hashtbl) + (modules hashtbl) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/io/dune b/src/io/dune index 4985a5b0d..77a0d4084 100644 --- a/src/io/dune +++ b/src/io/dune @@ -14,7 +14,7 @@ (name lin_tests_dsl_common_io) (modules lin_tests_dsl_common) (package multicoretests) - (libraries qcheck-lin.lin) + (libraries in_channel out_channel qcheck-lin.lin) ) (test @@ -35,3 +35,29 @@ ; (action (run %{test} --verbose)) (action (echo "Skipping src/io/%{test} from the test suite\n\n")) ) + +(rule + (target in_channel.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name in_channel) + (modules in_channel) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) + (package multicoretests) +) + +(rule + (target out_channel.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name out_channel) + (modules out_channel) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) + (package multicoretests) +) diff --git a/src/lazy/dune b/src/lazy/dune index 937d13dd8..04042c983 100644 --- a/src/lazy/dune +++ b/src/lazy/dune @@ -4,7 +4,7 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries lazy qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -27,3 +27,15 @@ ; (action (run %{test} --verbose)) (action (echo "Skipping src/lazy/%{test} from the test suite\n\n")) ) + +(rule + (target lazy.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name lazy) + (modules lazy) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/queue/dune b/src/queue/dune index 246e7bf06..86b4469d6 100644 --- a/src/queue/dune +++ b/src/queue/dune @@ -5,7 +5,7 @@ (modules lin_tests_dsl) (package multicoretests) (flags (:standard -w -27)) - (libraries qcheck-lin.domain qcheck-lin.thread) + (libraries queue qcheck-lin.domain qcheck-lin.thread) (action (run %{test} --verbose)) ) @@ -19,3 +19,15 @@ ;(action (run %{test} --verbose)) (action (echo "Skipping src/queue/%{test} from the test suite\n\n")) ) + +(rule + (target queue.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name queue) + (modules queue) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/semaphore/dune b/src/semaphore/dune index 6e4d5e285..e3e2aafb3 100644 --- a/src/semaphore/dune +++ b/src/semaphore/dune @@ -4,7 +4,19 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries semaphore qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) + +(rule + (target semaphore.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name semaphore) + (modules semaphore) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/stack/dune b/src/stack/dune index ac02856a6..579f96822 100644 --- a/src/stack/dune +++ b/src/stack/dune @@ -5,7 +5,7 @@ (modules lin_tests_dsl) (package multicoretests) (flags (:standard -w -27)) - (libraries qcheck-lin.domain qcheck-lin.thread) + (libraries stack qcheck-lin.domain qcheck-lin.thread) (action (run %{test} --verbose)) ) @@ -20,3 +20,14 @@ (action (echo "Skipping src/stack/%{test} from the test suite\n\n")) ) +(rule + (target stack.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name stack) + (modules stack) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/sys/dune b/src/sys/dune index bac13a868..37aabb5bc 100644 --- a/src/sys/dune +++ b/src/sys/dune @@ -4,7 +4,19 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries sys qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) + +(rule + (target sys.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name sys) + (modules sys) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +) diff --git a/src/weak/dune b/src/weak/dune index d054148f3..3db1dcebc 100644 --- a/src/weak/dune +++ b/src/weak/dune @@ -4,7 +4,7 @@ (name stm_tests) (modules stm_tests) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries weak qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -13,7 +13,7 @@ (name stm_tests_hashset) (modules stm_tests_hashset) (package multicoretests) - (libraries qcheck-stm.sequential qcheck-stm.domain) + (libraries weak qcheck-stm.sequential qcheck-stm.domain) (preprocess (pps ppx_deriving.show)) (action (run %{test} --verbose)) ) @@ -22,7 +22,7 @@ (name lin_tests_dsl) (modules lin_tests_dsl) (package multicoretests) - (libraries qcheck-lin.domain) + (libraries weak qcheck-lin.domain) (action (run %{test} --verbose)) ) @@ -30,6 +30,18 @@ (name lin_tests_dsl_hashset) (modules lin_tests_dsl_hashset) (package multicoretests) - (libraries qcheck-lin.domain) + (libraries weak qcheck-lin.domain) (action (run %{test} --verbose)) ) + +(rule + (target weak.ml) + (action (copy %{ocaml-config:standard_library}/%{target} %{target})) +) + +(library + (name weak) + (modules weak) + (flags (:standard -w -9)) + (instrumentation (backend bisect_ppx)) +)