swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

29
data/tls/certificates/foo Normal file
View file

@ -0,0 +1,29 @@
-----BEGIN CERTIFICATE-----
MIIFCTCCAvGgAwIBAgIUBmSRa4019HvyNTHuxkoAXMgVs0YwDQYJKoZIhvcNAQEL
BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MB4XDTI1MTEwMjE1MDQ1M1oXDTI2MTEw
MjE1MDQ1M1owFDESMBAGA1UEAwwJbG9jYWxob3N0MIICIjANBgkqhkiG9w0BAQEF
AAOCAg8AMIICCgKCAgEA7gACN8U+sg5nFZ8hNPpBT7kxXqP1vI4F/AYzjbjonjMZ
7UtWoOoMa49OfzYW4KjJO1oRVGlYLg3pR8iS2kZhwSivTZoKLepBFM5EzlOeB4JJ
uJcBbzB17rpJfl37Wr+Tp76gUY2PV7wXWtkFe14LmnqxKuVCTj/a8TogN22h/Skz
ZB34wds4QGKKfNjdkzl5hInICwztoOCd5xAM19+0dpCB2TlHajgr1/5Syuygb33J
n1SxPSjborZGWC9DOcsHaArmD/+aO0Fkta2M20SgxWg6pUc3VBP4JgXLf+J490Dd
hTm+QM6aqpoBeAG6oYEE2mVPk1kWXrCPLQVKOJx8qe9ciG1nw0Zw3JlDplTgTOhu
d9NCUC7Be+NNeOe8/chPz40Yx5YMy3FsTrn5m7P/U0W3C5hJ0u0tCUJwR4aoI8+c
JMxw+6RyW9IyQP11dFsX2XfGYiVYug7tcB+UBzUXHkqFm/pryVduxCaMW6GBuYj4
lQt5+9w0Udtmmy1fLdPNd976xjs44py9lug8ZjrBqLgovpplP/nlENeUAhDOTcvJ
7+wkgAUbSjmmmCQysn1+kIM1E8G/5IWWpnrFVc8/AeHX6xl77SHsZNWPglrR2U48
dMVFWg9Iow4/wo2Q/98U3JXJFCMgYNnLsmqLJAt/kwn+50Oe1vvrZpuDONc9sKEC
AwEAAaNTMFEwHQYDVR0OBBYEFBLecWdZ6LfT3DOxGt1laLUXEMD7MB8GA1UdIwQY
MBaAFBLecWdZ6LfT3DOxGt1laLUXEMD7MA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZI
hvcNAQELBQADggIBADfY6Urz93TXI37qzls91yRD+EtEgrmKk3XGD4fIEso7z7Ds
1g6CUZk9Yqv66ETtJIjZUYp6Gm4I3gGdrC6dQS0ubhRy1VPkxfpZxL6keFaN/S1i
r9Xt8L/FT7umUB7xBInvgXTaJhhwFh6okzALAKe69QPQtGHO3d8mz/PBsS+yqr/h
7WQOLkcIS+hAnKGCRDvdIbLwdFny17QiHK/W17OKCPH7Re6lDaA2QmWJIaL/oFII
8agLr68Wv2/zE6FYS0bAaSyu4jIDOzVEUWS57vx70SFtbtYRQXHK2egWZH9iubmn
rBzGpNlPhRiS7CWkSxfocJJXqEd7FLWDpAnl8GRDmCwHixr4Ip76dOt1Wo7EgSfO
3INHKi2cuM0+JwcpfafnJ0HL4+mWso//ZficQWfrBcsRmdM/x1Tl8IgHtqmW2SxF
dNf5Dt47WHrQgg1PuJu88GGUSyN6NKn9xV/SipZM+ZGfjHusTnaQEwkJZD0P2sDm
n4R37BvAmiGDY1ri9h2AzO0qXrsGZKQup2Q5VtgOadX26sa1DeFhUHGwMgpuq/qT
rED/wfcJ4VfI9phorPoaKEBoOv81hjlQ4byEYNgyGJzhdRgcmkUXNOIoiu0iB01Y
YXDB9XEwwu3Gotx4RFv03V4Dlj3Cn9aRZ3LB9w5UnYA0PsFh8Wm5Tld1J1AJ
-----END CERTIFICATE-----

52
data/tls/keys/foo Normal file
View file

@ -0,0 +1,52 @@
-----BEGIN PRIVATE KEY-----
MIIJQgIBADANBgkqhkiG9w0BAQEFAASCCSwwggkoAgEAAoICAQDuAAI3xT6yDmcV
nyE0+kFPuTFeo/W8jgX8BjONuOieMxntS1ag6gxrj05/NhbgqMk7WhFUaVguDelH
yJLaRmHBKK9Nmgot6kEUzkTOU54Hgkm4lwFvMHXuukl+Xftav5OnvqBRjY9XvBda
2QV7XguaerEq5UJOP9rxOiA3baH9KTNkHfjB2zhAYop82N2TOXmEicgLDO2g4J3n
EAzX37R2kIHZOUdqOCvX/lLK7KBvfcmfVLE9KNuitkZYL0M5ywdoCuYP/5o7QWS1
rYzbRKDFaDqlRzdUE/gmBct/4nj3QN2FOb5AzpqqmgF4AbqhgQTaZU+TWRZesI8t
BUo4nHyp71yIbWfDRnDcmUOmVOBM6G5300JQLsF7401457z9yE/PjRjHlgzLcWxO
ufmbs/9TRbcLmEnS7S0JQnBHhqgjz5wkzHD7pHJb0jJA/XV0WxfZd8ZiJVi6Du1w
H5QHNRceSoWb+mvJV27EJoxboYG5iPiVC3n73DRR22abLV8t08133vrGOzjinL2W
6DxmOsGouCi+mmU/+eUQ15QCEM5Ny8nv7CSABRtKOaaYJDKyfX6QgzUTwb/khZam
esVVzz8B4dfrGXvtIexk1Y+CWtHZTjx0xUVaD0ijDj/CjZD/3xTclckUIyBg2cuy
aoskC3+TCf7nQ57W++tmm4M41z2woQIDAQABAoICAAoBXdaAoCm93YNNDukyXpnG
hi7te2SPf2yoiZULCZtx+ERvqv8Fi9tfOUxzhotwCRKpzwnyikqYWt7hzZunww8K
4fDEGaqzuwPwBng6j22PIoCEN6MYIVMViYaqlokqfd96zfRTvEuSzJQNBNQagGgg
gY91NyABQvfqasWNwjY5e8+5C1bB+6fIRLxqJQl+DG/gF3TweJJvcu/ubq3KGaT0
3wKV6/zJCv3P8yTVBQse2YGtXqycqbwZx9QH+55jvMZY0/Jm+1HDpmNVXhMvO8eE
wddmKqsqEj/t9S/FgnKZi16BDpCcpuemZQqpnvIQcZbpVKqz/3LgXwqEWwoNeRea
h0GiuzHuPrd6XrU9EhSD/aWDcs7/wnaZx5iNmF4gqEfmb/gj9M586jyoIvO5vxDd
2BkaT56YtShNC49VDF5opApC3ZDwqirY0sUufTZ41ZtJCs6lNpMoDPddORA9FLja
rrIemSlzcdOp+bwlx2hXfqIXpskzeHKy1m7ZXPp0ugpHYvwSiU2YvBJLF+tYwcCj
goZ1v79QjEfjNoVw8M/OPA2A0LpA5fR/jALwBBl/sZYbMl4Z2mz7lI+PNlWHaFRQ
hlp+ua9kqU4JvFMksrkwYv4hEKQtGJ/q4XyQZWoRqt569GFNih7n24X6HWy0Tfgs
7rHLfHu8dzQxXyPWNC4ZAoIBAQD5kfPN3gKS5P7WYGiLrucZenAK0227A/PoR7aU
j5KUg8nwWKfnGI6TT7QMJ7iWq/fkFql3qFOZx7t45Btjz2+3GSFBVu1ajyghXiFM
r/s0cYLyeo61TYApZRlH1KV+6ooSemB3YqnI1FRNqc6UUAfVm2ysLJ8Iu8xyEQQ6
KkJDe3oRb0j36cgU9XblEbFJFgKHFwdRLD32JylSMLy18ooyI6I0WILUyhTCBvVB
28KGcH7KHMadqJb8m9Gaj7JpaFkgqcKm5hTIdbaEQZfdpQneVGonioekT9i51AOv
Iba6+OuctDBCc1JJk+znk6lDZqvmaiIz+oNe8SQVeLJgDAgJAoIBAQD0Ib7SE+37
KR7UmyZ77+Tvv/AgZXVTU8HedItPvDZvMQef5gngvVoO3G0dVZN3Mkp9hEfXFsqX
9QAW2EWV5RPA8QmdciL84jC611ordLJNeG/lieyL+uJ+7amOi/eHL0Sb4RzYS95U
m8A6UZCL2PVFxQ4M02YGOZC1kp6Ht4hpv4eAj6+fVRWgH0d/qx/sJPCVMjGKUMb8
AlgjT1lV9O76E5lmbQhE5AdMcGyDWdnti9QpdUjJxcJywb5sJFVKI5MPbLaI5F9x
YhTEa0Ee+v5fo/pNv7ljqVUx4EIIfl1msMIxk7Lt17MZdsYFepSCmhVo1xSPBJSR
Q46mq7fashnZAoIBABUauIlCKumNH9e1E2IsijJnXi4sLu1PqkKMPe5WLckNU/hV
Ju2t7/CZHtqgSUXEiRPqrq4Ft/wbHcldUMuh8QqEv4Es/qlXzcb0lNBNWWrX5oDm
yEagpSPa/sZKPyx6XO6vFpVB7KWk/vQKVgPIuMDhgdEVfOVaLDHBKqBYjn3yZSIw
TPVZ+ad8Em/QjTNm/xO5aM7+dMbqDN58bJjeR71xsffHPFkONa8qs3a8RLjlrnMc
99bBOPNnodP2LtonDtJqSKGgd0V0XtjUSyldGXaJoOhzGIFWlzcvrJgUu8UX46S+
wA3+fojmT3RN0lR2zDaR5w6KMq3Gqox+RmdE3TECggEBAO9VedZH9YHJ8VCq/dJ4
/27PM2D/NkNHlIM6rCyyLodZgMkQY1SxLW3uSQZ+E8DCS+a7XRaPYHQSm1DKG4X0
+yWm6C8zavuR4AX8A4kgsYBjdweH7J/aiFu5MQXvT+52t4M98OJXlpJJ0u0Zc2S2
gNYydjC6uoWVv7lSERqqIhDR1MyDkL/aUQYWRCj0IaqHGFibyZd402rR/Yg4TTOI
mRQPTM7uSzIGfuVAPhGTb6OC9q7iLUaqGpQYPk+UWw0AzTZM9LJFeRAWAJgDMedm
VyR6BHReZig/JKdt3C6pe3WmCetCiiLD2PA40a8jWh6jYiPS33PKIMA8g8gABpFf
ExkCggEAUzoVzOD/zzC04icPmIbwO3cpEfCT/JwEF/qOteKWu50Uj8K2Yf96+BRb
u9bSjIPEedjm21kcZLHcJJ+RW/uVq8RhtKmriXSxB81jC0EHGZShav12fTHwmPXk
jipUclGjbug0LkQsgI5ayO2jo6lfJuKMpby9BANFeujRTe2M7IrUlDkEhWfgwNmo
0bOTl1VgdAFCh0zraOhrLlRwIDKIrL3ptKj2rc/LNb7NwrvCY0nz0bctcrwiyB+Z
wwrrCQskHfB6j2l+H6OWaGEZBxRku/7JPXvBvjxSpOn/Fjlj0W8bRKmlW5qn0nFg
cMST03o2tFqgpeUPjWGaRM+nsa1Pfg==
-----END PRIVATE KEY-----

10
unikernel/dist/dune vendored Normal file
View file

@ -0,0 +1,10 @@
;; Generated by mirage.v4.10.3
(rule
(mode
(promote (until-clean)))
(target mte)
(enabled_if
(= %{context_name} "default"))
(action
(copy ../mte %{target})))

44
unikernel/dune.build Normal file
View file

@ -0,0 +1,44 @@
;; Generated by mirage.v4.10.3
(copy_files# ./mirage/main.ml)
(rule
(target mte)
(enabled_if (= %{context_name} "default"))
(deps main.exe)
(action
(copy main.exe %{target})))
(executable
(name main)
(libraries caqti caqti-driver-pgx caqti-lwt caqti-mirage caqti-tls
cmdliner-stdlib dns-client-mirage duration h2 happy-eyeballs-mirage
logs lwt mimic-happy-eyeballs mirage-bootvar mirage-bootvar.unix
mirage-crypto-rng-mirage mirage-kv-mem mirage-logs mirage-mtime
mirage-mtime.unix mirage-ptime mirage-ptime.unix mirage-runtime
mirage-runtime.network mirage-sleep mirage-sleep.unix mirage-unix
paf.mirage tcpip.stack-direct tcpip.stack-socket tcpip.tcpv4v6-socket
tcpip.udpv4v6-socket mte)
(link_flags (-thread))
(modules (:standard \ config))
(flags :standard -w -70 -color always)
(enabled_if (= %{context_name} "default"))
)
(rule
(targets Static____data_assets.ml Static____data_assets.mli)
(deps (source_tree ../data/assets))
(action
(run ocaml-crunch -o Static____data_assets.ml ../data/assets)))
(rule
(targets Static____data_tls_certificates.ml Static____data_tls_certificates.mli)
(deps (source_tree ../data/tls/certificates))
(action
(run ocaml-crunch -o Static____data_tls_certificates.ml ../data/tls/certificates)))
(rule
(targets Static____data_tls_keys.ml Static____data_tls_keys.mli)
(deps (source_tree ../data/tls/keys))
(action
(run ocaml-crunch -o Static____data_tls_keys.ml ../data/tls/keys)))

9
unikernel/dune.config Normal file
View file

@ -0,0 +1,9 @@
;; Generated by mirage.v4.10.3
(data_only_dirs duniverse dist)
(executable
(name config)
(modules config)
(flags :standard -warn-error -A)
(libraries mirage))

24
unikernel/duniverse/README.md Normal file
View file

@ -0,0 +1,24 @@
# duniverse
This folder contains vendored source code of the dependencies of the project,
created by the [opam-monorepo](https://github.com/ocamllabs/opam-monorepo)
tool. You can find the packages and versions that are included in this folder
in the `.opam.locked` files.
To update the packages do not modify the files and directories by hand, instead
use `opam-monorepo` to keep the lockfiles and directory contents accurate and
in sync:
```sh
opam monorepo lock
opam monorepo pull
```
If you happen to include the `duniverse/` folder in your Git repository make
sure to commit all files:
```sh
git add -A duniverse/
```
For more information check out the homepage and manual of `opam-monorepo`.

4
unikernel/duniverse/Zarith/.gitattributes vendored Normal file
View file

@ -0,0 +1,4 @@
# Default behaviour, for if core.autocrlf isn't set
* text=auto
configure text eol=lf

32
unikernel/duniverse/Zarith/.github/workflows/CI.yml vendored Normal file
View file

@ -0,0 +1,32 @@
name: CI
on: [push, pull_request]
jobs:
Ubuntu:
runs-on: ubuntu-latest
steps:
- name: Install packages
run: sudo apt-get install ocaml-nox libgmp-dev
- name: Checkout
uses: actions/checkout@v2
- name: configure tree
run: ./configure
- name: Build
run: make
- name: Run the testsuite
run: make -C tests test
MacOS:
runs-on: macos-latest
steps:
- name: Install packages
run: brew install ocaml ocaml-findlib gmp
- name: Checkout
uses: actions/checkout@v2
- name: configure tree
run: ./configure
- name: Build
run: make
- name: Run the testsuite
run: make -C tests test

49
unikernel/duniverse/Zarith/.github/workflows/build.yml vendored Normal file
View file

@ -0,0 +1,49 @@
name: build
on:
pull_request:
push:
branches:
- master
schedule:
# Prime the caches every Monday
- cron: 0 1 * * MON
jobs:
build:
strategy:
fail-fast: false
matrix:
os:
- ubuntu-latest
- windows-latest
- macos-latest
ocaml-compiler:
- "4.14"
- "5.2"
runs-on: ${{ matrix.os }}
steps:
- name: Checkout code
uses: actions/checkout@v4
- name: Set-up OCaml ${{ matrix.ocaml-compiler }}
uses: ocaml/setup-ocaml@v3
with:
ocaml-compiler: ${{ matrix.ocaml-compiler }}
- run: opam install . --with-test --deps-only
- name: configure tree
run: opam exec -- sh ./configure
- name: Build
run: opam exec -- make
- name: Run the testsuite
run: opam exec -- make -C tests test
- run: opam install . --with-test
- run: opam exec -- git diff --exit-code

12
unikernel/duniverse/Zarith/.gitignore vendored Normal file
View file

@ -0,0 +1,12 @@
*.a
*.cm?
*.cmxa
*.cmxs
*.cmti
*.exe
*.byt
*.o
*.so
Makefile
depend
zarith_version.ml

2
unikernel/duniverse/Zarith/.ocamlformat Normal file
View file

@ -0,0 +1,2 @@
version=0.20.1
disable=true

143
unikernel/duniverse/Zarith/Changes Normal file
View file

@ -0,0 +1,143 @@
Release 1.14 (2024-07-10)
- #148, #149: Fail unmarshaling when it would produce non-canonical big ints
- #145, #150: Use standard hash function for `Z.hash` and add `Z.seeded_hash`
- #140, #147: Add fast path for `Z.divisible` on small arguments
Release 1.13 (2023-07-19)
- #113: add conversions to/from small unsigned integers `(to|fits)_(int32|int64|nativeint)_unsigned` [Antoine Miné]
- #128: add functions to pseudo-randomly generate integers [Xavier Leroy]
- #105: add `Big_int.big_int_of_float` [Yishuai Li]
- #90: add fast path to `Z.extract` when extraction leads to a small integer [Frédéric Recoules]
- #137: more precise bounds for of_float conversion to small ints [Antoine Miné]
- #118: fix Z_mlgmpidl interface for mlgmpidl >= 1.2 [Simmo Saan]
- #109: fix typo in `ml_z_mul` function [Bernhard Schommer]
- #108: fix dependency on C evaluation order in `ml_z_remove` [Xavier Clerc]
- #117 #120 #129 #132 #135 #139 #141: configure & build simplifications and fixes [various authors]
- #134: CI testing: add Windows, test both 4.14 and 5.0 [Hugo Heuzard]
Release 1.12 (2021-03-03)
- PR #79: fast path in OCaml (instead of assembly language) [Xavier Leroy]
- PR #94: remove source preprocessing and simplify configuration [Xavier Leroy]
- PR #93: fix parallel build [Guillaume Melquiond]
- PR #92: fix benchmark for subtraction [Guillaume Melquiond]
- Require OCaml 4.04 or later [Xavier Leroy]
- Add CI testing on macOS [Xavier Leroy]
Release 1.11 (2020-11-09)
- Fixes #72, #75, #78: multiple fixes for of_string, support for underscores [hhugo]
- Fix #74: fix Q.to_float for denormal numbers [pascal-cuoq]
- Fix #84: always represent min_int by a tagged integer [xavierleroy]
- muliple fixes for min_int arguments [xavierleroy]
- Improvement #85: optimize the fast paths for comparison and equality tests [xavierleroy]
- Fix #80: ar tool is detected in configure [jsmolic]
Release 1.10 (2020-09-11)
- Improvement #66: added some mpz functions (divisible, congruent, jacobi, legendre, krobecker, remove, fac, primorial, bin, fib, lucnum)
- Improvement #65: Q.of_string now handles decimal point and scientific notation [Ghiles Ziat]
- Fix #60: Z.root now raises an exception for invalid arguments
- Fix #62: raise division by 0 for 0-modulo in powm
- Fix #59: improved abs for negative arguments
- Fix #58: gcd, lcm, gcdext now behave as gmp for negative arguments
- Fix #57: clean compile with safe strings [hhugo]
Release 1.9.1 (2019-08-28) (bugfix):
- Fix configure issue for non-bash sh introduced in #45
- Tweaks to opam file [kit-ty-kate]
Release 1.9 (2019-08-22):
- Issue #50: add opam file, make it easy to "opam publish" new versions
- Issue #38: configure detects 32bit OCaml switch on 64bit host
- Fix #36: change Q.equal, leq, geq comparisons for undef
- Request #47: move infix comparison operators of Z in submodule
avoid shadowing the polymorphic compare [Bernhard Schommer]
- Fix #49: INT_MAX undeclared
- Request #46: add prefixnonocaml option [Et7f3]
- Request #45: fix ocamllibdir/caml/mlvalues.h bug (Cygwin) [Et7f3]
- Fix: attempting to build numbers too large for GMP raises an OCaml exception
instead of crashing with "gmp: overflow in mpz type"
Release 1.8 (2019-03-30):
- Request #20: infix comparison operators for Q and Z [Max Mouratov]
- Request #39: gdc(x,0) = gcd(0,x) = x [Vincent Laporte]
- Request #41: support for upcoming OCaml 4.08 [Daniel Hillerström]
- Issue #17: add package zarith.top with REPL printer [Christophe Troestler]
- Issue #22: wrong stack marking directive in caml_z_x86_64_mingw64.S
[Bernhard Schommer]
- Issue #24: generate and install .cmti files for easy access to documentation
- Issue #25: false alarm in tests/zq.ml owing to unreliable printing
of FP values
- Request #28: better handling of absolute paths in "configure"
Release 1.7 (2017-10-13):
- Issue#14, pull request#15: ARM assembly code was broken.
- Fix tests so that they work even if the legacy Num library is unavailable.
Release 1.6 (2017-09-23):
- On Linux and BSD, keep the stack non-executable.
- Issue#10: clarify documentation of Q.of_string
- Fixed spurious installation error if shared libraries not supported
[Bernhard Schommer]
Release 1.5 (2017-05-26):
- Install all .cmx files, improving performance of clients and
avoiding a warning from OCaml 4.03 and up.
- Z.of_float: fix a bug in the fast path [Richard Jones]
(See https://bugzilla.redhat.com/show_bug.cgi?id=1392247)
- Improve compatibility with OCaml 4.03 and up
[Bernhard Schommer]
- Overflow issue in Z.pow and Z.root with very large exponents (GPR#5)
[Andre Maroneze]
- Added function Q.to_float.
Release 1.4.1 (2015-11-09):
- Fixed ml_z_of_substring_base and Z.of_substring [Thomas Braibant]
- Integrated Opam fix for Perl scripts [Thomas Braibant]
Release 1.4 (2015-11-02):
- Improvements to Q (using divexact) [Bertrand Jeannet]
- Fixed div_2exp bug [Bertrand Jeannet]
- Improvements for divexact [Bertrand Jeannet]
- Added of_substring, with fast path for native integers [Thomas Braibant]
- Added Z.powm_sec (constant-time modular exponentiation)
- Reimplemented Z.to_float, now produces correctly rounded FP numbers
- Added Z.trailing_zeros.
- Added Z.testbit, Z.is_even, Z.is_odd.
- Added Z.numbits, Z.log2 and Z.log2up.
- PR#1467: Z.hash is declared as "noalloc" [François Bobot]
- PR#1451: configure fix [Spiros Eliopoulos]
- PR#1436: disable "(void)" trick for unused variables on Windows [Bernhard Schommer]
- PR#1434: removed dependencies on printf & co when Z_PERFORM_CHECK is 0 [Hannes Mehnert]
- PR#1462: issues with Z.to_float and large numbers.
Release 1.3 (2014-09-03):
- Fixed inefficiencies in asm fast path for ARM.
- Revised detection of NaNs and infinities in Z.of_float
- Suppress the redundant fast paths written in C if a corresponding
fast path exists in asm.
- Use <stdint.h> to ensure compatibility with OCaml 4.02.
- More prudent implementation of Z.of_int, avoids GC problem
with OCaml < 4.02 (PR#6501 in the OCaml bug tracker).
- PR#1429: of_string accepts 'a' in base 10.
- Macro change to avoid compiler warnings on unused variables.
Release 1.2.1 (2013-06-12):
- Install fixes
Release 1.2 (2013-05-19):
- Added fast asm path for ARMv7 processors.
- PR#1192: incorrect behavior of div_2exp
- Issue with aggressive C compiler optimization in the fast path for multiply
- Better support for Windows/Mingw32
Release 1.1 (2012-03-24):
- Various improvements in the asm fast path for i686 and x86_64
- PR#1034: support for static linking of GMP/MPIR
- PR#1046: autodetection of ocamlopt and dynlink
- PR#1048: autodetection of more platforms that we support
- PR#1051: support architectures with strict alignment constraints for
64-bit integers (e.g. Sparc)
- Fixed 1-bit precision loss when converting doubles to rationals
- Improved support for the forthcoming release 4.00 of OCaml
Release 1.0 (2011-08-18):
- First public release

501
unikernel/duniverse/Zarith/LICENSE Normal file
View file

@ -0,0 +1,501 @@
This Library is distributed under the terms of the GNU Library General
Public License version 2 (included below).
As a special exception to the GNU Library General Public License, you
may link, statically or dynamically, a "work that uses the Library"
with a publicly distributed version of the Library to produce an
executable file containing portions of the Library, and distribute
that executable file under terms of your choice, without any of the
additional requirements listed in clause 6 of the GNU Library General
Public License. By "a publicly distributed version of the Library",
we mean either the unmodified Library as distributed by INRIA, or a
modified version of the Library that is distributed under the
conditions defined in clause 3 of the GNU Library General Public
License. This exception does not however invalidate any other reasons
why the executable file might be covered by the GNU Library General
Public License.
----------------------------------------------------------------------
GNU LIBRARY GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1991 Free Software Foundation, Inc.
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
[This is the first released version of the library GPL. It is
numbered 2 because it goes with version 2 of the ordinary GPL.]
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.
This license, the Library General Public License, applies to some
specially designated Free Software Foundation software, and to any
other libraries whose authors decide to use it. You can use it for
your libraries, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if
you distribute copies of the library, or if you modify it.
For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you. You must make sure that they, too, receive or can get the source
code. If you link a program with the library, you must provide
complete object files to the recipients so that they can relink them
with the library, after making changes to the library and recompiling
it. And you must show them these terms so they know their rights.
Our method of protecting your rights has two steps: (1) copyright
the library, and (2) offer you this license which gives you legal
permission to copy, distribute and/or modify the library.
Also, for each distributor's protection, we want to make certain
that everyone understands that there is no warranty for this free
library. If the library is modified by someone else and passed on, we
want its recipients to know that what they have is not the original
version, so that any problems introduced by others will not reflect on
the original authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that companies distributing free
software will individually obtain patent licenses, thus in effect
transforming the program into proprietary software. To prevent this,
we have made it clear that any patent must be licensed for everyone's
free use or not licensed at all.
Most GNU software, including some libraries, is covered by the ordinary
GNU General Public License, which was designed for utility programs. This
license, the GNU Library General Public License, applies to certain
designated libraries. This license is quite different from the ordinary
one; be sure to read it in full, and don't assume that anything in it is
the same as in the ordinary license.
The reason we have a separate public license for some libraries is that
they blur the distinction we usually make between modifying or adding to a
program and simply using it. Linking a program with a library, without
changing the library, is in some sense simply using the library, and is
analogous to running a utility program or application program. However, in
a textual and legal sense, the linked executable is a combined work, a
derivative of the original library, and the ordinary General Public License
treats it as such.
Because of this blurred distinction, using the ordinary General
Public License for libraries did not effectively promote software
sharing, because most developers did not use the libraries. We
concluded that weaker conditions might promote sharing better.
However, unrestricted linking of non-free programs would deprive the
users of those programs of all benefit from the free status of the
libraries themselves. This Library General Public License is intended to
permit developers of non-free programs to use free libraries, while
preserving your freedom as a user of such programs to change the free
libraries that are incorporated in them. (We have not seen how to achieve
this as regards changes in header files, but we have achieved it as regards
changes in the actual functions of the Library.) The hope is that this
will lead to faster development of free libraries.
The precise terms and conditions for copying, distribution and
modification follow. Pay close attention to the difference between a
"work based on the library" and a "work that uses the library". The
former contains code derived from the library, while the latter only
works together with the library.
Note that it is possible for a library to be covered by the ordinary
General Public License rather than by this special one.
GNU LIBRARY GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any software library which
contains a notice placed by the copyright holder or other authorized
party saying it may be distributed under the terms of this Library
General Public License (also called "this License"). Each licensee is
addressed as "you".
A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.
The "Library", below, refers to any such software library or work
which has been distributed under these terms. A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language. (Hereinafter, translation is
included without limitation in the term "modification".)
"Source code" for a work means the preferred form of the work for
making modifications to it. For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control compilation
and installation of the library.
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it). Whether that is true depends on what the Library does
and what the program that uses the Library does.
1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.
You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.
2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) The modified work must itself be a software library.
b) You must cause the files modified to carry prominent notices
stating that you changed the files and the date of any change.
c) You must cause the whole of the work to be licensed at no
charge to all third parties under the terms of this License.
d) If a facility in the modified Library refers to a function or a
table of data to be supplied by an application program that uses
the facility, other than as an argument passed when the facility
is invoked, then you must make a good faith effort to ensure that,
in the event an application does not supply such function or
table, the facility still operates, and performs whatever part of
its purpose remains meaningful.
(For example, a function in a library to compute square roots has
a purpose that is entirely well-defined independent of the
application. Therefore, Subsection 2d requires that any
application-supplied function or table used by this function must
be optional: if the application does not supply it, the square
root function must still compute square roots.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.
In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library. To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License. (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.) Do not make any other change in
these notices.
Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.
This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.
4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.
If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.
5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library". Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.
However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library". The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.
When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library. The
threshold for this to be true is not precisely defined by law.
If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work. (Executables containing this object code plus portions of the
Library will still fall under Section 6.)
Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.
6. As an exception to the Sections above, you may also compile or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.
You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License. You must supply a copy of this License. If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License. Also, you must do one
of these things:
a) Accompany the work with the complete corresponding
machine-readable source code for the Library including whatever
changes were used in the work (which must be distributed under
Sections 1 and 2 above); and, if the work is an executable linked
with the Library, with the complete machine-readable "work that
uses the Library", as object code and/or source code, so that the
user can modify the Library and then relink to produce a modified
executable containing the modified Library. (It is understood
that the user who changes the contents of definitions files in the
Library will not necessarily be able to recompile the application
to use the modified definitions.)
b) Accompany the work with a written offer, valid for at
least three years, to give the same user the materials
specified in Subsection 6a, above, for a charge no more
than the cost of performing this distribution.
c) If distribution of the work is made by offering access to copy
from a designated place, offer equivalent access to copy the above
specified materials from the same place.
d) Verify that the user has already received a copy of these
materials or that you have already sent this user a copy.
For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it. However, as a special exception,
the source code distributed need not include anything that is normally
distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.
It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system. Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.
7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:
a) Accompany the combined library with a copy of the same work
based on the Library, uncombined with any other library
facilities. This must be distributed under the terms of the
Sections above.
b) Give prominent notice with the combined library of the fact
that part of it is a work based on the Library, and explaining
where to find the accompanying uncombined form of the same work.
8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License. Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License. However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.
9. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Library or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.
10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all. For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.
If any portion of this section is held invalid or unenforceable under any
particular circumstance, the balance of the section is intended to apply,
and the section as a whole is intended to apply in other circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License may add
an explicit geographical distribution limitation excluding those countries,
so that distribution is permitted only in or among countries not thus
excluded. In such case, this License incorporates the limitation as if
written in the body of this License.
13. The Free Software Foundation may publish revised and/or new
versions of the Library General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the Library
specifies a version number of this License which applies to it and
"any later version", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation. If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.
14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission. For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this. Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.
NO WARRANTY
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.
END OF TERMS AND CONDITIONS
Appendix: How to Apply These Terms to Your New Libraries
If you develop a new library, and you want it to be of the greatest
possible use to the public, we recommend making it free software that
everyone can redistribute and change. You can do so by permitting
redistribution under these terms (or, alternatively, under the terms of the
ordinary General Public License).
To apply these terms, attach the following notices to the library. It is
safest to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
<one line to give the library's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
MA 02111-1307, USA
Also add information on how to contact you by electronic and paper mail.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the library, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the
library `Frob' (a library for tweaking knobs) written by James Random Hacker.
<signature of Ty Coon>, 1 April 1990
Ty Coon, President of Vice
That's all there is to it!

18
unikernel/duniverse/Zarith/META Normal file
View file

@ -0,0 +1,18 @@
description = "Arbitrary precision integers"
requires = ""
version = "1.14"
archive(byte) = "zarith.cma"
archive(native) = "zarith.cmxa"
plugin(byte) = "zarith.cma"
plugin(native) = "zarith.cmxs"
package "top" (
version = "1.13"
description = "ZArith toplevel support"
requires = "zarith"
archive(byte) = "zarith_top.cma"
archive(native) = "zarith_top.cmxa"
plugin(byte) = "zarith_top.cma"
plugin(native) = "zarith_top.cmxs"
exists_if = "zarith_top.cma"
)

129
unikernel/duniverse/Zarith/README.md Normal file
View file

@ -0,0 +1,129 @@
# The Zarith library
## OVERVIEW
This library implements arithmetic and logical operations over
arbitrary-precision integers.
The module is simply named `Z`. Its interface is similar to that of
the `Int32`, `Int64` and `Nativeint` modules from the OCaml standard
library, with some additional functions. See the file `z.mli` for
documentation.
The implementation uses GMP (the GNU Multiple Precision arithmetic
library) to compute over big integers.
However, small integers are represented as unboxed Caml integers, to save
space and improve performance. Big integers are allocated in the Caml heap,
bypassing GMP's memory management and achieving better GC behavior than e.g.
the MLGMP library.
Computations on small integers use a special, faster path (in C or OCaml)
eschewing calls to GMP, while computations on large intergers use the
low-level MPN functions from GMP.
Arbitrary-precision integers can be compared correctly using OCaml's
polymorphic comparison operators (`=`, `<`, `>`, etc.).
Additional features include:
* a module `Q` for rationals, built on top of `Z` (see `q.mli`)
* a compatibility layer `Big_int_Z` that implements the same API as Big_int from the legacy `Num` library, but uses `Z` internally
Support for [js_of_ocaml](https://github.com/ocsigen/js_of_ocaml/) is
provided by [Zarith_stubs_js](https://github.com/janestreet/zarith_stubs_js).
## REQUIREMENTS
* OCaml, version 4.04.0 or later.
* Either the GMP library or the MPIR library, including development files.
* GCC or Clang or a gcc-compatible C compiler and assembler (other compilers may work).
* The Findlib package manager (optional, recommended).
## INSTALLATION
1) First, run the "configure" script by typing:
```
./configure
```
The `configure` script has a few options. Use the `-help` option to get a
list and short description of each option.
2) It creates a Makefile, which can be invoked by:
```
make
```
This builds native and bytecode versions of the library.
3) The libraries are installed by typing:
```
make install
```
or, if you install to a system location but are not an administrator
```
sudo make install
```
If Findlib is detected, it is used to install files.
Otherwise, the files are copied to a `zarith/` subdirectory of the directory
given by `ocamlc -where`.
The libraries are named `zarith.cmxa` and `zarith.cma`, and the Findlib module
is named `zarith`.
Compiling and linking with the library requires passing the `-I +zarith`
option to `ocamlc` / `ocamlopt`, or the `-package zarith` option to `ocamlfind`.
4) (optional, recommended) Test programs are built and run by the additional command
```
make tests
```
(but these are not installed).
5) (optional) HTML API documentation is built (using `ocamldoc`) by the additional command
```
make doc
```
## ONLINE DOCUMENTATION
The documentation for the latest release is hosted on [GitHub Pages](https://antoinemine.github.io/Zarith/doc/latest/index.html).
## LICENSE
This Library is distributed under the terms of the GNU Library General
Public License version 2, with a special exception allowing unconstrained
static linking.
See LICENSE file for details.
## AUTHORS
* Antoine Miné, Sorbonne Université, formerly at ENS Paris.
* Xavier Leroy, Collège de France, formerly at Inria Paris.
* Pascal Cuoq, TrustInSoft.
* Christophe Troestler (toplevel module)
## COPYRIGHT
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
## CONTENTS
Source files | Description
--------------------|-----------------------------------------
configure | configuration script
z.ml[i] | Z module and implementation for small integers
caml_z.c | C implementation
big_int_z.ml[i] | wrapper to provide a Big_int compatible API to Z
q.ml[i] | rational library, pure OCaml on top of Z
zarith_top.ml | toplevel module to provide pretty-printing
projet.mak | builds Z, Q and the tests
zarith.opam | package description for opam
z_mlgmpidl.ml[i] | conversion between Zarith and MLGMPIDL
tests/ | simple regression tests and benchmarks

144
unikernel/duniverse/Zarith/big_int_Z.ml Normal file
View file

@ -0,0 +1,144 @@
(**
[Big_int] interface for Z module.
This modules provides an interface compatible with [Big_int], but using
[Z] functions internally.
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
type big_int = Z.t
let zero_big_int = Z.zero
let unit_big_int = Z.one
let minus_big_int = Z.neg
let abs_big_int = Z.abs
let add_big_int = Z.add
let succ_big_int = Z.succ
let add_int_big_int x y = Z.add (Z.of_int x) y
let sub_big_int = Z.sub
let pred_big_int = Z.pred
let mult_big_int = Z.mul
let mult_int_big_int x y = Z.mul (Z.of_int x) y
let square_big_int x = Z.mul x x
let sqrt_big_int = Z.sqrt
let quomod_big_int = Z.ediv_rem
let div_big_int = Z.ediv
let mod_big_int = Z.erem
let gcd_big_int = Z.gcd
let power = Z.pow
let power_big a b =
Z.pow a (Z.to_int b)
let power_int_positive_int a b =
if b < 0 then raise (Invalid_argument "power_int_positive_int");
power (Z.of_int a) b
let power_big_int_positive_int a b =
if b < 0 then raise (Invalid_argument "power_big_int_positive_int");
power a b
let power_int_positive_big_int a b =
if Z.sign b < 0 then raise (Invalid_argument "power_int_positive_big_int");
power_big (Z.of_int a) b
let power_big_int_positive_big_int a b =
if Z.sign b < 0 then raise (Invalid_argument "power_big_int_positive_big_int");
power_big a b
let sign_big_int = Z.sign
let compare_big_int = Z.compare
let eq_big_int = Z.equal
let le_big_int a b = Z.compare a b <= 0
let ge_big_int a b = Z.compare a b >= 0
let lt_big_int a b = Z.compare a b < 0
let gt_big_int a b = Z.compare a b > 0
let max_big_int = Z.max
let min_big_int = Z.min
let num_digits_big_int = Z.size
let string_of_big_int = Z.to_string
let big_int_of_string = Z.of_string
let big_int_of_int = Z.of_int
let is_int_big_int = Z.fits_int
let int_of_big_int x =
try Z.to_int x with Z.Overflow -> failwith "int_of_big_int"
let big_int_of_int32 = Z.of_int32
let big_int_of_nativeint = Z.of_nativeint
let big_int_of_int64 = Z.of_int64
let int32_of_big_int x =
try Z.to_int32 x with Z.Overflow -> failwith "int32_of_big_int"
let nativeint_of_big_int x =
try Z.to_nativeint x with Z.Overflow -> failwith "nativeint_of_big_int"
let int64_of_big_int x =
try Z.to_int64 x with Z.Overflow -> failwith "int64_of_big_int"
let float_of_big_int = Z.to_float
let big_int_of_float = Z.of_float
let and_big_int = Z.logand
let or_big_int = Z.logor
let xor_big_int = Z.logxor
let shift_left_big_int = Z.shift_left
let shift_right_big_int = Z.shift_right
let shift_right_towards_zero_big_int = Z.shift_right_trunc
let extract_big_int = Z.extract

78
unikernel/duniverse/Zarith/big_int_Z.mli Normal file
View file

@ -0,0 +1,78 @@
(**
[Big_int] interface for Z module.
This modules provides an interface compatible with [Big_int], but using
[Z] functions internally.
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
(* note: generated with ocamlc -i *)
type big_int = Z.t
val zero_big_int : Z.t
val unit_big_int : Z.t
val minus_big_int : Z.t -> Z.t
val abs_big_int : Z.t -> Z.t
val add_big_int : Z.t -> Z.t -> Z.t
val succ_big_int : Z.t -> Z.t
val add_int_big_int : int -> Z.t -> Z.t
val sub_big_int : Z.t -> Z.t -> Z.t
val pred_big_int : Z.t -> Z.t
val mult_big_int : Z.t -> Z.t -> Z.t
val mult_int_big_int : int -> Z.t -> Z.t
val square_big_int : Z.t -> Z.t
val sqrt_big_int : Z.t -> Z.t
val quomod_big_int : Z.t -> Z.t -> Z.t * Z.t
val div_big_int : Z.t -> Z.t -> Z.t
val mod_big_int : Z.t -> Z.t -> Z.t
val gcd_big_int : Z.t -> Z.t -> Z.t
val power : Z.t -> int -> Z.t
val power_big : Z.t -> Z.t -> Z.t
val power_int_positive_int : int -> int -> Z.t
val power_big_int_positive_int : Z.t -> int -> Z.t
val power_int_positive_big_int : int -> Z.t -> Z.t
val power_big_int_positive_big_int : Z.t -> Z.t -> Z.t
val sign_big_int : Z.t -> int
val compare_big_int : Z.t -> Z.t -> int
val eq_big_int : Z.t -> Z.t -> bool
val le_big_int : Z.t -> Z.t -> bool
val ge_big_int : Z.t -> Z.t -> bool
val lt_big_int : Z.t -> Z.t -> bool
val gt_big_int : Z.t -> Z.t -> bool
val max_big_int : Z.t -> Z.t -> Z.t
val min_big_int : Z.t -> Z.t -> Z.t
val num_digits_big_int : Z.t -> int
val string_of_big_int : Z.t -> string
val big_int_of_string : string -> Z.t
val big_int_of_int : int -> Z.t
val is_int_big_int : Z.t -> bool
val int_of_big_int : Z.t -> int
val big_int_of_int32 : int32 -> Z.t
val big_int_of_nativeint : nativeint -> Z.t
val big_int_of_int64 : int64 -> Z.t
val int32_of_big_int : Z.t -> int32
val nativeint_of_big_int : Z.t -> nativeint
val int64_of_big_int : Z.t -> int64
val float_of_big_int : Z.t -> float
val big_int_of_float : float -> Z.t
val and_big_int : Z.t -> Z.t -> Z.t
val or_big_int : Z.t -> Z.t -> Z.t
val xor_big_int : Z.t -> Z.t -> Z.t
val shift_left_big_int : Z.t -> int -> Z.t
val shift_right_big_int : Z.t -> int -> Z.t
val shift_right_towards_zero_big_int : Z.t -> int -> Z.t
val extract_big_int : Z.t -> int -> int -> Z.t

3543
unikernel/duniverse/Zarith/caml_z.c Normal file
View file

File diff suppressed because it is too large Load diff

388
unikernel/duniverse/Zarith/configure vendored Executable file
View file

@ -0,0 +1,388 @@
#! /bin/sh
# configuration script
# This file is part of the Zarith library
# http://forge.ocamlcore.org/projects/zarith .
# It is distributed under LGPL 2 licensing, with static linking exception.
# See the LICENSE file included in the distribution.
#
# Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
# Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
# a joint laboratory by:
# CNRS (Centre national de la recherche scientifique, France),
# ENS (École normale supérieure, Paris, France),
# INRIA Rocquencourt (Institut national de recherche en informatique, France).
# options
installdir='auto'
ocamllibdir='auto'
gmp='auto'
perf='no'
ocaml='ocaml'
ocamlc='ocamlc'
ocamlopt='ocamlopt'
ocamlmklib='ocamlmklib'
ocamldep='ocamldep'
ocamldoc='ocamldoc'
ccinc="$CPPFLAGS"
ldflags="$LDFLAGS"
cclib=''
ccdef=''
mlflags="$OCAMLFLAGS"
mloptflags="$OCAMLOPTFLAGS"
mlinc="$OCAMLINC"
objsuffix="o"
ocamlfind="auto"
# sanitize
LC_ALL=C
export LC_ALL
unset IFS
# help
help()
{
cat <<EOF
usage: configure [options]
where options include:
-installdir dir installation directory
-ocamllibdir dir ocaml library directory
-gmp use GMP library (default if found)
-mpir use MPIR library instead of GMP
-perf enable performance statistics
-prefixnonocaml add for non ocaml tool, e.g. -prefixnonocaml x86_64-w64-mingw32-
Environment variables that affect configuration:
CFLAGS extra flags to pass to the C compiler
CPPFLAGS extra includes, e.g. -I/path/to/gmp/include
LDFLAGS extra link flags, e.g. -L/path/to/gmp/lib
OCAMLFLAGS extra flags to pass to the ocamlc Caml compiler
OCAMLOPTFLAGS extra flags to pass to the ocamlopt Caml compiler
OCAMLINC extra includes to pass to the Caml compilers
EOF
exit
}
# parse arguments
while : ; do
case "$1" in
"")
break;;
-installdir|--installdir)
installdir="$2"
shift;;
-ocamllibdir|--ocamllibdir)
ocamllibdir="$2"
shift;;
-no-ocamlfind|--no-ocamlfind)
ocamlfind="no"
shift;;
-help|--help)
help;;
-gmp|--gmp)
gmp='gmp';;
-mpir|--mpir)
gmp='mpir';;
-perf|--perf)
perf='yes';;
-prefixnonocaml|--prefixnonocaml)
prefixnonocaml="$2"
shift;;
*)
echo "unknown option $1, try -help"
exit 2;;
esac
shift
done
if test "$perf" = "yes"; then ccdef="-DZ_PERF_COUNTER $ccdef"; fi
echo_n()
{
echo "$1" | tr -d '\012'
}
# checking binaries in $PATH
searchbin()
{
if test "x$1" = "x"; then return 0; fi
echo_n "binary $1: "
case "$1" in
/*|./*|../*)
if test -f "$1" && test -x "$1"
then echo "found"; return 1
else echo "not found"; return 0
fi;;
esac
IFS=':'
for i in $PATH
do
if test -z "$i"; then i='.'; fi
if test -f $i/$1 && test -x $i/$1; then echo "found in $i"; unset IFS; return 1; fi
done
echo "not found"
unset IFS
return 0
}
searchbinreq()
{
searchbin $1
if test $? -eq 0; then echo "required program $1 not found"; exit 2; fi
}
# checking includes and libraries
checkinc()
{
echo_n "include $1: "
rm -f tmp.c tmp.o
echo "#include <$1>" > tmp.c
echo "int main() { return 1; }" >> tmp.c
r=1
$CC $ccopt $ccinc -c tmp.c -o tmp.o >/dev/null 2>/dev/null || r=0
if test ! -f tmp.o; then r=0; fi
rm -f tmp.c tmp.o
if test $r -eq 0; then echo "not found"; else echo "found"; fi
return $r
}
checklib()
{
echo_n "library $1: "
rm -f tmp.c tmp.out
echo "int main() { return 1; }" > tmp.c
r=1
$CC $ccopt $ldflags $cclib tmp.c -l$1 -o tmp.out >/dev/null 2>/dev/null || r=0
if test ! -x tmp.out; then r=0; fi
rm -f tmp.c tmp.o tmp.out
if test $r -eq 0; then echo "not found"; else echo "found"; fi
return $r
}
checkcc()
{
echo_n "checking compilation with $cc $ccopt: "
rm -f tmp.c tmp.out
echo "int main() { return 1; }" >> tmp.c
r=1
$CC $ccopt tmp.c -o tmp.out >/dev/null 2>/dev/null || r=0
if test ! -x tmp.out; then r=0; fi
rm -f tmp.c tmp.o tmp.out
if test $r -eq 0; then echo "not working"; else echo "working"; fi
return $r
}
checkcmxalib()
{
echo_n "library $1: "
$ocamlopt $mloptflags $1 -o tmp.out >/dev/null 2>/dev/null || r=0
if test ! -x tmp.out; then r=0; fi
rm -f tmp.out
if test $r -eq 0; then echo "not found"; else echo "found"; fi
return $r
}
# check required programs
searchbinreq $ocaml
searchbinreq $ocamlc
searchbinreq $ocamldep
searchbinreq $ocamlmklib
if searchbin $ocamldoc; then
ocamldoc=''
fi
if test -n "$CC"; then
searchbinreq "$CC"
ccopt="$CFLAGS"
else
ccopt="-O3 -Wall -Wextra $CFLAGS"
fi
# optional native-code generation
hasocamlopt='no'
searchbin $ocamlopt
if test $? -eq 1; then hasocamlopt='yes'; fi
# check C compiler
checkcc
if test $? -eq 0; then
# try again with (almost) no options
ccopt='-O'
checkcc
if test $? -eq 0; then echo "cannot compile and link program"; exit 2; fi
fi
# directories
if test "$ocamllibdir" = "auto"
then ocamllibdir=`ocamlc -where | sed 's/\r$//'`
fi
if test ! -f "$ocamllibdir/caml/mlvalues.h"
then echo "cannot find OCaml libraries in $ocamllibdir"; exit 2; fi
ccinc="-I$ocamllibdir $ccinc"
checkinc "caml/mlvalues.h"
if test $? -eq 0; then echo "cannot include caml/mlvalues.h"; exit 2; fi
# optional dynamic linking
hasdynlink='no'
if test $hasocamlopt = yes
then
checkcmxalib dynlink.cmxa
if test $? -eq 1; then hasdynlink='yes'; fi
fi
# installation method
searchbin ocamlfind
if test $? -eq 1 && test $ocamlfind != "no"; then
instmeth='findlib'
if test "$installdir" = "auto"
then installdir=`ocamlfind printconf destdir`; fi
else
searchbin install
if test $? -eq 1; then instmeth='install'
else echo "no installation method found"; exit 2; fi
if test "$installdir" = "auto"; then installdir="$ocamllibdir"; fi
fi
# detect OCaml's word-size
echo "print_int (Sys.word_size);;" > tmp.ml
wordsize=`ocaml tmp.ml`
echo "OCaml's word size is $wordsize"
rm -f tmp.ml
# check GMP, MPIR
if test "$gmp" = 'gmp' || test "$gmp" = 'auto'; then
if pkg-config gmp 2>/dev/null; then
echo 'package gmp: found'
gmp='OK'
cclib="$cclib $(pkg-config --libs gmp)"
ccinc="$ccinc $(pkg-config --cflags gmp)"
ccdef="-DHAS_GMP $ccdef"
else
checkinc gmp.h
if test $? -eq 1; then
checklib gmp
if test $? -eq 1; then
gmp='OK'
cclib="$cclib -lgmp"
ccdef="-DHAS_GMP $ccdef"
fi
fi
fi
fi
if test "$gmp" = 'mpir' || test "$gmp" = 'auto'; then
checkinc mpir.h
if test $? -eq 1; then
checklib mpir
if test $? -eq 1; then
gmp='OK'
cclib="$cclib -lmpir"
ccdef="-DHAS_MPIR $ccdef"
fi
fi
fi
if test "$gmp" != 'OK'; then echo "cannot find GMP nor MPIR"; exit 2; fi
# OCaml version
ocamlver=`ocamlc -version`
# OCaml version 4.04 or later is required
case "$ocamlver" in
[123].* | 4.0[0123].*)
echo "OCaml version $ocamlver is no longer supported."
echo "OCaml version 4.04.0 or later is required."
exit 2
;;
esac
# -bin-annot available since 4.00.0
echo "OCaml supports -bin-annot to produce documentation"
hasbinannot='yes'
# Changes to C API (the custom_operation struct) since 4.08.0
case "$ocamlver" in
[123].* | 4.0[01234567].* )
echo "Using OCaml legacy C API custom operations"
ccdef="-DZ_OCAML_LEGACY_CUSTOM_OPERATIONS $ccdef"
;;
*)
;;
esac
# dump Makefile
cat > Makefile <<EOF
# generated by ./configure
OCAMLC=$ocamlc
OCAMLOPT=$ocamlopt
OCAMLDEP=$ocamldep
OCAMLMKLIB=$ocamlmklib
OCAMLDOC=$ocamldoc
OCAMLFLAGS=$mlflags
OCAMLOPTFLAGS=$mloptflags
OCAMLINC=$mlinc
CFLAGS=$ccinc $ccdef $ccopt
LIBS=$cclib
LDFLAGS=$ldflags
INSTALLDIR=$installdir
INSTALL=install
OCAMLFIND=ocamlfind
INSTMETH=$instmeth
OBJSUFFIX=$objsuffix
HASOCAMLOPT=$hasocamlopt
HASDYNLINK=$hasdynlink
HASBINANNOT=$hasbinannot
include project.mak
EOF
# dump summary
cat <<EOF
detected configuration:
native-code: $hasocamlopt
dynamic linking: $hasdynlink
defines: $ccdef
includes: $ccinc
libraries: $cclib
linker options: $ldflags
C options: $ccopt
installation path: $installdir
installation method $instmeth
configuration successful!
now type "make" to build
then type "make install" or "sudo make install" to install
EOF

111
unikernel/duniverse/Zarith/configure_env.ml Normal file
View file

@ -0,0 +1,111 @@
(* A simple executable to figure out where is our libgmp.a.
*
* This executable wants to generate an environment which contains:
* - `CC` as the compiler
* - `CFLAGS` and `CPPFLAGS` as C options
* - `LDFLAGS` as options at the link time
*
* If [--with-conf-gmp] (related to the virtual OPAM package [conf-gmp]) is
* set, the script will just set `CC` and compile Zarith with the **host**'s
* `libgmp.a`.
*
* If [--with-gmp=<path>] is set (related to the [gmp] package), Zarith will be
* compile with the location of the [gmp] package. However, [gmp] can be
* located into an OPAM switch (if the <path> is absolute) or a local
* directory. The second case appears when you use [opam monorepo] which pulls
* dependencies into a [duniverse] local directory.
*
* The second case appears for the MirageOS 4.0 support too when we want to use
* a cross-compiled version of `libgmp.a` which should be available into our
* source-tree (compiled by `dune`).
*
* This script wants to help us to compile Zarith in these contexts:
* - as a simple OPAM dependency (which will be installed into a switch)
* - as a dependency brought by [opam monorepo]
* - in the situation where we use [opam monorepo] and the cross-compilation
*)
let always x _ = x
let deadbeef = "\xde\xad\xbe\xef"
let cc = ref deadbeef
let gmp_path = ref deadbeef
let with_conf_gmp = ref false
let dir_sep_char = '/'
let is_relative p = p.[0] <> dir_sep_char
let ( / ) = Filename.concat
let split s =
let min = 0 and max = max_int and sat chr = chr <> dir_sep_char in
if min > max || max = 0 then (s, "") else
let len = String.length s in
let max_idx = len - 1 in
let min_idx = let k = len - max in (if k < 0 then 0 else k) in
let need_idx = max_idx - min in
let rec loop i =
if i >= min_idx && sat s.[i] then loop (i - 1) else
if i > need_idx || i = max_idx then (s, "") else
if i = -1 then ("", s) else
let cut = i + 1 in
String.sub s 0 cut, String.sub s cut (len - cut)
in
loop max_idx
let is_prefix ~affix s =
let len_a = String.length affix in
let len_s = String.length s in
if len_a > len_s then false else
let max_idx_a = len_a - 1 in
let rec loop i =
if i > max_idx_a then true else
if affix.[i] <> s.[i] then false else loop (i + 1)
in
loop 0
let is_prefix ~prefix p =
if not (is_prefix ~affix:prefix p) then false else
let suff_start = String.length prefix in
if prefix.[suff_start - 1] = dir_sep_char then true else
if suff_start = String.length p then (* suffix empty *) true else
p.[suff_start] = dir_sep_char
let spec =
[ "--with-gmp", Arg.Set_string gmp_path, "Location of libgmp.a"
; "--with-conf-gmp", Arg.Set with_conf_gmp, "Use the host's libgmp.a"
; "--cc", Arg.Set_string cc, "C compiler" ]
let usage = Format.asprintf "%s --cc <compiler> [--with-gmp=<path>] [--with-conf-gmp]\n%!" Sys.argv.(0)
let where () = match !gmp_path, !with_conf_gmp with
| gmp_path, _ when gmp_path <> deadbeef ->
let gmp_path, _libgmp_a = split gmp_path in
let cwd = Sys.getcwd () in
if is_relative gmp_path || is_prefix ~prefix:cwd gmp_path
then `Source (cwd / gmp_path)
else `Switch gmp_path
| _, true -> `Host
| _, false -> `Missing
let env = function
| `Source gmp_path when is_relative gmp_path ->
let gmp_path = Sys.getcwd () / gmp_path in
Format.asprintf "CC=\"%s\" LDFLAGS=\"-L%s\" CFLAGS=\"-I%s\" CPPFLAGS=\"-I%s\""
!cc gmp_path gmp_path gmp_path
| `Source gmp_path
| `Switch gmp_path ->
Format.asprintf "CC=\"%s\" LDFLAGS=\"-L%s\" CFLAGS=\"-I%s\" CPPFLAGS=\"-I%s\""
!cc gmp_path gmp_path gmp_path
| `Host ->
Format.asprintf "CC=\"%s\"" !cc
| `Missing -> failwith "Zarith requires gmp."
let () =
Arg.parse spec (always ()) usage ;
if !cc = deadbeef
then ( Format.eprintf "%s%!" usage ; exit 1 ) ;
let where = where () in
let env = env where in
Format.printf "%s%!" env
(* XXX(dinosaure): we must **not** append '\n'. Otherwise,
* we don't set the environment. *)

99
unikernel/duniverse/Zarith/dune Normal file
View file

@ -0,0 +1,99 @@
(env
(dev
(flags
(:standard -w -6-32-39))))
(library
(name zarith)
(public_name zarith)
(modules z q big_int_Z zarith_version)
(wrapped false)
(foreign_stubs
(language c)
(names caml_z)
(flags
:standard
(:include cflags.sexp)))
(c_library_flags
(:include libs.sexp)))
(executable
(name configure_env)
(modules configure_env))
(rule
(target Makefile)
(deps configure env)
(action
(bash
"env %{read:env} ./configure --ocamllibdir %{ocaml-config:standard_library}")))
(rule
(target env)
(action
(copy gmp.%{lib-available:gmp} env)))
(rule
(target gmp.true)
(deps
(:exe configure_env.exe)
%{lib:gmp:libgmp.a}
%{lib:gmp:libgmp.so}
%{lib:gmp:gmp.h})
(action
(with-stdout-to
%{target}
(run %{exe} --cc "%{cc}" --with-gmp=%{lib:gmp:libgmp.a}))))
(rule
(target gmp.false)
(deps
(:exe configure_env.exe))
(action
(with-stdout-to
%{target}
(run %{exe} --cc "%{cc}" --with-conf-gmp))))
(rule
(target cflags.sexp)
(deps Makefile)
(action
(with-stdout-to
%{target}
(progn
(bash "echo -n '('")
(bash "cat Makefile | sed -n -e 's/CFLAGS=//p'")
(bash "echo -n ')'")))))
; Note that the order (LDFLAGS, then LIBS) is important below since
; zarith uses pkg-config to detect gmp, and adds the output to LIBS
; but we like -L ..._build/solo5/duniverse/Zarith/../../../install/solo5/lib/gmp
; first, followed by -L/usr/local/lib -lgmp (from pkg-config)
(rule
(target libs.sexp)
(deps Makefile)
(action
(with-stdout-to
%{target}
(progn
(bash "echo -n '('")
(bash "cat Makefile | sed -n -e 's/LDFLAGS=//p'")
(bash "cat Makefile | sed -n -e 's/LIBS=//p'")
(bash "echo -n ')'")))))
(rule
(deps META)
(action
(with-stdout-to
zarith_version.ml
(progn
(run echo "let")
(bash "grep \"version\" META | head -1")))))
(library
(name zarith_top)
(optional)
(public_name zarith.top)
(modules zarith_top)
(libraries zarith compiler-libs.toplevel))

3
unikernel/duniverse/Zarith/dune-project Normal file
View file

@ -0,0 +1,3 @@
(lang dune 2.8)
(name zarith)
(version df8969d)

158
unikernel/duniverse/Zarith/project.mak Normal file
View file

@ -0,0 +1,158 @@
# This file is part of the Zarith library
# http://forge.ocamlcore.org/projects/zarith .
# It is distributed under LGPL 2 licensing, with static linking exception.
# See the LICENSE file included in the distribution.
#
# Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
# Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
# a joint laboratory by:
# CNRS (Centre national de la recherche scientifique, France),
# ENS (École normale supérieure, Paris, France),
# INRIA Rocquencourt (Institut national de recherche en informatique, France).
ifeq "$(shell $(OCAMLC) -config |grep ccomp_type)" "ccomp_type: msvc"
OBJSUFFIX := obj
LIBSUFFIX := lib
DLLSUFFIX := dll
EXE := .exe
else
OBJSUFFIX := o
LIBSUFFIX := a
ifeq "$(findstring mingw,$(shell $(OCAMLC) -config |grep system))" "mingw"
DLLSUFFIX := dll
EXE := .exe
else
DLLSUFFIX := so
EXE :=
endif
endif
# project files
###############
CSRC = caml_z.c
MLSRC = zarith_version.ml z.ml q.ml big_int_Z.ml
MLISRC = z.mli q.mli big_int_Z.mli
AUTOGEN = zarith_version.ml
CMIOBJ = $(MLISRC:%.mli=%.cmi)
CMXOBJ = $(MLSRC:%.ml=%.cmx)
CMIDOC = $(MLISRC:%.mli=%.cmti)
TOBUILD = zarith.cma libzarith.$(LIBSUFFIX) $(CMIOBJ) zarith_top.cma z.mli
TOINSTALL = $(TOBUILD) zarith.h q.mli big_int_Z.mli
ifeq ($(HASOCAMLOPT),yes)
TOBUILD += zarith.cmxa $(CMXOBJ)
TOINSTALL += zarith.$(LIBSUFFIX)
endif
OCAMLFLAGS += -I +compiler-libs
OCAMLOPTFLAGS += -I +compiler-libs
ifeq ($(HASDYNLINK),yes)
TOBUILD += zarith.cmxs
endif
ifeq ($(HASBINANNOT),yes)
TOINSTALL += $(CMIDOC)
OCAMLFLAGS += -bin-annot
endif
# build targets
###############
all: $(TOBUILD)
tests:
make -C tests test
zarith.cma: $(MLSRC:%.ml=%.cmo)
$(OCAMLMKLIB) -failsafe -o zarith $+ $(LIBS) $(LDFLAGS)
zarith.cmxa: $(MLSRC:%.ml=%.cmx)
$(OCAMLMKLIB) -failsafe -o zarith $+ $(LIBS) $(LDFLAGS)
zarith.cmxs: zarith.cmxa libzarith.$(LIBSUFFIX)
$(OCAMLOPT) -shared -o $@ -I . zarith.cmxa -linkall
libzarith.$(LIBSUFFIX): $(CSRC:%.c=%.$(OBJSUFFIX))
$(OCAMLMKLIB) -failsafe -o zarith $+ $(LIBS) $(LDFLAGS)
zarith_top.cma: zarith_top.cmo
$(OCAMLC) -o $@ -a $<
doc: $(MLISRC)
ifneq ($(OCAMLDOC),)
mkdir -p html
$(OCAMLDOC) -html -d html -charset utf8 $+
else
$(error ocamldoc is required to build the documentation)
endif
zarith_version.ml: META
(echo "let"; grep "version" META | head -1) > zarith_version.ml
# install targets
#################
ifeq ($(INSTMETH),install)
install:
install -d $(INSTALLDIR) $(INSTALLDIR)/zarith $(INSTALLDIR)/stublibs
for i in $(TOINSTALL); do \
if test -f $$i; then $(INSTALL) -m 0644 $$i $(INSTALLDIR)/zarith/$$i; fi; \
done
if test -f dllzarith.$(DLLSUFFIX); then $(INSTALL) -m 0755 dllzarith.$(DLLSUFFIX) $(INSTALLDIR)/stublibs/dllzarith.$(DLLSUFFIX); fi
uninstall:
for i in $(TOINSTALL); do \
rm -f $(INSTALLDIR)/zarith/$$i; \
done
if test -f $(INSTALLDIR)/stublibs/dllzarith.$(DLLSUFFIX); then rm -f $(INSTALLDIR)/stublibs/dllzarith.$(DLLSUFFIX); fi
endif
ifeq ($(INSTMETH),findlib)
install:
$(OCAMLFIND) install -destdir "$(INSTALLDIR)" zarith META $(TOINSTALL) -optional dllzarith.$(DLLSUFFIX)
uninstall:
$(OCAMLFIND) remove -destdir "$(INSTALLDIR)" zarith
endif
# rules
#######
%.cmi: %.mli
$(OCAMLC) $(OCAMLFLAGS) $(OCAMLINC) -c $<
%.cmo: %.ml %.cmi
$(OCAMLC) $(OCAMLFLAGS) $(OCAMLINC) -c $<
%.cmx: %.ml %.cmi
$(OCAMLOPT) $(OCAMLOPTFLAGS) $(OCAMLINC) -c $<
%.cmo: %.ml
$(OCAMLC) $(OCAMLFLAGS) $(OCAMLINC) -c $<
%.cmx: %.ml
$(OCAMLOPT) $(OCAMLOPTFLAGS) $(OCAMLINC) -c $<
%.$(OBJSUFFIX): %.c
$(OCAMLC) -ccopt "$(CFLAGS)" -c $<
clean:
/bin/rm -rf *.$(OBJSUFFIX) *.$(LIBSUFFIX) *.$(DLLSUFFIX) *.cmi *.cmo *.cmx *.cmxa *.cmxs *.cma *.cmt *.cmti *~ \#* depend test $(AUTOGEN) tmp.c depend
make -C tests clean
depend: $(AUTOGEN)
$(OCAMLDEP) $(OCAMLINC) $(MLSRC) $(MLISRC) > depend
include depend
$(CSRC:%.c=%.$(OBJSUFFIX)): zarith.h
.PHONY: clean
.PHONY: tests

574
unikernel/duniverse/Zarith/q.ml Normal file
View file

@ -0,0 +1,574 @@
(**
Rationals.
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
type t = {
num: Z.t; (** Numerator. *)
den: Z.t; (** Denominator, >= 0 *)
}
(* Type of rationals.
Invariants:
- den is always >= 0;
- num and den have no common factor;
- if den=0, then num is -1, 0 or 1.
- if num=0, then den is -1, 0 or 1.
*)
(* creation *)
(* -------- *)
(* make *)
let mk n d =
{ num = n; den = d; }
(* make and normalize n/d, assuming d > 0 *)
let make_real n d =
if n == Z.zero || d == Z.one then mk n Z.one
else
let g = Z.gcd n d in
if g == Z.one
then mk n d
else mk (Z.divexact n g) (Z.divexact d g)
(* make and normalize any fraction *)
let make n d =
let sd = Z.sign d in
if sd = 0 then mk (Z.of_int (Z.sign n)) Z.zero else
if sd > 0 then make_real n d else
make_real (Z.neg n) (Z.neg d)
let of_bigint n = mk n Z.one
(* n/1 *)
let of_int n = of_bigint (Z.of_int n)
let of_int32 n = of_bigint (Z.of_int32 n)
let of_int64 n = of_bigint (Z.of_int64 n)
let of_nativeint n = of_bigint (Z.of_nativeint n)
let of_ints n d = make (Z.of_int n) (Z.of_int d)
let zero = of_bigint Z.zero
(* 0/1 *)
let one = of_bigint Z.one
(* 1/1 *)
let minus_one = of_bigint Z.minus_one
(* -1/1 *)
let inf = mk Z.one Z.zero
(* 1/0 *)
let minus_inf = mk Z.minus_one Z.zero
(* -1/0 *)
let undef = mk Z.zero Z.zero
(* 0/0 *)
let of_float d =
if d = infinity then inf else
if d = neg_infinity then minus_inf else
if classify_float d = FP_nan then undef else
let m,e = frexp d in
(* put into the form m * 2^e, where m is an integer *)
let m,e = Z.of_float (ldexp m 53), e-53 in
if e >= 0 then of_bigint (Z.shift_left m e)
else make_real m (Z.shift_left Z.one (-e))
(* queries *)
(* ------- *)
type kind =
| ZERO (* 0 *)
| INF (* 1/0 *)
| MINF (* -1/0 *)
| UNDEF (* 0/0 *)
| NZERO (* non-special, non-0 *)
let classify n =
if n.den == Z.zero then
match Z.sign n.num with
| 1 -> INF
| -1 -> MINF
| _ -> UNDEF
else
if n.num == Z.zero
then ZERO
else NZERO
let is_real n = (n.den != Z.zero)
let num x = x.num
let den x = x.den
let sign x = Z.sign x.num
(* sign undef = 0
sign inf = 1
sign -inf = -1
*)
let equal x y =
(Z.equal x.num y.num) && (Z.equal x.den y.den) && (classify x <> UNDEF)
let compare x y =
match classify x, classify y with
| UNDEF,UNDEF | INF,INF | MINF,MINF -> 0
| UNDEF,_ -> -1
| _,UNDEF -> 1
| MINF,_ | _,INF -> -1
| INF,_ | _,MINF -> 1
| _ ->
if x.den = y.den (* implies equality,
especially if immediate value and not a pointer,
in particular in the case den = 1 *)
then Z.compare x.num y.num
else
Z.compare
(Z.mul x.num y.den)
(Z.mul y.num x.den)
let min a b = if compare a b <= 0 then a else b
let max a b = if compare a b >= 0 then a else b
let leq x y =
match classify x, classify y with
| UNDEF,_ | _,UNDEF -> false
| MINF,_ | _,INF -> true
| INF,_ | _,MINF -> false
| _ ->
if x.den = y.den
then Z.leq x.num y.num
else
Z.leq
(Z.mul x.num y.den)
(Z.mul y.num x.den)
let lt x y =
match classify x, classify y with
| UNDEF,_ | _,UNDEF -> false
| INF,_ | _,MINF -> false
| MINF,_ | _,INF -> true
| _ ->
if x.den = y.den
then Z.lt x.num y.num
else
Z.lt
(Z.mul x.num y.den)
(Z.mul y.num x.den)
let geq x y = leq y x
let gt x y = lt y x
let to_string n =
match classify n with
| UNDEF -> "undef"
| INF -> "+inf"
| MINF -> "-inf"
| ZERO -> "0"
| NZERO ->
if Z.equal n.den Z.one then Z.to_string n.num
else (Z.to_string n.num) ^ "/" ^ (Z.to_string n.den)
let to_bigint x = Z.div x.num x.den
(* raises a Division by zero in case x is undefined or infinity *)
let to_int x = Z.to_int (to_bigint x)
let to_int32 x = Z.to_int32 (to_bigint x)
let to_int64 x = Z.to_int64 (to_bigint x)
let to_nativeint x = Z.to_nativeint (to_bigint x)
let to_float x =
match classify x with
| ZERO -> 0.0
| INF -> infinity
| MINF -> neg_infinity
| UNDEF -> nan
| NZERO ->
let p = x.num and q = x.den in
let np = Z.numbits p and nq = Z.numbits q in
if np <= 53 && nq <= 53 then
(* p and q convert to floats exactly; use FP division to get the
correctly-rounded result. *)
Int64.to_float (Z.to_int64 p) /. Int64.to_float (Z.to_int64 q)
else begin
let negat =
if Z.sign p < 0 then -1 else 1
in
(* p is in [2^(np-1), 2^np)
q is in [2^(nq-1), 2^nq)
We define n,p',q' such that p'/q'*2^n=p/q and |p'/q'| is in [1, 2). *)
let n = np - nq in
(* Scaling p/q by 2^n *)
let (p', q') =
if n >= 0
then (p, Z.shift_left q n)
else (Z.shift_left p (-n), q)
in
let (p', n) =
if Z.geq (Z.abs p') q'
then (p', n)
else (Z.shift_left p' 1, pred n)
in
(* If we divided p' by q' now, the resulting quotient would
have one significant digit. *)
let p' = Z.shift_left p' 54 in
(* When we divide p' by q' next, the resulting quotient will
have 55 significant digits. The strategy is:
- First, compute the quotient with 55 significant digits in
round-to-odd, and
- Second, round that number to the number of effective
significant digits we desire for the result, which is 53
for a normal result and less than 53 for a subnormal result.
We cannot afford an intermediate rounding at 53 significant digits
if the end-result is subnormal. See
https://github.com/ocaml/Zarith/issues/29 *)
(* Euclidean division of p' by q' *)
let (quo, rem) = Z.ediv_rem p' q' in
if n <= -1080
then
(* The end result is +0.0 or -0.0 (depending on negat)
or perhaps the next floating-point number of the same
sign (depending on the current rounding mode. *)
ldexp (float_of_int negat) (-1080)
else
let offset =
if n <= -1023
then
(* The end result will be subnormal, add an offset
to make the rounding happen directly at the place
where it should happend.
quo has the form: 1xxxx...
we add: 1000000...
so as to end up with: 101xxxx... *)
Z.shift_left (Z.of_int negat) (55 + (-1023 - n))
else
Z.zero
in
let quo = Z.add offset quo in
let quo =
if Z.sign rem = 0
then quo
else Z.logor Z.one quo (* round to odd *)
in
(* The FPU rounding mode affects the Z.to_float that comes next,
making the rounding computed according to the current FPU rounding
mode. *)
let f = Z.to_float quo in
(* The subtraction that comes next is exact, so that the rounding
mode does not change what it does. *)
let f = f -. (Z.to_float offset)
in
(* ldexp is also exact and unaffected by the rounding mode.
We have made sure that if the end result is going to be subnormal,
then f has exactly the correct number of significant digits for
no rounding to happen here. *)
ldexp f (n - 54)
end
(* operations *)
(* ---------- *)
let neg x =
mk (Z.neg x.num) x.den
(* neg undef = undef
neg inf = -inf
neg -inf = inf
*)
let abs x =
mk (Z.abs x.num) x.den
(* abs undef = undef
abs inf = abs -inf = inf
*)
(* addition or substraction (zaors) of finite numbers *)
let aors zaors x y =
if x.den == y.den then (* implies equality,
especially if immediate value and not a pointer,
in particular in the case den = 1 *)
make_real (zaors x.num y.num) x.den
else
make_real
(zaors
(Z.mul x.num y.den)
(Z.mul y.num x.den))
(Z.mul x.den y.den)
let add x y =
if x.den == Z.zero || y.den == Z.zero then match classify x, classify y with
| ZERO,_ -> y
| _,ZERO -> x
| UNDEF,_ | _,UNDEF -> undef
| INF,MINF | MINF,INF -> undef
| INF,_ | _,INF -> inf
| MINF,_ | _,MINF -> minus_inf
| NZERO,NZERO -> failwith "impossible case"
else
aors Z.add x y
(* undef + x = x + undef = undef
inf + -inf = -inf + inf = undef
inf + x = x + inf = inf
-inf + x = x + -inf = -inf
*)
let sub x y =
if x.den == Z.zero || y.den == Z.zero then match classify x, classify y with
| ZERO,_ -> neg y
| _,ZERO -> x
| UNDEF,_ | _,UNDEF -> undef
| INF,INF | MINF,MINF -> undef
| INF,_ | _,MINF -> inf
| MINF,_ | _,INF -> minus_inf
| NZERO,NZERO -> failwith "impossible case"
else
aors Z.sub x y
(* sub x y = add x (neg y) *)
let mul x y =
if x.den == Z.zero || y.den == Z.zero then
mk
(Z.of_int ((Z.sign x.num) * (Z.sign y.num)))
Z.zero
else
make_real (Z.mul x.num y.num) (Z.mul x.den y.den)
(* undef * x = x * undef = undef
0 * inf = inf * 0 = 0 * -inf = -inf * 0 = undef
inf * x = x * inf = sign x * inf
-inf * x = x * -inf = - sign x * inf
*)
let inv x =
match Z.sign x.num with
| 1 -> mk x.den x.num
| -1 -> mk (Z.neg x.den) (Z.neg x.num)
| _ -> if x.den == Z.zero then undef else inf
(* 1 / undef = undef
1 / inf = 1 / -inf = 0
1 / 0 = inf
note that: inv (inv -inf) = inf <> -inf
*)
let div x y =
if Z.sign y.num >= 0
then mul x (mk y.den y.num)
else mul x (mk (Z.neg y.den) (Z.neg y.num))
(* undef / x = x / undef = undef
0 / 0 = undef
inf / inf = inf / -inf = -inf / inf = -inf / -inf = undef
0 / inf = 0 / -inf = x / inf = x / -inf = 0
inf / x = sign x * inf
-inf / x = - sign x * inf
inf / 0 = inf
-inf / 0 = -inf
x / 0 = sign x * inf
we have div x y = mul x (inv y)
*)
let mul_2exp x n =
if x.den == Z.zero then x
else make_real (Z.shift_left x.num n) x.den
let div_2exp x n =
if x.den == Z.zero then x
else make_real x.num (Z.shift_left x.den n)
type supported_base =
| B2 | B8 | B10 | B16
let int_of_base = function
| B2 -> 2
| B8 -> 8
| B10 -> 10
| B16 -> 16
(* [find_in_string s ~pos ~last pred] find the first index in the string between [pos]
(inclusive) and [last] (exclusive) that satisfy the predicate [pred] *)
let rec find_in_string s ~pos ~last p =
if pos >= last
then None
else if p s.[pos]
then Some pos
else find_in_string s ~pos:(pos + 1) ~last p
(* The current implementation supports plain decimals, decimal points,
scientific notation ('e' or 'E' for base 10 litteral and 'p' or 'P'
for base 16), and fraction of integers (eg. 1/2). In particular it
accepts any numeric literal accepted by OCaml's lexer.
Restrictions:
- exponents in scientific notation should fit on an integer
- scientific notation only available in hexa and decimal (as in OCaml) *)
let of_string =
(* return a boolean (true for negative) and the next offset to read *)
let parse_sign s i j =
if j < i + 1
then false, i
else
match s.[i] with
| '-' -> true , i + 1
| '+' -> false, i + 1
| _ -> false ,i
in
(* return the base and the next offset to read *)
let parse_base s i j =
if j < i + 2
then B10, i
else
match s.[i],s.[i+1] with
| '0',('x'|'X') -> B16, i + 2
| '0',('o'|'O') -> B8, i + 2
| '0',('b'|'B') -> B2, i + 2
| _ -> B10, i
in
let find_exponent_mark = function
| B10 -> (function 'e' | 'E' -> true | _ -> false)
| B16 -> (function 'p' | 'P' -> true | _ -> false)
| B8 | B2 -> (fun _ -> false)
in
let of_scientific_notation s =
let i = 0 in
let j = String.length s in
let sign,i = parse_sign s i j in
let base,i = parse_base s i j in
(* shift left due to the exponent *)
let shift_left, j =
match find_in_string s ~pos:i ~last:j (find_exponent_mark base) with
| None -> 0, j
| Some ei ->
let pos = ei + 1 in
let ez = Z.of_substring_base 10 s ~pos ~len:(j - pos) in
Z.to_int ez, ei
in
(* shift right due to the radix *)
let z, shift_right =
match base with
| B2 | B8 -> Z.of_substring_base (int_of_base base) s ~pos:i ~len:(j - i), 0
| B10 | B16 ->
match find_in_string s ~pos:i ~last:j ((=) '.') with
| None -> Z.of_substring_base (int_of_base base) s ~pos:i ~len:(j - i), 0
| Some k ->
(* shift_right_factor correspond to the shift to apply when we move the decimal
point one position to the left.
0x1.1p1 = 0x11p-3 = 0x0.11p5
1.1e1 = 11e0 = 0.11e2 *)
let shift_right_factor =
match base with
| B10 -> 1
| B16 -> 4
| B2 | B8 -> assert false
in
(* We should only consider actual digits to perform the shift. *)
let num_digits = ref 0 in
for h = k + 1 to j - 1 do
match s.[h] with
| '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' ->
incr num_digits
| '_' -> ()
| _ ->
(* '-' and '+' could wrongly be accepted by Z.of_string_base *)
invalid_arg "Q.of_string: invalid digit"
done;
let first_digit_after_dot =
match find_in_string s ~pos:(k+1) ~last:j ((<>) '_') with
| None -> j
| Some x -> x
in
let shift = !num_digits * shift_right_factor in
let without_dot =
String.sub s i (k-i)
^ (String.sub s first_digit_after_dot (j - first_digit_after_dot))
in
Z.of_string_base (int_of_base base) without_dot, shift
in
let shift = shift_left - shift_right in
let exponent_pow =
match base with
| B10 -> 10
| B16 -> 2
| B8 | B2 -> 1
in
let abs =
if shift < 0 then
make z (Z.pow (Z.of_int exponent_pow) (~- shift))
else
of_bigint (Z.mul z (Z.pow (Z.of_int exponent_pow) shift))
in
if sign
then neg abs
else abs
in
function
| "" -> zero
| "inf" | "+inf" -> inf
| "-inf" -> minus_inf
| "undef" -> undef
| s ->
try
let i = String.index s '/' in
make
(Z.of_substring s ~pos:0 ~len:i)
(Z.of_substring s ~pos:(i+1) ~len:(String.length s-i-1))
with Not_found ->
of_scientific_notation s
(* printing *)
(* -------- *)
let print x = print_string (to_string x)
let output chan x = output_string chan (to_string x)
let sprint () x = to_string x
let bprint b x = Buffer.add_string b (to_string x)
let pp_print f x = Format.pp_print_string f (to_string x)
(* prefix and infix *)
(* ---------------- *)
let (~-) = neg
let (~+) x = x
let (+) = add
let (-) = sub
let ( * ) = mul
let (/) = div
let (lsl) = mul_2exp
let (asr) = div_2exp
let (~$) = of_int
let (//) = of_ints
let (~$$) = of_bigint
let (///) = make
let (=) = equal
let (<) = lt
let (>) = gt
let (<=) = leq
let (>=) = geq
let (<>) a b = not (equal a b)

298
unikernel/duniverse/Zarith/q.mli Normal file
View file

@ -0,0 +1,298 @@
(**
Rationals.
This modules builds arbitrary precision rationals on top of arbitrary
integers from module Z.
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
(** {1 Types} *)
type t = {
num: Z.t; (** Numerator. *)
den: Z.t; (** Denominator, >= 0 *)
}
(** A rational is represented as a pair numerator/denominator, reduced to
have a non-negative denominator and no common factor.
This form is canonical (enabling polymorphic equality and hashing).
The representation allows three special numbers: [inf] (1/0), [-inf] (-1/0)
and [undef] (0/0).
*)
(** {1 Construction} *)
val make: Z.t -> Z.t -> t
(** [make num den] constructs a new rational equal to [num]/[den].
It takes care of putting the rational in canonical form.
*)
val zero: t
val one: t
val minus_one:t
(** 0, 1, -1. *)
val inf: t
(** 1/0. *)
val minus_inf: t
(** -1/0. *)
val undef: t
(** 0/0. *)
val of_bigint: Z.t -> t
val of_int: int -> t
val of_int32: int32 -> t
val of_int64: int64 -> t
val of_nativeint: nativeint -> t
(** Conversions from various integer types. *)
val of_ints: int -> int -> t
(** Conversion from an [int] numerator and an [int] denominator. *)
val of_float: float -> t
(** Conversion from a [float].
The conversion is exact, and maps NaN to [undef].
*)
val of_string: string -> t
(** Converts a string to a rational. Plain integers, [/] separated
integer ratios (with optional sign), decimal point and scientific
notations are understood.
Additionally, the special [inf], [-inf], and [undef] are
recognized (they can also be typeset respectively as [1/0], [-1/0],
[0/0]). *)
(** {1 Inspection} *)
val num: t -> Z.t
(** Get the numerator. *)
val den: t -> Z.t
(** Get the denominator. *)
(** {1 Testing} *)
type kind =
| ZERO (** 0 *)
| INF (** infinity, i.e. 1/0 *)
| MINF (** minus infinity, i.e. -1/0 *)
| UNDEF (** undefined, i.e., 0/0 *)
| NZERO (** well-defined, non-infinity, non-zero number *)
(** Rationals can be categorized into different kinds, depending mainly on
whether the numerator and/or denominator is null.
*)
val classify: t -> kind
(** Determines the kind of a rational. *)
val is_real: t -> bool
(** Whether the argument is non-infinity and non-undefined. *)
val sign: t -> int
(** Returns 1 if the argument is positive (including inf), -1 if it is
negative (including -inf), and 0 if it is null or undefined.
*)
val compare: t -> t -> int
(** [compare x y] compares [x] to [y] and returns 1 if [x] is strictly
greater that [y], -1 if it is strictly smaller, and 0 if they are
equal.
This is a total ordering.
Infinities are ordered in the natural way, while undefined is considered
the smallest of all: undef = undef < -inf <= -inf < x < inf <= inf.
This is consistent with OCaml's handling of floating-point infinities
and NaN.
OCaml's polymorphic comparison will NOT return a result consistent with
the ordering of rationals.
*)
val equal: t -> t -> bool
(** Equality testing.
Unlike [compare], this follows IEEE semantics: [undef] <> [undef].
*)
val min: t -> t -> t
(** Returns the smallest of its arguments. *)
val max: t -> t -> t
(** Returns the largest of its arguments. *)
val leq: t -> t -> bool
(** Less than or equal. [leq undef undef] returns false. *)
val geq: t -> t -> bool
(** Greater than or equal. [leq undef undef] returns false. *)
val lt: t -> t -> bool
(** Less than (not equal). *)
val gt: t -> t -> bool
(** Greater than (not equal). *)
(** {1 Conversions} *)
val to_bigint: t -> Z.t
val to_int: t -> int
val to_int32: t -> int32
val to_int64: t -> int64
val to_nativeint: t -> nativeint
(** Convert to integer by truncation.
Raises a [Divide_by_zero] if the argument is an infinity or undefined.
Raises a [Z.Overflow] if the result does not fit in the destination
type.
*)
val to_string: t -> string
(** Converts to human-readable, base-10, [/]-separated rational. *)
val to_float: t -> float
(** Converts to a floating-point number, using the current
floating-point rounding mode. With the default rounding mode,
the result is the floating-point number closest to the given
rational; ties break to even mantissa. *)
(** {1 Arithmetic operations} *)
(**
In all operations, the result is [undef] if one argument is [undef].
Other operations can return [undef]: such as [inf]-[inf], [inf]*0, 0/0.
*)
val neg: t -> t
(** Negation. *)
val abs: t -> t
(** Absolute value. *)
val add: t -> t -> t
(** Addition. *)
val sub: t -> t -> t
(** Subtraction. We have [sub x y] = [add x (neg y)]. *)
val mul: t -> t -> t
(** Multiplication. *)
val inv: t -> t
(** Inverse.
Note that [inv 0] is defined, and equals [inf].
*)
val div: t -> t -> t
(** Division.
We have [div x y] = [mul x (inv y)], and [inv x] = [div one x].
*)
val mul_2exp: t -> int -> t
(** [mul_2exp x n] multiplies [x] by 2 to the power of [n]. *)
val div_2exp: t -> int -> t
(** [div_2exp x n] divides [x] by 2 to the power of [n]. *)
(** {1 Printing} *)
val print: t -> unit
(** Prints the argument on the standard output. *)
val output: out_channel -> t -> unit
(** Prints the argument on the specified channel.
Also intended to be used as [%a] format printer in [Printf.printf].
*)
val sprint: unit -> t -> string
(** To be used as [%a] format printer in [Printf.sprintf]. *)
val bprint: Buffer.t -> t -> unit
(** To be used as [%a] format printer in [Printf.bprintf]. *)
val pp_print: Format.formatter -> t -> unit
(** Prints the argument on the specified formatter.
Also intended to be used as [%a] format printer in [Format.printf].
*)
(** {1 Prefix and infix operators} *)
(**
Classic prefix and infix [int] operators are redefined on [t].
*)
val (~-): t -> t
(** Negation [neg]. *)
val (~+): t -> t
(** Identity. *)
val (+): t -> t -> t
(** Addition [add]. *)
val (-): t -> t -> t
(** Subtraction [sub]. *)
val ( * ): t -> t -> t
(** Multiplication [mul]. *)
val (/): t -> t -> t
(** Division [div]. *)
val (lsl): t -> int -> t
(** Multiplication by a power of two [mul_2exp]. *)
val (asr): t -> int -> t
(** Division by a power of two [shift_right]. *)
val (~$): int -> t
(** Conversion from [int]. *)
val (//): int -> int -> t
(** Creates a rational from two [int]s. *)
val (~$$): Z.t -> t
(** Conversion from [Z.t]. *)
val (///): Z.t -> Z.t -> t
(** Creates a rational from two [Z.t]. *)
val (=): t -> t -> bool
(** Same as [equal].
@since 1.8 *)
val (<): t -> t -> bool
(** Same as [lt].
@since 1.8 *)
val (>): t -> t -> bool
(** Same as [gt].
@since 1.8 *)
val (<=): t -> t -> bool
(** Same as [leq].
@since 1.8 *)
val (>=): t -> t -> bool
(** Same as [geq].
@since 1.8 *)
val (<>): t -> t -> bool
(** [a <> b] is equivalent to [not (equal a b)].
@since 1.8 *)

198
unikernel/duniverse/Zarith/tests/bi.ml Normal file
View file

@ -0,0 +1,198 @@
(* stress test, using random and corner cases
compares Big_int_Z, a Big_int compatible interface for Z, to OCaml's
reference Big_int library
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
module B = Big_int (* reference library *)
module T = Big_int_Z (* tested library *)
(* randomness *)
let _ = Random.init 42
let random_int64 () =
let a,b,c = Random.bits(), Random.bits(), Random.bits () in
let a,b,c = Int64.of_int a, Int64.of_int b, Int64.of_int c in
let a,b,c = Int64.shift_left a 60, Int64.shift_left b 30, c in
Int64.logor a (Int64.logor b c)
let random_int () = Int64.to_int (random_int64 ())
let random_string () =
let l = 1 + Random.int 200 in
let s = Buffer.create l in
let st = if l > 1 && Random.bool () then begin
Buffer.add_char s '-';
1
end else 0 in
for i = st to l - 1 do
Buffer.add_char s (Char.chr (48 + Random.int 10))
done;
Buffer.contents s
(* list utility *)
let list_make n f =
let rec doit i acc = if i < 0 then acc else doit (i-1) ((f i)::acc) in
doit (n-1) []
(* interesting numbers, as big_int *)
let p = (list_make 128 (B.shift_left_big_int B.unit_big_int))
let pn = p @ (List.map B.minus_big_int p)
let g_list =
[B.zero_big_int] @
pn @ (List.map B.succ_big_int pn) @ (List.map B.pred_big_int pn) @
(list_make 128 (fun _ -> B.big_int_of_int (random_int ()))) @
(list_make 128 (fun _ -> B.big_int_of_string (random_string())))
let sh_list = list_make 256 (fun x -> x)
let pow_list = [1;2;3;4;5;6;7;8;9;10;20;55]
(* conversion to Z *)
let g_t_list =
Printf.printf "converting %i numbers\n%!" (List.length g_list);
List.map
(fun g ->
let t = T.big_int_of_string (B.string_of_big_int g) in
let g' = B.big_int_of_string (T.string_of_big_int t) in
if B.compare_big_int g g' <> 0 then failwith (Printf.sprintf "string_of_big_int failure: %s" (B.string_of_big_int g));
g, t
)
g_list
let rec cut_list n l =
if n <= 0 then [] else match l with [] -> [] | h :: t -> h :: cut_list (n-1) t
let small_g_t_list = cut_list 256 g_t_list
(* operator tests *)
let test_un msg filt gf tf =
Printf.printf "testing %s on %i numbers\n%!" msg (List.length g_t_list);
List.iter
(fun (g,t) ->
try
if filt g then (
let g' = gf g and t' = tf t in
if B.string_of_big_int g' <> T.string_of_big_int t' then failwith (Printf.sprintf "%s failure: arg=%s Bresult=%s Tresult=%s" msg (B.string_of_big_int g) (B.string_of_big_int g') (T.string_of_big_int t'))
)
with Failure _ -> ()
) g_t_list
let test_bin_gen msg filt gf tf l =
Printf.printf "testing %s on %i x %i numbers\n%!" msg (List.length l) (List.length l);
List.iter
(fun (g1,t1) ->
List.iter
(fun (g2,t2) ->
if filt (g1,g2) then (
let g' = gf g1 g2 and t' = tf t1 t2 in
if B.string_of_big_int g' <> T.string_of_big_int t' then failwith (Printf.sprintf "%s failure: arg1=%s arg2=%s Bresult=%s Tresult=%s" msg (B.string_of_big_int g1) (B.string_of_big_int g2) (B.string_of_big_int g') (T.string_of_big_int t'))
)
) l
) l
let test_bin msg filt gf tf = test_bin_gen msg filt gf tf g_t_list
let test_bin_small msg filt gf tf = test_bin_gen msg filt gf tf small_g_t_list
let test_shift msg gf tf =
Printf.printf "testing %s on %i numbers\n%!" msg (List.length g_t_list);
List.iter
(fun s ->
List.iter
(fun (g,t) ->
let g' = gf g s and t' = tf t s in
if B.string_of_big_int g' <> T.string_of_big_int t' then failwith (Printf.sprintf "%s failure: arg1=%s arg2=%i Bresult=%s Tresult=%s" msg (B.string_of_big_int g) s (B.string_of_big_int g') (T.string_of_big_int t'))
) g_t_list
) sh_list
let test_pow msg gf tf =
Printf.printf "testing %s on %i numbers\n%!" msg (List.length g_t_list);
List.iter
(fun s ->
List.iter
(fun (g,t) ->
let g' = gf g s and t' = tf t s in
if B.string_of_big_int g' <> T.string_of_big_int t' then failwith (Printf.sprintf "%s failure: arg1=%s arg2=%i Bresult=%s Tresult=%s" msg (B.string_of_big_int g) s (B.string_of_big_int g') (T.string_of_big_int t'))
) g_t_list
) pow_list
let test_comparison msg gf tf l =
Printf.printf "testing %s on %i x %i numbers\n%!" msg (List.length l) (List.length l);
List.iter
(fun (g1,t1) ->
List.iter
(fun (g2,t2) ->
let g' = gf g1 g2 and t' = tf t1 t2 in
if g' <> t' then failwith (Printf.sprintf "%s failure: arg1=%s arg2=%s" msg (B.string_of_big_int g1) (B.string_of_big_int g2))
) l
) l
let filt_none _ = true
let filt_pos x = B.sign_big_int x >= 0
let filt_nonzero2 (_,d) = B.sign_big_int d <> 0
let filt_pos2 (x,y) = B.sign_big_int x >= 0 && B.sign_big_int y >= 0
let filt_nonzero22 (x,y) = B.sign_big_int x <> 0 && B.sign_big_int y <> 0
let ffst f x = fst (f x)
let fsnd f x = snd (f x)
let ffst2 f x y = fst (f x y)
let fsnd2 f x y = snd (f x y)
let _ = test_un "int_of_big_int" filt_none (fun x -> x) (fun x -> T.big_int_of_int (T.int_of_big_int x))
let _ = test_un "int32_of_big_int" filt_none (fun x -> x) (fun x -> T.big_int_of_int32 (T.int32_of_big_int x))
let _ = test_un "int64_of_big_int" filt_none (fun x -> x) (fun x -> T.big_int_of_int64 (T.int64_of_big_int x))
let _ = test_un "nativeint_of_big_int" filt_none (fun x -> x) (fun x -> T.big_int_of_nativeint (T.nativeint_of_big_int x))
let _ = test_un "string_of_big_int" filt_none (fun x -> x) (fun x -> T.big_int_of_string (T.string_of_big_int x))
let _ = test_un "minus_big_int" filt_none B.minus_big_int T.minus_big_int
let _ = test_un "abs_big_int" filt_none B.abs_big_int T.abs_big_int
let _ = test_un "succ_big_int"filt_none B.succ_big_int T.succ_big_int
let _ = test_un "pred_big_int" filt_none B.pred_big_int T.pred_big_int
let _ = test_un "sqrt_big_int" filt_pos B.sqrt_big_int T.sqrt_big_int
let _ = test_bin "add_big_int" filt_none B.add_big_int T.add_big_int
let _ = test_bin "sub_big_int" filt_none B.sub_big_int T.sub_big_int
let _ = test_bin "mult_big_int" filt_none B.mult_big_int T.mult_big_int
let _ = test_bin_small "div_big_int" filt_nonzero2 B.div_big_int T.div_big_int
let _ = test_bin_small "quomod_big_int #1" filt_nonzero2 (ffst2 B.quomod_big_int) (ffst2 T.quomod_big_int)
let _ = test_bin_small "quomod_big_int #2" filt_nonzero2 (fsnd2 B.quomod_big_int) (fsnd2 T.quomod_big_int)
let _ = test_bin_small "mod_big_int" filt_nonzero2 B.mod_big_int T.mod_big_int
let _ = test_bin_small "gcd_big_int" filt_nonzero22 B.gcd_big_int T.gcd_big_int
let _ = test_bin "and_big_int" filt_pos2 B.and_big_int T.and_big_int
let _ = test_bin "or_big_int" filt_pos2 B.or_big_int T.or_big_int
let _ = test_bin "xor_big_int" filt_pos2 B.xor_big_int T.xor_big_int
let _ = test_shift "shift_left_big_int" B.shift_left_big_int T.shift_left_big_int
let _ = test_shift "shift_right_big_int" B.shift_right_big_int T.shift_right_big_int
let _ = test_shift "shift_right_towards_zero_big_int" B.shift_right_towards_zero_big_int T.shift_right_towards_zero_big_int
let _ = test_pow "power_big_int_positive_int" B.power_big_int_positive_int T.power_big_int_positive_int
let _ = test_comparison "compare" B.compare_big_int Z.compare g_t_list
let _ = test_comparison "equal" B.eq_big_int Z.equal g_t_list
let _ = test_comparison "lt" B.lt_big_int (fun x y -> x < y) g_t_list
let _ = test_comparison "ge" B.ge_big_int (fun x y -> x >= y) g_t_list
let _ = Printf.printf "All tests passed!\n"

60
unikernel/duniverse/Zarith/tests/chi2.ml Normal file
View file

@ -0,0 +1,60 @@
(* Accumulate [n] samples from function [f] and check the chi-square.
Assumes [f] returns integers in the [0..255] range. *)
let chisquare n f =
let r = 256 in
let freq = Array.make r 0 in
for i = 0 to n - 1 do
let t = f () in freq.(t) <- freq.(t) + 1
done;
let expected = float n /. float r in
let t =
Array.fold_left
(fun s x -> let d = float x -. expected in d *. d +. s)
0.0 freq in
let chi2 = t /. expected in
let degfree = float r -. 1.0 in
(* The degree of freedom is high, so we approximate as a normal
distribution with mean equal to degfree and variance 2 * degfree.
Four sigmas correspond to a 99.9968% confidence interval.
(Without the approximation, the confidence interval seems to be 99.986%.)
*)
chi2 <= degfree +. 4.0 *. sqrt (2.0 *. degfree)
let failed = ref false
let test_base name f =
if not (chisquare 100_000 f) then begin
Printf.printf "%s: suspicious result\n%!" name;
failed := true
end
let test name f =
(* Test the low 8 bits of the result of f *)
test_base name (fun () -> Z.to_int (Z.logand (f ()) (Z.of_int 0xFF)))
let p = Z.of_string "35742549198872617291353508656626642567"
let _ =
test "random_bits 15 (bits 0-7)"
(fun () -> Z.random_bits 15);
test "random_bits 32 (bits 12-19)"
(fun () -> Z.(shift_right (random_bits 32) 12));
test "random_bits 31 (bits 23-30)"
(fun () -> Z.(shift_right (random_bits 31) 23));
test "random_int 2^30 (bits 0-7)"
(fun () -> Z.(random_int (shift_left one 30)));
test "random_int 2^30 (bits 21-28)"
(fun () -> Z.(shift_right (random_int (shift_left one 30)) 21));
test "random_int (256 * p) / p"
(let bound = Z.shift_left p 8 in
fun () -> Z.(div (random_int bound) p));
(* Also test our hash function, why not? *)
test_base "hash (random_int p) (bits 0-7)"
(fun () -> Z.(hash (random_int p)) land 0xFF);
test_base "hash (random_int p) (bits 16-23)"
(fun () -> (Z.(hash (random_int p)) lsr 16) land 0xFF);
exit (if !failed then 2 else 0)

BIN
unikernel/duniverse/Zarith/tests/extern.data32 Normal file
View file

Binary file not shown.

BIN
unikernel/duniverse/Zarith/tests/extern.data64 Normal file
View file

Binary file not shown.

14
unikernel/duniverse/Zarith/tests/extern.ml Normal file
View file

@ -0,0 +1,14 @@
(* Marshal some interesting big integers to the given file *)
let _ =
let file = Sys.argv.(1) in
let oc = open_out_bin file in
for nbits = 16 to 128 do
let x = Z.shift_left Z.one nbits in
output_value oc (Z.pred (Z.neg x));
output_value oc (Z.neg x);
output_value oc (Z.pred x);
output_value oc x
done;
close_out oc

24
unikernel/duniverse/Zarith/tests/intern.ml Normal file
View file

@ -0,0 +1,24 @@
(* Unmarshal big integers from the given file, and report errors *)
open Printf
let expect ic n =
try
let m = (input_value ic : Z.t) in
if Z.equal m n then printf " OK" else printf " Wrong"
with Failure _ ->
printf " Fail"
let _ =
let file = Sys.argv.(1) in
let ic = open_in_bin file in
for nbits = 16 to 128 do
printf "%d:" nbits;
let x = Z.shift_left Z.one nbits in
expect ic (Z.pred (Z.neg x));
expect ic (Z.neg x);
expect ic (Z.pred x);
expect ic x;
print_newline()
done;
close_in ic

113
unikernel/duniverse/Zarith/tests/intern.output3232 Normal file
View file

@ -0,0 +1,113 @@
16: OK OK OK OK
17: OK OK OK OK
18: OK OK OK OK
19: OK OK OK OK
20: OK OK OK OK
21: OK OK OK OK
22: OK OK OK OK
23: OK OK OK OK
24: OK OK OK OK
25: OK OK OK OK
26: OK OK OK OK
27: OK OK OK OK
28: OK OK OK OK
29: OK OK OK OK
30: OK OK OK OK
31: OK OK OK OK
32: OK OK OK OK
33: OK OK OK OK
34: OK OK OK OK
35: OK OK OK OK
36: OK OK OK OK
37: OK OK OK OK
38: OK OK OK OK
39: OK OK OK OK
40: OK OK OK OK
41: OK OK OK OK
42: OK OK OK OK
43: OK OK OK OK
44: OK OK OK OK
45: OK OK OK OK
46: OK OK OK OK
47: OK OK OK OK
48: OK OK OK OK
49: OK OK OK OK
50: OK OK OK OK
51: OK OK OK OK
52: OK OK OK OK
53: OK OK OK OK
54: OK OK OK OK
55: OK OK OK OK
56: OK OK OK OK
57: OK OK OK OK
58: OK OK OK OK
59: OK OK OK OK
60: OK OK OK OK
61: OK OK OK OK
62: OK OK OK OK
63: OK OK OK OK
64: OK OK OK OK
65: OK OK OK OK
66: OK OK OK OK
67: OK OK OK OK
68: OK OK OK OK
69: OK OK OK OK
70: OK OK OK OK
71: OK OK OK OK
72: OK OK OK OK
73: OK OK OK OK
74: OK OK OK OK
75: OK OK OK OK
76: OK OK OK OK
77: OK OK OK OK
78: OK OK OK OK
79: OK OK OK OK
80: OK OK OK OK
81: OK OK OK OK
82: OK OK OK OK
83: OK OK OK OK
84: OK OK OK OK
85: OK OK OK OK
86: OK OK OK OK
87: OK OK OK OK
88: OK OK OK OK
89: OK OK OK OK
90: OK OK OK OK
91: OK OK OK OK
92: OK OK OK OK
93: OK OK OK OK
94: OK OK OK OK
95: OK OK OK OK
96: OK OK OK OK
97: OK OK OK OK
98: OK OK OK OK
99: OK OK OK OK
100: OK OK OK OK
101: OK OK OK OK
102: OK OK OK OK
103: OK OK OK OK
104: OK OK OK OK
105: OK OK OK OK
106: OK OK OK OK
107: OK OK OK OK
108: OK OK OK OK
109: OK OK OK OK
110: OK OK OK OK
111: OK OK OK OK
112: OK OK OK OK
113: OK OK OK OK
114: OK OK OK OK
115: OK OK OK OK
116: OK OK OK OK
117: OK OK OK OK
118: OK OK OK OK
119: OK OK OK OK
120: OK OK OK OK
121: OK OK OK OK
122: OK OK OK OK
123: OK OK OK OK
124: OK OK OK OK
125: OK OK OK OK
126: OK OK OK OK
127: OK OK OK OK
128: OK OK OK OK

113
unikernel/duniverse/Zarith/tests/intern.output3264 Normal file
View file

@ -0,0 +1,113 @@
16: OK OK OK OK
17: OK OK OK OK
18: OK OK OK OK
19: OK OK OK OK
20: OK OK OK OK
21: OK OK OK OK
22: OK OK OK OK
23: OK OK OK OK
24: OK OK OK OK
25: OK OK OK OK
26: OK OK OK OK
27: OK OK OK OK
28: OK OK OK OK
29: OK OK OK OK
30: Fail OK OK Fail
31: Fail Fail Fail Fail
32: Fail Fail Fail Fail
33: Fail Fail Fail Fail
34: Fail Fail Fail Fail
35: Fail Fail Fail Fail
36: Fail Fail Fail Fail
37: Fail Fail Fail Fail
38: Fail Fail Fail Fail
39: Fail Fail Fail Fail
40: Fail Fail Fail Fail
41: Fail Fail Fail Fail
42: Fail Fail Fail Fail
43: Fail Fail Fail Fail
44: Fail Fail Fail Fail
45: Fail Fail Fail Fail
46: Fail Fail Fail Fail
47: Fail Fail Fail Fail
48: Fail Fail Fail Fail
49: Fail Fail Fail Fail
50: Fail Fail Fail Fail
51: Fail Fail Fail Fail
52: Fail Fail Fail Fail
53: Fail Fail Fail Fail
54: Fail Fail Fail Fail
55: Fail Fail Fail Fail
56: Fail Fail Fail Fail
57: Fail Fail Fail Fail
58: Fail Fail Fail Fail
59: Fail Fail Fail Fail
60: Fail Fail Fail Fail
61: Fail Fail Fail Fail
62: OK Fail Fail OK
63: OK OK OK OK
64: OK OK OK OK
65: OK OK OK OK
66: OK OK OK OK
67: OK OK OK OK
68: OK OK OK OK
69: OK OK OK OK
70: OK OK OK OK
71: OK OK OK OK
72: OK OK OK OK
73: OK OK OK OK
74: OK OK OK OK
75: OK OK OK OK
76: OK OK OK OK
77: OK OK OK OK
78: OK OK OK OK
79: OK OK OK OK
80: OK OK OK OK
81: OK OK OK OK
82: OK OK OK OK
83: OK OK OK OK
84: OK OK OK OK
85: OK OK OK OK
86: OK OK OK OK
87: OK OK OK OK
88: OK OK OK OK
89: OK OK OK OK
90: OK OK OK OK
91: OK OK OK OK
92: OK OK OK OK
93: OK OK OK OK
94: OK OK OK OK
95: OK OK OK OK
96: OK OK OK OK
97: OK OK OK OK
98: OK OK OK OK
99: OK OK OK OK
100: OK OK OK OK
101: OK OK OK OK
102: OK OK OK OK
103: OK OK OK OK
104: OK OK OK OK
105: OK OK OK OK
106: OK OK OK OK
107: OK OK OK OK
108: OK OK OK OK
109: OK OK OK OK
110: OK OK OK OK
111: OK OK OK OK
112: OK OK OK OK
113: OK OK OK OK
114: OK OK OK OK
115: OK OK OK OK
116: OK OK OK OK
117: OK OK OK OK
118: OK OK OK OK
119: OK OK OK OK
120: OK OK OK OK
121: OK OK OK OK
122: OK OK OK OK
123: OK OK OK OK
124: OK OK OK OK
125: OK OK OK OK
126: OK OK OK OK
127: OK OK OK OK
128: OK OK OK OK

113
unikernel/duniverse/Zarith/tests/intern.output6432 Normal file
View file

@ -0,0 +1,113 @@
16: OK OK OK OK
17: OK OK OK OK
18: OK OK OK OK
19: OK OK OK OK
20: OK OK OK OK
21: OK OK OK OK
22: OK OK OK OK
23: OK OK OK OK
24: OK OK OK OK
25: OK OK OK OK
26: OK OK OK OK
27: OK OK OK OK
28: OK OK OK OK
29: OK OK OK OK
30: Fail OK OK Fail
31: Fail Fail Fail Fail
32: Fail Fail Fail Fail
33: Fail Fail Fail Fail
34: Fail Fail Fail Fail
35: Fail Fail Fail Fail
36: Fail Fail Fail Fail
37: Fail Fail Fail Fail
38: Fail Fail Fail Fail
39: Fail Fail Fail Fail
40: Fail Fail Fail Fail
41: Fail Fail Fail Fail
42: Fail Fail Fail Fail
43: Fail Fail Fail Fail
44: Fail Fail Fail Fail
45: Fail Fail Fail Fail
46: Fail Fail Fail Fail
47: Fail Fail Fail Fail
48: Fail Fail Fail Fail
49: Fail Fail Fail Fail
50: Fail Fail Fail Fail
51: Fail Fail Fail Fail
52: Fail Fail Fail Fail
53: Fail Fail Fail Fail
54: Fail Fail Fail Fail
55: Fail Fail Fail Fail
56: Fail Fail Fail Fail
57: Fail Fail Fail Fail
58: Fail Fail Fail Fail
59: Fail Fail Fail Fail
60: Fail Fail Fail Fail
61: Fail Fail Fail Fail
62: OK Fail Fail OK
63: OK OK OK OK
64: OK OK OK OK
65: OK OK OK OK
66: OK OK OK OK
67: OK OK OK OK
68: OK OK OK OK
69: OK OK OK OK
70: OK OK OK OK
71: OK OK OK OK
72: OK OK OK OK
73: OK OK OK OK
74: OK OK OK OK
75: OK OK OK OK
76: OK OK OK OK
77: OK OK OK OK
78: OK OK OK OK
79: OK OK OK OK
80: OK OK OK OK
81: OK OK OK OK
82: OK OK OK OK
83: OK OK OK OK
84: OK OK OK OK
85: OK OK OK OK
86: OK OK OK OK
87: OK OK OK OK
88: OK OK OK OK
89: OK OK OK OK
90: OK OK OK OK
91: OK OK OK OK
92: OK OK OK OK
93: OK OK OK OK
94: OK OK OK OK
95: OK OK OK OK
96: OK OK OK OK
97: OK OK OK OK
98: OK OK OK OK
99: OK OK OK OK
100: OK OK OK OK
101: OK OK OK OK
102: OK OK OK OK
103: OK OK OK OK
104: OK OK OK OK
105: OK OK OK OK
106: OK OK OK OK
107: OK OK OK OK
108: OK OK OK OK
109: OK OK OK OK
110: OK OK OK OK
111: OK OK OK OK
112: OK OK OK OK
113: OK OK OK OK
114: OK OK OK OK
115: OK OK OK OK
116: OK OK OK OK
117: OK OK OK OK
118: OK OK OK OK
119: OK OK OK OK
120: OK OK OK OK
121: OK OK OK OK
122: OK OK OK OK
123: OK OK OK OK
124: OK OK OK OK
125: OK OK OK OK
126: OK OK OK OK
127: OK OK OK OK
128: OK OK OK OK

113
unikernel/duniverse/Zarith/tests/intern.output6464 Normal file
View file

@ -0,0 +1,113 @@
16: OK OK OK OK
17: OK OK OK OK
18: OK OK OK OK
19: OK OK OK OK
20: OK OK OK OK
21: OK OK OK OK
22: OK OK OK OK
23: OK OK OK OK
24: OK OK OK OK
25: OK OK OK OK
26: OK OK OK OK
27: OK OK OK OK
28: OK OK OK OK
29: OK OK OK OK
30: OK OK OK OK
31: OK OK OK OK
32: OK OK OK OK
33: OK OK OK OK
34: OK OK OK OK
35: OK OK OK OK
36: OK OK OK OK
37: OK OK OK OK
38: OK OK OK OK
39: OK OK OK OK
40: OK OK OK OK
41: OK OK OK OK
42: OK OK OK OK
43: OK OK OK OK
44: OK OK OK OK
45: OK OK OK OK
46: OK OK OK OK
47: OK OK OK OK
48: OK OK OK OK
49: OK OK OK OK
50: OK OK OK OK
51: OK OK OK OK
52: OK OK OK OK
53: OK OK OK OK
54: OK OK OK OK
55: OK OK OK OK
56: OK OK OK OK
57: OK OK OK OK
58: OK OK OK OK
59: OK OK OK OK
60: OK OK OK OK
61: OK OK OK OK
62: OK OK OK OK
63: OK OK OK OK
64: OK OK OK OK
65: OK OK OK OK
66: OK OK OK OK
67: OK OK OK OK
68: OK OK OK OK
69: OK OK OK OK
70: OK OK OK OK
71: OK OK OK OK
72: OK OK OK OK
73: OK OK OK OK
74: OK OK OK OK
75: OK OK OK OK
76: OK OK OK OK
77: OK OK OK OK
78: OK OK OK OK
79: OK OK OK OK
80: OK OK OK OK
81: OK OK OK OK
82: OK OK OK OK
83: OK OK OK OK
84: OK OK OK OK
85: OK OK OK OK
86: OK OK OK OK
87: OK OK OK OK
88: OK OK OK OK
89: OK OK OK OK
90: OK OK OK OK
91: OK OK OK OK
92: OK OK OK OK
93: OK OK OK OK
94: OK OK OK OK
95: OK OK OK OK
96: OK OK OK OK
97: OK OK OK OK
98: OK OK OK OK
99: OK OK OK OK
100: OK OK OK OK
101: OK OK OK OK
102: OK OK OK OK
103: OK OK OK OK
104: OK OK OK OK
105: OK OK OK OK
106: OK OK OK OK
107: OK OK OK OK
108: OK OK OK OK
109: OK OK OK OK
110: OK OK OK OK
111: OK OK OK OK
112: OK OK OK OK
113: OK OK OK OK
114: OK OK OK OK
115: OK OK OK OK
116: OK OK OK OK
117: OK OK OK OK
118: OK OK OK OK
119: OK OK OK OK
120: OK OK OK OK
121: OK OK OK OK
122: OK OK OK OK
123: OK OK OK OK
124: OK OK OK OK
125: OK OK OK OK
126: OK OK OK OK
127: OK OK OK OK
128: OK OK OK OK

292
unikernel/duniverse/Zarith/tests/ofstring.ml Normal file
View file

@ -0,0 +1,292 @@
let pow2 n =
let rec doit acc n =
if n<=0 then acc else doit (Z.add acc acc) (n-1)
in
doit Z.one n
let p30 = pow2 30
let p62 = pow2 62
let p300 = pow2 300
let p120 = pow2 120
let p121 = pow2 121
let test_of_string_Z () =
let round_trip_Z () =
let round_trip fmt x=
(Z.equal (Z.of_string (Z.format fmt x)) x)
in
let formats = [
"%i"; "%#b"; "%#o"; "%#x"; "%#X";
"%+i"; "%#+b"; "%#+o"; "%#+x"; "%#+X";
"%+0i"; "%#+0b"; "%#+0o"; "%#+0x"; "%#+0X";
] in
let numbers =
let (+) = Z.add in
let l = [p30; p62; p30 + p62; p300; p120; p121] in
l @ (List.map Z.neg l)
in
List.iter
(fun fmt ->
assert
(
List.for_all
(fun x -> round_trip fmt x)
numbers
)
)
formats
in
let fail d f x =
try
ignore (f x);
Printf.printf "%s should fail on %s\n" d x
with _ -> ()
in
let succ d f x y =
try
let z = f x in
if Z.equal z y
then ()
else
Printf.printf
"%s(%s) returned %s, expected %s\n"
d
x
(Z.to_string z)
(Z.to_string y)
with _ ->
Printf.printf "%s failed. Expected %s\n" d (Z.to_string y)
in
let z_and_int_agree s =
let f = try Some (int_of_string s) with _ -> None in
let z = try Some (Z.of_string s) with _ -> None in
match f,z with
| None, None -> ()
| Some i, Some z ->
if not (Z.equal (Z.of_int i) z)
then
Printf.printf
"Z.of_string (%s) returned %s, expected %s\n"
s
(Z.to_string z)
(string_of_int i)
| Some i, None ->
Printf.printf
"Z.of_string (%s) failed, expected %s\n"
s
(string_of_int i)
| None, Some z ->
Printf.printf
"Z.of_string (%s) returned %s, failure expected"
s
(Z.to_string z)
in
round_trip_Z ();
fail "Z.of_string" Z.of_string "0b2";
fail "Z.of_string" Z.of_string "0o8";
fail "Z.of_string" Z.of_string "0xg";
fail "Z.of_string" Z.of_string "0xG";
fail "Z.of_string" Z.of_string "0A";
succ "Z.of_string" Z.of_string "" Z.zero;
succ "Z.of_string" Z.of_string "+" Z.zero;
succ "Z.of_string" Z.of_string "-" Z.zero;
succ "Z.of_string" Z.of_string "0x" Z.zero;
succ "Z.of_string" Z.of_string "0b" Z.zero;
fail "Z.of_substring" (Z.of_substring ~pos:1 ~len:2) "0b2";
fail "Z.of_substring" (Z.of_substring ~pos:1 ~len:2) "0o8";
fail "Z.of_substring" (Z.of_substring ~pos:1 ~len:2) "0xg";
fail "Z.of_substring" (Z.of_substring ~pos:1 ~len:2) "0xG";
fail "Z.of_substring" (Z.of_substring ~pos:1 ~len:1) "0A";
succ "Z.of_substring" (Z.of_substring ~pos:1 ~len:0) "+" Z.zero;
succ "Z.of_substring" (Z.of_substring ~pos:1 ~len:1) "-+" Z.zero;
succ "Z.of_substring" (Z.of_substring ~pos:1 ~len:2)"--1-" (Z.minus_one);
succ "Z.of_substring" (Z.of_substring ~pos:1 ~len:2)"--1\000" (Z.minus_one);
succ "Z.of_substring" (Z.of_substring ~pos:1 ~len:2)"\000-1\000" (Z.minus_one);
succ "Z.of_substring" (Z.of_substring ~pos:1 ~len:1)"00b1" Z.zero;
succ "Z.of_substring" (Z.of_substring ~pos:1 ~len:2)"00b1" Z.zero;
succ "Z.of_substring" (Z.of_substring ~pos:1 ~len:3)"00b1" Z.one;
z_and_int_agree "_123";
z_and_int_agree "1_23";
z_and_int_agree "12_3";
z_and_int_agree "123_";
z_and_int_agree "0x_123";
z_and_int_agree "0_123";
let s = Z.format "%#b" p120 in
let n = String.length s in
for i = 0 to n - 3 do
succ "Z.of_substring"
(Z.of_substring ~pos:0 ~len:(n - i))
s
(Z.shift_right p120 i)
done
let _ = test_of_string_Z ()
let test_of_string_Q () =
let round_trip_Q () =
let round_trip fmt x=
let os = Q.of_string (Z.to_string x) in
let ob = Q.of_bigint x in
if Q.equal os ob then
true
else begin
Format.printf "%a not equal to %a\n" Q.pp_print os Q.pp_print ob;
false
end
in
let formats = [
"%i"; "%#b"; "%#o"; "%#x"; "%#X";
"%+i"; "%#+b"; "%#+o"; "%#+x"; "%#+X";
"%+0i"; "%#+0b"; "%#+0o"; "%#+0x"; "%#+0X";
] in
let numbers =
let (+) = Z.add in
let l = [p30; p62; p30 + p62; p300; p120; p121] in
(l @ (List.map Z.neg l))
in
List.iter
(fun fmt ->
assert
(
List.for_all
(fun x -> round_trip fmt x)
numbers
)
)
formats
in
let fail d f x =
try
let s = f x in
Printf.printf "%s should fail on %s. Got %s\n" d x (Q.to_string s)
with _ -> ()
in
let succ d f x y =
try
let z = f x in
if Q.equal z y
then ()
else
Printf.printf
"%s(%s) returned %s, expected %s\n"
d
x
(Q.to_string z)
(Q.to_string y)
with exc ->
Printf.printf "%s failed. Expected %s. Got %s\n" d (Q.to_string y)
(Printexc.to_string exc)
in
let q_and_float_agree s =
let f = try Some (float_of_string s) with _ -> None in
let q = try Some (Q.of_string s) with _ -> None in
match f,q with
| None, None -> ()
| Some f, Some q ->
if not ((Q.to_float q) = f)
then
Printf.printf
"Q.of_string (%s) returned %s, expected %s\n"
s
(Q.to_string q)
(string_of_float f)
| Some f, None ->
Printf.printf
"Q.of_string (%s) failed, expected %s\n"
s
(string_of_float f)
| None, Some q ->
Printf.printf
"Q.of_string (%s) returned %s, failure expected"
s
(Q.to_string q)
in
round_trip_Q ();
fail "Q.of_string" Q.of_string "0b2";
fail "Q.of_string" Q.of_string "0o8";
fail "Q.of_string" Q.of_string "0xg";
fail "Q.of_string" Q.of_string "0xG";
fail "Q.of_string" Q.of_string "0A";
succ "Q.of_string" Q.of_string "" Q.zero;
succ "Q.of_string" Q.of_string "+" Q.zero;
succ "Q.of_string" Q.of_string "-" Q.zero;
succ "Q.of_string" Q.of_string "0x" Q.zero;
succ "Q.of_string" Q.of_string "0X" Q.zero;
succ "Q.of_string" Q.of_string "0o" Q.zero;
succ "Q.of_string" Q.of_string "0O" Q.zero;
succ "Q.of_string" Q.of_string "0b" Q.zero;
succ "Q.of_string" Q.of_string "0B" Q.zero;
succ "Q.of_string" Q.of_string "0b101" (Q.of_string "5");
succ "Q.of_string" Q.of_string "0B101" (Q.of_string "5");
succ "Q.of_string" Q.of_string "0o101" (Q.of_string "65");
succ "Q.of_string" Q.of_string "0O101" (Q.of_string "65");
fail "Q.of_string" Q.of_string "0b2";
fail "Q.of_string" Q.of_string "0o8";
fail "Q.of_string" Q.of_string "0xg";
fail "Q.of_string" Q.of_string "0xG";
fail "Q.of_string" Q.of_string "0A";
fail "Q.of_string" Q.of_string "-0b0.1e1";
fail "Q.of_string" Q.of_string "-0o0.1E1";
fail "Q.of_string" Q.of_string "-0b0.1P1";
fail "Q.of_string" Q.of_string "-0o0.1p1";
fail "Q.of_string" Q.of_string "-0.1P1";
fail "Q.of_string" Q.of_string "-0.1p1";
succ "Q.of_string" Q.of_string "0x1e2" (Q.of_int 482);
succ "Q.of_string" Q.of_string "1e2" (Q.of_int 100);
succ "Q.of_string" Q.of_string "+" Q.zero;
succ "Q.of_string" Q.of_string "-+" Q.zero;
succ "Q.of_string" Q.of_string "-1" Q.minus_one;
succ "Q.of_string" Q.of_string "+0xFF.8" (Q.of_float 255.5);
succ "Q.of_string" Q.of_string "+0xff.8" (Q.of_float 255.5);
succ "Q.of_string" Q.of_string "-0xFF.8" (Q.of_float (-255.5));
succ "Q.of_string" Q.of_string "-0xff.8" (Q.of_float (-255.5));
succ "Q.of_string" Q.of_string "-0.1e1" (Q.of_float (float_of_string "-0.1e1")) ;
succ "Q.of_string" Q.of_string "-0.1E1" (Q.of_float (float_of_string "-0.1E1")) ;
succ "Q.of_string" Q.of_string "-0x0.1P1" (Q.of_float (float_of_string "-0x0.1P1")) ;
succ "Q.of_string" Q.of_string "-0x0.1p1" (Q.of_float (float_of_string "-0x0.1p1")) ;
succ "Q.of_string" Q.of_string "6.674e-11" (Q.of_string "0.00000000006674") ;
q_and_float_agree "-0x0.1p1" ;
q_and_float_agree "-0x0.1P1" ;
q_and_float_agree "-0x0.1p10" ;
q_and_float_agree "-0x0.1p10" ;
q_and_float_agree "1_2.34e03";
q_and_float_agree "12_.34e03";
q_and_float_agree "12._34e03";
q_and_float_agree "12.3_4e03";
q_and_float_agree "12.34_e03";
(* float_of_string accept leading underscores after ( 'e' | 'E'), Q does not. *)
(* q_and_float_agree "12.34e_03"; *)
q_and_float_agree "12.34e0_3";
q_and_float_agree "12.34e03_";
q_and_float_agree "000_001";
q_and_float_agree "001_000";
q_and_float_agree "123.";
(* underscores right after dot are accepted. *)
q_and_float_agree "1._001";
q_and_float_agree "._001";
(* float_of_string doesn't accept strings without digits, Q and Z do (e.g. "+", "-", "0x", "." *)
(* q_and_float_agree "."; *)
(* q_and_float_agree "._"; *)
q_and_float_agree "0.x00a";
q_and_float_agree ".-001";
()
let _ = test_of_string_Q ()

65
unikernel/duniverse/Zarith/tests/pi.ml Normal file
View file

@ -0,0 +1,65 @@
(* Pi digits computed with the streaming algorithm given on pages 4, 6
& 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy
Gibbons, August 2004. *)
open Printf
let zero = Z.zero
and one = Z.one
and three = Z.of_int 3
and four = Z.of_int 4
and ten = Z.of_int 10
and neg_ten = Z.of_int (-10)
;;
(* Linear Fractional (aka M=F6bius) Transformations *)
module LFT = struct
let floor_ev (q, r, s, t) x =
Z.((q * x + r) / (s * x + t))
let unit = (one, zero, zero, one)
let comp (q, r, s, t) (q', r', s', t') =
Z.(q * q' + r * s', q * r' + r * t',
s * q' + t * s', s * r' + t * t')
end
let next z = LFT.floor_ev z three
let safe z n = (n = LFT.floor_ev z four)
let prod z n = LFT.comp (ten, Z.(neg_ten * n), zero, one) z
let cons z k =
let den = 2 * k + 1 in
LFT.comp z (Z.of_int k, Z.of_int (2 * den), zero, Z.of_int den)
let rec digit k z n row col =
if n > 0 then
let y = next z in
if safe z y then
if col = 10 then (
let row = row + 10 in
printf "\t:%i\n%a" row Z.output y;
digit k (prod z y) (n - 1) row 1
)
else (
printf "%a" Z.output y;
digit k (prod z y) (n - 1) row (col + 1)
)
else digit (k + 1) (cons z k) n row col
else
printf "%*s\t:%i\n" (10 - col) "" (row + col)
let digits n = digit 1 LFT.unit n 0 0
let usage () =
prerr_endline "Usage: pi <number of digits to compute for pi>";
exit 2
let _ =
let args = Sys.argv in
if Array.length args <> 2 then usage () else
digits (int_of_string Sys.argv.(1))

50
unikernel/duniverse/Zarith/tests/pi.output Normal file
View file

@ -0,0 +1,50 @@
3141592653 :10
5897932384 :20
6264338327 :30
9502884197 :40
1693993751 :50
0582097494 :60
4592307816 :70
4062862089 :80
9862803482 :90
5342117067 :100
9821480865 :110
1328230664 :120
7093844609 :130
5505822317 :140
2535940812 :150
8481117450 :160
2841027019 :170
3852110555 :180
9644622948 :190
9549303819 :200
6442881097 :210
5665933446 :220
1284756482 :230
3378678316 :240
5271201909 :250
1456485669 :260
2346034861 :270
0454326648 :280
2133936072 :290
6024914127 :300
3724587006 :310
6063155881 :320
7488152092 :330
0962829254 :340
0917153643 :350
6789259036 :360
0011330530 :370
5488204665 :380
2138414695 :390
1941511609 :400
4330572703 :410
6575959195 :420
3092186117 :430
3819326117 :440
9310511854 :450
8074462379 :460
9627495673 :470
5188575272 :480
4891227938 :490
1830119491 :500

27
unikernel/duniverse/Zarith/tests/setround.c Normal file
View file

@ -0,0 +1,27 @@
/* Auxiliary function to control FP rounding mode. Assumes ISO C99. */
#include <fenv.h>
#include <caml/mlvalues.h>
#ifndef FE_DOWNWARD
#define FE_DOWNWARD (-1)
#endif
#ifndef FE_TONEAREST
#define FE_TONEAREST (-1)
#endif
#ifndef FE_TOWARDZERO
#define FE_TOWARDZERO (-1)
#endif
#ifndef FE_UPWARD
#define FE_UPWARD (-1)
#endif
static int modes[4] = {
FE_DOWNWARD, FE_TONEAREST, FE_TOWARDZERO, FE_UPWARD
};
CAMLprim value caml_ztest_setround(value vmode)
{
int rc = fesetround(modes[Int_val(vmode)]);
return Val_bool(rc == 0);
}

154
unikernel/duniverse/Zarith/tests/timings.ml Normal file
View file

@ -0,0 +1,154 @@
open Printf
(* Timing harness harness *)
let time fn arg =
let start = Sys.time() in
let rec time accu =
let qty = fn arg in
let duration = Sys.time() -. start in
let qty = float qty in
if duration >= 1.0
then duration /. (accu +. qty)
else time (accu +. qty)
in time 0.0
let time_repeat rep fn arg =
time (fun () -> for i = 1 to rep do ignore (fn arg) done; rep) ()
(* Basic arithmetic operations *)
let add (x, y) =
for i = 1 to 50_000_000 do
ignore (Sys.opaque_identity (Z.add x y))
done;
50_000_000
let sub (x, y) =
for i = 1 to 50_000_000 do
ignore (Sys.opaque_identity (Z.sub x y))
done;
50_000_000
let mul (x, y) =
for i = 1 to 50_000_000 do
ignore (Sys.opaque_identity (Z.mul x y))
done;
50_000_000
let div (x, y) =
for i = 1 to 10_000_000 do
ignore (Sys.opaque_identity (Z.div x y))
done;
1_000_000
let shl (x, y) =
for i = 1 to 50_000_000 do
ignore (Sys.opaque_identity (Z.shift_left x y))
done;
50_000_000
let big = Z.pow (Z.of_int 17) 150
let med = Z.pow (Z.of_int 3) 150
let _ =
printf "%.2e add (small, no overflow)\n%!"
(time add (Z.of_int 1, Z.of_int 2));
printf "%.2e add (small, overflow)\n%!"
(time add (Z.of_int max_int, Z.of_int 2));
printf "%.2e add (small, big)\n%!"
(time add (Z.of_int 1, big));
printf "%.2e add (big, big)\n%!"
(time add (big, big));
printf "%.2e sub (small, no overflow)\n%!"
(time sub (Z.of_int 1, Z.of_int 2));
printf "%.2e sub (small, overflow)\n%!"
(time sub (Z.of_int max_int, Z.of_int (-2)));
printf "%.2e sub (big, small)\n%!"
(time sub (big, Z.of_int 1));
printf "%.2e sub (big, big)\n%!"
(time sub (big, big));
printf "%.2e mul (small, no overflow)\n%!"
(time mul (Z.of_int 42, Z.of_int 74));
printf "%.2e mul (small, overflow)\n%!"
(time mul (Z.of_int max_int, Z.of_int 3));
printf "%.2e mul (small, big)\n%!"
(time mul (Z.of_int 3, big));
printf "%.2e mul (medium, medium)\n%!"
(time mul (med, med));
printf "%.2e mul (big, big)\n%!"
(time mul (big, big));
printf "%.2e div (small, small)\n%!"
(time div (Z.of_int 12345678, Z.of_int 443));
printf "%.2e div (big, small)\n%!"
(time div (big, Z.of_int 443));
printf "%.2e div (big, medium)\n%!"
(time div (big, med));
printf "%.2e shl (small, no overflow)\n%!"
(time shl (Z.of_int 3, 10));
printf "%.2e shl (small, overflow)\n%!"
(time shl (Z.of_int max_int, 2));
printf "%.2e shl (big)\n%!"
(time shl (big, 42))
(* Factorial *)
let rec fact_z n =
if n <= 0 then Z.one else Z.mul (Z.of_int n) (fact_z (n-1))
let _ =
printf "%.2e fact 10\n%!"
(time_repeat 1_000_000 fact_z 10);
printf "%.2e fact 40\n%!"
(time_repeat 10_000 fact_z 40);
printf "%.2e fact 200\n%!"
(time_repeat 10_000 fact_z 200)
(* Fibonacci *)
let rec fib_int n =
if n < 2 then 1 else fib_int(n-1) + fib_int(n-2)
let rec fib_natint n =
if n < 2 then 1n else Nativeint.add (fib_natint(n-1)) (fib_natint(n-2))
let rec fib_z n =
if n < 2 then Z.one else Z.add (fib_z(n-1)) (fib_z(n-2))
let fib_arg = 32
let _ =
printf "%.2e fib (int)\n%!"
(time_repeat 100 fib_int fib_arg);
printf "%.2e fib (nativeint)\n%!"
(time_repeat 100 fib_natint fib_arg);
printf "%.2e fib (Z)\n%!"
(time_repeat 100 fib_z fib_arg)
(* Takeushi *)
let rec tak_int (x, y, z) =
if x > y
then tak_int(tak_int (x-1, y, z), tak_int (y-1, z, x), tak_int (z-1, x, y))
else z
let rec tak_natint (x, y, z) =
if x > y
then tak_natint(tak_natint (Nativeint.sub x 1n, y, z),
tak_natint (Nativeint.sub y 1n, z, x),
tak_natint (Nativeint.sub z 1n, x, y))
else z
let rec tak_z (x, y, z) =
if Z.compare x y > 0
then tak_z(tak_z (Z.pred x, y, z),
tak_z (Z.pred y, z, x),
tak_z (Z.pred z, x, y))
else z
let _ =
printf "%.2e tak (int)\n%!"
(time_repeat 1000 tak_int (18,12,6));
printf "%.2e tak (nativeint)\n%!"
(time_repeat 1000 tak_natint (18n,12n,6n));
printf "%.2e tak (Z)\n%!"
(time_repeat 1000 tak_z (Z.of_int 18, Z.of_int 12, Z.of_int 6))

134
unikernel/duniverse/Zarith/tests/tofloat.ml Normal file
View file

@ -0,0 +1,134 @@
(* Testing Z.to_float *)
open Printf
type rounding_mode =
FE_DOWNWARD | FE_TONEAREST | FE_TOWARDZERO | FE_UPWARD
external setround: rounding_mode -> bool = "caml_ztest_setround"
external format_float: string -> float -> string = "caml_format_float"
let hex_of_float f = format_float "%a" f
(* For testing, we use randomly-generated integers of the form
<signed 64-bit integer> * 2^<exponent>
We can predict their FP value by converting the integer part to FP,
then scale by the exponent using ldexp. *)
let test1 (mant: int64) (exp: int) =
let expected = ldexp (Int64.to_float mant) exp in
let actual = Z.to_float (Z.shift_left (Z.of_int64 mant) exp) in
if actual = expected then true else begin
printf "%Ld * 2^%d: expected %s, got %s\n"
mant exp (hex_of_float expected) (hex_of_float actual);
false
end
let rnd64 () =
let m1 = Random.bits() in (* 30 bits *)
let m2 = Random.bits() in (* 30 bits *)
let m3 = Random.bits() in
Int64.(logor (of_int m1)
(logor (shift_left (of_int m2) 30)
(shift_left (of_int m3) 60)))
let testN numrounds =
printf " (%d tests)... %!" numrounds;
let errors = ref 0 in
(* Some random int64 values *)
for i = 1 to numrounds do
let m = Random.int64 Int64.max_int in
if not (test1 m 0) then incr errors;
if not (test1 (Int64.neg m) 0) then incr errors
done;
(* Some random int64 values scaled by some random power of 2 *)
for i = 1 to numrounds do
let m = rnd64() in
let exp = Random.int 1100 in (* sometimes +inf will result *)
if not (test1 m exp) then incr errors
done;
(* Special test close to a rounding point *)
for i = 0 to 15 do
let m = Int64.(add 0xfffffffffffff0L (of_int i)) in
if not (test1 m 32) then incr errors;
if not (test1 (Int64.neg m) 32) then incr errors
done;
if !errors = 0
then printf "passed\n%!"
else printf "FAILED (%d errors)\n%!" !errors
let testQ1 (mant1: int64) (exp1: int) (mant2: int64) (exp2: int) =
let expected =
ldexp (Int64.to_float mant1) exp1 /. ldexp (Int64.to_float mant2) exp2 in
let actual =
Q.to_float (Q.make (Z.shift_left (Z.of_int64 mant1) exp1)
(Z.shift_left (Z.of_int64 mant2) exp2)) in
if compare actual expected = 0 then true else begin
printf "%Ld * 2^%d / %Ld * 2^%d : expected %s, got %s\n"
mant1 exp1 mant2 exp2 (hex_of_float expected) (hex_of_float actual);
false
end
let testQN numrounds =
printf " (%d tests)... %!" numrounds;
let errors = ref 0 in
(* Some special values *)
if not (testQ1 0L 0 1L 0) then incr errors;
if not (testQ1 1L 0 0L 0) then incr errors;
if not (testQ1 (-1L) 0 0L 0) then incr errors;
if not (testQ1 0L 0 0L 0) then incr errors;
(* Some random fractions *)
for i = 1 to numrounds do
let m1 = Random.int64 0x20000000000000L in
let m1 = if Random.bool() then m1 else Int64.neg m1 in
let exp1 = Random.int 500 in
let m2 = Random.int64 0x20000000000000L in
let exp2 = Random.int 500 in
if not (testQ1 m1 exp1 m2 exp2) then incr errors
done;
if !errors = 0
then printf "passed\n%!"
else printf "FAILED (%d errors)\n%!" !errors
let _ =
let numrounds =
if Array.length Sys.argv >= 2
then int_of_string Sys.argv.(1)
else 100_000 in
printf "Default rounding mode (Z)";
testN numrounds;
printf "Default rounding mode (Q)";
testQN numrounds;
if setround FE_TOWARDZERO then begin
printf "Round toward zero (Z)";
testN numrounds;
printf "Round toward zero (Q)";
testQN numrounds
end else begin
printf "Round toward zero not supported, skipping\n"
end;
if setround FE_DOWNWARD then begin
printf "Round downward (Z)";
testN numrounds;
printf "Round downward (Q)";
testQN numrounds
end else begin
printf "Round downward not supported, skipping\n"
end;
if setround FE_UPWARD then begin
printf "Round upward (Z)";
testN numrounds;
printf "Round upward (Q)";
testQN numrounds
end else begin
printf "Round upward not supported, skipping\n"
end;
if setround FE_TONEAREST then begin
printf "Round to nearest (Z)";
testN numrounds;
printf "Round to nearest (Q)";
testQN numrounds
end else begin
printf "Round to nearest not supported, skipping\n"
end

35
unikernel/duniverse/Zarith/tests/tst_extract.ml Normal file
View file

@ -0,0 +1,35 @@
module I = Z
let pr ch x =
output_string ch (I.to_string x);
flush ch
let chk_extract x o l =
let expected =
I.logand (I.shift_right x o) (I.pred (I.shift_left (I.of_int 1) l))
and actual =
I.extract x o l in
if actual <> expected then (Printf.printf "extract %a %d %d = %a found %a\n" pr x o l pr expected pr actual; failwith "test failed")
let doit () =
let max = 128 in
for l = 1 to max do
if l mod 16 == 0 then Printf.printf "%i/%i\n%!" l max;
for o = 0 to 256 do
for n = 0 to 256 do
let x = I.shift_left I.one n in
chk_extract x o l;
chk_extract (I.mul x x) o l;
chk_extract (I.mul x (I.mul x x)) o l;
chk_extract (I.succ x) o l;
chk_extract (I.pred x) o l;
chk_extract (I.neg (I.mul x x)) o l;
chk_extract (I.neg (I.mul x (I.mul x x))) o l;
chk_extract (I.neg x) o l;
chk_extract (I.neg (I.succ x)) o l;
chk_extract (I.neg (I.pred x)) o l;
done
done
done
let _ = doit ()

920
unikernel/duniverse/Zarith/tests/zq.ml Normal file
View file

@ -0,0 +1,920 @@
(* Simple tests for the Z and Q modules.
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
(* testing Z *)
module I = Z
let pr ch x =
output_string ch (I.to_string x);
flush ch
let pr2 ch (x,y) =
Printf.fprintf ch "%s, %s" (I.to_string x) (I.to_string y);
flush ch
let pr3 ch (x,y,z) =
Printf.fprintf ch "%s, %s, %s"
(I.to_string x) (I.to_string y) (I.to_string z);
flush ch
let prfloat ch (x,y : float * float) =
if x = y then
Printf.fprintf ch "OK"
else
Printf.fprintf ch "WRONG! (expected %g, got %g)" y x
let prmarshal ch (x,y : I.t * I.t) =
(if I.equal x y then
Printf.fprintf ch "OK"
else
Printf.fprintf ch "WRONG! (expected %a, got %a)" pr y pr x);
flush ch
let pow2 n =
let rec doit acc n =
if n<=0 then acc else doit (I.add acc acc) (n-1)
in
doit I.one n
let fact n =
let rec doit acc n =
if n<=1 then acc
else doit (I.mul acc (I.of_int n)) (n-1)
in
doit I.one n
let pow a b =
let rec doit b =
if b <= 0 then I.one else
let acc = doit (b lsr 1) in
if b land 1 = 1 then I.mul (I.mul acc acc) (I.of_int a)
else I.mul acc acc
in
doit b
let cvt_int x =
(string_of_bool (I.fits_int x))
^","^
(try string_of_int (I.to_int x) with I.Overflow -> "ovf")
let cvt_int32 x =
(string_of_bool (I.fits_int32 x))
^","^
(try Int32.to_string (I.to_int32 x) with I.Overflow -> "ovf")
let cvt_int64 x =
(string_of_bool (I.fits_int64 x))
^","^
(try Int64.to_string (I.to_int64 x) with I.Overflow -> "ovf")
let cvt_nativeint x =
(string_of_bool (I.fits_nativeint x))
^","^
(try Nativeint.to_string (I.to_nativeint x) with I.Overflow -> "ovf")
let cvt_int32_unsigned x =
(string_of_bool (I.fits_int32_unsigned x))
^","^
(try Int32.to_string (I.to_int32_unsigned x) with I.Overflow -> "ovf")
let cvt_int64_unsigned x =
(string_of_bool (I.fits_int64_unsigned x))
^","^
(try Int64.to_string (I.to_int64_unsigned x) with I.Overflow -> "ovf")
let cvt_nativeint_unsigned x =
(string_of_bool (I.fits_nativeint_unsigned x))
^","^
(try Nativeint.to_string (I.to_nativeint_unsigned x) with I.Overflow -> "ovf")
let p2 = I.of_int 2
let p3 = I.of_int 3
let p30 = pow2 30
let p62 = pow2 62
let p300 = pow2 300
let p120 = pow2 120
let p121 = pow2 121
let maxi = I.of_int max_int
let mini = I.of_int min_int
let maxi32 = I.of_int32 Int32.max_int
let mini32 = I.of_int32 Int32.min_int
let maxi64 = I.of_int64 Int64.max_int
let mini64 = I.of_int64 Int64.min_int
let maxni = I.of_nativeint Nativeint.max_int
let minni = I.of_nativeint Nativeint.min_int
let chk_bits x =
Printf.printf "to_bits %a\n =" pr x;
String.iter (fun c -> Printf.printf " %02x" (Char.code c)) (I.to_bits x);
Printf.printf "\n";
assert(I.equal (I.abs x) (I.of_bits (I.to_bits x)));
assert((I.to_bits x) = (I.to_bits (I.neg x)));
Printf.printf "marshal round trip %a\n =" pr x;
let y = Marshal.(from_string (to_string x []) 0) in
Printf.printf " %a\n" prmarshal (y, x)
let chk_extract (x, o, l) =
let expected =
I.logand (I.shift_right x o) (I.pred (I.shift_left (I.of_int 1) l))
and actual =
I.extract x o l in
Printf.printf "extract %a %d %d = %a " pr x o l pr actual;
if I.equal actual expected
then Printf.printf "(passed)\n"
else Printf.printf "(FAILED, expected %a)\n" pr expected
let chk_signed_extract (x, o, l) =
let uns_res = I.extract x o l in
let expected =
if I.compare uns_res (I.shift_left (I.of_int 1) (l-1)) >= 0
then I.sub uns_res (I.shift_left (I.of_int 1) l)
else uns_res in
let actual =
I.signed_extract x o l in
Printf.printf "signed_extract %a %d %d = %a " pr x o l pr actual;
if I.equal actual expected
then Printf.printf "(passed)\n"
else Printf.printf "(FAILED, expected %a)\n" pr expected
let chk_numbits_tz x =
Printf.printf "numbits / trailing_zeros %a " pr x;
let n = I.numbits x and z = I.trailing_zeros x in
if
if I.equal x I.zero then
n = 0 && z = max_int
else
n > 0 && z >= 0 && z < n
&& I.leq (I.shift_left I.one (n-1)) (I.abs x)
&& I.lt (I.abs x) (I.shift_left I.one n)
&& (z = 0 || I.equal (I.extract x 0 z) I.zero)
&& I.testbit x z
then Printf.printf "(passed)\n"
else Printf.printf "(FAILED)\n"
let chk_testbit x =
Printf.printf "testbit %a " pr x;
let n = I.numbits x in
let ok = ref true in
for i = 0 to n + 64 do
let actual = I.testbit x i
and expected = I.extract x i 1 in
if not (I.equal expected (if actual then I.one else I.zero))
then begin Printf.printf "(error on %d) " i; ok := false end
done;
if !ok
then Printf.printf "(passed)\n"
else Printf.printf "(FAILED)\n"
let pr_byte =
let state = ref 0 in
fun () ->
state := (!state * 65793 + 4282663) land 0xFF_FF_FF;
!state lsr 16
let pr_bytes buf pos len =
for i = pos to pos + len - 1 do
Bytes.set_uint8 buf i (pr_byte ())
done
let test_Z() =
Printf.printf "0\n = %a\n" pr I.zero;
Printf.printf "1\n = %a\n" pr I.one;
Printf.printf "-1\n = %a\n" pr I.minus_one;
Printf.printf "42\n = %a\n" pr (I.of_int 42);
Printf.printf "1+1\n = %a\n" pr (I.add I.one I.one);
Printf.printf "1-1\n = %a\n" pr (I.sub I.one I.one);
Printf.printf "- 1\n = %a\n" pr (I.neg I.one);
Printf.printf "0-1\n = %a\n" pr (I.sub I.zero I.one);
Printf.printf "max_int\n = %a\n" pr maxi;
Printf.printf "min_int\n = %a\n" pr mini;
Printf.printf "-max_int\n = %a\n" pr (I.neg maxi);
Printf.printf "-min_int\n = %a\n" pr (I.neg mini);
Printf.printf "2^300\n = %a\n" pr p300;
Printf.printf "2^120\n = %a\n" pr p120;
Printf.printf "2^300+2^120\n = %a\n" pr (I.add p300 p120);
Printf.printf "2^300-2^120\n = %a\n" pr (I.sub p300 p120);
Printf.printf "2^300+(-(2^120))\n = %a\n" pr (I.add p300 (I.neg p120));
Printf.printf "2^120-2^300\n = %a\n" pr (I.sub p120 p300);
Printf.printf "2^120+(-(2^300))\n = %a\n" pr (I.add p120 (I.neg p300));
Printf.printf "-(2^120)+(-(2^300))\n = %a\n" pr (I.add (I.neg p120) (I.neg p300));
Printf.printf "-(2^120)-2^300\n = %a\n" pr (I.sub (I.neg p120) p300);
Printf.printf "2^300-2^300\n = %a\n" pr (I.sub p300 p300);
Printf.printf "2^121\n = %a\n" pr p121;
Printf.printf "2^121+2^120\n = %a\n" pr (I.add p121 p120);
Printf.printf "2^121-2^120\n = %a\n" pr (I.sub p121 p120);
Printf.printf "2^121+(-(2^120))\n = %a\n" pr (I.add p121 (I.neg p120));
Printf.printf "2^120-2^121\n = %a\n" pr (I.sub p120 p121);
Printf.printf "2^120+(-(2^121))\n = %a\n" pr (I.add p120 (I.neg p121));
Printf.printf "-(2^120)+(-(2^121))\n = %a\n" pr (I.add (I.neg p120) (I.neg p121));
Printf.printf "-(2^120)-2^121\n = %a\n" pr (I.sub (I.neg p120) p121);
Printf.printf "2^121+0\n = %a\n" pr (I.add p121 I.zero);
Printf.printf "2^121-0\n = %a\n" pr (I.sub p121 I.zero);
Printf.printf "0+2^121\n = %a\n" pr (I.add I.zero p121);
Printf.printf "0-2^121\n = %a\n" pr (I.sub I.zero p121);
Printf.printf "2^300+1\n = %a\n" pr (I.add p300 I.one);
Printf.printf "2^300-1\n = %a\n" pr (I.sub p300 I.one);
Printf.printf "1+2^300\n = %a\n" pr (I.add I.one p300);
Printf.printf "1-2^300\n = %a\n" pr (I.sub I.one p300);
Printf.printf "2^300+(-1)\n = %a\n" pr (I.add p300 I.minus_one);
Printf.printf "2^300-(-1)\n = %a\n" pr (I.sub p300 I.minus_one);
Printf.printf "(-1)+2^300\n = %a\n" pr (I.add I.minus_one p300);
Printf.printf "(-1)-2^300\n = %a\n" pr (I.sub I.minus_one p300);
Printf.printf "-(2^300)+1\n = %a\n" pr (I.add (I.neg p300) I.one);
Printf.printf "-(2^300)-1\n = %a\n" pr (I.sub (I.neg p300) I.one);
Printf.printf "1+(-(2^300))\n = %a\n" pr (I.add I.one (I.neg p300));
Printf.printf "1-(-(2^300))\n = %a\n" pr (I.sub I.one (I.neg p300));
Printf.printf "-(2^300)+(-1)\n = %a\n" pr (I.add (I.neg p300) I.minus_one);
Printf.printf "-(2^300)-(-1)\n = %a\n" pr (I.sub (I.neg p300) I.minus_one);
Printf.printf "(-1)+(-(2^300))\n = %a\n" pr (I.add I.minus_one (I.neg p300));
Printf.printf "(-1)-(-(2^300))\n = %a\n" pr (I.sub I.minus_one (I.neg p300));
Printf.printf "max_int+1\n = %a\n" pr (I.add maxi I.one);
Printf.printf "min_int-1\n = %a\n" pr (I.sub mini I.one);
Printf.printf "-max_int-1\n = %a\n" pr (I.sub (I.neg maxi) I.one);
Printf.printf "-min_int-1\n = %a\n" pr (I.sub (I.neg mini) I.one);
Printf.printf "5! = %a\n" pr (fact 5);
Printf.printf "12! = %a\n" pr (fact 12);
Printf.printf "15! = %a\n" pr (fact 15);
Printf.printf "20! = %a\n" pr (fact 20);
Printf.printf "25! = %a\n" pr (fact 25);
Printf.printf "50! = %a\n" pr (fact 50);
Printf.printf "2^300*2^120\n = %a\n" pr (I.mul p300 p120);
Printf.printf "2^120*2^300\n = %a\n" pr (I.mul p120 p300);
Printf.printf "2^300*(-(2^120))\n = %a\n" pr (I.mul p300 (I.neg p120));
Printf.printf "2^120*(-(2^300))\n = %a\n" pr (I.mul p120 (I.neg p300));
Printf.printf "-(2^120)*(-(2^300))\n = %a\n" pr (I.mul (I.neg p120) (I.neg p300));
Printf.printf "2^121*2^120\n = %a\n" pr (I.mul p121 p120);
Printf.printf "2^120*2^121\n = %a\n" pr (I.mul p120 p121);
Printf.printf "2^121*0\n = %a\n" pr (I.mul p121 I.zero);
Printf.printf "0*2^121\n = %a\n" pr (I.mul I.zero p121);
Printf.printf "2^300*1\n = %a\n" pr (I.mul p300 I.one);
Printf.printf "1*2^300\n = %a\n" pr (I.mul I.one p300);
Printf.printf "2^300*(-1)\n = %a\n" pr (I.mul p300 I.minus_one);
Printf.printf "(-1)*2^300\n = %a\n" pr (I.mul I.minus_one p300);
Printf.printf "-(2^300)*1\n = %a\n" pr (I.mul (I.neg p300) I.one);
Printf.printf "1*(-(2^300))\n = %a\n" pr (I.mul I.one (I.neg p300));
Printf.printf "-(2^300)*(-1)\n = %a\n" pr (I.mul (I.neg p300) I.minus_one);
Printf.printf "(-1)*(-(2^300))\n = %a\n" pr (I.mul I.minus_one (I.neg p300));
Printf.printf "1*(2^30)\n = %a\n" pr (I.mul I.one p30);
Printf.printf "1*(2^62)\n = %a\n" pr (I.mul I.one p62);
Printf.printf "(2^30)*(2^30)\n = %a\n" pr (I.mul p30 p30);
Printf.printf "(2^62)*(2^62)\n = %a\n" pr (I.mul p62 p62);
Printf.printf "0+1\n = %a\n" pr (I.succ I.zero);
Printf.printf "1+1\n = %a\n" pr (I.succ I.one);
Printf.printf "-1+1\n = %a\n" pr (I.succ I.minus_one);
Printf.printf "2+1\n = %a\n" pr (I.succ p2);
Printf.printf "-2+1\n = %a\n" pr (I.succ (I.neg p2));
Printf.printf "(2^300)+1\n = %a\n" pr (I.succ p300);
Printf.printf "-(2^300)+1\n = %a\n" pr (I.succ (I.neg p300));
Printf.printf "0-1\n = %a\n" pr (I.pred I.zero);
Printf.printf "1-1\n = %a\n" pr (I.pred I.one);
Printf.printf "-1-1\n = %a\n" pr (I.pred I.minus_one);
Printf.printf "2-1\n = %a\n" pr (I.pred p2);
Printf.printf "-2-1\n = %a\n" pr (I.pred (I.neg p2));
Printf.printf "(2^300)-1\n = %a\n" pr (I.pred p300);
Printf.printf "-(2^300)-1\n = %a\n" pr (I.pred (I.neg p300));
Printf.printf "max_int+1\n = %a\n" pr (I.succ maxi);
Printf.printf "min_int-1\n = %a\n" pr (I.pred mini);
Printf.printf "-max_int-1\n = %a\n" pr (I.pred (I.neg maxi));
Printf.printf "-min_int-1\n = %a\n" pr (I.pred (I.neg mini));
Printf.printf "abs(0)\n = %a\n" pr (I.abs I.zero);
Printf.printf "abs(1)\n = %a\n" pr (I.abs I.one);
Printf.printf "abs(-1)\n = %a\n" pr (I.abs I.minus_one);
Printf.printf "abs(min_int)\n = %a\n" pr (I.abs mini);
Printf.printf "abs(2^300)\n = %a\n" pr (I.abs p300);
Printf.printf "abs(-(2^300))\n = %a\n" pr (I.abs (I.neg p300));
Printf.printf "max_nativeint\n = %a\n" pr maxni;
Printf.printf "max_int32\n = %a\n" pr maxi32;
Printf.printf "max_int64\n = %a\n" pr maxi64;
Printf.printf "to_int 1\n = %s\n" (cvt_int I.one);
Printf.printf "to_int max_int\n = %s\n" (cvt_int maxi);
Printf.printf "to_int max_nativeint\n = %s\n" (cvt_int maxni);
Printf.printf "to_int max_int32\n = %s\n" (cvt_int maxi32);
Printf.printf "to_int max_int64\n = %s\n" (cvt_int maxi64);
Printf.printf "to_int32 1\n = %s\n" (cvt_int32 I.one);
Printf.printf "to_int32 max_int\n = %s\n" (cvt_int32 maxi);
Printf.printf "to_int32 max_nativeint\n = %s\n" (cvt_int32 maxni);
Printf.printf "to_int32 max_int32\n = %s\n" (cvt_int32 maxi32);
Printf.printf "to_int32 max_int64\n = %s\n" (cvt_int32 maxi64);
Printf.printf "to_int64 1\n = %s\n" (cvt_int64 I.one);
Printf.printf "to_int64 max_int\n = %s\n" (cvt_int64 maxi);
Printf.printf "to_int64 max_nativeint\n = %s\n" (cvt_int64 maxni);
Printf.printf "to_int64 max_int32\n = %s\n" (cvt_int64 maxi32);
Printf.printf "to_int64 max_int64\n = %s\n" (cvt_int64 maxi64);
Printf.printf "to_nativeint 1\n = %s\n" (cvt_nativeint I.one);
Printf.printf "to_nativeint max_int\n = %s\n" (cvt_nativeint maxi);
Printf.printf "to_nativeint max_nativeint\n = %s\n" (cvt_nativeint maxni);
Printf.printf "to_nativeint max_int32\n = %s\n" (cvt_nativeint maxi32);
Printf.printf "to_nativeint max_int64\n = %s\n" (cvt_nativeint maxi64);
Printf.printf "to_int -min_int\n = %s\n" (cvt_int (I.neg mini));
Printf.printf "to_int -min_nativeint\n = %s\n" (cvt_int (I.neg minni));
Printf.printf "to_int -min_int32\n = %s\n" (cvt_int (I.neg mini32));
Printf.printf "to_int -min_int64\n = %s\n" (cvt_int (I.neg mini64));
Printf.printf "to_int32 -min_int\n = %s\n" (cvt_int32 (I.neg mini));
Printf.printf "to_int32 -min_nativeint\n = %s\n" (cvt_int32 (I.neg minni));
Printf.printf "to_int32 -min_int32\n = %s\n" (cvt_int32 (I.neg mini32));
Printf.printf "to_int32 -min_int64\n = %s\n" (cvt_int32(I.neg mini64));
Printf.printf "to_int64 -min_int\n = %s\n" (cvt_int64 (I.neg mini));
Printf.printf "to_int64 -min_nativeint\n = %s\n" (cvt_int64 (I.neg minni));
Printf.printf "to_int64 -min_int32\n = %s\n" (cvt_int64 (I.neg mini32));
Printf.printf "to_int64 -min_int64\n = %s\n" (cvt_int64 (I.neg mini64));
Printf.printf "to_nativeint -min_int\n = %s\n" (cvt_nativeint (I.neg mini));
Printf.printf "to_nativeint -min_nativeint\n = %s\n" (cvt_nativeint (I.neg minni));
Printf.printf "to_nativeint -min_int32\n = %s\n" (cvt_nativeint (I.neg mini32));
Printf.printf "to_nativeint -min_int64\n = %s\n" (cvt_nativeint (I.neg mini64));
Printf.printf "to_int32_unsigned 1\n = %s\n" (cvt_int32_unsigned I.one);
Printf.printf "to_int32_unsigned -1\n = %s\n" (cvt_int32_unsigned I.minus_one);
Printf.printf "to_int32_unsigned max_int\n = %s\n" (cvt_int32_unsigned maxi);
Printf.printf "to_int32_unsigned max_nativeint\n = %s\n" (cvt_int32_unsigned maxni);
Printf.printf "to_int32_unsigned max_int32\n = %s\n" (cvt_int32_unsigned maxi32);
Printf.printf "to_int32_unsigned 2max_int32\n = %s\n" (cvt_int32_unsigned (I.mul p2 maxi32));
Printf.printf "to_int32_unsigned 3max_int32\n = %s\n" (cvt_int32_unsigned (I.mul p3 maxi32));
Printf.printf "to_int32_unsigned max_int64\n = %s\n" (cvt_int32_unsigned maxi64);
Printf.printf "to_int64_unsigned 1\n = %s\n" (cvt_int64_unsigned I.one);
Printf.printf "to_int64_unsigned -1\n = %s\n" (cvt_int64_unsigned I.minus_one);
Printf.printf "to_int64_unsigned max_int\n = %s\n" (cvt_int64_unsigned maxi);
Printf.printf "to_int64_unsigned max_nativeint\n = %s\n" (cvt_int64_unsigned maxni);
Printf.printf "to_int64_unsigned max_int32\n = %s\n" (cvt_int64_unsigned maxi32);
Printf.printf "to_int64_unsigned max_int64\n = %s\n" (cvt_int64_unsigned maxi64);
Printf.printf "to_int64_unsigned 2max_int64\n = %s\n" (cvt_int64_unsigned (I.mul p2 maxi64));
Printf.printf "to_int64_unsigned 3max_int64\n = %s\n" (cvt_int64_unsigned (I.mul p3 maxi64));
Printf.printf "to_nativeint_unsigned 1\n = %s\n" (cvt_nativeint_unsigned I.one);
Printf.printf "to_nativeint_unsigned -1\n = %s\n" (cvt_nativeint_unsigned I.minus_one);
Printf.printf "to_nativeint_unsigned max_int\n = %s\n" (cvt_nativeint_unsigned maxi);
Printf.printf "to_nativeint_unsigned max_nativeint\n = %s\n" (cvt_nativeint_unsigned maxni);
Printf.printf "to_nativeint_unsigned 2max_nativeint\n = %s\n" (cvt_nativeint_unsigned (I.mul p2 maxni));
Printf.printf "to_nativeint_unsigned max_int32\n = %s\n" (cvt_nativeint_unsigned maxi32);
Printf.printf "to_nativeint_unsigned max_int64\n = %s\n" (cvt_nativeint_unsigned maxi64);
Printf.printf "to_nativeint_unsigned 2max_int64\n = %s\n" (cvt_nativeint_unsigned (I.mul p2 maxi64));
Printf.printf "to_nativeint_unsigned 3max_int64\n = %s\n" (cvt_nativeint_unsigned (I.mul p3 maxi64));
Printf.printf "of_int32_unsigned -1\n = %a\n" pr (I.of_int32_unsigned (-1l));
Printf.printf "of_int64_unsigned -1\n = %a\n" pr (I.of_int64_unsigned (-1L));
Printf.printf "of_nativeint_unsigned -1\n = %a\n" pr (I.of_nativeint_unsigned (-1n));
Printf.printf "of_float 1.\n = %a\n" pr (I.of_float 1.);
Printf.printf "of_float -1.\n = %a\n" pr (I.of_float (-. 1.));
Printf.printf "of_float pi\n = %a\n" pr (I.of_float (2. *. acos 0.));
Printf.printf "of_float 2^30\n = %a\n" pr (I.of_float (ldexp 1. 30));
Printf.printf "of_float 2^31\n = %a\n" pr (I.of_float (ldexp 1. 31));
Printf.printf "of_float 2^32\n = %a\n" pr (I.of_float (ldexp 1. 32));
Printf.printf "of_float 2^33\n = %a\n" pr (I.of_float (ldexp 1. 33));
Printf.printf "of_float -2^30\n = %a\n" pr (I.of_float (-.(ldexp 1. 30)));
Printf.printf "of_float -2^31\n = %a\n" pr (I.of_float (-.(ldexp 1. 31)));
Printf.printf "of_float -2^32\n = %a\n" pr (I.of_float (-.(ldexp 1. 32)));
Printf.printf "of_float -2^33\n = %a\n" pr (I.of_float (-.(ldexp 1. 33)));
Printf.printf "of_float 2^61\n = %a\n" pr (I.of_float (ldexp 1. 61));
Printf.printf "of_float 2^62\n = %a\n" pr (I.of_float (ldexp 1. 62));
Printf.printf "of_float 2^63\n = %a\n" pr (I.of_float (ldexp 1. 63));
Printf.printf "of_float 2^64\n = %a\n" pr (I.of_float (ldexp 1. 64));
Printf.printf "of_float 2^65\n = %a\n" pr (I.of_float (ldexp 1. 65));
Printf.printf "of_float -2^61\n = %a\n" pr (I.of_float (-.(ldexp 1. 61)));
Printf.printf "of_float -2^62\n = %a\n" pr (I.of_float (-.(ldexp 1. 62)));
Printf.printf "of_float -2^63\n = %a\n" pr (I.of_float (-.(ldexp 1. 63)));
Printf.printf "of_float -2^64\n = %a\n" pr (I.of_float (-.(ldexp 1. 64)));
Printf.printf "of_float -2^65\n = %a\n" pr (I.of_float (-.(ldexp 1. 65)));
Printf.printf "of_float 2^120\n = %a\n" pr (I.of_float (ldexp 1. 120));
Printf.printf "of_float 2^300\n = %a\n" pr (I.of_float (ldexp 1. 300));
Printf.printf "of_float -2^120\n = %a\n" pr (I.of_float (-.(ldexp 1. 120)));
Printf.printf "of_float -2^300\n = %a\n" pr (I.of_float (-.(ldexp 1. 300)));
Printf.printf "of_float 0.5\n = %a\n" pr (I.of_float 0.5);
Printf.printf "of_float -0.5\n = %a\n" pr (I.of_float (-. 0.5));
Printf.printf "of_float 200.5\n = %a\n" pr (I.of_float 200.5);
Printf.printf "of_float -200.5\n = %a\n" pr (I.of_float (-. 200.5));
Printf.printf "to_float 0\n = %a\n" prfloat (I.to_float I.zero, 0.0);
Printf.printf "to_float 1\n = %a\n" prfloat (I.to_float I.one, 1.0);
Printf.printf "to_float -1\n = %a\n" prfloat (I.to_float I.minus_one, -1.0);
Printf.printf "to_float 2^120\n = %a\n" prfloat (I.to_float p120, ldexp 1.0 120);
Printf.printf "to_float -2^120\n = %a\n" prfloat (I.to_float (I.neg p120), -. (ldexp 1.0 120));
Printf.printf "to_float (2^120-1)\n = %a\n" prfloat (I.to_float (I.pred p120), ldexp 1.0 120);
Printf.printf "to_float (-2^120+1)\n = %a\n" prfloat (I.to_float (I.succ (I.neg p120)), -. (ldexp 1.0 120));
Printf.printf "to_float 2^63\n = %a\n" prfloat (I.to_float (pow2 63), ldexp 1.0 63);
Printf.printf "to_float -2^63\n = %a\n" prfloat (I.to_float (I.neg (pow2 63)), -. (ldexp 1.0 63));
Printf.printf "to_float (2^63-1)\n = %a\n" prfloat (I.to_float (I.pred (pow2 63)), ldexp 1.0 63);
Printf.printf "to_float (-2^63-1)\n = %a\n" prfloat (I.to_float (I.pred (I.neg (pow2 63))), -. (ldexp 1.0 63));
Printf.printf "to_float (-2^63+1)\n = %a\n" prfloat (I.to_float (I.succ (I.neg (pow2 63))), -. (ldexp 1.0 63));
Printf.printf "to_float 2^300\n = %a\n" prfloat (I.to_float p300, ldexp 1.0 300);
Printf.printf "to_float -2^300\n = %a\n" prfloat (I.to_float (I.neg p300), -. (ldexp 1.0 300));
Printf.printf "to_float (2^300-1)\n = %a\n" prfloat (I.to_float (I.pred p300), ldexp 1.0 300);
Printf.printf "to_float (-2^300+1)\n = %a\n" prfloat (I.to_float (I.succ (I.neg p300)), -. (ldexp 1.0 300));
Printf.printf "of_string 12\n = %a\n" pr (I.of_string "12");
Printf.printf "of_string 0x12\n = %a\n" pr (I.of_string "0x12");
Printf.printf "of_string 0b10\n = %a\n" pr (I.of_string "0b10");
Printf.printf "of_string 0o12\n = %a\n" pr (I.of_string "0o12");
Printf.printf "of_string -12\n = %a\n" pr (I.of_string "-12");
Printf.printf "of_string -0x12\n = %a\n" pr (I.of_string "-0x12");
Printf.printf "of_string -0b10\n = %a\n" pr (I.of_string "-0b10");
Printf.printf "of_string -0o12\n = %a\n" pr (I.of_string "-0o12");
Printf.printf "of_string 000123456789012345678901234567890\n = %a\n" pr (I.of_string "000123456789012345678901234567890");
Printf.printf "2^120 / 2^300 (trunc)\n = %a\n" pr (I.div p120 p300);
Printf.printf "max_int / 2 (trunc)\n = %a\n" pr (I.div maxi p2);
Printf.printf "(2^300+1) / 2^120 (trunc)\n = %a\n" pr (I.div (I.succ p300) p120);
Printf.printf "(-(2^300+1)) / 2^120 (trunc)\n = %a\n" pr (I.div (I.neg (I.succ p300)) p120);
Printf.printf "(2^300+1) / (-(2^120)) (trunc)\n = %a\n" pr (I.div (I.succ p300) (I.neg p120));
Printf.printf "(-(2^300+1)) / (-(2^120)) (trunc)\n = %a\n" pr (I.div (I.neg (I.succ p300)) (I.neg p120));
Printf.printf "2^120 / 2^300 (ceil)\n = %a\n" pr (I.cdiv p120 p300);
Printf.printf "max_int / 2 (ceil)\n = %a\n" pr (I.cdiv maxi p2);
Printf.printf "(2^300+1) / 2^120 (ceil)\n = %a\n" pr (I.cdiv (I.succ p300) p120);
Printf.printf "(-(2^300+1)) / 2^120 (ceil)\n = %a\n" pr (I.cdiv (I.neg (I.succ p300)) p120);
Printf.printf "(2^300+1) / (-(2^120)) (ceil)\n = %a\n" pr (I.cdiv (I.succ p300) (I.neg p120));
Printf.printf "(-(2^300+1)) / (-(2^120)) (ceil)\n = %a\n" pr (I.cdiv (I.neg (I.succ p300)) (I.neg p120));
Printf.printf "2^120 / 2^300 (floor)\n = %a\n" pr (I.fdiv p120 p300);
Printf.printf "max_int / 2 (floor)\n = %a\n" pr (I.fdiv maxi p2);
Printf.printf "(2^300+1) / 2^120 (floor)\n = %a\n" pr (I.fdiv (I.succ p300) p120);
Printf.printf "(-(2^300+1)) / 2^120 (floor)\n = %a\n" pr (I.fdiv (I.neg (I.succ p300)) p120);
Printf.printf "(2^300+1) / (-(2^120)) (floor)\n = %a\n" pr (I.fdiv (I.succ p300) (I.neg p120));
Printf.printf "(-(2^300+1)) / (-(2^120)) (floor)\n = %a\n" pr (I.fdiv (I.neg (I.succ p300)) (I.neg p120));
Printf.printf "2^120 %% 2^300\n = %a\n" pr (I.rem p120 p300);
Printf.printf "max_int %% 2\n = %a\n" pr (I.rem maxi p2);
Printf.printf "(2^300+1) %% 2^120\n = %a\n" pr (I.rem (I.succ p300) p120);
Printf.printf "(-(2^300+1)) %% 2^120\n = %a\n" pr (I.rem (I.neg (I.succ p300)) p120);
Printf.printf "(2^300+1) %% (-(2^120))\n = %a\n" pr (I.rem (I.succ p300) (I.neg p120));
Printf.printf "(-(2^300+1)) %% (-(2^120))\n = %a\n" pr (I.rem (I.neg (I.succ p300)) (I.neg p120));
Printf.printf "2^120 /,%% 2^300\n = %a\n" pr2 (I.div_rem p120 p300);
Printf.printf "max_int /,%% 2\n = %a\n" pr2 (I.div_rem maxi p2);
Printf.printf "(2^300+1) /,%% 2^120\n = %a\n" pr2 (I.div_rem (I.succ p300) p120);
Printf.printf "(-(2^300+1)) /,%% 2^120\n = %a\n" pr2 (I.div_rem (I.neg (I.succ p300)) p120);
Printf.printf "(2^300+1) /,%% (-(2^120))\n = %a\n" pr2 (I.div_rem (I.succ p300) (I.neg p120));
Printf.printf "(-(2^300+1)) /,%% (-(2^120))\n = %a\n" pr2 (I.div_rem (I.neg (I.succ p300)) (I.neg p120));
Printf.printf "1 & 2\n = %a\n" pr (I.logand I.one p2);
Printf.printf "1 & 2^300\n = %a\n" pr (I.logand I.one p300);
Printf.printf "2^120 & 2^300\n = %a\n" pr (I.logand p120 p300);
Printf.printf "2^300 & 2^120\n = %a\n" pr (I.logand p300 p120);
Printf.printf "2^300 & 2^300\n = %a\n" pr (I.logand p300 p300);
Printf.printf "2^300 & 0\n = %a\n" pr (I.logand p300 I.zero);
Printf.printf "-2^120 & 2^300\n = %a\n" pr (I.logand (I.neg p120) p300);
Printf.printf " 2^120 & -2^300\n = %a\n" pr (I.logand p120 (I.neg p300));
Printf.printf "-2^120 & -2^300\n = %a\n" pr (I.logand (I.neg p120) (I.neg p300));
Printf.printf "-2^300 & 2^120\n = %a\n" pr (I.logand (I.neg p300) p120);
Printf.printf " 2^300 & -2^120\n = %a\n" pr (I.logand p300 (I.neg p120));
Printf.printf "-2^300 & -2^120\n = %a\n" pr (I.logand (I.neg p300) (I.neg p120));
Printf.printf "1 | 2\n = %a\n" pr (I.logor I.one p2);
Printf.printf "1 | 2^300\n = %a\n" pr (I.logor I.one p300);
Printf.printf "2^120 | 2^300\n = %a\n" pr (I.logor p120 p300);
Printf.printf "2^300 | 2^120\n = %a\n" pr (I.logor p300 p120);
Printf.printf "2^300 | 2^300\n = %a\n" pr (I.logor p300 p300);
Printf.printf "2^300 | 0\n = %a\n" pr (I.logor p300 I.zero);
Printf.printf "-2^120 | 2^300\n = %a\n" pr (I.logor (I.neg p120) p300);
Printf.printf " 2^120 | -2^300\n = %a\n" pr (I.logor p120 (I.neg p300));
Printf.printf "-2^120 | -2^300\n = %a\n" pr (I.logor (I.neg p120) (I.neg p300));
Printf.printf "-2^300 | 2^120\n = %a\n" pr (I.logor (I.neg p300) p120);
Printf.printf " 2^300 | -2^120\n = %a\n" pr (I.logor p300 (I.neg p120));
Printf.printf "-2^300 | -2^120\n = %a\n" pr (I.logor (I.neg p300) (I.neg p120));
Printf.printf "1 ^ 2\n = %a\n" pr (I.logxor I.one p2);
Printf.printf "1 ^ 2^300\n = %a\n" pr (I.logxor I.one p300);
Printf.printf "2^120 ^ 2^300\n = %a\n" pr (I.logxor p120 p300);
Printf.printf "2^300 ^ 2^120\n = %a\n" pr (I.logxor p300 p120);
Printf.printf "2^300 ^ 2^300\n = %a\n" pr (I.logxor p300 p300);
Printf.printf "2^300 ^ 0\n = %a\n" pr (I.logxor p300 I.zero);
Printf.printf "-2^120 ^ 2^300\n = %a\n" pr (I.logxor (I.neg p120) p300);
Printf.printf " 2^120 ^ -2^300\n = %a\n" pr (I.logxor p120 (I.neg p300));
Printf.printf "-2^120 ^ -2^300\n = %a\n" pr (I.logxor (I.neg p120) (I.neg p300));
Printf.printf "-2^300 ^ 2^120\n = %a\n" pr (I.logxor (I.neg p300) p120);
Printf.printf " 2^300 ^ -2^120\n = %a\n" pr (I.logxor p300 (I.neg p120));
Printf.printf "-2^300 ^ -2^120\n = %a\n" pr (I.logxor (I.neg p300) (I.neg p120));
Printf.printf "~0\n = %a\n" pr (I.lognot I.zero);
Printf.printf "~1\n = %a\n" pr (I.lognot I.one);
Printf.printf "~2\n = %a\n" pr (I.lognot p2);
Printf.printf "~2^300\n = %a\n" pr (I.lognot p300);
Printf.printf "~(-1)\n = %a\n" pr (I.lognot I.minus_one);
Printf.printf "~(-2)\n = %a\n" pr (I.lognot (I.neg p2));
Printf.printf "~(-(2^300))\n = %a\n" pr (I.lognot (I.neg p300));
Printf.printf "0 >> 1\n = %a\n" pr (I.shift_right I.zero 1);
Printf.printf "0 >> 100\n = %a\n" pr (I.shift_right I.zero 100);
Printf.printf "2 >> 1\n = %a\n" pr (I.shift_right p2 1);
Printf.printf "2 >> 2\n = %a\n" pr (I.shift_right p2 2);
Printf.printf "2 >> 100\n = %a\n" pr (I.shift_right p2 100);
Printf.printf "2^300 >> 1\n = %a\n" pr (I.shift_right p300 1);
Printf.printf "2^300 >> 2\n = %a\n" pr (I.shift_right p300 2);
Printf.printf "2^300 >> 100\n = %a\n" pr (I.shift_right p300 100);
Printf.printf "2^300 >> 200\n = %a\n" pr (I.shift_right p300 200);
Printf.printf "2^300 >> 300\n = %a\n" pr (I.shift_right p300 300);
Printf.printf "2^300 >> 400\n = %a\n" pr (I.shift_right p300 400);
Printf.printf "-1 >> 1\n = %a\n" pr (I.shift_right I.minus_one 1);
Printf.printf "-2 >> 1\n = %a\n" pr (I.shift_right (I.neg p2) 1);
Printf.printf "-2 >> 2\n = %a\n" pr (I.shift_right (I.neg p2) 2);
Printf.printf "-2 >> 100\n = %a\n" pr (I.shift_right (I.neg p2) 100);
Printf.printf "-2^300 >> 1\n = %a\n" pr (I.shift_right (I.neg p300) 1);
Printf.printf "-2^300 >> 2\n = %a\n" pr (I.shift_right (I.neg p300) 2);
Printf.printf "-2^300 >> 100\n = %a\n" pr (I.shift_right (I.neg p300) 100);
Printf.printf "-2^300 >> 200\n = %a\n" pr (I.shift_right (I.neg p300) 200);
Printf.printf "-2^300 >> 300\n = %a\n" pr (I.shift_right (I.neg p300) 300);
Printf.printf "-2^300 >> 400\n = %a\n" pr (I.shift_right (I.neg p300) 400);
Printf.printf "0 >>0 1\n = %a\n" pr (I.shift_right_trunc I.zero 1);
Printf.printf "0 >>0 100\n = %a\n" pr (I.shift_right_trunc I.zero 100);
Printf.printf "2 >>0 1\n = %a\n" pr (I.shift_right_trunc p2 1);
Printf.printf "2 >>0 2\n = %a\n" pr (I.shift_right_trunc p2 2);
Printf.printf "2 >>0 100\n = %a\n" pr (I.shift_right_trunc p2 100);
Printf.printf "2^300 >>0 1\n = %a\n" pr (I.shift_right_trunc p300 1);
Printf.printf "2^300 >>0 2\n = %a\n" pr (I.shift_right_trunc p300 2);
Printf.printf "2^300 >>0 100\n = %a\n" pr (I.shift_right_trunc p300 100);
Printf.printf "2^300 >>0 200\n = %a\n" pr (I.shift_right_trunc p300 200);
Printf.printf "2^300 >>0 300\n = %a\n" pr (I.shift_right_trunc p300 300);
Printf.printf "2^300 >>0 400\n = %a\n" pr (I.shift_right_trunc p300 400);
Printf.printf "-1 >>0 1\n = %a\n" pr (I.shift_right_trunc I.minus_one 1);
Printf.printf "-2 >>0 1\n = %a\n" pr (I.shift_right_trunc (I.neg p2) 1);
Printf.printf "-2 >>0 2\n = %a\n" pr (I.shift_right_trunc (I.neg p2) 2);
Printf.printf "-2 >>0 100\n = %a\n" pr (I.shift_right_trunc (I.neg p2) 100);
Printf.printf "-2^300 >>0 1\n = %a\n" pr (I.shift_right_trunc (I.neg p300) 1);
Printf.printf "-2^300 >>0 2\n = %a\n" pr (I.shift_right_trunc (I.neg p300) 2);
Printf.printf "-2^300 >>0 100\n = %a\n" pr (I.shift_right_trunc (I.neg p300) 100);
Printf.printf "-2^300 >>0 200\n = %a\n" pr (I.shift_right_trunc (I.neg p300) 200);
Printf.printf "-2^300 >>0 300\n = %a\n" pr (I.shift_right_trunc (I.neg p300) 300);
Printf.printf "-2^300 >>0 400\n = %a\n" pr (I.shift_right_trunc (I.neg p300) 400);
Printf.printf "0 << 1\n = %a\n" pr (I.shift_left I.zero 1);
Printf.printf "0 << 100\n = %a\n" pr (I.shift_left I.zero 100);
Printf.printf "2 << 1\n = %a\n" pr (I.shift_left p2 1);
Printf.printf "2 << 32\n = %a\n" pr (I.shift_left p2 32);
Printf.printf "2 << 64\n = %a\n" pr (I.shift_left p2 64);
Printf.printf "2 << 299\n = %a\n" pr (I.shift_left p2 299);
Printf.printf "2^120 << 1\n = %a\n" pr (I.shift_left p120 1);
Printf.printf "2^120 << 180\n = %a\n" pr (I.shift_left p120 180);
Printf.printf "compare 1 2\n = %i\n" (I.compare I.one p2);
Printf.printf "compare 1 1\n = %i\n" (I.compare I.one I.one);
Printf.printf "compare 2 1\n = %i\n" (I.compare p2 I.one);
Printf.printf "compare 2^300 2^120\n = %i\n" (I.compare p300 p120);
Printf.printf "compare 2^120 2^120\n = %i\n" (I.compare p120 p120);
Printf.printf "compare 2^120 2^300\n = %i\n" (I.compare p120 p300);
Printf.printf "compare 2^121 2^120\n = %i\n" (I.compare p121 p120);
Printf.printf "compare 2^120 2^121\n = %i\n" (I.compare p120 p121);
Printf.printf "compare 2^300 -2^120\n = %i\n" (I.compare p300 (I.neg p120));
Printf.printf "compare 2^120 -2^120\n = %i\n" (I.compare p120 (I.neg p120));
Printf.printf "compare 2^120 -2^300\n = %i\n" (I.compare p120 (I.neg p300));
Printf.printf "compare -2^300 2^120\n = %i\n" (I.compare (I.neg p300) p120);
Printf.printf "compare -2^120 2^120\n = %i\n" (I.compare (I.neg p120) p120);
Printf.printf "compare -2^120 2^300\n = %i\n" (I.compare (I.neg p120) p300);
Printf.printf "compare -2^300 -2^120\n = %i\n" (I.compare (I.neg p300) (I.neg p120));
Printf.printf "compare -2^120 -2^120\n = %i\n" (I.compare (I.neg p120) (I.neg p120));
Printf.printf "compare -2^120 -2^300\n = %i\n" (I.compare (I.neg p120) (I.neg p300));
Printf.printf "equal 1 2\n = %B\n" (I.equal I.one p2);
Printf.printf "equal 1 1\n = %B\n" (I.equal I.one I.one);
Printf.printf "equal 2 1\n = %B\n" (I.equal p2 I.one);
Printf.printf "equal 2^300 2^120\n = %B\n" (I.equal p300 p120);
Printf.printf "equal 2^120 2^120\n = %B\n" (I.equal p120 p120);
Printf.printf "equal 2^120 2^300\n = %B\n" (I.equal p120 p300);
Printf.printf "equal 2^121 2^120\n = %B\n" (I.equal p121 p120);
Printf.printf "equal 2^120 2^121\n = %B\n" (I.equal p120 p121);
Printf.printf "equal 2^120 -2^120\n = %B\n" (I.equal p120 (I.neg p120));
Printf.printf "equal -2^120 2^120\n = %B\n" (I.equal (I.neg p120) p120);
Printf.printf "equal -2^120 -2^120\n = %B\n" (I.equal (I.neg p120) (I.neg p120));
Printf.printf "sign 0\n = %i\n" (I.sign I.zero);
Printf.printf "sign 1\n = %i\n" (I.sign I.one);
Printf.printf "sign -1\n = %i\n" (I.sign I.minus_one);
Printf.printf "sign 2^300\n = %i\n" (I.sign p300);
Printf.printf "sign -2^300\n = %i\n" (I.sign (I.neg p300));
Printf.printf "gcd 0 0\n = %a\n" pr (I.gcd I.zero I.zero);
Printf.printf "gcd 0 -137\n = %a\n" pr (I.gcd (I.of_int 0) (I.of_int (-137)));
Printf.printf "gcd 12 27\n = %a\n" pr (I.gcd (I.of_int 12) (I.of_int 27));
Printf.printf "gcd 27 12\n = %a\n" pr (I.gcd (I.of_int 27) (I.of_int 12));
Printf.printf "gcd 27 27\n = %a\n" pr (I.gcd (I.of_int 27) (I.of_int 27));
Printf.printf "gcd -12 27\n = %a\n" pr (I.gcd (I.of_int (-12)) (I.of_int 27));
Printf.printf "gcd 12 -27\n = %a\n" pr (I.gcd (I.of_int 12) (I.of_int (-27)));
Printf.printf "gcd -12 -27\n = %a\n" pr (I.gcd (I.of_int (-12)) (I.of_int (-27)));
Printf.printf "gcd 0 2^300\n = %a\n" pr (I.gcd (I.of_int 0) p300);
Printf.printf "gcd 2^120 2^300\n = %a\n" pr (I.gcd p120 p300);
Printf.printf "gcd 2^300 2^120\n = %a\n" pr (I.gcd p300 p120);
Printf.printf "gcd 0 -2^300\n = %a\n" pr (I.gcd (I.of_int 0) (I.neg p300));
Printf.printf "gcd 2^120 -2^300\n = %a\n" pr (I.gcd p120 (I.neg p300));
Printf.printf "gcd 2^300 -2^120\n = %a\n" pr (I.gcd p300 (I.neg p120));
Printf.printf "gcd -2^120 2^300\n = %a\n" pr (I.gcd (I.neg p120) p300);
Printf.printf "gcd -2^300 2^120\n = %a\n" pr (I.gcd (I.neg p300) p120);
Printf.printf "gcd -2^120 -2^300\n = %a\n" pr (I.gcd (I.neg p120) (I.neg p300));
Printf.printf "gcd -2^300 -2^120\n = %a\n" pr (I.gcd (I.neg p300) (I.neg p120));
Printf.printf "gcdext 12 27\n = %a\n" pr3 (I.gcdext (I.of_int 12) (I.of_int 27));
Printf.printf "gcdext 27 12\n = %a\n" pr3 (I.gcdext (I.of_int 27) (I.of_int 12));
Printf.printf "gcdext 27 27\n = %a\n" pr3 (I.gcdext (I.of_int 27) (I.of_int 27));
Printf.printf "gcdext -12 27\n = %a\n" pr3 (I.gcdext (I.of_int (-12)) (I.of_int 27));
Printf.printf "gcdext 12 -27\n = %a\n" pr3 (I.gcdext (I.of_int 12) (I.of_int (-27)));
Printf.printf "gcdext -12 -27\n = %a\n" pr3 (I.gcdext (I.of_int (-12)) (I.of_int (-27)));
Printf.printf "gcdext 2^120 2^300\n = %a\n" pr3 (I.gcdext p120 p300);
Printf.printf "gcdext 2^300 2^120\n = %a\n" pr3 (I.gcdext p300 p120);
Printf.printf "gcdext 12 0\n = %a\n" pr3 (I.gcdext (I.of_int 12) I.zero);
Printf.printf "gcdext 0 27\n = %a\n" pr3 (I.gcdext I.zero (I.of_int 27));
Printf.printf "gcdext -12 0\n = %a\n" pr3 (I.gcdext (I.of_int (-12)) I.zero);
Printf.printf "gcdext 0 -27\n = %a\n" pr3 (I.gcdext I.zero (I.of_int (-27)));
Printf.printf "gcdext 2^120 0\n = %a\n" pr3 (I.gcdext p120 I.zero);
Printf.printf "gcdext 0 2^300\n = %a\n" pr3 (I.gcdext I.zero p300);
Printf.printf "gcdext -2^120 0\n = %a\n" pr3 (I.gcdext (I.neg p120) I.zero);
Printf.printf "gcdext 0 -2^300\n = %a\n" pr3 (I.gcdext I.zero (I.neg p300));
Printf.printf "gcdext 0 0\n = %a\n" pr3 (I.gcdext I.zero I.zero);
Printf.printf "lcm 0 0 = %a\n" pr (I.lcm I.zero I.zero);
Printf.printf "lcm 10 12 = %a\n" pr (I.lcm (I.of_int 10) (I.of_int 12));
Printf.printf "lcm -10 12 = %a\n" pr (I.lcm (I.of_int (-10)) (I.of_int 12));
Printf.printf "lcm 10 -12 = %a\n" pr (I.lcm (I.of_int 10) (I.of_int (-12)));
Printf.printf "lcm -10 -12 = %a\n" pr (I.lcm (I.of_int (-10)) (I.of_int (-12)));
Printf.printf "lcm 0 12 = %a\n" pr (I.lcm I.zero (I.of_int 12));
Printf.printf "lcm 0 -12 = %a\n" pr (I.lcm I.zero (I.of_int (-12)));
Printf.printf "lcm 10 0 = %a\n" pr (I.lcm (I.of_int 10) I.zero);
Printf.printf "lcm -10 0 = %a\n" pr (I.lcm (I.of_int (-10)) I.zero);
Printf.printf "lcm 2^120 2^300 = %a\n" pr (I.lcm p120 p300);
Printf.printf "lcm 2^120 -2^300 = %a\n" pr (I.lcm p120 (I.neg p300));
Printf.printf "lcm -2^120 2^300 = %a\n" pr (I.lcm (I.neg p120) p300);
Printf.printf "lcm -2^120 -2^300 = %a\n" pr (I.lcm (I.neg p120) (I.neg p300));
Printf.printf "lcm 2^120 0 = %a\n" pr (I.lcm p120 I.zero);
Printf.printf "lcm -2^120 0 = %a\n" pr (I.lcm (I.neg p120) I.zero);
Printf.printf "is_odd 0\n = %b\n" (I.is_odd (Z.of_int 0));
Printf.printf "is_odd 1\n = %b\n" (I.is_odd (Z.of_int 1));
Printf.printf "is_odd 2\n = %b\n" (I.is_odd (Z.of_int 2));
Printf.printf "is_odd 3\n = %b\n" (I.is_odd (Z.of_int 3));
Printf.printf "is_odd 2^120\n = %b\n" (I.is_odd p120);
Printf.printf "is_odd 2^120+1\n = %b\n" (I.is_odd (Z.succ p120));
Printf.printf "is_odd 2^300\n = %b\n" (I.is_odd p300);
Printf.printf "is_odd 2^300+1\n = %b\n" (I.is_odd (Z.succ p300));
Printf.printf "sqrt 0\n = %a\n" pr (I.sqrt I.zero);
Printf.printf "sqrt 1\n = %a\n" pr (I.sqrt I.one);
Printf.printf "sqrt 2\n = %a\n" pr (I.sqrt p2);
Printf.printf "sqrt 2^120\n = %a\n" pr (I.sqrt p120);
Printf.printf "sqrt 2^121\n = %a\n" pr (I.sqrt p121);
Printf.printf "sqrt_rem 0\n = %a\n" pr2 (I.sqrt_rem I.zero);
Printf.printf "sqrt_rem 1\n = %a\n" pr2 (I.sqrt_rem I.one);
Printf.printf "sqrt_rem 2\n = %a\n" pr2 (I.sqrt_rem p2);
Printf.printf "sqrt_rem 2^120\n = %a\n" pr2 (I.sqrt_rem p120);
Printf.printf "sqrt_rem 2^121\n = %a\n" pr2 (I.sqrt_rem p121);
Printf.printf "popcount 0\n = %i\n" (I.popcount I.zero);
Printf.printf "popcount 1\n = %i\n" (I.popcount I.one);
Printf.printf "popcount 2\n = %i\n" (I.popcount p2);
Printf.printf "popcount max_int32\n = %i\n" (I.popcount maxi32);
Printf.printf "popcount 2^120\n = %i\n" (I.popcount p120);
Printf.printf "popcount (2^120-1)\n = %i\n" (I.popcount (I.pred p120));
Printf.printf "hamdist 0 0\n = %i\n" (I.hamdist I.zero I.zero);
Printf.printf "hamdist 0 1\n = %i\n" (I.hamdist I.zero I.one);
Printf.printf "hamdist 0 2^300\n = %i\n" (I.hamdist I.zero p300);
Printf.printf "hamdist 2^120 2^120\n = %i\n" (I.hamdist p120 p120);
Printf.printf "hamdist 2^120 (2^120-1)\n = %i\n" (I.hamdist p120 (I.pred p120));
Printf.printf "hamdist 2^120 2^300\n = %i\n" (I.hamdist p120 p300);
Printf.printf "hamdist (2^120-1) (2^300-1)\n = %i\n" (I.hamdist (I.pred p120) (I.pred p300));
Printf.printf "divisible 42 7\n = %B\n" (I.divisible (I.of_int 42) (I.of_int 7));
Printf.printf "divisible 43 7\n = %B\n" (I.divisible (I.of_int 43) (I.of_int 7));
Printf.printf "divisible 0 0\n = %B\n" (I.divisible I.zero I.zero);
Printf.printf "divisible 0 2^120\n = %B\n" (I.divisible I.zero p120);
Printf.printf "divisible 2 2^120\n = %B\n" (I.divisible (I.of_int 2) p120);
Printf.printf "divisible 2^300 2^120\n = %B\n" (I.divisible p300 p120);
Printf.printf "divisible (2^300-1) 32\n = %B\n" (I.divisible (I.pred p300) (I.of_int 32));
Printf.printf "divisible min_int (max_int+1)\n = %B\n" (I.divisible (I.of_int min_int) (I.succ (I.of_int max_int)));
Printf.printf "divisible (max_int+1) min_int\n = %B\n" (I.divisible (I.succ (I.of_int max_int)) (I.of_int min_int));
(* always 0 when not using custom blocks *)
Printf.printf "hash(2^120)\n = %i\n" (Hashtbl.hash p120);
Printf.printf "hash(2^121)\n = %i\n" (Hashtbl.hash p121);
Printf.printf "hash(2^300)\n = %i\n" (Hashtbl.hash p300);
(* fails if not using custom blocks *)
Printf.printf "2^120 = 2^300\n = %B\n" (p120 = p300);
Printf.printf "2^120 = 2^120\n = %B\n" (p120 = p120);
Printf.printf "2^120 = 2^120\n = %B\n" (p120 = (pow2 120));
Printf.printf "2^120 > 2^300\n = %B\n" (p120 > p300);
Printf.printf "2^120 < 2^300\n = %B\n" (p120 < p300);
Printf.printf "2^120 = 1\n = %B\n" (p120 = I.one);
(* In OCaml < 3.12.1, the order is not consistent with integers when
comparing mpn_ and ints with OCaml's polymorphic compare operator.
In OCaml >= 3.12.1, the results are consistent.
*)
Printf.printf "2^120 > 1\n = %B\n" (p120 > I.one);
Printf.printf "2^120 < 1\n = %B\n" (p120 < I.one);
Printf.printf "-2^120 > 1\n = %B\n" ((I.neg p120) > I.one);
Printf.printf "-2^120 < 1\n = %B\n" ((I.neg p120) < I.one);
Printf.printf "demarshal 2^120, 2^300, 1\n = %a\n" pr3
(Marshal.from_string (Marshal.to_string (p120,p300,I.one) []) 0);
Printf.printf "demarshal -2^120, -2^300, -1\n = %a\n" pr3
(Marshal.from_string (Marshal.to_string (I.neg p120,I.neg p300,I.minus_one) []) 0);
Printf.printf "format %%i 0 = /%s/\n" (I.format "%i" I.zero);
Printf.printf "format %%i 1 = /%s/\n" (I.format "%i" I.one);
Printf.printf "format %%i -1 = /%s/\n" (I.format "%i" I.minus_one);
Printf.printf "format %%i 2^30 = /%s/\n" (I.format "%i" p30);
Printf.printf "format %%i -2^30 = /%s/\n" (I.format "%i" (I.neg p30));
Printf.printf "format %% i 1 = /%s/\n" (I.format "% i" I.one);
Printf.printf "format %%+i 1 = /%s/\n" (I.format "%+i" I.one);
Printf.printf "format %%x 0 = /%s/\n" (I.format "%x" I.zero);
Printf.printf "format %%x 1 = /%s/\n" (I.format "%x" I.one);
Printf.printf "format %%x -1 = /%s/\n" (I.format "%x" I.minus_one);
Printf.printf "format %%x 2^30 = /%s/\n" (I.format "%x" p30);
Printf.printf "format %%x -2^30 = /%s/\n" (I.format "%x" (I.neg p30));
Printf.printf "format %%X 0 = /%s/\n" (I.format "%X" I.zero);
Printf.printf "format %%X 1 = /%s/\n" (I.format "%X" I.one);
Printf.printf "format %%X -1 = /%s/\n" (I.format "%X" I.minus_one);
Printf.printf "format %%X 2^30 = /%s/\n" (I.format "%X" p30);
Printf.printf "format %%X -2^30 = /%s/\n" (I.format "%X" (I.neg p30));
Printf.printf "format %%o 0 = /%s/\n" (I.format "%o" I.zero);
Printf.printf "format %%o 1 = /%s/\n" (I.format "%o" I.one);
Printf.printf "format %%o -1 = /%s/\n" (I.format "%o" I.minus_one);
Printf.printf "format %%o 2^30 = /%s/\n" (I.format "%o" p30);
Printf.printf "format %%o -2^30 = /%s/\n" (I.format "%o" (I.neg p30));
Printf.printf "format %%10i 0 = /%s/\n" (I.format "%10i" I.zero);
Printf.printf "format %%10i 1 = /%s/\n" (I.format "%10i" I.one);
Printf.printf "format %%10i -1 = /%s/\n" (I.format "%10i" I.minus_one);
Printf.printf "format %%10i 2^30 = /%s/\n" (I.format "%10i" p30);
Printf.printf "format %%10i -2^30 = /%s/\n" (I.format "%10i" (I.neg p30));
Printf.printf "format %%-10i 0 = /%s/\n" (I.format "%-10i" I.zero);
Printf.printf "format %%-10i 1 = /%s/\n" (I.format "%-10i" I.one);
Printf.printf "format %%-10i -1 = /%s/\n" (I.format "%-10i" I.minus_one);
Printf.printf "format %%-10i 2^30 = /%s/\n" (I.format "%-10i" p30);
Printf.printf "format %%-10i -2^30 = /%s/\n" (I.format "%-10i" (I.neg p30));
Printf.printf "format %%+10i 0 = /%s/\n" (I.format "%+10i" I.zero);
Printf.printf "format %%+10i 1 = /%s/\n" (I.format "%+10i" I.one);
Printf.printf "format %%+10i -1 = /%s/\n" (I.format "%+10i" I.minus_one);
Printf.printf "format %%+10i 2^30 = /%s/\n" (I.format "%+10i" p30);
Printf.printf "format %%+10i -2^30 = /%s/\n" (I.format "%+10i" (I.neg p30));
Printf.printf "format %% 10i 0 = /%s/\n" (I.format "% 10i" I.zero);
Printf.printf "format %% 10i 1 = /%s/\n" (I.format "% 10i" I.one);
Printf.printf "format %% 10i -1 = /%s/\n" (I.format "% 10i" I.minus_one);
Printf.printf "format %% 10i 2^30 = /%s/\n" (I.format "% 10i" p30);
Printf.printf "format %% 10i -2^30 = /%s/\n" (I.format "% 10i" (I.neg p30));
Printf.printf "format %%010i 0 = /%s/\n" (I.format "%010i" I.zero);
Printf.printf "format %%010i 1 = /%s/\n" (I.format "%010i" I.one);
Printf.printf "format %%010i -1 = /%s/\n" (I.format "%010i" I.minus_one);
Printf.printf "format %%010i 2^30 = /%s/\n" (I.format "%010i" p30);
Printf.printf "format %%010i -2^30 = /%s/\n" (I.format "%010i" (I.neg p30));
Printf.printf "format %%#x 0 = /%s/\n" (I.format "%#x" I.zero);
Printf.printf "format %%#x 1 = /%s/\n" (I.format "%#x" I.one);
Printf.printf "format %%#x -1 = /%s/\n" (I.format "%#x" I.minus_one);
Printf.printf "format %%#x 2^30 = /%s/\n" (I.format "%#x" p30);
Printf.printf "format %%#x -2^30 = /%s/\n" (I.format "%#x" (I.neg p30));
Printf.printf "format %%#X 0 = /%s/\n" (I.format "%#X" I.zero);
Printf.printf "format %%#X 1 = /%s/\n" (I.format "%#X" I.one);
Printf.printf "format %%#X -1 = /%s/\n" (I.format "%#X" I.minus_one);
Printf.printf "format %%#X 2^30 = /%s/\n" (I.format "%#X" p30);
Printf.printf "format %%#X -2^30 = /%s/\n" (I.format "%#X" (I.neg p30));
Printf.printf "format %%#o 0 = /%s/\n" (I.format "%#o" I.zero);
Printf.printf "format %%#o 1 = /%s/\n" (I.format "%#o" I.one);
Printf.printf "format %%#o -1 = /%s/\n" (I.format "%#o" I.minus_one);
Printf.printf "format %%#o 2^30 = /%s/\n" (I.format "%#o" p30);
Printf.printf "format %%#o -2^30 = /%s/\n" (I.format "%#o" (I.neg p30));
Printf.printf "format %%#10x 0 = /%s/\n" (I.format "%#10x" I.zero);
Printf.printf "format %%#10x 1 = /%s/\n" (I.format "%#10x" I.one);
Printf.printf "format %%#10x -1 = /%s/\n" (I.format "%#10x" I.minus_one);
Printf.printf "format %%#10x 2^30 = /%s/\n" (I.format "%#10x" p30);
Printf.printf "format %%#10x -2^30 = /%s/\n" (I.format "%#10x" (I.neg p30));
Printf.printf "format %%#10X 0 = /%s/\n" (I.format "%#10X" I.zero);
Printf.printf "format %%#10X 1 = /%s/\n" (I.format "%#10X" I.one);
Printf.printf "format %%#10X -1 = /%s/\n" (I.format "%#10X" I.minus_one);
Printf.printf "format %%#10X 2^30 = /%s/\n" (I.format "%#10X" p30);
Printf.printf "format %%#10X -2^30 = /%s/\n" (I.format "%#10X" (I.neg p30));
Printf.printf "format %%#10o 0 = /%s/\n" (I.format "%#10o" I.zero);
Printf.printf "format %%#10o 1 = /%s/\n" (I.format "%#10o" I.one);
Printf.printf "format %%#10o -1 = /%s/\n" (I.format "%#10o" I.minus_one);
Printf.printf "format %%#10o 2^30 = /%s/\n" (I.format "%#10o" p30);
Printf.printf "format %%#10o -2^30 = /%s/\n" (I.format "%#10o" (I.neg p30));
Printf.printf "format %%#-10x 0 = /%s/\n" (I.format "%#-10x" I.zero);
Printf.printf "format %%#-10x 1 = /%s/\n" (I.format "%#-10x" I.one);
Printf.printf "format %%#-10x -1 = /%s/\n" (I.format "%#-10x" I.minus_one);
Printf.printf "format %%#-10x 2^30 = /%s/\n" (I.format "%#-10x" p30);
Printf.printf "format %%#-10x -2^30 = /%s/\n" (I.format "%#-10x" (I.neg p30));
Printf.printf "format %%#-10X 0 = /%s/\n" (I.format "%#-10X" I.zero);
Printf.printf "format %%#-10X 1 = /%s/\n" (I.format "%#-10X" I.one);
Printf.printf "format %%#-10X -1 = /%s/\n" (I.format "%#-10X" I.minus_one);
Printf.printf "format %%#-10X 2^30 = /%s/\n" (I.format "%#-10X" p30);
Printf.printf "format %%#-10X -2^30 = /%s/\n" (I.format "%#-10X" (I.neg p30));
Printf.printf "format %%#-10o 0 = /%s/\n" (I.format "%#-10o" I.zero);
Printf.printf "format %%#-10o 1 = /%s/\n" (I.format "%#-10o" I.one);
Printf.printf "format %%#-10o -1 = /%s/\n" (I.format "%#-10o" I.minus_one);
Printf.printf "format %%#-10o 2^30 = /%s/\n" (I.format "%#-10o" p30);
Printf.printf "format %%#-10o -2^30 = /%s/\n" (I.format "%#-10o" (I.neg p30));
let extract_testdata =
let a = I.of_int 42
and b = I.of_int (-42)
and c = I.of_string "3141592653589793238462643383279502884197169399375105820974944592307816406286208998628034825342117067982148086513282306647093844609550582231725359408128481117450284102701" in
[a,0,1; a,0,5; a,0,32; a,0,64;
a,1,1; a,1,5; a,1,32; a,1,63; a,1,64; a,1,127; a,1,128;
a,69,12;
b,0,1; b,0,5; b,0,32; b,0,64;
b,1,1; b,1,5; b,1,32; b,1,63; b,1,64; b,1,127; b,1,128;
b,69,12;
c,0,1; c,0,64; c,128,1; c,128,5; c,131,32; c,175,63; c,277,123] in
List.iter chk_extract extract_testdata;
List.iter chk_signed_extract extract_testdata;
chk_bits I.zero;
chk_bits p2;
chk_bits (I.neg p2);
chk_bits p30;
chk_bits (I.neg p30);
chk_bits p62;
chk_bits (I.neg p62);
chk_bits p300;
chk_bits p120;
chk_bits p121;
chk_bits maxi;
chk_bits mini;
chk_bits maxi32;
chk_bits mini32;
chk_bits maxi64;
chk_bits mini64;
chk_bits maxni;
chk_bits minni;
List.iter chk_testbit [
I.zero; I.one; I.of_int (-42);
I.of_string "31415926535897932384626433832795028841971693993751058209749445923078164062862089986";
I.neg (I.shift_left (I.of_int 123456) 64);
];
List.iter chk_numbits_tz [
I.zero; I.one; I.of_int (-42);
I.shift_left (I.of_int 9999) 77;
I.neg (I.shift_left (I.of_int 123456) 64);
];
Printf.printf "random_bits 45 = %a\n"
pr (I.random_bits_gen ~fill:pr_bytes 45);
Printf.printf "random_bits 45 = %a\n"
pr (I.random_bits_gen ~fill:pr_bytes 45);
Printf.printf "random_bits 12 = %a\n"
pr (I.random_bits_gen ~fill:pr_bytes 12);
Printf.printf "random_int 123456 = %a\n"
pr (I.random_int_gen ~fill:pr_bytes (I.of_int 123456));
Printf.printf "random_int 9999999 = %a\n"
pr (I.random_int_gen ~fill:pr_bytes (I.of_int 9999999));
()
(* testing Q *)
(* gcd extended to: gcd x 0 = gcd 0 x = 0 *)
let gcd2 a b =
if Z.sign a = 0 then b
else if Z.sign b = 0 then a
else Z.gcd a b
(* check invariant *)
let check x =
assert (Z.sign x.Q.den >= 0);
assert (Z.compare (gcd2 x.Q.num x.Q.den) Z.one <= 0)
let t_list = [Q.zero;Q.one;Q.minus_one;Q.inf;Q.minus_inf;Q.undef]
let test1 msg op =
List.iter
(fun x ->
let r = op x in
check r;
Printf.printf "%s %s = %s\n" msg (Q.to_string x) (Q.to_string r)
) t_list
let test2 msg op =
List.iter
(fun x ->
List.iter
(fun y ->
let r = op x y in
check r;
Printf.printf "%s %s %s = %s\n" (Q.to_string x) msg (Q.to_string y) (Q.to_string r)
) t_list
) t_list
let test_Q () =
let _ = List.iter check t_list in
let _ = test1 "-" Q.neg in
let _ = test1 "1/" Q.inv in
let _ = test1 "abs" Q.abs in
let _ = test2 "+" Q.add in
let _ = test2 "-" Q.sub in
let _ = test2 "*" Q.mul in
let _ = test2 "/" Q.div in
let _ = test2 "* 1/" (fun a b -> Q.mul a (Q.inv b)) in
let _ = test1 "mul_2exp (1) " (fun a -> Q.mul_2exp a 1) in
let _ = test1 "mul_2exp (2) " (fun a -> Q.mul_2exp a 2) in
let _ = test1 "div_2exp (1) " (fun a -> Q.div_2exp a 1) in
let _ = test1 "div_2exp (2) " (fun a -> Q.div_2exp a 2) in
(* check simple identitites *)
List.iter
(fun x ->
assert (0 = Q.compare x (Q.div_2exp (Q.mul_2exp x 2) 2));
assert (0 = Q.compare x (Q.mul_2exp (Q.div_2exp x 2) 2));
List.iter
(fun y ->
Printf.printf "identity checking %s %s\n" (Q.to_string x) (Q.to_string y);
assert (0 = Q.compare (Q.add x y) (Q.add y x));
assert (0 = Q.compare (Q.sub x y) (Q.neg (Q.sub y x)));
assert (0 = Q.compare (Q.sub x y) (Q.add x (Q.neg y)));
assert (0 = Q.compare (Q.mul x y) (Q.mul y x));
assert (0 = Q.compare (Q.div x y) (Q.mul x (Q.inv y)));
) t_list
) t_list;
assert (Q.compare Q.undef Q.undef = 0);
assert (not (Q.equal Q.undef Q.undef));
assert (not (Q.lt Q.undef Q.undef));
assert (not (Q.leq Q.undef Q.undef));
assert (not (Q.gt Q.undef Q.undef));
assert (not (Q.geq Q.undef Q.undef))
(* main *)
let _ = test_Z()
let _ = test_Q()

1452
unikernel/duniverse/Zarith/tests/zq.output32 Normal file
View file

File diff suppressed because it is too large Load diff

1452
unikernel/duniverse/Zarith/tests/zq.output64 Normal file
View file

File diff suppressed because it is too large Load diff

555
unikernel/duniverse/Zarith/z.ml Normal file
View file

@ -0,0 +1,555 @@
(**
Integers.
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
type t
exception Overflow
external init: unit -> unit = "ml_z_init"
let _ = init ()
let _ = Callback.register_exception "ml_z_overflow" Overflow
external is_small_int: t -> bool = "%obj_is_int"
external unsafe_to_int: t -> int = "%identity"
external of_int: int -> t = "%identity"
external c_neg: t -> t = "ml_z_neg"
let neg x =
if is_small_int x && unsafe_to_int x <> min_int
then of_int (- unsafe_to_int x)
else c_neg x
external c_add: t -> t -> t = "ml_z_add"
let add x y =
if is_small_int x && is_small_int y then begin
let z = unsafe_to_int x + unsafe_to_int y in
(* Overflow check -- Hacker's Delight, section 2.12 *)
if (z lxor unsafe_to_int x) land (z lxor unsafe_to_int y) >= 0
then of_int z
else c_add x y
end else
c_add x y
external c_sub: t -> t -> t = "ml_z_sub"
let sub x y =
if is_small_int x && is_small_int y then begin
let z = unsafe_to_int x - unsafe_to_int y in
(* Overflow check -- Hacker's Delight, section 2.12 *)
if (unsafe_to_int x lxor unsafe_to_int y)
land (z lxor unsafe_to_int x) >= 0
then of_int z
else c_sub x y
end else
c_sub x y
external mul_overflows: int -> int -> bool = "ml_z_mul_overflows" [@@noalloc]
external c_mul: t -> t -> t = "ml_z_mul"
let mul x y =
if is_small_int x && is_small_int y
&& not (mul_overflows (unsafe_to_int x) (unsafe_to_int y))
then of_int (unsafe_to_int x * unsafe_to_int y)
else c_mul x y
external c_div: t -> t -> t = "ml_z_div"
let div x y =
if is_small_int y then
if unsafe_to_int y = -1 then
neg x
else if is_small_int x then
of_int (unsafe_to_int x / unsafe_to_int y)
else
c_div x y
else
c_div x y
external cdiv: t -> t -> t = "ml_z_cdiv"
external fdiv: t -> t -> t = "ml_z_fdiv"
external c_rem: t -> t -> t = "ml_z_rem"
let rem x y =
if is_small_int y then
if unsafe_to_int y = -1 then
of_int 0
else if is_small_int x then
of_int (unsafe_to_int x mod unsafe_to_int y)
else
c_rem x y
else
c_rem x y
external div_rem: t -> t -> (t * t) = "ml_z_div_rem"
external c_divexact: t -> t -> t = "ml_z_divexact"
let divexact x y =
if is_small_int y then
if unsafe_to_int y = -1 then
neg x
else if is_small_int x then
of_int (unsafe_to_int x / unsafe_to_int y)
else
c_divexact x y
else
c_divexact x y
external c_succ: t -> t = "ml_z_succ"
let succ x =
if is_small_int x && unsafe_to_int x <> max_int
then of_int (unsafe_to_int x + 1)
else c_succ x
external c_pred: t -> t = "ml_z_pred"
let pred x =
if is_small_int x && unsafe_to_int x <> min_int
then of_int (unsafe_to_int x - 1)
else c_pred x
external c_abs: t -> t = "ml_z_abs"
let abs x =
if is_small_int x then
if unsafe_to_int x >= 0 then x
else if unsafe_to_int x <> min_int then
of_int (- unsafe_to_int x)
else
c_abs x
else
c_abs x
external c_logand: t -> t -> t = "ml_z_logand"
let logand x y =
if is_small_int x && is_small_int y
then of_int (unsafe_to_int x land unsafe_to_int y)
else c_logand x y
external c_logor: t -> t -> t = "ml_z_logor"
let logor x y =
if is_small_int x && is_small_int y
then of_int (unsafe_to_int x lor unsafe_to_int y)
else c_logor x y
external c_logxor: t -> t -> t = "ml_z_logxor"
let logxor x y =
if is_small_int x && is_small_int y
then of_int (unsafe_to_int x lxor unsafe_to_int y)
else c_logxor x y
external c_lognot: t -> t = "ml_z_lognot"
let lognot x =
if is_small_int x
then of_int (unsafe_to_int x lxor (-1))
else c_lognot x
external c_shift_left: t -> int -> t = "ml_z_shift_left"
let shift_left x y =
if is_small_int x && y >= 0 && y < Sys.word_size then begin
let z = unsafe_to_int x lsl y in
if z asr y = unsafe_to_int x
then of_int z
else c_shift_left x y
end else
c_shift_left x y
external c_shift_right: t -> int -> t = "ml_z_shift_right"
let shift_right x y =
if is_small_int x && y >= 0 then
of_int
(unsafe_to_int x asr (if y < Sys.word_size then y else Sys.word_size - 1))
else
c_shift_right x y
external c_shift_right_trunc: t -> int -> t = "ml_z_shift_right_trunc"
let shift_right_trunc x y =
if is_small_int x && y >= 0 then
if y >= Sys.word_size then
of_int 0
else if unsafe_to_int x >= 0 then
of_int (unsafe_to_int x lsr y)
else
of_int (- ((- unsafe_to_int x) lsr y))
else
c_shift_right_trunc x y
external of_int32: int32 -> t = "ml_z_of_int32"
external of_int64: int64 -> t = "ml_z_of_int64"
external of_nativeint: nativeint -> t = "ml_z_of_nativeint"
external of_float: float -> t = "ml_z_of_float"
let uint32_mask = pred (shift_left (of_int 1) 32)
let of_int32_unsigned x = logand (of_int32 x) uint32_mask
let uint64_mask = pred (shift_left (of_int 1) 64)
let of_int64_unsigned x = logand (of_int64 x) uint64_mask
let uintnat_mask = pred (shift_left (of_int 1) Nativeint.size)
let of_nativeint_unsigned x = logand (of_nativeint x) uintnat_mask
external c_to_int: t -> int = "ml_z_to_int"
let to_int x =
if is_small_int x then unsafe_to_int x else c_to_int x
external to_int32: t -> int32 = "ml_z_to_int32"
external to_int64: t -> int64 = "ml_z_to_int64"
external to_nativeint: t -> nativeint = "ml_z_to_nativeint"
external to_int32_unsigned: t -> int32 = "ml_z_to_int32_unsigned"
external to_int64_unsigned: t -> int64 = "ml_z_to_int64_unsigned"
external to_nativeint_unsigned: t -> nativeint = "ml_z_to_nativeint_unsigned"
external format: string -> t -> string = "ml_z_format"
external of_substring_base: int -> string -> pos:int -> len:int -> t = "ml_z_of_substring_base"
external compare: t -> t -> int = "ml_z_compare" [@@noalloc]
external equal: t -> t -> bool = "ml_z_equal" [@@noalloc]
external sign: t -> int = "ml_z_sign" [@@noalloc]
external gcd: t -> t -> t = "ml_z_gcd"
external gcdext_intern: t -> t -> (t * t * bool) = "ml_z_gcdext_intern"
external sqrt: t -> t = "ml_z_sqrt"
external sqrt_rem: t -> (t * t) = "ml_z_sqrt_rem"
external numbits: t -> int = "ml_z_numbits" [@@noalloc]
external trailing_zeros: t -> int = "ml_z_trailing_zeros" [@@noalloc]
external popcount: t -> int = "ml_z_popcount"
external hamdist: t -> t -> int = "ml_z_hamdist"
external size: t -> int = "ml_z_size" [@@noalloc]
external fits_int: t -> bool = "ml_z_fits_int" [@@noalloc]
external fits_int32: t -> bool = "ml_z_fits_int32" [@@noalloc]
external fits_int64: t -> bool = "ml_z_fits_int64" [@@noalloc]
external fits_nativeint: t -> bool = "ml_z_fits_nativeint" [@@noalloc]
external fits_int32_unsigned: t -> bool = "ml_z_fits_int32_unsigned" [@@noalloc]
external fits_int64_unsigned: t -> bool = "ml_z_fits_int64_unsigned" [@@noalloc]
external fits_nativeint_unsigned: t -> bool = "ml_z_fits_nativeint_unsigned" [@@noalloc]
external extract: t -> int -> int -> t = "ml_z_extract"
external powm: t -> t -> t -> t = "ml_z_powm"
external pow: t -> int -> t = "ml_z_pow"
external powm_sec: t -> t -> t -> t = "ml_z_powm_sec"
external root: t -> int -> t = "ml_z_root"
external rootrem: t -> int -> t * t = "ml_z_rootrem"
external invert: t -> t -> t = "ml_z_invert"
external perfect_power: t -> bool = "ml_z_perfect_power"
external perfect_square: t -> bool = "ml_z_perfect_square"
external probab_prime: t -> int -> int = "ml_z_probab_prime"
external nextprime: t -> t = "ml_z_nextprime"
let hash: t -> int = Stdlib.Hashtbl.hash
let seeded_hash: int -> t -> int = Stdlib.Hashtbl.seeded_hash
external to_bits: t -> string = "ml_z_to_bits"
external of_bits: string -> t = "ml_z_of_bits"
external c_divisible: t -> t -> bool = "ml_z_divisible"
let divisible x y =
if is_small_int x then
if is_small_int y then
if unsafe_to_int y = 0
then unsafe_to_int x = 0
else (unsafe_to_int x) mod (unsafe_to_int y) = 0
else
(* If y divides x, we have |y| <= |x| or x = 0.
Here, x is small: min_int <= x <= max_int
and y is not small: y < min_int \/ y > max_int.
|y| <= |x| is possible only if
x = min_int and y = -min_int = max_int+1 .
So, the only two cases where y divides x are
x = 0 or x = min_int /\ y = -min_int. *)
unsafe_to_int x = 0 || (unsafe_to_int x = min_int && y = c_neg x)
else
c_divisible x y
external congruent: t -> t -> t -> bool = "ml_z_congruent"
external jacobi: t -> t -> int = "ml_z_jacobi"
external legendre: t -> t -> int = "ml_z_legendre"
external kronecker: t -> t -> int = "ml_z_kronecker"
external remove: t -> t -> t * int = "ml_z_remove"
external fac: int -> t = "ml_z_fac"
external fac2: int -> t = "ml_z_fac2"
external facM: int -> int -> t = "ml_z_facM"
external primorial: int -> t = "ml_z_primorial"
external bin: t -> int -> t = "ml_z_bin"
external fib: int -> t = "ml_z_fib"
external lucnum: int -> t = "ml_z_lucnum"
let zero = of_int 0
let one = of_int 1
let minus_one = of_int (-1)
let min a b = if compare a b <= 0 then a else b
let max a b = if compare a b >= 0 then a else b
let leq a b = compare a b <= 0
let geq a b = compare a b >= 0
let lt a b = compare a b < 0
let gt a b = compare a b > 0
let to_string = format "%d"
let of_string s = of_substring_base 0 s ~pos:0 ~len:(String.length s)
let of_substring = of_substring_base 0
let of_string_base base s = of_substring_base base s ~pos:0 ~len:(String.length s)
let ediv_rem a b =
(* we have a = q * b + r, but [Big_int]'s remainder satisfies 0 <= r < |b|,
while [Z]'s remainder satisfies -|b| < r < |b| and sign(r) = sign(a)
*)
let q,r = div_rem a b in
if sign r >= 0 then (q,r) else
if sign b >= 0 then (pred q, add r b)
else (succ q, sub r b)
let ediv a b =
if sign b >= 0 then fdiv a b else cdiv a b
let erem a b =
let r = rem a b in
if sign r >= 0 then r else add r (abs b)
let gcdext u v =
match sign u, sign v with
(* special cases: one argument is null *)
| 0, 0 -> zero, zero, zero
| 0, 1 -> v, zero, one
| 0, -1 -> neg v, zero, minus_one
| 1, 0 -> u, one, zero
| -1, 0 -> neg u, minus_one, zero
| _ ->
(* general case *)
let g,s,z = gcdext_intern u v in
if z then g, s, div (sub g (mul u s)) v
else g, div (sub g (mul v s)) u, s
let lcm u v =
if u = zero || v = zero then zero
else
let g = gcd u v in
abs (mul (divexact u g) v)
external testbit_internal: t -> int -> bool = "ml_z_testbit" [@@noalloc]
let testbit x n =
if n >= 0 then testbit_internal x n else invalid_arg "Z.testbit"
(* The test [n >= 0] is done in Caml rather than in the C stub code
so that the latter raises no exceptions and can be declared [@@noalloc]. *)
let is_odd x = testbit_internal x 0
let is_even x = not (testbit_internal x 0)
external c_extract_small: t -> int -> int -> t
= "ml_z_extract_small" [@@noalloc]
external c_extract: t -> int -> int -> t = "ml_z_extract"
let extract_internal x o l =
if is_small_int x then
(* Fast path *)
let o = if o >= Sys.int_size then Sys.int_size - 1 else o in
(* Shift away low "o" bits. If "o" too big, just replicate sign bit. *)
let z = unsafe_to_int x asr o in
if l < Sys.int_size then
(* Extract "l" low bits, if "l" is small enough *)
of_int (z land ((1 lsl l) - 1))
else if z >= 0 then
(* If x >= 0, the extraction of "l" low bits keeps x unchanged. *)
of_int z
else
(* If x < 0, fall through slow path *)
c_extract x o l
else if l < Sys.int_size then
(* Alternative fast path since no allocation is required *)
c_extract_small x o l
else
c_extract x o l
let extract x o l =
if o < 0 then invalid_arg "Z.extract: negative bit offset";
if l < 1 then invalid_arg "Z.extract: nonpositive bit length";
extract_internal x o l
let signed_extract x o l =
if o < 0 then invalid_arg "Z.signed_extract: negative bit offset";
if l < 1 then invalid_arg "Z.signed_extract: nonpositive bit length";
if testbit x (o + l - 1)
then lognot (extract (lognot x) o l)
else extract x o l
let log2 x =
if sign x > 0 then (numbits x) - 1 else invalid_arg "Z.log2"
let log2up x =
if sign x > 0 then numbits (pred x) else invalid_arg "Z.log2up"
(* Consider a real number [r] such that
- the integral part of [r] is the bigint [x]
- 2^54 <= |x| < 2^63
- the fractional part of [r] is 0 if [exact = true],
nonzero if [exact = false].
Then, the following function returns [r] correctly rounded
according to the current rounding mode of the processor.
This is an instance of the "round to odd" technique formalized in
"When double rounding is odd" by S. Boldo and G. Melquiond.
The claim above is lemma Fappli_IEEE_extra.round_odd_fix
from the CompCert Coq development. *)
let round_to_float x exact =
let m = to_int64 x in
(* Unless the fractional part is exactly 0, round m to an odd integer *)
let m = if exact then m else Int64.logor m 1L in
(* Then convert m to float, with the current rounding mode. *)
Int64.to_float m
let to_float x =
if Obj.is_int (Obj.repr x) then
(* Fast path *)
float_of_int (Obj.magic x : int)
else begin
let n = numbits x in
if n <= 63 then
Int64.to_float (to_int64 x)
else begin
let n = n - 55 in
(* Extract top 55 bits of x *)
let top = shift_right x n in
(* Check if the other bits are all zero *)
let exact = equal x (shift_left top n) in
(* Round to float and apply exponent *)
ldexp (round_to_float top exact) n
end
end
(* Formatting *)
let print x = print_string (to_string x)
let output chan x = output_string chan (to_string x)
let sprint () x = to_string x
let bprint b x = Buffer.add_string b (to_string x)
let pp_print f x = Format.pp_print_string f (to_string x)
(* Pseudo-random generation *)
let rec raw_bits_random ?(rng: Random.State.t option) nbits =
let rec raw_bits accu n =
if n >= nbits then (accu, n) else begin
let i =
match rng with
| None -> Random.bits ()
| Some r -> Random.State.bits r in
raw_bits (logxor (shift_left accu 30) (of_int i)) (n + 30)
end in
raw_bits zero 0
let raw_bits_from_bytes ~(fill: bytes -> int -> int -> unit) nbits =
let nbytes = (nbits + 7) / 8 in
let buf = Bytes.create nbytes in
fill buf 0 nbytes;
(of_bits (Bytes.to_string buf), nbytes * 8)
let random_bits_aux (f: int -> t * int) nbits =
if nbits < 0 then invalid_arg "random_bits: number of bits must be >= 0";
let (x, _) = f nbits in
extract x 0 nbits
let random_int_aux (f: int -> t * int) bound =
if sign bound <= 0 then invalid_arg "random_int: bound must be > 0";
let nbits1 = log2up bound in
let rec draw () =
(* The minimal number of random bits we need to draw is nbits1.
However, in the worst case, rejection (as described below)
will occur with probability almost 1/2. So, we draw more bits
than strictly necessary to make rejection much less likely.
With 4 extra bits, the probability of rejection is less than
1/32. *)
let (x, nbits) = f (nbits1 + 4) in
let y = rem x bound in
(* We divide the range of x, namely [0 .. 2^nbits), into
- k intervals of width bound :
[0 .. bound) [bound.. 2*bound) .. [(k-1) * bound.. k * bound)
- the remaining numbers: [k * bound .. 2^nbits)
k is chosen as large as possible: k = floor (2^nbits / bound).
If x falls within the k intervals of width bound,
y = x mod bound is evenly distributed in [0 .. bound)
and we can use it as the pseudo-random number.
If x falls within the [k * bound .. 2^nbits) interval,
y = x mod bound may not be evenly distributed;
we reject and draw again.
We can decide efficiently whether to reject, as follows.
Write 2^nbits = k * bound + r and x = q * bound + y,
with r and y in [0 .. bound).
If x - y <= 2^nbits - bound, then
q * bound = x - y <= 2^nbits - bound < 2^nbits - r = k * bound,
hence q < k and we can accept x.
Otherwise,
q * bound = x - y > 2^nbits - bound = (k - 1) * bound + r
hence q >= k and we must reject x.
*)
if leq (sub x y) (sub (shift_left one nbits) bound)
then y
else draw () in
draw ()
let random_int ?rng bound =
random_int_aux (raw_bits_random ?rng) bound
let random_bits ?rng nbits =
random_bits_aux (raw_bits_random ?rng) nbits
let random_int_gen ~fill bound =
random_int_aux (raw_bits_from_bytes ~fill) bound
let random_bits_gen ~fill nbits =
random_bits_aux (raw_bits_from_bytes ~fill) nbits
(* Infix notations *)
let (~-) = neg
let (~+) x = x
let (+) = add
let (-) = sub
let ( * ) = mul
let (/) = div
external (/>): t -> t -> t = "ml_z_cdiv"
external (/<): t -> t -> t = "ml_z_fdiv"
let (/|) = divexact
let (mod) = rem
let (land) = logand
let (lor) = logor
let (lxor) = logxor
let (~!) = lognot
let (lsl) = shift_left
let (asr) = shift_right
external (~$): int -> t = "%identity"
external ( ** ): t -> int -> t = "ml_z_pow"
module Compare = struct
let (=) = equal
let (<) = lt
let (>) = gt
let (<=) = leq
let (>=) = geq
let (<>) a b = not (equal a b)
end
let version = Zarith_version.version

880
unikernel/duniverse/Zarith/z.mli Normal file
View file

@ -0,0 +1,880 @@
(**
Integers.
This modules provides arbitrary-precision integers.
Small integers internally use a regular OCaml [int].
When numbers grow too large, we switch transparently to GMP numbers
([mpn] numbers fully allocated on the OCaml heap).
This interface is rather similar to that of [Int32] and [Int64],
with some additional functions provided natively by GMP
(GCD, square root, pop-count, etc.).
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
(** {1 Toplevel} *)
(** For an optimal experience with the [ocaml] interactive toplevel,
the magic commands are:
{[
#load "zarith.cma";;
#install_printer Z.pp_print;;
]}
Alternatively, using the new [Zarith_top] toplevel module, simply:
{[
#require "zarith.top";;
]}
*)
(** {1 Types} *)
type t
(** Type of integers of arbitrary length. *)
exception Overflow
(** Raised by conversion functions when the value cannot be represented in
the destination type.
*)
(** {1 Construction} *)
val zero: t
(** The number 0. *)
val one: t
(** The number 1. *)
val minus_one: t
(** The number -1. *)
external of_int: int -> t = "%identity"
(** Converts from a base integer. *)
external of_int32: int32 -> t = "ml_z_of_int32"
(** Converts from a 32-bit (signed) integer. *)
external of_int64: int64 -> t = "ml_z_of_int64"
(** Converts from a 64-bit (signed) integer. *)
external of_nativeint: nativeint -> t = "ml_z_of_nativeint"
(** Converts from a native (signed) integer. *)
val of_int32_unsigned: int32 -> t
(** Converts from a 32-bit integer, interpreted as an unsigned integer.
@since 1.13
*)
val of_int64_unsigned: int64 -> t
(** Converts from a 64-bit integer, interpreted as an unsigned integer.
@since 1.13
*)
val of_nativeint_unsigned: nativeint -> t
(** Converts from a native integer, interpreted as an unsigned integer..
@since 1.13
*)
external of_float: float -> t = "ml_z_of_float"
(** Converts from a floating-point value.
The value is truncated (rounded towards zero).
Raises [Overflow] on infinity and NaN arguments.
*)
val of_string: string -> t
(** Converts a string to an integer.
An optional [-] prefix indicates a negative number, while a [+]
prefix is ignored.
An optional prefix [0x], [0o], or [0b] (following the optional [-]
or [+] prefix) indicates that the number is,
represented, in hexadecimal, octal, or binary, respectively.
Otherwise, base 10 is assumed.
(Unlike C, a lone [0] prefix does not denote octal.)
Raises an [Invalid_argument] exception if the string is not a
syntactically correct representation of an integer.
*)
val of_substring : string -> pos:int -> len:int -> t
(** [of_substring s ~pos ~len] is the same as [of_string (String.sub s
pos len)]
@since 1.4
*)
val of_string_base: int -> string -> t
(** Parses a number represented as a string in the specified base,
with optional [-] or [+] prefix.
The base must be between 2 and 16.
*)
external of_substring_base
: int -> string -> pos:int -> len:int -> t
= "ml_z_of_substring_base"
(** [of_substring_base base s ~pos ~len] is the same as [of_string_base
base (String.sub s pos len)]
@since 1.4
*)
(** {1 Basic arithmetic operations} *)
val succ: t -> t
(** Returns its argument plus one. *)
val pred: t -> t
(** Returns its argument minus one. *)
val abs: t -> t
(** Absolute value. *)
val neg: t -> t
(** Unary negation. *)
val add: t -> t -> t
(** Addition. *)
val sub: t -> t -> t
(** Subtraction. *)
val mul: t -> t -> t
(** Multiplication. *)
val div: t -> t -> t
(** Integer division. The result is truncated towards zero
and obeys the rule of signs.
Raises [Division_by_zero] if the divisor (second argument) is 0.
*)
val rem: t -> t -> t
(** Integer remainder. Can raise a [Division_by_zero].
The result of [rem a b] has the sign of [a], and its absolute value is
strictly smaller than the absolute value of [b].
The result satisfies the equality [a = b * div a b + rem a b].
*)
external div_rem: t -> t -> (t * t) = "ml_z_div_rem"
(** Computes both the integer quotient and the remainder.
[div_rem a b] is equal to [(div a b, rem a b)].
Raises [Division_by_zero] if [b = 0].
*)
external cdiv: t -> t -> t = "ml_z_cdiv"
(** Integer division with rounding towards +oo (ceiling).
Can raise a [Division_by_zero].
*)
external fdiv: t -> t -> t = "ml_z_fdiv"
(** Integer division with rounding towards -oo (floor).
Can raise a [Division_by_zero].
*)
val ediv_rem: t -> t -> (t * t)
(** Euclidean division and remainder. [ediv_rem a b] returns a pair [(q, r)]
such that [a = b * q + r] and [0 <= r < |b|].
Raises [Division_by_zero] if [b = 0].
*)
val ediv: t -> t -> t
(** Euclidean division. [ediv a b] is equal to [fst (ediv_rem a b)].
The result satisfies [0 <= a - b * ediv a b < |b|].
Raises [Division_by_zero] if [b = 0].
*)
val erem: t -> t -> t
(** Euclidean remainder. [erem a b] is equal to [snd (ediv_rem a b)].
The result satisfies [0 <= erem a b < |b|] and
[a = b * ediv a b + erem a b]. Raises [Division_by_zero] if [b = 0].
*)
val divexact: t -> t -> t
(** [divexact a b] divides [a] by [b], only producing correct result when the
division is exact, i.e., when [b] evenly divides [a].
It should be faster than general division.
Can raise a [Division_by_zero].
*)
val divisible: t -> t -> bool
(** [divisible a b] returns [true] if [a] is exactly divisible by [b].
Unlike the other division functions, [b = 0] is accepted
(only 0 is considered divisible by 0).
@since 1.10
*)
external congruent: t -> t -> t -> bool = "ml_z_congruent"
(** [congruent a b c] returns [true] if [a] is congruent to [b] modulo [c].
Unlike the other division functions, [c = 0] is accepted
(only equal numbers are considered equal congruent 0).
@since 1.10
*)
(** {1 Bit-level operations} *)
(** For all bit-level operations, negative numbers are considered in 2's
complement representation, starting with a virtual infinite number of
1s.
*)
val logand: t -> t -> t
(** Bitwise logical and. *)
val logor: t -> t -> t
(** Bitwise logical or. *)
val logxor: t -> t -> t
(** Bitwise logical exclusive or. *)
val lognot: t -> t
(** Bitwise logical negation.
The identity [lognot a]=[-a-1] always hold.
*)
val shift_left: t -> int -> t
(** Shifts to the left.
Equivalent to a multiplication by a power of 2.
The second argument must be nonnegative.
*)
val shift_right: t -> int -> t
(** Shifts to the right.
This is an arithmetic shift,
equivalent to a division by a power of 2 with rounding towards -oo.
The second argument must be nonnegative.
*)
val shift_right_trunc: t -> int -> t
(** Shifts to the right, rounding towards 0.
This is equivalent to a division by a power of 2, with truncation.
The second argument must be nonnegative.
*)
external numbits: t -> int = "ml_z_numbits" [@@noalloc]
(** Returns the number of significant bits in the given number.
If [x] is zero, [numbits x] returns 0. Otherwise,
[numbits x] returns a positive integer [n] such that
[2^{n-1} <= |x| < 2^n]. Note that [numbits] is defined
for negative arguments, and that [numbits (-x) = numbits x].
@since 1.4
*)
external trailing_zeros: t -> int = "ml_z_trailing_zeros" [@@noalloc]
(** Returns the number of trailing 0 bits in the given number.
If [x] is zero, [trailing_zeros x] returns [max_int].
Otherwise, [trailing_zeros x] returns a nonnegative integer [n]
which is the largest [n] such that [2^n] divides [x] evenly.
Note that [trailing_zeros] is defined for negative arguments,
and that [trailing_zeros (-x) = trailing_zeros x].
@since 1.4
*)
val testbit: t -> int -> bool
(** [testbit x n] return the value of bit number [n] in [x]:
[true] if the bit is 1, [false] if the bit is 0.
Bits are numbered from 0. Raise [Invalid_argument] if [n]
is negative.
@since 1.4
*)
external popcount: t -> int = "ml_z_popcount"
(** Counts the number of bits set.
Raises [Overflow] for negative arguments, as those have an infinite
number of bits set.
*)
external hamdist: t -> t -> int = "ml_z_hamdist"
(** Counts the number of different bits.
Raises [Overflow] if the arguments have different signs
(in which case the distance is infinite).
*)
(** {1 Conversions} *)
(** Note that, when converting to an integer type that cannot represent the
converted value, an [Overflow] exception is raised.
*)
val to_int: t -> int
(** Converts to a signed OCaml [int].
Raises an [Overflow] if the value does not fit in a signed OCaml [int]. *)
external to_int32: t -> int32 = "ml_z_to_int32"
(** Converts to a signed 32-bit integer [int32].
Raises an [Overflow] if the value does not fit in a signed [int32]. *)
external to_int64: t -> int64 = "ml_z_to_int64"
(** Converts to a signed 64-bit integer [int64].
Raises an [Overflow] if the value does not fit in a signed [int64]. *)
external to_nativeint: t -> nativeint = "ml_z_to_nativeint"
(** Converts to a native signed integer [nativeint].
Raises an [Overflow] if the value does not fit in a signed [nativeint]. *)
external to_int32_unsigned: t -> int32 = "ml_z_to_int32_unsigned"
(** Converts to an unsigned 32-bit integer.
The result is stored into an OCaml [int32].
Beware that most [Int32] operations consider [int32] to a signed type, not unsigned.
Raises an [Overflow] if the value is negative or does not fit in an unsigned 32-bit integer.
@since 1.13
*)
external to_int64_unsigned: t -> int64 = "ml_z_to_int64_unsigned"
(** Converts to an unsigned 64-bit integer.
The result is stored into an OCaml [int64].
Beware that most [Int64] operations consider [int64] to a signed type, not unsigned.
Raises an [Overflow] if the value is negative or does not fit in an unsigned 64-bit integer.
@since 1.13
*)
external to_nativeint_unsigned: t -> nativeint = "ml_z_to_nativeint_unsigned"
(** Converts to a native unsigned integer.
The result is stored into an OCaml [nativeint].
Beware that most [Nativeint] operations consider [nativeint] to a signed type, not unsigned.
Raises an [Overflow] if the value is negative or does not fit in an unsigned native integer.
@since 1.13
*)
val to_float: t -> float
(** Converts to a floating-point value.
This function rounds the given integer according to the current
rounding mode of the processor. In default mode, it returns
the floating-point number nearest to the given integer,
breaking ties by rounding to even. *)
val to_string: t -> string
(** Gives a human-readable, decimal string representation of the argument. *)
external format: string -> t -> string = "ml_z_format"
(** Gives a string representation of the argument in the specified
printf-like format.
The general specification has the following form:
[% \[flags\] \[width\] type]
Where the type actually indicates the base:
- [i], [d], [u]: decimal
- [b]: binary
- [o]: octal
- [x]: lowercase hexadecimal
- [X]: uppercase hexadecimal
Supported flags are:
- [+]: prefix positive numbers with a [+] sign
- space: prefix positive numbers with a space
- [-]: left-justify (default is right justification)
- [0]: pad with zeroes (instead of spaces)
- [#]: alternate formatting (actually, simply output a literal-like prefix: [0x], [0b], [0o])
Unlike the classic [printf], all numbers are signed (even hexadecimal ones),
there is no precision field, and characters that are not part of the format
are simply ignored (and not copied in the output).
*)
external fits_int: t -> bool = "ml_z_fits_int" [@@noalloc]
(** Whether the argument fits in an OCaml signed [int]. *)
external fits_int32: t -> bool = "ml_z_fits_int32" [@@noalloc]
(** Whether the argument fits in a signed [int32]. *)
external fits_int64: t -> bool = "ml_z_fits_int64" [@@noalloc]
(** Whether the argument fits in a signed [int64]. *)
external fits_nativeint: t -> bool = "ml_z_fits_nativeint" [@@noalloc]
(** Whether the argument fits in a signed [nativeint]. *)
external fits_int32_unsigned: t -> bool = "ml_z_fits_int32_unsigned" [@@noalloc]
(** Whether the argument is non-negative and fits in an unsigned [int32].
@since 1.13
*)
external fits_int64_unsigned: t -> bool = "ml_z_fits_int64_unsigned" [@@noalloc]
(** Whether the argument is non-negative and fits in an unsigned [int64].
@since 1.13
*)
external fits_nativeint_unsigned: t -> bool = "ml_z_fits_nativeint_unsigned" [@@noalloc]
(** Whether the argument is non-negative fits in an unsigned [nativeint].
@since 1.13
*)
(** {1 Printing} *)
val print: t -> unit
(** Prints the argument on the standard output. *)
val output: out_channel -> t -> unit
(** Prints the argument on the specified channel.
Also intended to be used as [%a] format printer in [Printf.printf].
*)
val sprint: unit -> t -> string
(** To be used as [%a] format printer in [Printf.sprintf]. *)
val bprint: Buffer.t -> t -> unit
(** To be used as [%a] format printer in [Printf.bprintf]. *)
val pp_print: Format.formatter -> t -> unit
(** Prints the argument on the specified formatter.
Can be used as [%a] format printer in [Format.printf] and as
argument to [#install_printer] in the top-level.
*)
(** {1 Ordering} *)
external compare: t -> t -> int = "ml_z_compare" [@@noalloc]
(** Comparison. [compare x y] returns 0 if [x] equals [y],
-1 if [x] is smaller than [y], and 1 if [x] is greater than [y].
Note that Pervasive.compare can be used to compare reliably two integers
only on OCaml 3.12.1 and later versions.
*)
external equal: t -> t -> bool = "ml_z_equal" [@@noalloc]
(** Equality test. *)
val leq: t -> t -> bool
(** Less than or equal. *)
val geq: t -> t -> bool
(** Greater than or equal. *)
val lt: t -> t -> bool
(** Less than (and not equal). *)
val gt: t -> t -> bool
(** Greater than (and not equal). *)
external sign: t -> int = "ml_z_sign" [@@noalloc]
(** Returns -1, 0, or 1 when the argument is respectively negative, null, or
positive.
*)
val min: t -> t -> t
(** Returns the minimum of its arguments. *)
val max: t -> t -> t
(** Returns the maximum of its arguments. *)
val is_even: t -> bool
(** Returns true if the argument is even (divisible by 2), false if odd.
@since 1.4
*)
val is_odd: t -> bool
(** Returns true if the argument is odd, false if even.
@since 1.4
*)
val hash: t -> int
(** Hashes a number, producing a small integer.
The result is consistent with equality:
if [a] = [b], then [hash a] = [hash b].
The result is the same as produced by OCaml's generic hash function,
{!Hashtbl.hash}.
Together with type {!Z.t}, the function {!Z.hash} makes it possible
to pass module {!Z} as argument to the functor {!Hashtbl.Make}.
@before 1.14 a different hash algorithm was used.
*)
val seeded_hash: int -> t -> int
(** Like {!Z.hash}, but takes a seed as extra argument for diversification.
The result is the same as produced by OCaml's generic seeded hash function,
{!Hashtbl.seeded_hash}.
Together with type {!Z.t}, the function {!Z.hash} makes it possible
to pass module {!Z} as argument to the functor {!Hashtbl.MakeSeeded}.
@since 1.14
*)
(** {1 Elementary number theory} *)
external gcd: t -> t -> t = "ml_z_gcd"
(** Greatest common divisor.
The result is always nonnegative.
We have [gcd(a,0) = gcd(0,a) = abs(a)], including [gcd(0,0) = 0].
*)
val gcdext: t -> t -> (t * t * t)
(** [gcdext u v] returns [(g,s,t)] where [g] is the greatest common divisor
and [g=us+vt].
[g] is always nonnegative.
Note: the function is based on the GMP [mpn_gcdext] function. The exact choice of [s] and [t] such that [g=us+vt] is not specified, as it may vary from a version of GMP to another (it has changed notably in GMP 4.3.0 and 4.3.1).
*)
val lcm: t -> t -> t
(**
Least common multiple.
The result is always nonnegative.
We have [lcm(a,0) = lcm(0,a) = 0].
*)
external powm: t -> t -> t -> t = "ml_z_powm"
(** [powm base exp mod] computes [base]^[exp] modulo [mod].
Negative [exp] are supported, in which case ([base]^-1)^(-[exp]) modulo
[mod] is computed.
However, if [exp] is negative but [base] has no inverse modulo [mod], then
a [Division_by_zero] is raised.
*)
external powm_sec: t -> t -> t -> t = "ml_z_powm_sec"
(** [powm_sec base exp mod] computes [base]^[exp] modulo [mod].
Unlike [Z.powm], this function is designed to take the same time
and have the same cache access patterns for any two same-size
arguments. Used in cryptographic applications, it provides better
resistance to side-channel attacks than [Z.powm].
The exponent [exp] must be positive, and the modulus [mod]
must be odd. Otherwise, [Invalid_arg] is raised.
@since 1.4
*)
external invert: t -> t -> t = "ml_z_invert"
(** [invert base mod] returns the inverse of [base] modulo [mod].
Raises a [Division_by_zero] if [base] is not invertible modulo [mod].
*)
external probab_prime: t -> int -> int = "ml_z_probab_prime"
(** [probab_prime x r] returns 0 if [x] is definitely composite,
1 if [x] is probably prime, and 2 if [x] is definitely prime.
The [r] argument controls how many Miller-Rabin probabilistic
primality tests are performed (5 to 10 is a reasonable value).
*)
external nextprime: t -> t = "ml_z_nextprime"
(** Returns the next prime greater than the argument.
The result is only prime with very high probability.
*)
external jacobi: t -> t -> int = "ml_z_jacobi"
(** [jacobi a b] returns the Jacobi symbol [(a/b)].
@since 1.10 *)
external legendre: t -> t -> int = "ml_z_legendre"
(** [legendre a b] returns the Legendre symbol [(a/b)].
@since 1.10 *)
external kronecker: t -> t -> int = "ml_z_kronecker"
(** [kronecker a b] returns the Kronecker symbol [(a/b)].
@since 1.10 *)
external remove: t -> t -> t * int = "ml_z_remove"
(** [remove a b] returns [a] after removing all the occurences of the
factor [b].
Also returns how many occurrences were removed.
@since 1.10 *)
external fac: int -> t = "ml_z_fac"
(** [fac n] returns the factorial of [n] ([n!]).
Raises an [Invaid_argument] if [n] is non-positive.
@since 1.10 *)
external fac2: int -> t = "ml_z_fac2"
(** [fac2 n] returns the double factorial of [n] ([n!!]).
Raises an [Invaid_argument] if [n] is non-positive.
@since 1.10 *)
external facM: int -> int -> t = "ml_z_facM"
(** [facM n m] returns the [m]-th factorial of [n].
Raises an [Invaid_argument] if [n] or [m] is non-positive.
@since 1.10 *)
external primorial: int -> t = "ml_z_primorial"
(** [primorial n] returns the product of all positive prime numbers less
than or equal to [n].
Raises an [Invaid_argument] if [n] is non-positive.
@since 1.10 *)
external bin: t -> int -> t = "ml_z_bin"
(** [bin n k] returns the binomial coefficient [n] over [k].
Raises an [Invaid_argument] if [k] is non-positive.
@since 1.10 *)
external fib: int -> t = "ml_z_fib"
(** [fib n] returns the [n]-th Fibonacci number.
Raises an [Invaid_argument] if [n] is non-positive.
@since 1.10 *)
external lucnum: int -> t = "ml_z_lucnum"
(** [lucnum n] returns the [n]-th Lucas number.
Raises an [Invaid_argument] if [n] is non-positive.
@since 1.10 *)
(** {1 Powers} *)
external pow: t -> int -> t = "ml_z_pow"
(** [pow base exp] raises [base] to the [exp] power.
[exp] must be nonnegative.
Note that only exponents fitting in a machine integer are supported, as
larger exponents would surely make the result's size overflow the
address space.
*)
external sqrt: t -> t = "ml_z_sqrt"
(** Returns the square root. The result is truncated (rounded down
to an integer).
Raises an [Invalid_argument] on negative arguments.
*)
external sqrt_rem: t -> (t * t) = "ml_z_sqrt_rem"
(** Returns the square root truncated, and the remainder.
Raises an [Invalid_argument] on negative arguments.
*)
external root: t -> int -> t = "ml_z_root"
(** [root x n] computes the [n]-th root of [x].
[n] must be positive and, if [n] is even, then [x] must be nonnegative.
Otherwise, an [Invalid_argument] is raised.
*)
external rootrem: t -> int -> t * t = "ml_z_rootrem"
(** [rootrem x n] computes the [n]-th root of [x] and the remainder
[x-root**n].
[n] must be positive and, if [n] is even, then [x] must be nonnegative.
Otherwise, an [Invalid_argument] is raised.
@since 1.10 *)
external perfect_power: t -> bool = "ml_z_perfect_power"
(** True if the argument has the form [a^b], with [b>1] *)
external perfect_square: t -> bool = "ml_z_perfect_square"
(** True if the argument has the form [a^2]. *)
val log2: t -> int
(** Returns the base-2 logarithm of its argument, rounded down to
an integer. If [x] is positive, [log2 x] returns the largest [n]
such that [2^n <= x]. If [x] is negative or zero, [log2 x] raise
the [Invalid_argument] exception.
@since 1.4
*)
val log2up: t -> int
(** Returns the base-2 logarithm of its argument, rounded up to
an integer. If [x] is positive, [log2up x] returns the smallest [n]
such that [x <= 2^n]. If [x] is negative or zero, [log2up x] raise
the [Invalid_argument] exception.
@since 1.4
*)
(** {1 Representation} *)
external size: t -> int = "ml_z_size" [@@noalloc]
(** Returns the number of machine words used to represent the number. *)
val extract: t -> int -> int -> t
(** [extract a off len] returns a nonnegative number corresponding to bits
[off] to [off]+[len]-1 of [a].
Negative [a] are considered in infinite-length 2's complement
representation.
Raises an [Invalid_argument] if [off] is strictly negative, or if [len] is negative or null.
*)
val signed_extract: t -> int -> int -> t
(** [signed_extract a off len] extracts bits [off] to [off]+[len]-1 of [b],
as [extract] does, then sign-extends bit [len-1] of the result
(that is, bit [off + len - 1] of [a]). The result is between
[- 2{^[len]-1}] (included) and [2{^[len]-1}] (excluded),
and equal to [extract a off len] modulo [2{^len}].
Raises an [Invalid_argument] if [off] is strictly negative, or if [len] is negative or null.
*)
external to_bits: t -> string = "ml_z_to_bits"
(** Returns a binary representation of the argument.
The string result should be interpreted as a sequence of bytes,
corresponding to the binary representation of the absolute value of
the argument in little endian ordering.
The sign is not stored in the string.
*)
external of_bits: string -> t = "ml_z_of_bits"
(** Constructs a number from a binary string representation.
The string is interpreted as a sequence of bytes in little endian order,
and the result is always positive.
We have the identity: [of_bits (to_bits x) = abs x].
However, we can have [to_bits (of_bits s) <> s] due to the presence of
trailing zeros in s.
*)
(** {1 Pseudo-random number generation} *)
val random_int: ?rng: Random.State.t -> t -> t
(** [random_int bound] returns a random integer between 0 (inclusive)
and [bound] (exclusive). [bound] must be greater than 0.
The source of randomness is the {!Random} module from the OCaml
standard library. The optional [rng] argument specifies which
random state to use. If omitted, the default random state for the
{!Random} module is used.
Random numbers produced by this function are not cryptographically
strong and must not be used in cryptographic or high-security
contexts. See {!Z.random_int_gen} for an alternative.
@since 1.13
*)
val random_bits: ?rng: Random.State.t -> int -> t
(** [random_bits nbits] returns a random integer between 0 (inclusive)
and [2{^nbits}] (exclusive). [nbits] must be nonnegative.
This is a more efficient special case of {!Z.random_int} when the
bound is a power of two.
The source of randomness and the [rng] optional argument are as
described in {!Z.random_int}.
Random numbers produced by this function are not cryptographically
strong and must not be used in cryptographic or high-security
contexts. See {!Z.random_bits_gen} for an alternative.
@since 1.13
*)
val random_int_gen: fill: (bytes -> int -> int -> unit) -> t -> t
(** [random_int_gen ~fill bound] returns a random integer between 0 (inclusive)
and [bound] (exclusive). [bound] must be greater than 0.
The [fill] parameter is the source of randomness. It is called
as [fill buf pos len], and is responsible for drawing [len] random
bytes and writing them to offsets [pos] to [pos + len - 1] of
the byte array [buf].
Example of use where [/dev/random] provides the random bytes:
<<
In_channel.with_open_bin "/dev/random"
(fun ic -> Z.random_int_gen ~fill:(really_input ic) bound)
>>
Example of use where the Cryptokit library provides the random bytes:
<<
Z.random_int_gen ~fill:Cryptokit.Random.secure_rng#bytes bound
>>
@since 1.13
*)
val random_bits_gen: fill: (bytes -> int -> int -> unit) -> int -> t
(** [random_bits_gen ~fill nbits] returns a random integer between 0 (inclusive)
and [2{^nbits}] (exclusive). [nbits] must be nonnegative.
This is a more efficient special case of {!Z.random_int_gen} when the
bound is a power of two. The [fill] parameter is as described in
{!Z.random_int_gen}.
@since 1.13
*)
(** {1 Prefix and infix operators} *)
(**
Classic (and less classic) prefix and infix [int] operators are
redefined on [t].
This makes it easy to typeset expressions.
Using OCaml 3.12's local open, you can simply write
[Z.(~$2 + ~$5 * ~$10)].
*)
val (~-): t -> t
(** Negation [neg]. *)
val (~+): t -> t
(** Identity. *)
val (+): t -> t -> t
(** Addition [add]. *)
val (-): t -> t -> t
(** Subtraction [sub]. *)
val ( * ): t -> t -> t
(** Multiplication [mul]. *)
val (/): t -> t -> t
(** Truncated division [div]. *)
external (/>): t -> t -> t = "ml_z_cdiv"
(** Ceiling division [cdiv]. *)
external (/<): t -> t -> t = "ml_z_fdiv"
(** Flooring division [fdiv]. *)
val (/|): t -> t -> t
(** Exact division [divexact]. *)
val (mod): t -> t -> t
(** Remainder [rem]. *)
val (land): t -> t -> t
(** Bit-wise logical and [logand]. *)
val (lor): t -> t -> t
(** Bit-wise logical inclusive or [logor]. *)
val (lxor): t -> t -> t
(** Bit-wise logical exclusive or [logxor]. *)
val (~!): t -> t
(** Bit-wise logical negation [lognot]. *)
val (lsl): t -> int -> t
(** Bit-wise shift to the left [shift_left]. *)
val (asr): t -> int -> t
(** Bit-wise shift to the right [shift_right]. *)
external (~$): int -> t = "%identity"
(** Conversion from [int] [of_int]. *)
external ( ** ): t -> int -> t = "ml_z_pow"
(** Power [pow]. *)
module Compare : sig
val (=): t -> t -> bool
(** Same as [equal]. *)
val (<): t -> t -> bool
(** Same as [lt]. *)
val (>): t -> t -> bool
(** Same as [gt]. *)
val (<=): t -> t -> bool
(** Same as [leq]. *)
val (>=): t -> t -> bool
(** Same as [geq]. *)
val (<>): t -> t -> bool
(** [a <> b] is equivalent to [not (equal a b)]. *)
end
(** {1 Miscellaneous} *)
val version: string
(** Library version.
@since 1.1
*)
(**/**)
(** For internal use in module [Q]. *)
val round_to_float: t -> bool -> float

49
unikernel/duniverse/Zarith/z_mlgmpidl.ml Normal file
View file

@ -0,0 +1,49 @@
(**
Conversion between Zarith and MLGmpIDL integers and rationals.
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
external mlgmpidl_of_mpz: Mpz.t -> Z.t = "ml_z_mlgmpidl_of_mpz"
external mlgmpidl_set_mpz: Mpz.t -> Z.t -> unit = "ml_z_mlgmpidl_set_mpz"
let z_of_mpz x =
mlgmpidl_of_mpz x
let mpz_of_z x =
let r = Mpz.init () in
mlgmpidl_set_mpz r x;
r
let z_of_mpzf x =
z_of_mpz (Mpzf._mpz x)
let mpzf_of_z x =
Mpzf._mpzf (mpz_of_z x)
let q_of_mpq x =
let n,d = Mpz.init (), Mpz.init () in
Mpq.get_num n x;
Mpq.get_den d x;
Q.make (z_of_mpz n) (z_of_mpz d)
let mpq_of_q x =
Mpq.of_mpz2 (mpz_of_z x.Q.num) (mpz_of_z x.Q.den)
let q_of_mpqf x =
q_of_mpq (Mpqf._mpq x)
let mpqf_of_q x =
Mpqf._mpqf (mpq_of_q x)

26
unikernel/duniverse/Zarith/z_mlgmpidl.mli Normal file
View file

@ -0,0 +1,26 @@
(**
Conversion between Zarith and MLGmpIDL integers and rationals.
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*)
val z_of_mpz: Mpz.t -> Z.t
val mpz_of_z: Z.t -> Mpz.t
val z_of_mpzf: Mpzf.t -> Z.t
val mpzf_of_z: Z.t -> Mpzf.t
val q_of_mpq: Mpq.t -> Q.t
val mpq_of_q: Q.t -> Mpq.t
val q_of_mpqf: Mpqf.t -> Q.t
val mpqf_of_q: Q.t -> Mpqf.t

42
unikernel/duniverse/Zarith/zarith.h Normal file
View file

@ -0,0 +1,42 @@
/**
Public C interface for Zarith.
This is intended for C libraries that wish to convert between mpz_t and
Z.t objects.
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
a joint laboratory by:
CNRS (Centre national de la recherche scientifique, France),
ENS (École normale supérieure, Paris, France),
INRIA Rocquencourt (Institut national de recherche en informatique, France).
*/
/* gmp.h or mpir.h must be included manually before zarith.h */
#ifdef __cplusplus
extern "C" {
#endif
#include <caml/mlvalues.h>
/* sets rop to the value in op (limbs are copied) */
void ml_z_mpz_set_z(mpz_t rop, value op);
/* inits and sets rop to the value in op (limbs are copied) */
void ml_z_mpz_init_set_z(mpz_t rop, value op);
/* returns a new z objects equal to op (limbs are copied) */
value ml_z_from_mpz(mpz_t op);
#ifdef __cplusplus
}
#endif

29
unikernel/duniverse/Zarith/zarith.opam Normal file
View file

@ -0,0 +1,29 @@
version: "release-1.14-1-gdf8969d"
opam-version: "2.0"
maintainer: "Xavier Leroy <xavier.leroy@inria.fr>"
authors: [
"Antoine Miné"
"Xavier Leroy"
"Pascal Cuoq"
]
homepage: "https://github.com/mirage/Zarith"
bug-reports: "https://github.com/mirage/Zarith/issues"
dev-repo: "git+https://github.com/mirage/Zarith.git"
license: "LGPL-2.0-only WITH OCaml-LGPL-linking-exception"
build: [
["dune" "build" "-p" "zarith" ]
]
depends: [
"ocaml" {>= "4.07.0"}
"dune" {>= "2.8"}
("gmp" | "conf-gmp" )
]
conflicts: [ "gmp" {< "6.2.1-5"} ]
synopsis:
"Implements arithmetic and logical operations over arbitrary-precision integers"
description: """
The Zarith library implements arithmetic and logical operations over
arbitrary-precision integers. It uses GMP to efficiently implement
arithmetic over big integers. Small integers are represented as Caml
unboxed integers, for speed and space economy."""
tags: ["cross-compile"]

23
unikernel/duniverse/Zarith/zarith_top.ml Normal file
View file

@ -0,0 +1,23 @@
(*
This file is part of the Zarith library
http://forge.ocamlcore.org/projects/zarith .
It is distributed under LGPL 2 licensing, with static linking exception.
See the LICENSE file included in the distribution.
Contributed by Christophe Troestler.
*)
open Printf
let eval_string
?(print_outcome = false) ?(err_formatter = Format.err_formatter) str =
let lexbuf = Lexing.from_string str in
let phrase = !Toploop.parse_toplevel_phrase lexbuf in
Toploop.execute_phrase print_outcome err_formatter phrase
let () =
let printers = ["Z.pp_print"; "Q.pp_print"] in
let ok = List.fold_left (fun b p ->
b && eval_string(sprintf "#install_printer %s;;" p))
true printers in
if not ok then Format.eprintf "Problem installing ZArith-printers@."

77
unikernel/duniverse/angstrom/.github/workflows/test.yml vendored Normal file
View file

@ -0,0 +1,77 @@
name: build
on:
- push
- pull_request
jobs:
builds:
name: Earliest Supported Version
strategy:
fail-fast: false
matrix:
os:
- ubuntu-latest
ocaml-version:
- 4.04.0
runs-on: ${{ matrix.os }}
steps:
- name: Checkout code
uses: actions/checkout@v2
- name: Use OCaml ${{ matrix.ocaml-version }}
uses: avsm/setup-ocaml@v1
with:
ocaml-version: ${{ matrix.ocaml-version }}
- name: Deps
run: |
opam pin add -n angstrom .
opam install --deps-only angstrom
- name: Build
run: opam exec -- dune build -p angstrom
tests:
name: Tests
strategy:
fail-fast: false
matrix:
os:
- ubuntu-latest
ocaml-version:
- 4.08.1
- 4.10.2
- 4.11.2
- 4.12.0
runs-on: ${{ matrix.os }}
steps:
- name: Checkout code
uses: actions/checkout@v2
- name: Use OCaml ${{ matrix.ocaml-version }}
uses: avsm/setup-ocaml@v1
with:
ocaml-version: ${{ matrix.ocaml-version }}
- name: Deps
run: |
opam pin add -n angstrom .
opam pin add -n angstrom-async .
opam pin add -n angstrom-lwt-unix .
opam install -t --deps-only .
- name: Build
run: opam exec -- dune build
- name: Test
run: opam exec -- dune runtest
- name: Examples
run: |
opam install -t angstrom-async angstrom-lwt-unix
opam exec -- make examples

12
unikernel/duniverse/angstrom/.gitignore vendored Normal file
View file

@ -0,0 +1,12 @@
.*.sw[a-z]
*~
_build/
_tests/
lib_test/tests_
setup.log
setup.data
*.native
*.byte
*.docdir
*.install
.merlin

30
unikernel/duniverse/angstrom/LICENSE Normal file
View file

@ -0,0 +1,30 @@
Copyright (c) 2016, Inhabited Type LLC
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

16
unikernel/duniverse/angstrom/META.angstrom.template Normal file
View file

@ -0,0 +1,16 @@
# JBUILDER_GEN
package "unix" (
description = "Deprecated. Use angstrom-unix directly"
requires = "angstrom-unix"
)
package "lwt-unix" (
description = "Deprecated. Use angstrom-lwt-unix directly"
requires = "angstrom-lwt-unix"
)
package "async" (
description = "Deprecated. Use angstrom-async directly"
requires = "angstrom-async"
)

24
unikernel/duniverse/angstrom/Makefile Normal file
View file

@ -0,0 +1,24 @@
.PHONY: all build clean test install uninstall doc examples
build:
dune build
all: build
test:
dune runtest
examples:
dune build @examples
install:
dune install
uninstall:
dune uninstall
doc:
dune build @doc
clean:
rm -rf _build *.install

152
unikernel/duniverse/angstrom/README.md Normal file
View file

@ -0,0 +1,152 @@
# Angstrom
Angstrom is a parser-combinator library that makes it easy to write efficient,
expressive, and reusable parsers suitable for high-performance applications. It
exposes monadic and applicative interfaces for composition, and supports
incremental input through buffered and unbuffered interfaces. Both interfaces
give the user total control over the blocking behavior of their application,
with the unbuffered interface enabling zero-copy IO. Parsers are backtracking
by default and support unbounded lookahead.
[![Build Status](https://github.com/inhabitedtype/angstrom/workflows/build/badge.svg)](https://github.com/inhabitedtype/angstrom/actions?query=workflow%3A%22build%22)
## Installation
Install the library and its dependencies via [OPAM][opam]:
[opam]: http://opam.ocaml.org/
```bash
opam install angstrom
```
## Usage
Angstrom is written with network protocols and serialization formats in mind.
As such, its source distribution includes implementations of various RFCs that
are illustrative of real-world applications of the library. These include an
[HTTP parser][http] and a [JSON parser][json].
[http]: https://github.com/inhabitedtype/angstrom/blob/master/examples/rFC2616.ml
[json]: https://github.com/inhabitedtype/angstrom/blob/master/examples/rFC7159.ml
In addition, it is an informal tradition for OCaml parser-combinator libraries
to include in their READMEs a parser for a simple arithmetic expression
language. The code below implements a parser for such a language and computes
the numerical result of the expression as it is being parsed. Because Angstrom
is written with network protocols and serialization libraries in mind, it does
not include combinators for creating infix expression parsers. Such
combinators, e.g., `chainl1`, are nevertheless simple to define.
```ocaml
open Angstrom
let parens p = char '(' *> p <* char ')'
let add = char '+' *> return (+)
let sub = char '-' *> return (-)
let mul = char '*' *> return ( * )
let div = char '/' *> return (/)
let integer =
take_while1 (function '0' .. '9' -> true | _ -> false) >>| int_of_string
let chainl1 e op =
let rec go acc =
(lift2 (fun f x -> f acc x) op e >>= go) <|> return acc in
e >>= fun init -> go init
let expr : int t =
fix (fun expr ->
let factor = parens expr <|> integer in
let term = chainl1 factor (mul <|> div) in
chainl1 term (add <|> sub))
let eval (str:string) : int =
match parse_string ~consume:All expr str with
| Ok v -> v
| Error msg -> failwith msg
```
For an explanation of the infix operators and other combinators used in the
implementation of this example, see the documentation in the [`mli`][mli].
[mli]: https://github.com/inhabitedtype/angstrom/blob/master/lib/angstrom.mli
## Comparison to Other Libraries
There are several other parser-combinator libraries available for OCaml that
may suit your needs, and are worth considering. Most of them are derivatives of
or inspired by [Parsec][]. As such, they require the use of a `try` combinator
to achieve backtracking, rather than providing it by default. They also all use
something akin to a lazy character stream as the underlying input abstraction.
While this suits Haskell quite nicely, it requires blocking read calls when the
entire input is not immediately available&mdash;an approach that is inherently
incompatible with monadic concurrency libraries such as [Async] and [Lwt], and
writing high-performance, concurrent applications in general. Another
consequence of this approach to modeling and retrieving input is that the
parsers cannot iterate over sections of input in a tight loop, which adversely
affects performance.
Below is a table that compares the features of Angstrom against the those of
other parser-combinator libraries.
[parsec]: https://hackage.haskell.org/package/parsec
[async]: https://github.com/janestreet/async
[lwt]: https://ocsigen.org/lwt/
Feature \ Library | Angstrom | [mparser] | [planck] | [opal] |
------------------------------------|:--------:|:---------:|:--------:|:------:|
Monadic interface | ✅ | ✅ | ✅ | ✅ |
Backtracking by default | ✅ | ❌ | ❌ | ❌ |
Unbounded lookahead | ✅ | ✅ | ✅ | ❌ |
Reports line numbers in errors | ❌ | ✅ | ❌ | ❌ |
Efficient `take_while`/`skip_while` | ✅ | ❌ | ❌ | ❌ |
Unbuffered (zero-copy) interface | ✅ | ❌ | ❌ | ❌ |
Non-blocking incremental interface | ✅ | ❌ | ❌ | ❌ |
Async Support | ✅ | ❌ | ❌ | ❌ |
Lwt Support | ✅ | ❌ | ❌ | ❌ |
[mparser]: https://github.com/cakeplus/mparser
[opal]: https://github.com/pyrocat101/opal
[planck]: https://bitbucket.org/camlspotter/planck
## Development
To install development dependencies, pin the package from the root of the
repository:
```bash
opam pin add -n angstrom .
opam install --deps-only angstrom
```
After this, you may install a development version of the library using the
install command as usual.
For building and running the tests during development, you will need to install
the `alcotest` package:
```bash
opam install alcotest
make test
```
## Acknowledgements
This library started off as a direct port of the inimitable [attoparsec][]
library. While the original approach of continuation-passing still survives in
the source code, several modifications have been made in order to adapt the
ideas to OCaml, and in the process allow for more efficient memory usage and
integration with monadic concurrency libraries. This library will undoubtedly
diverge further as time goes on, but its name will stand as an homage to its
origin.
[attoparsec]: https://github.com/bos/attoparsec
## License
BSD3, see LICENSE file for its text.

20
unikernel/duniverse/angstrom/angstrom-async.opam Normal file
View file

@ -0,0 +1,20 @@
version: "0.16.1"
opam-version: "2.0"
maintainer: "Spiros Eliopoulos <spiros@inhabitedtype.com>"
authors: [ "Spiros Eliopoulos <spiros@inhabitedtype.com>" ]
license: "BSD-3-clause"
homepage: "https://github.com/inhabitedtype/angstrom"
bug-reports: "https://github.com/inhabitedtype/angstrom/issues"
dev-repo: "git+https://github.com/inhabitedtype/angstrom.git"
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
depends: [
"ocaml" {>= "4.04.1"}
"dune" {>= "1.8"}
"angstrom" {>= "0.9.0"}
"async" {>= "v0.10.0"}
]
synopsis: "Async support for Angstrom"

21
unikernel/duniverse/angstrom/angstrom-lwt-unix.opam Normal file
View file

@ -0,0 +1,21 @@
version: "0.16.1"
opam-version: "2.0"
maintainer: "Spiros Eliopoulos <spiros@inhabitedtype.com>"
authors: [ "Spiros Eliopoulos <spiros@inhabitedtype.com>" ]
license: "BSD-3-clause"
homepage: "https://github.com/inhabitedtype/angstrom"
bug-reports: "https://github.com/inhabitedtype/angstrom/issues"
dev-repo: "git+https://github.com/inhabitedtype/angstrom.git"
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
depends: [
"ocaml" {>= "4.03.0"}
"dune" {>= "1.8"}
"angstrom"
"lwt"
"base-unix"
]
synopsis: "Lwt_unix support for Angstrom"

20
unikernel/duniverse/angstrom/angstrom-unix.opam Normal file
View file

@ -0,0 +1,20 @@
version: "0.16.1"
opam-version: "2.0"
maintainer: "Spiros Eliopoulos <spiros@inhabitedtype.com>"
authors: [ "Spiros Eliopoulos <spiros@inhabitedtype.com>" ]
license: "BSD-3-clause"
homepage: "https://github.com/inhabitedtype/angstrom"
bug-reports: "https://github.com/inhabitedtype/angstrom/issues"
dev-repo: "git+https://github.com/inhabitedtype/angstrom.git"
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
depends: [
"ocaml" {>= "4.03.0"}
"dune" {>= "1.8"}
"angstrom"
"base-unix"
]
synopsis: "Unix support for Angstrom"

30
unikernel/duniverse/angstrom/angstrom.opam Normal file
View file

@ -0,0 +1,30 @@
version: "0.16.1"
opam-version: "2.0"
maintainer: "Spiros Eliopoulos <spiros@inhabitedtype.com>"
authors: [ "Spiros Eliopoulos <spiros@inhabitedtype.com>" ]
license: "BSD-3-clause"
homepage: "https://github.com/inhabitedtype/angstrom"
bug-reports: "https://github.com/inhabitedtype/angstrom/issues"
dev-repo: "git+https://github.com/inhabitedtype/angstrom.git"
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
depends: [
"ocaml" {>= "4.04.0"}
"dune" {>= "1.8"}
"alcotest" {with-test & >= "0.8.1"}
"bigstringaf"
"ppx_let" {with-test & >= "v0.14.0"}
"ocaml-syntax-shims" {build}
]
synopsis: "Parser combinators built for speed and memory-efficiency"
description: """
Angstrom is a parser-combinator library that makes it easy to write efficient,
expressive, and reusable parsers suitable for high-performance applications. It
exposes monadic and applicative interfaces for composition, and supports
incremental input through buffered and unbuffered interfaces. Both interfaces
give the user total control over the blocking behavior of their application,
with the unbuffered interface enabling zero-copy IO. Parsers are backtracking by
default and support unbounded lookahead."""

85
unikernel/duniverse/angstrom/async/angstrom_async.ml Normal file
View file

@ -0,0 +1,85 @@
(*----------------------------------------------------------------------------
Copyright (c) 2016 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
open Angstrom.Unbuffered
open Core
open Async
let empty_bigstring = Bigstring.create 0
let rec finalize state result =
(* It is very important to understand the assumptions that go into the second
* case. If execution reaches that case, then that means that the parser has
* commited all the way up to the last byte that was read by the reader, and
* the reader's internal buffer is empty. If the parser hadn't committed up
* to the last byte, then the reader buffer would not be empty and execution
* would hit the first case rather than the second.
*
* In other words, the second case looks wrong but it's not. *)
match state, result with
| Partial p, `Eof_with_unconsumed_data s ->
let bigstring = Bigstring.of_string s in
finalize (p.continue bigstring ~off:0 ~len:(String.length s) Complete) `Eof
| Partial p, `Eof ->
finalize (p.continue empty_bigstring ~off:0 ~len:0 Complete) `Eof
| Partial _, `Stopped () -> assert false
| (Done _ | Fail _) , _ -> state_to_result state
let response = function
| Partial p -> `Consumed(p.committed, `Need_unknown)
| Done(c, _) -> `Stop_consumed((), c)
| Fail _ -> `Stop ()
let default_pushback () = Deferred.unit
let parse ?(pushback=default_pushback) p reader =
let state = ref (parse p) in
let handle_chunk buf ~pos ~len =
begin match !state with
| Partial p ->
state := p.continue buf ~off:pos ~len Incomplete;
| Done _ | Fail _ -> ()
end;
pushback () >>| fun () -> response !state
in
Reader.read_one_chunk_at_a_time reader ~handle_chunk >>| fun result ->
finalize !state result
let async_many e k =
Angstrom.(skip_many (e <* commit >>| k) <?> "async_many")
let parse_many p write reader =
let wait = ref (default_pushback ()) in
let k x = wait := write x in
let pushback () = !wait in
parse ~pushback (async_many p k) reader

48
unikernel/duniverse/angstrom/async/angstrom_async.mli Normal file
View file

@ -0,0 +1,48 @@
(*----------------------------------------------------------------------------
Copyright (c) 2016 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
open Angstrom
open Async
val parse :
?pushback:(unit -> unit Deferred.t)
-> 'a t
-> Reader.t
-> ('a, string) result Deferred.t
val parse_many :
'a t
-> ('a -> unit Deferred.t)
-> Reader.t
-> (unit, string) result Deferred.t

5
unikernel/duniverse/angstrom/async/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name angstrom_async)
(public_name angstrom-async)
(flags :standard -safe-string)
(libraries angstrom async))

20
unikernel/duniverse/angstrom/benchmarks/async_benchmark.ml Normal file
View file

@ -0,0 +1,20 @@
open Async
let main parser () =
let toss _ = Deferred.unit in
let reader = Lazy.force Reader.stdin in
let parser =
match parser with
| `Http -> Angstrom.(RFC2616.request >>| fun x -> `Http x)
| `Json -> Angstrom.(RFC7159.json >>| fun x -> `Json x)
in
Angstrom_async.parse_many parser toss reader
>>| function
| Ok () -> ()
| Error err -> failwith err
;;
let () =
let parser = Command.Arg_type.of_alist_exn ["http", `Http; "json", `Json] in
Command.(async_spec ~summary:"async benchmark"
Spec.(empty +> Param.(anon ("PARSER" %: parser))) main |> run)

2
unikernel/duniverse/angstrom/benchmarks/data/ACKNOWLEDGEMENTS Normal file
View file

@ -0,0 +1,2 @@
Several of the data files in this directory were taken from the attoparsec
repository on GitHub. The source of twitter.json has been forgotten.

494
unikernel/duniverse/angstrom/benchmarks/data/http-requests.txt Normal file
View file

@ -0,0 +1,494 @@
GET / HTTP/1.1
Host: www.reddit.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
GET /reddit.v_EZwRzV-Ns.css HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: text/css,*/*;q=0.1
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /reddit-init.en-us.O1zuMqOOQvY.js HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: */*
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /reddit.en-us.31yAfSoTsfo.js HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: */*
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /kill.png HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /icon.png HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
GET /favicon.ico HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
GET /AMZM4CWd6zstSC8y.jpg HTTP/1.1
Host: b.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /jz1d5Nm0w97-YyNm.jpg HTTP/1.1
Host: b.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /aWGO99I6yOcNUKXB.jpg HTTP/1.1
Host: a.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /rZ_rD5TjrJM0E9Aj.css HTTP/1.1
Host: e.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: text/css,*/*;q=0.1
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /tmsPwagFzyTvrGRx.jpg HTTP/1.1
Host: a.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /KYgUaLvXCK3TCEJx.jpg HTTP/1.1
Host: a.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /81pzxT5x2ozuEaxX.jpg HTTP/1.1
Host: e.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /MFqCUiUVPO5V8t6x.jpg HTTP/1.1
Host: a.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /TFpYTiAO5aEowokv.jpg HTTP/1.1
Host: e.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /eMWMpmm9APNeNqcF.jpg HTTP/1.1
Host: e.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /S-IpsJrOKuaK9GZ8.jpg HTTP/1.1
Host: c.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /3V6dj9PDsNnheDXn.jpg HTTP/1.1
Host: c.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /wQ3-VmNXhv8sg4SJ.jpg HTTP/1.1
Host: c.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /ixd1C1njpczEWC22.jpg HTTP/1.1
Host: c.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /nGsQj15VyOHMwmq8.jpg HTTP/1.1
Host: c.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /zT4yQmDxQLbIxK1b.jpg HTTP/1.1
Host: c.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /L5e1HcZLv1iu4nrG.jpg HTTP/1.1
Host: f.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /WJFFPxD8X4JO_lIG.jpg HTTP/1.1
Host: f.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /hVMVTDdjuY3bQox5.jpg HTTP/1.1
Host: f.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /rnWf8CjBcyPQs5y_.jpg HTTP/1.1
Host: f.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /gZJL1jNylKbGV4d-.jpg HTTP/1.1
Host: d.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /aNd2zNRLXiMnKUFh.jpg HTTP/1.1
Host: c.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /droparrowgray.gif HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.redditstatic.com/reddit.v_EZwRzV-Ns.css
GET /sprite-reddit.an0Lnf61Ap4.png HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.redditstatic.com/reddit.v_EZwRzV-Ns.css
GET /ga.js HTTP/1.1
Host: www.google-analytics.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: */*
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
If-Modified-Since: Tue, 29 Oct 2013 19:33:51 GMT
GET /reddit/ads.html?sr=-reddit.com&bust2 HTTP/1.1
Host: static.adzerk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /pixel/of_destiny.png?v=hOlmDALJCWWdjzfBV4ZxJPmrdCLWB%2Ftq7Z%2Ffp4Q%2FxXbVPPREuMJMVGzKraTuhhNWxCCwi6yFEZg%3D&r=783333388 HTTP/1.1
Host: pixel.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /UNcO-h_QcS9PD-Gn.jpg HTTP/1.1
Host: c.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://e.thumbs.redditmedia.com/rZ_rD5TjrJM0E9Aj.css
GET /welcome-lines.png HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.redditstatic.com/reddit.v_EZwRzV-Ns.css
GET /welcome-upvote.png HTTP/1.1
Host: www.redditstatic.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.redditstatic.com/reddit.v_EZwRzV-Ns.css
GET /__utm.gif?utmwv=5.5.1&utms=1&utmn=720496082&utmhn=www.reddit.com&utme=8(site*srpath*usertype*uitype)9(%20reddit.com*%20reddit.com-GET_listing*guest*web)11(3!2)&utmcs=UTF-8&utmsr=2560x1600&utmvp=1288x792&utmsc=24-bit&utmul=en-us&utmje=1&utmfl=13.0%20r0&utmdt=reddit%3A%20the%20front%20page%20of%20the%20internet&utmhid=2129416330&utmr=-&utmp=%2F&utmht=1400862512705&utmac=UA-12131688-1&utmcc=__utma%3D55650728.585571751.1400862513.1400862513.1400862513.1%3B%2B__utmz%3D55650728.1400862513.1.1.utmcsr%3D(direct)%7Cutmccn%3D(direct)%7Cutmcmd%3D(none)%3B&utmu=qR~ HTTP/1.1
Host: www.google-analytics.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /ImnpOQhbXUPkwceN.png HTTP/1.1
Host: a.thumbs.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /ajax/libs/jquery/1.7.1/jquery.min.js HTTP/1.1
Host: ajax.googleapis.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: */*
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2
GET /__utm.gif?utmwv=5.5.1&utms=2&utmn=1493472678&utmhn=www.reddit.com&utmt=event&utme=5(AdBlock*enabled*false)(0)8(site*srpath*usertype*uitype)9(%20reddit.com*%20reddit.com-GET_listing*guest*web)11(3!2)&utmcs=UTF-8&utmsr=2560x1600&utmvp=1288x792&utmsc=24-bit&utmul=en-us&utmje=1&utmfl=13.0%20r0&utmdt=reddit%3A%20the%20front%20page%20of%20the%20internet&utmhid=2129416330&utmr=-&utmp=%2F&utmht=1400862512708&utmac=UA-12131688-1&utmni=1&utmcc=__utma%3D55650728.585571751.1400862513.1400862513.1400862513.1%3B%2B__utmz%3D55650728.1400862513.1.1.utmcsr%3D(direct)%7Cutmccn%3D(direct)%7Cutmcmd%3D(none)%3B&utmu=6R~ HTTP/1.1
Host: www.google-analytics.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /ados.js?q=43 HTTP/1.1
Host: secure.adzerk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: */*
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2
GET /fetch-trackers?callback=jQuery111005268222517967478_1400862512407&ids%5B%5D=t3_25jzeq-t8_k2ii&_=1400862512408 HTTP/1.1
Host: tracker.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: */*
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /ados?t=1400862512892&request={%22Placements%22:[{%22A%22:5146,%22S%22:24950,%22D%22:%22main%22,%22AT%22:5},{%22A%22:5146,%22S%22:24950,%22D%22:%22sponsorship%22,%22AT%22:8}],%22Keywords%22:%22-reddit.com%22,%22Referrer%22:%22http%3A%2F%2Fwww.reddit.com%2F%22,%22IsAsync%22:true,%22WriteResults%22:true} HTTP/1.1
Host: engine.adzerk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: */*
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2
GET /pixel/of_doom.png?id=t3_25jzeq-t8_k2ii&hash=da31d967485cdbd459ce1e9a5dde279fef7fc381&r=1738649500 HTTP/1.1
Host: pixel.redditmedia.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /Extensions/adFeedback.js HTTP/1.1
Host: static.adzrk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: */*
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2
GET /Extensions/adFeedback.css HTTP/1.1
Host: static.adzrk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: text/css,*/*;q=0.1
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2
GET /reddit/ads-load.html?bust2 HTTP/1.1
Host: static.adzerk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://www.reddit.com/
GET /Advertisers/a774d7d6148046efa89403a8db635a81.jpg HTTP/1.1
Host: static.adzerk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2
GET /i.gif?e=eyJhdiI6NjIzNTcsImF0Ijo1LCJjbSI6MTE2MzUxLCJjaCI6Nzk4NCwiY3IiOjMzNzAxNSwiZGkiOiI4NmI2Y2UzYWM5NDM0MjhkOTk2ZTg4MjYwZDE5ZTE1YyIsImRtIjoxLCJmYyI6NDE2MTI4LCJmbCI6MjEwNDY0LCJrdyI6Ii1yZWRkaXQuY29tIiwibWsiOiItcmVkZGl0LmNvbSIsIm53Ijo1MTQ2LCJwYyI6MCwicHIiOjIwMzYyLCJydCI6MSwicmYiOiJodHRwOi8vd3d3LnJlZGRpdC5jb20vIiwic3QiOjI0OTUwLCJ1ayI6InVlMS01ZWIwOGFlZWQ5YTc0MDFjOTE5NWNiOTMzZWI3Yzk2NiIsInRzIjoxNDAwODYyNTkzNjQ1fQ&s=lwlbFf2Uywt7zVBFRj_qXXu7msY HTTP/1.1
Host: engine.adzerk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2
Cookie: azk=ue1-5eb08aeed9a7401c9195cb933eb7c966
GET /BurstingPipe/adServer.bs?cn=tf&c=19&mc=imp&pli=9994987&PluID=0&ord=1400862593644&rtu=-1 HTTP/1.1
Host: bs.serving-sys.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads.html?sr=-reddit.com&bust2
GET /Advertisers/63cfd0044ffd49c0a71a6626f7a1d8f0.jpg HTTP/1.1
Host: static.adzerk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads-load.html?bust2
GET /BurstingPipe/adServer.bs?cn=tf&c=19&mc=imp&pli=9962555&PluID=0&ord=1400862593645&rtu=-1 HTTP/1.1
Host: bs.serving-sys.com
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads-load.html?bust2
Cookie: S_9994987=6754579095859875029; A4=01fmFvgRnI09SF00000; u2=d1263d39-874b-4a89-86cd-a2ab0860ed4e3Zl040
GET /i.gif?e=eyJhdiI6NjIzNTcsImF0Ijo4LCJjbSI6MTE2MzUxLCJjaCI6Nzk4NCwiY3IiOjMzNzAxOCwiZGkiOiI3OTdlZjU3OWQ5NjE0ODdiODYyMGMyMGJkOTE4YzNiMSIsImRtIjoxLCJmYyI6NDE2MTMxLCJmbCI6MjEwNDY0LCJrdyI6Ii1yZWRkaXQuY29tIiwibWsiOiItcmVkZGl0LmNvbSIsIm53Ijo1MTQ2LCJwYyI6MCwicHIiOjIwMzYyLCJydCI6MSwicmYiOiJodHRwOi8vd3d3LnJlZGRpdC5jb20vIiwic3QiOjI0OTUwLCJ1ayI6InVlMS01ZWIwOGFlZWQ5YTc0MDFjOTE5NWNiOTMzZWI3Yzk2NiIsInRzIjoxNDAwODYyNTkzNjQ2fQ&s=OjzxzXAgQksbdQOHNm-bjZcnZPA HTTP/1.1
Host: engine.adzerk.net
User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.8; rv:15.0) Gecko/20100101 Firefox/15.0.1
Accept: image/png,image/*;q=0.8,*/*;q=0.5
Accept-Language: en-us,en;q=0.5
Accept-Encoding: gzip, deflate
Connection: keep-alive
Referer: http://static.adzerk.net/reddit/ads-load.html?bust2
Cookie: azk=ue1-5eb08aeed9a7401c9195cb933eb7c966
GET /subscribe?host_int=1042356184&ns_map=571794054_374233948806,464381511_13349283399&user_id=245722467&nid=1399334269710011966&ts=1400862514 HTTP/1.1
Host: notify8.dropbox.com
Accept-Encoding: identity
Connection: keep-alive
X-Dropbox-Locale: en_US
User-Agent: DropboxDesktopClient/2.7.54 (Macintosh; 10.8; ('i32',); en_US)

6
unikernel/duniverse/angstrom/benchmarks/data/replicate Executable file
View file

@ -0,0 +1,6 @@
#!/usr/bin/env bash
# `replicate f n` creates a new file called `f.n` containing n copies of f.
for i in `seq 1 $2`; do
cat $1 >> $1.$2
done

15482
unikernel/duniverse/angstrom/benchmarks/data/twitter.json Normal file
View file

File diff suppressed because it is too large Load diff

1
unikernel/duniverse/angstrom/benchmarks/data/twitter1.json Normal file
View file

@ -0,0 +1 @@
{"results":[{"from_user_id_str":"80430860","profile_image_url":"http://a2.twimg.com/profile_images/536455139/icon32_normal.png","created_at":"Wed, 26 Jan 2011 07:07:02 +0000","from_user":"kazu_yamamoto","id_str":"30159761706061824","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Haskell Server Pages \u3063\u3066\u3001\u307e\u3060\u7d9a\u3044\u3066\u3044\u305f\u306e\u304b\uff01","id":30159761706061824,"from_user_id":80430860,"geo":null,"iso_language_code":"no","to_user_id_str":null,"source":"&lt;a href=&quot;http://twitter.com/&quot;&gt;web&lt;/a&gt;"}],"max_id":30159761706061824,"since_id":0,"refresh_url":"?since_id=30159761706061824&q=haskell","next_page":"?page=2&max_id=30159761706061824&rpp=1&q=haskell","results_per_page":1,"page":1,"completed_in":0.012606,"since_id_str":"0","max_id_str":"30159761706061824","query":"haskell"}

1
unikernel/duniverse/angstrom/benchmarks/data/twitter10.json Normal file
View file

File diff suppressed because one or more lines are too long

1
unikernel/duniverse/angstrom/benchmarks/data/twitter20.json Normal file
View file

File diff suppressed because one or more lines are too long

14
unikernel/duniverse/angstrom/benchmarks/dune Normal file
View file

@ -0,0 +1,14 @@
(executables
(libraries angstrom core_bench threads RFC2616 RFC7159)
(modules pure_benchmark)
(names pure_benchmark))
(executables
(libraries angstrom-async RFC2616 RFC7159)
(modules async_benchmark)
(names async_benchmark))
(executables
(libraries angstrom-lwt-unix RFC2616 RFC7159)
(modules lwt_benchmark)
(names lwt_benchmark))

18
unikernel/duniverse/angstrom/benchmarks/lwt_benchmark.ml Normal file
View file

@ -0,0 +1,18 @@
open Lwt
let main () =
let toss _ = Lwt.return_unit in
let parser =
match Sys.argv.(1) with
| "http" -> Angstrom.(RFC2616.request >>| fun x -> `Http x)
| "json" -> Angstrom.(RFC7159.json >>| fun x -> `Json x)
| _ -> print_endline "usage: lwt_json_benchmark.native PARSER"; exit 1
in
Lwt_io.resize_buffer Lwt_io.stdin 0x10000 >>= fun () ->
Angstrom_lwt_unix.parse_many parser toss Lwt_io.stdin
>|= function
| _, Ok () -> ()
| _, Error err -> failwith err
;;
Lwt_main.run (main ())

125
unikernel/duniverse/angstrom/benchmarks/pure_benchmark.ml Normal file
View file

@ -0,0 +1,125 @@
open Core
open Core_bench
let read file =
let open Unix in
let size = Int64.to_int_exn (stat file).st_size in
let buf = Bytes.create size in
let rec loop pos len fd =
let n = read ~pos ~len ~buf fd in
if n > 0 then loop (pos + n) (len - n) fd
in
with_file ~mode:[O_RDONLY] file ~f:(fun fd ->
loop 0 size fd);
Bigstring.of_bytes buf
;;
let zero =
let len = 65_536 in
Bigstring.of_string (String.make len '\x00')
;;
let make_bench name parser contents =
Bench.Test.create ~name (fun () ->
match Angstrom.(parse_bigstring ~consume:Consume.Prefix parser contents) with
| Ok _ -> ()
| Error err -> failwith err)
;;
let make_endian name p = make_bench name (Angstrom.skip_many p) zero
let make_json name contents = make_bench name RFC7159.json contents
let make_http name contents = make_bench name (Angstrom.skip_many RFC2616.request) contents
(* For input files involving trailing numbers, .e.g, [http-requests.txt.100],
* go into the [benchmarks/data] directory and use the [replicate] script to
* generate the file, i.e.,
*
* [./replicate http-requests.txt 100]
*
*)
let main () =
let twitter1 = read "benchmarks/data/twitter1.json" in
let twitter10 = read "benchmarks/data/twitter10.json" in
let twitter20 = read "benchmarks/data/twitter20.json" in
let twitter_big = read "benchmarks/data/twitter.json" in
let http_get = read "benchmarks/data/http-requests.txt.100" in
let json =
Bench.make_command [
make_json "twitter1" twitter1;
make_json "twitter10" twitter10;
make_json "twitter20" twitter20;
make_json "twitter-big" twitter_big;
]
in
let endian =
Bench.make_command [
make_endian "int64 le" Angstrom.LE.any_int64;
make_endian "int64 be" Angstrom.BE.any_int64;
]
in
let http =
Bench.make_command [ make_http "http" http_get ]
in
let numbers =
Bench.make_command [
Bench.Test.create ~name:"float" (fun () ->
float_of_string "1.7242915150166418e+36");
Bench.Test.create ~name:"int" (fun () ->
int_of_string "172429151501664");
Bench.Test.create ~name:"int-float" (fun () ->
float_of_string "172429151501664");
]
in
let characters =
let contents = Bigstring.of_string "a" in
let open Angstrom in
Bench.make_command [
make_bench "peek_char_fail" peek_char_fail contents;
make_bench "any_char" any_char contents;
make_bench "char" (char 'a') contents;
make_bench "not_char" (not_char 'b') contents;
make_bench "advance 1" (advance 1) contents;
]
in
let loops =
let contents = Bigstring.of_string (String.make 1024 'a') in
let open Angstrom in
Bench.make_command [
make_bench "skip_while true" (skip_while (fun _ -> true)) contents;
make_bench "take_while true" (take_while (fun _ -> true)) contents;
make_bench "take_while1 true" (take_while1 (fun _ -> true)) contents;
make_bench "many any_char " (many any_char) contents;
]
in
let short_strings =
let contents = Bigstring.of_string "\r\n\r\n\r\n" in
let old_style_be (n : int) =
Angstrom.(BE.any_int16 >>= fun i -> if i = n then return () else fail "not newline") in
Bench.make_command [
make_bench "string \"\\r\\n\"" (Angstrom.string "\r\n") contents;
make_bench "BE.any_int16 >>= f" (old_style_be 0x0d0a) contents;
make_bench "BE.int16 0x0d0a" (Angstrom.BE.int16 0x0d0a) contents;
make_bench "LE.int16 0x0a0d" (Angstrom.LE.int16 0x0a0d) contents;
]
in
let http_version =
let contents = Bigstring.of_string "HTTP/" in
Bench.make_command [
make_bench "string \"HTTP/\"" (Angstrom.string "HTTP/") contents;
make_bench "BE.int32 *> char" (Angstrom.(BE.int32 0x48545450l *> char '/')) contents;
make_bench "LE.int32 *> char" (Angstrom.(LE.int32 0x50545448l *> char '/')) contents;
]
in
Command.run
(Command.group ~summary:"various angstrom benchmarks"
[ "json" , json
; "endian" , endian
; "http" , http
; "numbers" , numbers
; "characters" , characters
; "loops" , loops
; "short-strings", short_strings
; "http-version" , http_version
])
let () = main ()

2
unikernel/duniverse/angstrom/dune-project Normal file
View file

@ -0,0 +1,2 @@
(lang dune 1.8)
(name angstrom)

16
unikernel/duniverse/angstrom/examples/dune Normal file
View file

@ -0,0 +1,16 @@
(library
(name RFC7159)
(wrapped false)
(modules RFC7159)
(libraries angstrom))
(library
(name RFC2616)
(wrapped false)
(modules RFC2616)
(libraries angstrom))
;; Build bytecode library just to make sure this compiles
(alias
(name examples)
(deps RFC7159.cma RFC2616.cma))

76
unikernel/duniverse/angstrom/examples/rFC2616.ml Normal file
View file

@ -0,0 +1,76 @@
open Angstrom
module P = struct
let is_space =
function | ' ' | '\t' -> true | _ -> false
let is_eol =
function | '\r' | '\n' -> true | _ -> false
let is_hex =
function | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false
let is_digit =
function '0' .. '9' -> true | _ -> false
let is_separator =
function
| ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"'
| '/' | '[' | ']' | '?' | '=' | '{' | '}' | ' ' | '\t' -> true
| _ -> false
let is_token =
(* The commented-out ' ' and '\t' are not necessary because of the range at
* the top of the match. *)
function
| '\000' .. '\031' | '\127'
| ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"'
| '/' | '[' | ']' | '?' | '=' | '{' | '}' (* | ' ' | '\t' *) -> false
| _ -> true
end
let token = take_while1 P.is_token
let digits = take_while1 P.is_digit
let spaces = skip_while P.is_space
let lex p = p <* spaces
let version =
string "HTTP/" *>
lift2 (fun major minor -> major, minor)
(digits <* char '.')
digits
let uri =
take_till P.is_space
let meth = token
let eol = string "\r\n"
let request_first_line =
lift3 (fun meth uri version -> (meth, uri, version))
(lex meth)
(lex uri)
version
let response_first_line =
lift3 (fun version status msg -> (version, status, msg))
(lex version)
(lex (take_till P.is_space))
(take_till P.is_eol)
let header =
let colon = char ':' <* spaces in
lift2 (fun key value -> (key, value))
token
(colon *> take_till P.is_eol)
let request =
lift2 (fun (meth, uri, version) headers -> (meth, uri, version, headers))
(request_first_line <* eol)
(many (header <* eol) <* eol)
let response =
lift2 (fun (version, status, msg) headers -> (version, status, msg, headers))
(response_first_line <* eol)
(many (header <* eol) <* eol)

169
unikernel/duniverse/angstrom/examples/rFC7159.ml Normal file
View file

@ -0,0 +1,169 @@
open Angstrom
type json =
[ `Null
| `False
| `True
| `String of string
| `Number of float
| `Object of (string * json) list
| `Array of json list ]
let ws = skip_while (function
| '\x20' | '\x0a' | '\x0d' | '\x09' -> true
| _ -> false)
let lchar c =
ws *> char c
let rsb = lchar ']'
let rcb = lchar '}'
let ns, vs = lchar ':', lchar ','
let quo = lchar '"'
let _false : json t = string "false" *> return `False
let _true : json t = string "true" *> return `True
let _null : json t = string "null" *> return `Null
let num =
take_while1 (function
| '\x20' | '\x0a' | '\x0d' | '\x09'
| '[' | ']' | '{' | '}' | ':' | ',' -> false
| _ -> true)
>>= fun s ->
try return (`Number (float_of_string s))
with _ -> fail "number"
module S = struct
type t =
[ `Unescaped
| `Escaped
| `UTF8 of char list
| `UTF16 of int * [`S | `U | `C of char list]
| `Error of string
| `Done ]
let to_string : [`Terminate | t] -> string = function
| `Unescaped -> "unescaped"
| `Escaped -> "escaped"
| `UTF8 _ -> "utf-8 _"
| `UTF16 _ -> "utf-16 _ _"
| `Error e -> Printf.sprintf "error %S" e
| `Terminate -> "terminate"
| `Done -> "done"
let unescaped buf = function
| '"' -> `Terminate
| '\\' -> `Escaped
| c ->
if c <= '\031'
then `Error (Printf.sprintf "unexpected character '%c'" c)
else begin Buffer.add_char buf c; `Unescaped end
let escaped buf = function
| '\x22' -> Buffer.add_char buf '\x22'; `Unescaped
| '\x5c' -> Buffer.add_char buf '\x5c'; `Unescaped
| '\x2f' -> Buffer.add_char buf '\x2f'; `Unescaped
| '\x62' -> Buffer.add_char buf '\x08'; `Unescaped
| '\x66' -> Buffer.add_char buf '\x0c'; `Unescaped
| '\x6e' -> Buffer.add_char buf '\x0a'; `Unescaped
| '\x72' -> Buffer.add_char buf '\x0d'; `Unescaped
| '\x74' -> Buffer.add_char buf '\x09'; `Unescaped
| '\x75' -> `UTF8 []
| _ -> `Error "invalid escape sequence"
let hex c =
match c with
| '0' .. '9' -> Char.code c - 0x30 (* '0' *)
| 'a' .. 'f' -> Char.code c - 87
| 'A' .. 'F' -> Char.code c - 55
| _ -> 255
let utf_8 buf d = function
| [c;b;a] ->
let a = hex a and b = hex b and c = hex c and d = hex d in
if a lor b lor c lor d = 255 then
`Error "invalid hex escape"
else
let cp = (a lsl 12) lor (b lsl 8) lor (c lsl 4) lor d in
if cp >= 0xd800 && cp <= 0xdbff then
`UTF16(cp, `S)
else begin
Buffer.add_char buf (Char.unsafe_chr (0b11100000 lor ((cp lsr 12) land 0b00001111)));
Buffer.add_char buf (Char.unsafe_chr (0b10000000 lor ((cp lsr 6) land 0b00111111)));
Buffer.add_char buf (Char.unsafe_chr (0b10000000 lor (cp land 0b00111111)));
`Unescaped
end
| cs -> `UTF8 (d::cs)
let utf_16 buf d x s =
match s, d with
| `S , '\\' -> `UTF16(x, `U)
| `U , 'u' -> `UTF16(x, `C [])
| `C [c;b;a], _ ->
let a = hex a and b = hex b and c = hex c and d = hex d in
if a lor b lor c lor d = 255 then
`Error "invalid hex escape"
else
let y = (a lsl 12) lor (b lsl 8) lor (c lsl 4) lor d in
if y >= 0xdc00 && y <= 0xdfff then begin
let hi = x - 0xd800 in
let lo = y - 0xdc00 in
let cp = 0x10000 + ((hi lsl 10) lor lo) in
Buffer.add_char buf (Char.unsafe_chr (0b11110000 lor ((cp lsr 18) land 0b00000111)));
Buffer.add_char buf (Char.unsafe_chr (0b10000000 lor ((cp lsr 12) land 0b00111111)));
Buffer.add_char buf (Char.unsafe_chr (0b10000000 lor ((cp lsr 6) land 0b00111111)));
Buffer.add_char buf (Char.unsafe_chr (0b10000000 lor (cp land 0b00111111)));
`Unescaped
end else
`Error "invalid escape sequence for utf-16 low surrogate"
| `C cs, _ -> `UTF16(x, `C (d::cs))
| _, _ -> `Error "invalid escape sequence for utf-16 low surrogate"
let str buf =
let state : t ref = ref `Unescaped in
skip_while (fun c ->
match
begin match !state with
| `Unescaped -> unescaped buf c
| `Escaped -> escaped buf c
| `UTF8 cs -> utf_8 buf c cs
| `UTF16(x, cs) -> utf_16 buf c x cs
| (`Error _ | `Done) as state -> state
end
with
| (`Error _) | `Done -> false
| `Terminate -> state := `Done; true
| #t as state' -> state := state'; true)
>>= fun () ->
match !state with
| `Done ->
let result = Buffer.contents buf in
Buffer.clear buf;
state := `Unescaped;
return result
| `Error msg ->
Buffer.clear buf; state := `Unescaped; fail msg
| `Unescaped | `Escaped | `UTF8 _ | `UTF16 _ ->
Buffer.clear buf; state := `Unescaped; fail "unterminated string"
end
let json =
let advance1 = advance 1 in
let pair x y = (x, y) in
let buf = Buffer.create 0x1000 in
let str = S.str buf in
fix (fun json ->
let mem = lift2 pair (quo *> str <* ns) json in
let obj = advance1 *> sep_by vs mem <* rcb >>| fun ms -> `Object ms in
let arr = advance1 *> sep_by vs json <* rsb >>| fun vs -> `Array vs in
let str = advance1 *> str >>| fun s -> `String s in
ws *> peek_char_fail
>>= function
| 'f' -> _false
| 'n' -> _null
| 't' -> _true
| '{' -> obj
| '[' -> arr
| '"' -> str
| _ -> num) <?> "json"

749
unikernel/duniverse/angstrom/lib/angstrom.ml Normal file
View file

@ -0,0 +1,749 @@
(*----------------------------------------------------------------------------
Copyright (c) 2016 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
module Bigarray = struct
(* Do not access Bigarray operations directly. If anything's needed, refer to
* the internal Bigstring module. *)
end
type bigstring = Bigstringaf.t
module Unbuffered = struct
include Parser
include Exported_state
type more = More.t =
| Complete
| Incomplete
end
include Unbuffered
include Parser.Monad
include Parser.Choice
module Buffered = struct
type unconsumed = Buffering.unconsumed =
{ buf : bigstring
; off : int
; len : int }
type input =
[ `Bigstring of bigstring
| `String of string ]
type 'a state =
| Partial of ([ input | `Eof ] -> 'a state)
| Done of unconsumed * 'a
| Fail of unconsumed * string list * string
let from_unbuffered_state ~f buffering = function
| Unbuffered.Partial p -> Partial (f p)
| Unbuffered.Done(consumed, v) ->
let unconsumed = Buffering.unconsumed ~shift:consumed buffering in
Done(unconsumed, v)
| Unbuffered.Fail(consumed, marks, msg) ->
let unconsumed = Buffering.unconsumed ~shift:consumed buffering in
Fail(unconsumed, marks, msg)
let parse ?(initial_buffer_size=0x1000) p =
if initial_buffer_size < 1 then
failwith "parse: invalid argument, initial_buffer_size < 1";
let buffering = Buffering.create initial_buffer_size in
let rec f p input =
Buffering.shift buffering p.committed;
let more : More.t =
match input with
| `Eof -> Complete
| #input as input ->
Buffering.feed_input buffering input;
Incomplete
in
let for_reading = Buffering.for_reading buffering in
p.continue for_reading ~off:0 ~len:(Bigstringaf.length for_reading) more
|> from_unbuffered_state buffering ~f
in
Unbuffered.parse p
|> from_unbuffered_state buffering ~f
let feed state input =
match state with
| Partial k -> k input
| Fail(unconsumed, marks, msg) ->
begin match input with
| `Eof -> state
| #input as input ->
let buffering = Buffering.of_unconsumed unconsumed in
Buffering.feed_input buffering input;
Fail(Buffering.unconsumed buffering, marks, msg)
end
| Done(unconsumed, v) ->
begin match input with
| `Eof -> state
| #input as input ->
let buffering = Buffering.of_unconsumed unconsumed in
Buffering.feed_input buffering input;
Done(Buffering.unconsumed buffering, v)
end
let state_to_option = function
| Done(_, v) -> Some v
| Partial _ -> None
| Fail _ -> None
let state_to_result = function
| Partial _ -> Error "incomplete input"
| Done(_, v) -> Ok v
| Fail(_, marks, msg) -> Error (Unbuffered.fail_to_string marks msg)
let state_to_unconsumed = function
| Done(unconsumed, _)
| Fail(unconsumed, _, _) -> Some unconsumed
| Partial _ -> None
end
(** BEGIN: getting input *)
let rec prompt input pos fail succ =
(* [prompt] should only call [succ] if it has received more input. If there
* is no chance that the input will grow, i.e., [more = Complete], then
* [prompt] should call [fail]. Otherwise (in the case where the input
* hasn't grown but [more = Incomplete] just prompt again. *)
let parser_uncommitted_bytes = Input.parser_uncommitted_bytes input in
let parser_committed_bytes = Input.parser_committed_bytes input in
(* The continuation should not hold any references to input above. *)
let continue input ~off ~len more =
if len < parser_uncommitted_bytes then
failwith "prompt: input shrunk!";
let input = Input.create input ~off ~len ~committed_bytes:parser_committed_bytes in
if len = parser_uncommitted_bytes then
match (more : More.t) with
| Complete -> fail input pos More.Complete
| Incomplete -> prompt input pos fail succ
else
succ input pos more
in
State.Partial { committed = Input.bytes_for_client_to_commit input; continue }
let demand_input =
{ run = fun input pos more fail succ ->
match (more : More.t) with
| Complete -> fail input pos more [] "not enough input"
| Incomplete ->
let succ' input' pos' more' = succ input' pos' more' ()
and fail' input' pos' more' = fail input' pos' more' [] "not enough input" in
prompt input pos fail' succ'
}
let ensure_suspended n input pos more fail succ =
let rec go =
{ run = fun input' pos' more' fail' succ' ->
if pos' + n <= Input.length input' then
succ' input' pos' more' ()
else
(demand_input *> go).run input' pos' more' fail' succ'
}
in
(demand_input *> go).run input pos more fail succ
let unsafe_apply len ~f =
{ run = fun input pos more _fail succ ->
succ input (pos + len) more (Input.apply input pos len ~f)
}
let unsafe_apply_opt len ~f =
{ run = fun input pos more fail succ ->
match Input.apply input pos len ~f with
| Error e -> fail input pos more [] e
| Ok x -> succ input (pos + len) more x
}
let ensure n p =
{ run = fun input pos more fail succ ->
if pos + n <= Input.length input
then p.run input pos more fail succ
else
let succ' input' pos' more' () = p.run input' pos' more' fail succ in
ensure_suspended n input pos more fail succ' }
(** END: getting input *)
let at_end_of_input =
{ run = fun input pos more _ succ ->
if pos < Input.length input then
succ input pos more false
else match more with
| Complete -> succ input pos more true
| Incomplete ->
let succ' input' pos' more' = succ input' pos' more' false
and fail' input' pos' more' = succ input' pos' more' true in
prompt input pos fail' succ'
}
let end_of_input =
at_end_of_input
>>= function
| true -> return ()
| false -> fail "end_of_input"
let advance n =
if n < 0
then fail "advance"
else
let p =
{ run = fun input pos more _fail succ -> succ input (pos + n) more () }
in
ensure n p
let pos =
{ run = fun input pos more _fail succ -> succ input pos more pos }
let available =
{ run = fun input pos more _fail succ ->
succ input pos more (Input.length input - pos)
}
let commit =
{ run = fun input pos more _fail succ ->
Input.commit input pos;
succ input pos more () }
(* Do not use this if [p] contains a [commit]. *)
let unsafe_lookahead p =
{ run = fun input pos more fail succ ->
let succ' input' _ more' v = succ input' pos more' v in
p.run input pos more fail succ' }
let peek_char =
{ run = fun input pos more _fail succ ->
if pos < Input.length input then
succ input pos more (Some (Input.unsafe_get_char input pos))
else if more = Complete then
succ input pos more None
else
let succ' input' pos' more' =
succ input' pos' more' (Some (Input.unsafe_get_char input' pos'))
and fail' input' pos' more' =
succ input' pos' more' None in
prompt input pos fail' succ'
}
(* This parser is too important to not be optimized. Do a custom job. *)
let rec peek_char_fail =
{ run = fun input pos more fail succ ->
if pos < Input.length input
then succ input pos more (Input.unsafe_get_char input pos)
else
let succ' input' pos' more' () =
peek_char_fail.run input' pos' more' fail succ in
ensure_suspended 1 input pos more fail succ' }
let satisfy f =
{ run = fun input pos more fail succ ->
if pos < Input.length input then
let c = Input.unsafe_get_char input pos in
if f c
then succ input (pos + 1) more c
else Printf.ksprintf (fail input pos more []) "satisfy: %C" c
else
let succ' input' pos' more' () =
let c = Input.unsafe_get_char input' pos' in
if f c
then succ input' (pos' + 1) more' c
else Printf.ksprintf (fail input' pos' more' []) "satisfy: %C" c
in
ensure_suspended 1 input pos more fail succ' }
let char c =
let p =
{ run = fun input pos more fail succ ->
if Input.unsafe_get_char input pos = c
then succ input (pos + 1) more c
else fail input pos more [] (Printf.sprintf "char %C" c) }
in
ensure 1 p
let not_char c =
let p =
{ run = fun input pos more fail succ ->
let c' = Input.unsafe_get_char input pos in
if c <> c'
then succ input (pos + 1) more c'
else fail input pos more [] (Printf.sprintf "not char %C" c) }
in
ensure 1 p
let any_char =
let p =
{ run = fun input pos more _fail succ ->
succ input (pos + 1) more (Input.unsafe_get_char input pos) }
in
ensure 1 p
let int8 i =
let p =
{ run = fun input pos more fail succ ->
let c = Char.code (Input.unsafe_get_char input pos) in
if c = i land 0xff
then succ input (pos + 1) more c
else fail input pos more [] (Printf.sprintf "int8 %d" i) }
in
ensure 1 p
let any_uint8 =
let p =
{ run = fun input pos more _fail succ ->
let c = Input.unsafe_get_char input pos in
succ input (pos + 1) more (Char.code c) }
in
ensure 1 p
let any_int8 =
(* https://graphics.stanford.edu/~seander/bithacks.html#VariableSignExtendRisky *)
let s = Sys.int_size - 8 in
let p =
{ run = fun input pos more _fail succ ->
let c = Input.unsafe_get_char input pos in
succ input (pos + 1) more ((Char.code c lsl s) asr s) }
in
ensure 1 p
let skip f =
let p =
{ run = fun input pos more fail succ ->
if f (Input.unsafe_get_char input pos)
then succ input (pos + 1) more ()
else fail input pos more [] "skip" }
in
ensure 1 p
let rec count_while ~init ~f ~with_buffer =
{ run = fun input pos more fail succ ->
let len = Input.count_while input (pos + init) ~f in
let input_len = Input.length input in
let init' = init + len in
(* Check if the loop terminated because it reached the end of the input
* buffer. If so, then prompt for additional input and continue. *)
if pos + init' < input_len || more = Complete
then succ input (pos + init') more (Input.apply input pos init' ~f:with_buffer)
else
let succ' input' pos' more' =
(count_while ~init:init' ~f ~with_buffer).run input' pos' more' fail succ
and fail' input' pos' more' =
succ input' (pos' + init') more' (Input.apply input' pos' init' ~f:with_buffer)
in
prompt input pos fail' succ'
}
let rec count_while1 ~f ~with_buffer =
{ run = fun input pos more fail succ ->
let len = Input.count_while input pos ~f in
let input_len = Input.length input in
(* Check if the loop terminated because it reached the end of the input
* buffer. If so, then prompt for additional input and continue. *)
if len < 1
then
if pos < input_len || more = Complete
then fail input pos more [] "count_while1"
else
let succ' input' pos' more' =
(count_while1 ~f ~with_buffer).run input' pos' more' fail succ
and fail' input' pos' more' =
fail input' pos' more' [] "count_while1"
in
prompt input pos fail' succ'
else if pos + len < input_len || more = Complete
then succ input (pos + len) more (Input.apply input pos len ~f:with_buffer)
else
let succ' input' pos' more' =
(count_while ~init:len ~f ~with_buffer).run input' pos' more' fail succ
and fail' input' pos' more' =
succ input' (pos' + len) more' (Input.apply input' pos' len ~f:with_buffer)
in
prompt input pos fail' succ'
}
let string_ f s =
(* XXX(seliopou): Inefficient. Could check prefix equality to short-circuit
* the io. *)
let len = String.length s in
ensure len (unsafe_apply_opt len ~f:(fun buffer ~off ~len ->
let i = ref 0 in
while !i < len && Char.equal (f (Bigstringaf.unsafe_get buffer (off + !i)))
(f (String.unsafe_get s !i))
do
incr i
done;
if len = !i
then Ok (Bigstringaf.substring buffer ~off ~len)
else Error "string"))
let string s = string_ (fun x -> x) s
let string_ci s = string_ Char.lowercase_ascii s
let skip_while f =
count_while ~init:0 ~f ~with_buffer:(fun _ ~off:_ ~len:_ -> ())
let take n =
if n < 0
then fail "take: n < 0"
else
let n = max n 0 in
ensure n (unsafe_apply n ~f:Bigstringaf.substring)
let take_bigstring n =
if n < 0
then fail "take_bigstring: n < 0"
else
let n = max n 0 in
ensure n (unsafe_apply n ~f:Bigstringaf.copy)
let take_bigstring_while f =
count_while ~init:0 ~f ~with_buffer:Bigstringaf.copy
let take_bigstring_while1 f =
count_while1 ~f ~with_buffer:Bigstringaf.copy
let take_bigstring_till f =
take_bigstring_while (fun c -> not (f c))
let peek_string n =
unsafe_lookahead (take n)
let take_while f =
count_while ~init:0 ~f ~with_buffer:Bigstringaf.substring
let take_while1 f =
count_while1 ~f ~with_buffer:Bigstringaf.substring
let take_till f =
take_while (fun c -> not (f c))
let choice ?(failure_msg="no more choices") ps =
List.fold_right (<|>) ps (fail failure_msg)
let notset = { run = fun _buf _pos _more _fail _succ -> failwith "Angstrom.fix_direct not set" }
let fix_direct f =
let rec p = ref notset
and r = { run = fun buf pos more fail succ ->
(!p).run buf pos more fail succ }
in
p := f r;
r
let fix_lazy ~max_steps f =
let steps = ref max_steps in
let rec p = lazy (f r)
and r = { run = fun buf pos more fail succ ->
decr steps;
if !steps < 0
then (
steps := max_steps;
State.Lazy (lazy ((Lazy.force p).run buf pos more fail succ)))
else
(Lazy.force p).run buf pos more fail succ
}
in
r
let fix = match Sys.backend_type with
| Native -> fix_direct
| Bytecode -> fix_direct
| Other _ -> fun f -> fix_lazy ~max_steps:20 f
let option x p =
p <|> return x
let cons x xs = x :: xs
let rec list ps =
match ps with
| [] -> return []
| p::ps -> lift2 cons p (list ps)
let count n p =
if n < 0
then fail "count: n < 0"
else
let rec loop = function
| 0 -> return []
| n -> lift2 cons p (loop (n - 1))
in
loop n
let many p =
fix (fun m ->
(lift2 cons p m) <|> return [])
let many1 p =
lift2 cons p (many p)
let many_till p t =
fix (fun m ->
(t *> return []) <|> (lift2 cons p m))
let sep_by1 s p =
fix (fun m ->
lift2 cons p ((s *> m) <|> return []))
let sep_by s p =
(lift2 cons p ((s *> sep_by1 s p) <|> return [])) <|> return []
let skip_many p =
fix (fun m ->
((p >>| fun _ -> true) <|> return false) >>= function
| true -> m
| false -> return ()
)
let skip_many1 p =
p *> skip_many p
let end_of_line =
(char '\n' *> return ()) <|> (string "\r\n" *> return ()) <?> "end_of_line"
let scan_ state f ~with_buffer =
{ run = fun input pos more fail succ ->
let state = ref state in
let parser =
count_while ~init:0 ~f:(fun c ->
match f !state c with
| None -> false
| Some state' -> state := state'; true)
~with_buffer
>>| fun x -> x, !state
in
parser.run input pos more fail succ }
let scan state f =
scan_ state f ~with_buffer:Bigstringaf.substring
let scan_state state f =
scan_ state f ~with_buffer:(fun _ ~off:_ ~len:_ -> ())
>>| fun ((), state) -> state
let scan_string state f =
scan state f >>| fst
let consume_with p f =
{ run = fun input pos more fail succ ->
let start = pos in
let parser_committed_bytes = Input.parser_committed_bytes input in
let succ' input' pos' more' _ =
if parser_committed_bytes <> Input.parser_committed_bytes input'
then fail input' pos' more' [] "consumed: parser committed"
else (
let len = pos' - start in
let consumed = Input.apply input' start len ~f in
succ input' pos' more' consumed)
in
p.run input pos more fail succ'
}
let consumed p = consume_with p Bigstringaf.substring
let consumed_bigstring p = consume_with p Bigstringaf.copy
let both a b = lift2 (fun a b -> a, b) a b
let map t ~f = t >>| f
let bind t ~f = t >>= f
let map2 a b ~f = lift2 f a b
let map3 a b c ~f = lift3 f a b c
let map4 a b c d ~f = lift4 f a b c d
module Let_syntax = struct
let return = return
let ( >>| ) = ( >>| )
let ( >>= ) = ( >>= )
module Let_syntax = struct
let return = return
let map = map
let bind = bind
let both = both
let map2 = map2
let map3 = map3
let map4 = map4
end
end
let ( let+ ) = ( >>| )
let ( let* ) = ( >>= )
let ( and+ ) = both
module BE = struct
(* XXX(seliopou): The pattern in both this module and [LE] are a compromise
* between efficiency and code reuse. By inlining [ensure] you can recover
* about 2 nanoseconds on average. That may add up in certain applications.
*
* This pattern does not allocate in the fast (success) path.
* *)
let int16 n =
let bytes = 2 in
let p =
{ run = fun input pos more fail succ ->
if Input.unsafe_get_int16_be input pos = (n land 0xffff)
then succ input (pos + bytes) more ()
else fail input pos more [] "BE.int16" }
in
ensure bytes p
let int32 n =
let bytes = 4 in
let p =
{ run = fun input pos more fail succ ->
if Int32.equal (Input.unsafe_get_int32_be input pos) n
then succ input (pos + bytes) more ()
else fail input pos more [] "BE.int32" }
in
ensure bytes p
let int64 n =
let bytes = 8 in
let p =
{ run = fun input pos more fail succ ->
if Int64.equal (Input.unsafe_get_int64_be input pos) n
then succ input (pos + bytes) more ()
else fail input pos more [] "BE.int64" }
in
ensure bytes p
let any_uint16 =
ensure 2 (unsafe_apply 2 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int16_be bs off))
let any_int16 =
ensure 2 (unsafe_apply 2 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int16_sign_extended_be bs off))
let any_int32 =
ensure 4 (unsafe_apply 4 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int32_be bs off))
let any_int64 =
ensure 8 (unsafe_apply 8 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int64_be bs off))
let any_float =
ensure 4 (unsafe_apply 4 ~f:(fun bs ~off ~len:_ -> Int32.float_of_bits (Bigstringaf.unsafe_get_int32_be bs off)))
let any_double =
ensure 8 (unsafe_apply 8 ~f:(fun bs ~off ~len:_ -> Int64.float_of_bits (Bigstringaf.unsafe_get_int64_be bs off)))
end
module LE = struct
let int16 n =
let bytes = 2 in
let p =
{ run = fun input pos more fail succ ->
if Input.unsafe_get_int16_le input pos = (n land 0xffff)
then succ input (pos + bytes) more ()
else fail input pos more [] "LE.int16" }
in
ensure bytes p
let int32 n =
let bytes = 4 in
let p =
{ run = fun input pos more fail succ ->
if Int32.equal (Input.unsafe_get_int32_le input pos) n
then succ input (pos + bytes) more ()
else fail input pos more [] "LE.int32" }
in
ensure bytes p
let int64 n =
let bytes = 8 in
let p =
{ run = fun input pos more fail succ ->
if Int64.equal (Input.unsafe_get_int64_le input pos) n
then succ input (pos + bytes) more ()
else fail input pos more [] "LE.int64" }
in
ensure bytes p
let any_uint16 =
ensure 2 (unsafe_apply 2 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int16_le bs off))
let any_int16 =
ensure 2 (unsafe_apply 2 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int16_sign_extended_le bs off))
let any_int32 =
ensure 4 (unsafe_apply 4 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int32_le bs off))
let any_int64 =
ensure 8 (unsafe_apply 8 ~f:(fun bs ~off ~len:_ -> Bigstringaf.unsafe_get_int64_le bs off))
let any_float =
ensure 4 (unsafe_apply 4 ~f:(fun bs ~off ~len:_ -> Int32.float_of_bits (Bigstringaf.unsafe_get_int32_le bs off)))
let any_double =
ensure 8 (unsafe_apply 8 ~f:(fun bs ~off ~len:_ -> Int64.float_of_bits (Bigstringaf.unsafe_get_int64_le bs off)))
end
module Unsafe = struct
let take n f =
let n = max n 0 in
ensure n (unsafe_apply n ~f)
let peek n f =
unsafe_lookahead (take n f)
let take_while check f =
count_while ~init:0 ~f:check ~with_buffer:f
let take_while1 check f =
count_while1 ~f:check ~with_buffer:f
let take_till check f =
take_while (fun c -> not (check c)) f
end
module Consume = struct
type t =
| Prefix
| All
end
let parse_bigstring ~consume p bs =
let p =
match (consume : Consume.t) with
| Prefix -> p
| All -> p <* end_of_input
in
Unbuffered.parse_bigstring p bs
let parse_string ~consume p s =
let len = String.length s in
let bs = Bigstringaf.create len in
Bigstringaf.unsafe_blit_from_string s ~src_off:0 bs ~dst_off:0 ~len;
parse_bigstring ~consume p bs

688
unikernel/duniverse/angstrom/lib/angstrom.mli Normal file
View file

@ -0,0 +1,688 @@
(*----------------------------------------------------------------------------
Copyright (c) 2016 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
(** Parser combinators built for speed and memory-efficiency.
Angstrom is a parser-combinator library that provides monadic and
applicative interfaces for constructing parsers with unbounded lookahead.
Its parsers can consume input incrementally, whether in a blocking or
non-blocking environment. To achieve efficient incremental parsing,
Angstrom offers both a buffered and unbuffered interface to input streams,
with the {!module:Unbuffered} interface enabling zero-copy IO. With these
features and low-level iteration parser primitives like {!take_while} and
{!skip_while}, Angstrom makes it easy to write efficient, expressive, and
reusable parsers suitable for high-performance applications. *)
type +'a t
(** A parser for values of type ['a]. *)
type bigstring = Bigstringaf.t
(** {2 Basic parsers} *)
val peek_char : char option t
(** [peek_char] accepts any char and returns it, or returns [None] if the end
of input has been reached.
This parser does not advance the input. Use it for lookahead. *)
val peek_char_fail : char t
(** [peek_char_fail] accepts any char and returns it. If end of input has been
reached, it will fail.
This parser does not advance the input. Use it for lookahead. *)
val peek_string : int -> string t
(** [peek_string n] accepts exactly [n] characters and returns them as a
string. If there is not enough input, it will fail.
This parser does not advance the input. Use it for lookahead. *)
val char : char -> char t
(** [char c] accepts [c] and returns it. *)
val not_char : char -> char t
(** [not_char] accepts any character that is not [c] and returns the matched
character. *)
val any_char : char t
(** [any_char] accepts any character and returns it. *)
val satisfy : (char -> bool) -> char t
(** [satisfy f] accepts any character for which [f] returns [true] and
returns the accepted character. In the case that none of the parser
succeeds, then the parser will fail indicating the offending
character. *)
val string : string -> string t
(** [string s] accepts [s] exactly and returns it. *)
val string_ci : string -> string t
(** [string_ci s] accepts [s], ignoring case, and returns the matched string,
preserving the case of the original input. *)
val skip : (char -> bool) -> unit t
(** [skip f] accepts any character for which [f] returns [true] and discards
the accepted character. [skip f] is equivalent to [satisfy f] but discards
the accepted character. *)
val skip_while : (char -> bool) -> unit t
(** [skip_while f] accepts input as long as [f] returns [true] and discards
the accepted characters. *)
val take : int -> string t
(** [take n] accepts exactly [n] characters of input and returns them as a
string. *)
val take_while : (char -> bool) -> string t
(** [take_while f] accepts input as long as [f] returns [true] and returns the
accepted characters as a string.
This parser does not fail. If [f] returns [false] on the first character,
it will return the empty string. *)
val take_while1 : (char -> bool) -> string t
(** [take_while1 f] accepts input as long as [f] returns [true] and returns the
accepted characters as a string.
This parser requires that [f] return [true] for at least one character of
input, and will fail otherwise. *)
val take_till : (char -> bool) -> string t
(** [take_till f] accepts input as long as [f] returns [false] and returns the
accepted characters as a string.
This parser does not fail. If [f] returns [true] on the first character, it
will return the empty string. *)
val consumed : _ t -> string t
(** [consumed p] runs [p] and returns the contents that were consumed during the
parsing as a string *)
val take_bigstring : int -> bigstring t
(** [take_bigstring n] accepts exactly [n] characters of input and returns them
as a newly allocated bigstring. *)
val take_bigstring_while : (char -> bool) -> bigstring t
(** [take_bigstring_while f] accepts input as long as [f] returns [true] and
returns the accepted characters as a newly allocated bigstring.
This parser does not fail. If [f] returns [false] on the first character,
it will return the empty bigstring. *)
val take_bigstring_while1 : (char -> bool) -> bigstring t
(** [take_bigstring_while1 f] accepts input as long as [f] returns [true] and
returns the accepted characters as a newly allocated bigstring.
This parser requires that [f] return [true] for at least one character of
input, and will fail otherwise. *)
val take_bigstring_till : (char -> bool) -> bigstring t
(** [take_bigstring_till f] accepts input as long as [f] returns [false] and
returns the accepted characters as a newly allocated bigstring.
This parser does not fail. If [f] returns [true] on the first character, it
will return the empty bigstring. *)
val consumed_bigstring : _ t -> bigstring t
(** [consumed p] runs [p] and returns the contents that were consumed during the
parsing as a bigstring *)
val advance : int -> unit t
(** [advance n] advances the input [n] characters, failing if the remaining
input is less than [n]. *)
val end_of_line : unit t
(** [end_of_line] accepts either a line feed [\n], or a carriage return
followed by a line feed [\r\n] and returns unit. *)
val at_end_of_input : bool t
(** [at_end_of_input] returns whether the end of the end of input has been
reached. This parser always succeeds. *)
val end_of_input : unit t
(** [end_of_input] succeeds if all the input has been consumed, and fails
otherwise. *)
val scan : 'state -> ('state -> char -> 'state option) -> (string * 'state) t
(** [scan init f] consumes until [f] returns [None]. Returns the final state
before [None] and the accumulated string *)
val scan_state : 'state -> ('state -> char -> 'state option) -> 'state t
(** [scan_state init f] is like {!scan} but only returns the final state before
[None]. Much more efficient than {!scan}. *)
val scan_string : 'state -> ('state -> char -> 'state option) -> string t
(** [scan_string init f] is like {!scan} but discards the final state and returns
the accumulated string. *)
val int8 : int -> int t
(** [int8 i] accepts one byte that matches the lower-order byte of [i] and
returns unit. *)
val any_uint8 : int t
(** [any_uint8] accepts any byte and returns it as an unsigned int8. *)
val any_int8 : int t
(** [any_int8] accepts any byte and returns it as a signed int8. *)
(** Big endian parsers *)
module BE : sig
val int16 : int -> unit t
(** [int16 i] accept two bytes that match the two lower order bytes of [i]
and returns unit. *)
val int32 : int32 -> unit t
(** [int32 i] accept four bytes that match the four bytes of [i]
and returns unit. *)
val int64 : int64 -> unit t
(** [int64 i] accept eight bytes that match the eight bytes of [i] and
returns unit. *)
val any_int16 : int t
val any_int32 : int32 t
val any_int64 : int64 t
(** [any_intN] reads [N] bits and interprets them as big endian signed integers. *)
val any_uint16 : int t
(** [any_uint16] reads [16] bits and interprets them as a big endian unsigned
integer. *)
val any_float : float t
(** [any_float] reads 32 bits and interprets them as a big endian floating
point value. *)
val any_double : float t
(** [any_double] reads 64 bits and interprets them as a big endian floating
point value. *)
end
(** Little endian parsers *)
module LE : sig
val int16 : int -> unit t
(** [int16 i] accept two bytes that match the two lower order bytes of [i]
and returns unit. *)
val int32 : int32 -> unit t
(** [int32 i] accept four bytes that match the four bytes of [i]
and returns unit. *)
val int64 : int64 -> unit t
(** [int32 i] accept eight bytes that match the eight bytes of [i] and
returns unit. *)
val any_int16 : int t
val any_int32 : int32 t
val any_int64 : int64 t
(** [any_intN] reads [N] bits and interprets them as little endian signed
integers. *)
val any_uint16 : int t
(** [uint16] reads [16] bits and interprets them as a little endian unsigned
integer. *)
val any_float : float t
(** [any_float] reads 32 bits and interprets them as a little endian floating
point value. *)
val any_double : float t
(** [any_double] reads 64 bits and interprets them as a little endian floating
point value. *)
end
(** {2 Combinators} *)
val option : 'a -> 'a t -> 'a t
(** [option v p] runs [p], returning the result of [p] if it succeeds and [v]
if it fails. *)
val both : 'a t -> 'b t -> ('a * 'b) t
(** [both p q] runs [p] followed by [q] and returns both results in a tuple *)
val list : 'a t list -> 'a list t
(** [list ps] runs each [p] in [ps] in sequence, returning a list of results of
each [p]. *)
val count : int -> 'a t -> 'a list t
(** [count n p] runs [p] [n] times, returning a list of the results. *)
val many : 'a t -> 'a list t
(** [many p] runs [p] {i zero} or more times and returns a list of results from
the runs of [p]. *)
val many1 : 'a t -> 'a list t
(** [many1 p] runs [p] {i one} or more times and returns a list of results from
the runs of [p]. *)
val many_till : 'a t -> _ t -> 'a list t
(** [many_till p e] runs parser [p] {i zero} or more times until action [e]
succeeds and returns the list of result from the runs of [p]. *)
val sep_by : _ t -> 'a t -> 'a list t
(** [sep_by s p] runs [p] {i zero} or more times, interspersing runs of [s] in between. *)
val sep_by1 : _ t -> 'a t -> 'a list t
(** [sep_by1 s p] runs [p] {i one} or more times, interspersing runs of [s] in between. *)
val skip_many : _ t -> unit t
(** [skip_many p] runs [p] {i zero} or more times, discarding the results. *)
val skip_many1 : _ t -> unit t
(** [skip_many1 p] runs [p] {i one} or more times, discarding the results. *)
val fix : ('a t -> 'a t) -> 'a t
(** [fix f] computes the fixpoint of [f] and runs the resultant parser. The
argument that [f] receives is the result of [fix f], which [f] must use,
paradoxically, to define [fix f].
[fix] is useful when constructing parsers for inductively-defined types
such as sequences, trees, etc. Consider for example the implementation of
the {!many} combinator defined in this library:
{[let many p =
fix (fun m ->
(cons <$> p <*> m) <|> return [])]}
[many p] is a parser that will run [p] zero or more times, accumulating the
result of every run into a list, returning the result. It's defined by
passing [fix] a function. This function assumes its argument [m] is a
parser that behaves exactly like [many p]. You can see this in the
expression comprising the left hand side of the alternative operator
[<|>]. This expression runs the parser [p] followed by the parser [m], and
after which the result of [p] is cons'd onto the list that [m] produces.
The right-hand side of the alternative operator provides a base case for
the combinator: if [p] fails and the parse cannot proceed, return an empty
list.
Another way to illustrate the uses of [fix] is to construct a JSON parser.
Assuming that parsers exist for the basic types such as [false], [true],
[null], strings, and numbers, the question then becomes how to define a
parser for objects and arrays? Both contain values that are themselves JSON
values, so it seems as though it's impossible to write a parser that will
accept JSON objects and arrays before writing a parser for JSON values as a
whole.
This is the exact situation that [fix] was made for. By defining the
parsers for arrays and objects within the function that you pass to [fix],
you will gain access to a parser that you can use to parse JSON values, the
very parser you are defining!
{[let json =
fix (fun json ->
let arr = char '[' *> sep_by (char ',') json <* char ']' in
let obj = char '{' *> ... json ... <* char '}' in
choice [str; num; arr json, ...])]} *)
(** [fix_lazy] is like [fix], but after the function reaches [max_steps]
deep, it wraps up the remaining computation and yields
back to the root of the parsing loop where it continues from there.
This is an effective way to break up the stack trace into more managable
chunks, which is important for Js_of_ocaml due to the lack of tailrec
optimizations for CPS-style tail calls. When compiling for Js_of_ocaml,
[fix] itself is defined as [fix_lazy ~max_steps:20]. *)
val fix_lazy : max_steps:int -> ('a t -> 'a t) -> 'a t
(** {2 Alternatives} *)
val (<|>) : 'a t -> 'a t -> 'a t
(** [p <|> q] runs [p] and returns the result if succeeds. If [p] fails, then
the input will be reset and [q] will run instead. *)
val choice : ?failure_msg:string -> 'a t list -> 'a t
(** [choice ?failure_msg ts] runs each parser in [ts] in order until one
succeeds and returns that result. In the case that none of the parser
succeeds, then the parser will fail with the message [failure_msg], if
provided, or a much less informative message otherwise. *)
val (<?>) : 'a t -> string -> 'a t
(** [p <?> name] associates [name] with the parser [p], which will be reported
in the case of failure. *)
val commit : unit t
(** [commit] prevents backtracking beyond the current position of the input,
allowing the manager of the input buffer to reuse the preceding bytes for
other purposes.
The {!module:Unbuffered} parsing interface will report directly to the
caller the number of bytes committed to the when returning a
{!Unbuffered.state.Partial} state, allowing the caller to reuse those bytes
for any purpose. The {!module:Buffered} will keep track of the region of
committed bytes in its internal buffer and reuse that region to store
additional input when necessary. *)
(** {2 Monadic/Applicative interface} *)
val return : 'a -> 'a t
(** [return v] creates a parser that will always succeed and return [v] *)
val fail : string -> _ t
(** [fail msg] creates a parser that will always fail with the message [msg] *)
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
(** [p >>= f] creates a parser that will run [p], pass its result to [f], run
the parser that [f] produces, and return its result. *)
val bind : 'a t -> f:('a -> 'b t) -> 'b t
(** [bind] is a prefix version of [>>=] *)
val (>>|) : 'a t -> ('a -> 'b) -> 'b t
(** [p >>| f] creates a parser that will run [p], and if it succeeds with
result [v], will return [f v] *)
val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
(** [f <*> p] is equivalent to [f >>= fun f -> p >>| f]. *)
val (<$>) : ('a -> 'b) -> 'a t -> 'b t
(** [f <$> p] is equivalent to [p >>| f] *)
val ( *>) : _ t -> 'a t -> 'a t
(** [p *> q] runs [p], discards its result and then runs [q], and returns its
result. *)
val (<* ) : 'a t -> _ t -> 'a t
(** [p <* q] runs [p], then runs [q], discards its result, and returns the
result of [p]. *)
val lift : ('a -> 'b) -> 'a t -> 'b t
val lift2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
val lift3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t
val lift4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a t -> 'b t -> 'c t -> 'd t -> 'e t
(** The [liftn] family of functions promote functions to the parser monad.
For any of these functions, the following equivalence holds:
{[liftn f p1 ... pn = f <$> p1 <*> ... <*> pn]}
These functions are more efficient than using the applicative interface
directly, mostly in terms of memory allocation but also in terms of speed.
Prefer them over the applicative interface, even when the arity of the
function to be lifted exceeds the maximum [n] for which there is an
implementation for [liftn]. In other words, if [f] has an arity of [5] but
only [lift4] is provided, do the following:
{[lift4 f m1 m2 m3 m4 <*> m5]}
Even with the partial application, it will be more efficient than the
applicative implementation. *)
val map : 'a t -> f:('a -> 'b) -> 'b t
val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
val map3 : 'a t -> 'b t -> 'c t -> f:('a -> 'b -> 'c -> 'd) -> 'd t
val map4 : 'a t -> 'b t -> 'c t -> 'd t -> f:('a -> 'b -> 'c -> 'd -> 'e) -> 'e t
(** The [mapn] family of functions are just like [liftn], with a slightly
different interface. *)
(** The [Let_syntax] module is intended to be used with the [ppx_let]
pre-processor, and just contains copies of functions described elsewhere. *)
module Let_syntax : sig
val return : 'a -> 'a t
val ( >>| ) : 'a t -> ('a -> 'b) -> 'b t
val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
module Let_syntax : sig
val return : 'a -> 'a t
val map : 'a t -> f:('a -> 'b) -> 'b t
val bind : 'a t -> f:('a -> 'b t) -> 'b t
val both : 'a t -> 'b t -> ('a * 'b) t
val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t
val map3 : 'a t -> 'b t -> 'c t -> f:('a -> 'b -> 'c -> 'd) -> 'd t
val map4 : 'a t -> 'b t -> 'c t -> 'd t -> f:('a -> 'b -> 'c -> 'd -> 'e) -> 'e t
end
end
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
(** Unsafe Operations on Angstrom's Internal Buffer
These functions are considered {b unsafe} as they expose the input buffer
to client code without any protections against modification, or leaking
references. They are exposed to support performance-sensitive parsers that
want to avoid allocation at all costs. Client code should take care to
write the input buffer callback functions such that they:
{ul
{- do not modify the input buffer {i outside} of the range
[\[off, off + len)];}
{- do not modify the input buffer {i inside} of the range
[\[off, off + len)] if the parser might backtrack; and}
{- do not return any direct or indirect references to the input buffer.}}
If the input buffer callback functions do not do any of these things, then
the client may consider their use safe. *)
module Unsafe : sig
val take : int -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [take n f] accepts exactly [n] characters of input into the parser's
internal buffer then calls [f buffer ~off ~len]. [buffer] is the
parser's internal buffer. [off] is the offset from the start of [buffer]
containing the requested content. [len] is the length of the requested
content. [len] is guaranteed to be equal to [n]. *)
val take_while : (char -> bool) -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [take_while check f] accepts input into the parser's interal buffer as
long as [check] returns [true] then calls [f buffer ~off ~len]. [buffer]
is the parser's internal buffer. [off] is the offset from the start of
[buffer] containing the requested content. [len] is the length of the
content matched by [check].
This parser does not fail. If [check] returns [false] on the first
character, [len] will be [0]. *)
val take_while1 : (char -> bool) -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [take_while1 check f] accepts input into the parser's interal buffer as
long as [check] returns [true] then calls [f buffer ~off ~len]. [buffer]
is the parser's internal buffer. [off] is the offset from the start of
[buffer] containing the requested content. [len] is the length of the
content matched by [check].
This parser requires that [f] return [true] for at least one character of
input, and will fail otherwise. *)
val take_till : (char -> bool) -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [take_till check f] accepts input into the parser's interal buffer as
long as [check] returns [false] then calls [f buffer ~off ~len]. [buffer]
is the parser's internal buffer. [off] is the offset from the start of
[buffer] containing the requested content. [len] is the length of the
content matched by [check].
This parser does not fail. If [check] returns [true] on the first
character, [len] will be [0]. *)
val peek : int -> (bigstring -> off:int -> len:int -> 'a) -> 'a t
(** [peek n ~f] accepts exactly [n] characters and calls [f buffer ~off ~len]
with [len = n]. If there is not enough input, it will fail.
This parser does not advance the input. Use it for lookahead. *)
end
(** {2 Running} *)
module Consume : sig
type t =
| Prefix
| All
end
val parse_bigstring : consume:Consume.t -> 'a t -> bigstring -> ('a, string) result
(** [parse_bigstring ~consume t bs] runs [t] on [bs]. The parser will receive
an [`Eof] after all of [bs] has been consumed. Passing {!Prefix} in the
[consume] argument allows the parse to successfully complete without
reaching eof. To require the parser to reach eof, pass {!All} in the
[consume] argument.
For use-cases requiring that the parser be fed input incrementally, see the
{!module:Buffered} and {!module:Unbuffered} modules below. *)
val parse_string : consume:Consume.t -> 'a t -> string -> ('a, string) result
(** [parse_string ~consume t bs] runs [t] on [bs]. The parser will receive an
[`Eof] after all of [bs] has been consumed. Passing {!Prefix} in the
[consume] argument allows the parse to successfully complete without
reaching eof. To require the parser to reach eof, pass {!All} in the
[consume] argument.
For use-cases requiring that the parser be fed input incrementally, see the
{!module:Buffered} and {!module:Unbuffered} modules below. *)
(** Buffered parsing interface.
Parsers run through this module perform internal buffering of input. The
parser state will keep track of unconsumed input and attempt to minimize
memory allocation and copying. The {!Buffered.state.Partial} parser state
will accept newly-read, incremental input and copy it into the internal
buffer. Users can feed parser states using the {!feed} function. As a
result, the interface is much easier to use than the one exposed by the
{!Unbuffered} module.
On success or failure, any unconsumed input will be returned to the user
for additional processing. The buffer that the unconsumed input is returned
in can also be reused. *)
module Buffered : sig
type unconsumed =
{ buf : bigstring
; off : int
; len : int }
type input =
[ `Bigstring of bigstring
| `String of string ]
type 'a state =
| Partial of ([ input | `Eof ] -> 'a state) (** The parser requires more input. *)
| Done of unconsumed * 'a (** The parser succeeded. *)
| Fail of unconsumed * string list * string (** The parser failed. *)
val parse : ?initial_buffer_size:int -> 'a t -> 'a state
(** [parse ?initial_buffer_size t] runs [t] and awaits input if needed.
[parse] will allocate a buffer of size [initial_buffer_size] (defaulting
to 4k bytes) to do input buffering and automatically grows the buffer as
needed. *)
val feed : 'a state -> [ input | `Eof ] -> 'a state
(** [feed state input] supplies the parser state with more input. If [state] is
[Partial], then parsing will continue where it left off. Otherwise, the
parser is in a [Fail] or [Done] state, in which case the [input] will be
copied into the state's buffer for later use by the caller. *)
val state_to_option : 'a state -> 'a option
(** [state_to_option state] returns [Some v] if the parser is in the
[Done (bs, v)] state and [None] otherwise. This function has no effect on
the current state of the parser. *)
val state_to_result : 'a state -> ('a, string) result
(** [state_to_result state] returns [Ok v] if the parser is in the [Done (bs, v)]
state and [Error msg] if it is in the [Fail] or [Partial] state.
This function has no effect on the current state of the parser. *)
val state_to_unconsumed : _ state -> unconsumed option
(** [state_to_unconsumed state] returns [Some bs] if [state = Done(bs, _)] or
[state = Fail(bs, _, _)] and [None] otherwise. *)
end
(** Unbuffered parsing interface.
Use this module for total control over memory allocation and copying.
Parsers run through this module perform no internal buffering. Instead, the
user is responsible for managing a buffer containing the entirety of the
input that has yet to be consumed by the parser. The
{!Unbuffered.state.Partial} parser state reports to the user how much input
the parser consumed during its last run, via the
{!Unbuffered.partial.committed} field. This area of input must be discarded
before parsing can resume. Once additional input has been collected, the
unconsumed input as well as new input must be passed to the parser state
via the {!Unbuffered.partial.continue} function, together with an
indication of whether there is {!Unbuffered.more} input to come.
The logic that must be implemented in order to make proper use of this
module is intricate and tied to your OS environment. It's advisable to use
the {!Buffered} module when initially developing and testing your parsers.
For production use-cases, consider the Async and Lwt support that this
library includes before attempting to use this module directly. *)
module Unbuffered : sig
type more =
| Complete
| Incomplete
type 'a state =
| Partial of 'a partial (** The parser requires more input. *)
| Done of int * 'a (** The parser succeeded, consuming specified bytes. *)
| Fail of int * string list * string (** The parser failed, consuming specified bytes. *)
and 'a partial =
{ committed : int
(** The number of bytes committed during the last input feeding.
Callers must drop this number of bytes from the beginning of the
input on subsequent calls. See {!commit} for additional details. *)
; continue : bigstring -> off:int -> len:int -> more -> 'a state
(** A continuation of a parse that requires additional input. The input
should include all uncommitted input (as reported by previous partial
states) in addition to any new input that has become available, as
well as an indication of whether there is {!more} input to come. *)
}
val parse : 'a t -> 'a state
(** [parse t] runs [t] and await input if needed. *)
val state_to_option : 'a state -> 'a option
(** [state_to_option state] returns [Some v] if the parser is in the
[Done (bs, v)] state and [None] otherwise. This function has no effect on the
current state of the parser. *)
val state_to_result : 'a state -> ('a, string) result
(** [state_to_result state] returns [Ok v] if the parser is in the
[Done (bs, v)] state and [Error msg] if it is in the [Fail] or [Partial]
state.
This function has no effect on the current state of the parser. *)
end
(** {2 Expert Parsers}
For people that know what they're doing. If you want to use them, read the
code. No further documentation will be provided. *)
val pos : int t
val available : int t

88
unikernel/duniverse/angstrom/lib/buffering.ml Normal file
View file

@ -0,0 +1,88 @@
type t =
{ mutable buf : Bigstringaf.t
; mutable off : int
; mutable len : int }
let of_bigstring ~off ~len buf =
assert (off >= 0);
assert (Bigstringaf.length buf >= len - off);
{ buf; off; len }
let create len =
of_bigstring ~off:0 ~len:0 (Bigstringaf.create len)
let writable_space t =
Bigstringaf.length t.buf - t.len
let trailing_space t =
Bigstringaf.length t.buf - (t.off + t.len)
let compress t =
Bigstringaf.unsafe_blit t.buf ~src_off:t.off t.buf ~dst_off:0 ~len:t.len;
t.off <- 0
let grow t to_copy =
let old_len = Bigstringaf.length t.buf in
let new_len = ref old_len in
let space = writable_space t in
while space + !new_len - old_len < to_copy do
new_len := (3 * !new_len) / 2
done;
let new_buf = Bigstringaf.create !new_len in
Bigstringaf.unsafe_blit t.buf ~src_off:t.off new_buf ~dst_off:0 ~len:t.len;
t.buf <- new_buf;
t.off <- 0
let ensure t to_copy =
if trailing_space t < to_copy then
if writable_space t >= to_copy
then compress t
else grow t to_copy
let write_pos t =
t.off + t.len
let feed_string t ~off ~len str =
assert (off >= 0);
assert (String.length str >= len - off);
ensure t len;
Bigstringaf.unsafe_blit_from_string str ~src_off:off t.buf ~dst_off:(write_pos t) ~len;
t.len <- t.len + len
let feed_bigstring t ~off ~len b =
assert (off >= 0);
assert (Bigstringaf.length b >= len - off);
ensure t len;
Bigstringaf.unsafe_blit b ~src_off:off t.buf ~dst_off:(write_pos t) ~len;
t.len <- t.len + len
let feed_input t = function
| `String s -> feed_string t ~off:0 ~len:(String .length s) s
| `Bigstring b -> feed_bigstring t ~off:0 ~len:(Bigstringaf.length b) b
let shift t n =
assert (t.len >= n);
t.off <- t.off + n;
t.len <- t.len - n
let for_reading { buf; off; len } =
Bigstringaf.sub ~off ~len buf
module Unconsumed = struct
type t =
{ buf : Bigstringaf.t
; off : int
; len : int }
end
let unconsumed ?(shift=0) { buf; off; len } =
assert (len >= shift);
{ Unconsumed.buf; off = off + shift; len = len - shift }
let of_unconsumed { Unconsumed.buf; off; len } =
{ buf; off; len }
type unconsumed = Unconsumed.t =
{ buf : Bigstringaf.t
; off : int
; len : int }

20
unikernel/duniverse/angstrom/lib/buffering.mli Normal file
View file

@ -0,0 +1,20 @@
type t
val create : int -> t
val of_bigstring : off:int -> len:int -> Bigstringaf.t -> t
val feed_string : t -> off:int -> len:int -> string -> unit
val feed_bigstring : t -> off:int -> len:int -> Bigstringaf.t -> unit
val feed_input : t -> [ `String of string | `Bigstring of Bigstringaf.t ] -> unit
val shift : t -> int -> unit
val for_reading : t -> Bigstringaf.t
type unconsumed =
{ buf : Bigstringaf.t
; off : int
; len : int }
val unconsumed : ?shift:int -> t -> unconsumed
val of_unconsumed : unconsumed -> t

6
unikernel/duniverse/angstrom/lib/dune Normal file
View file

@ -0,0 +1,6 @@
(library
(name angstrom)
(public_name angstrom)
(libraries bigstringaf)
(flags :standard -safe-string)
(preprocess future_syntax))

22
unikernel/duniverse/angstrom/lib/exported_state.ml Normal file
View file

@ -0,0 +1,22 @@
type 'a state =
| Partial of 'a partial
| Done of int * 'a
| Fail of int * string list * string
and 'a partial =
{ committed : int
; continue : Bigstringaf.t -> off:int -> len:int -> More.t -> 'a state }
let state_to_option x = match x with
| Done(_, v) -> Some v
| Fail _ -> None
| Partial _ -> None
let fail_to_string marks err =
String.concat " > " marks ^ ": " ^ err
let state_to_result x = match x with
| Done(_, v) -> Ok v
| Partial _ -> Error "incomplete input"
| Fail(_, marks, err) -> Error (fail_to_string marks err)

111
unikernel/duniverse/angstrom/lib/input.ml Normal file
View file

@ -0,0 +1,111 @@
(*----------------------------------------------------------------------------
Copyright (c) 2017 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
type t =
{ mutable parser_committed_bytes : int
; client_committed_bytes : int
; off : int
; len : int
; buffer : Bigstringaf.t
}
let create buffer ~off ~len ~committed_bytes =
{ parser_committed_bytes = committed_bytes
; client_committed_bytes = committed_bytes
; off
; len
; buffer }
let length t = t.client_committed_bytes + t.len
let client_committed_bytes t = t.client_committed_bytes
let parser_committed_bytes t = t.parser_committed_bytes
let committed_bytes_discrepancy t = t.parser_committed_bytes - t.client_committed_bytes
let bytes_for_client_to_commit t = committed_bytes_discrepancy t
let parser_uncommitted_bytes t = t.len - bytes_for_client_to_commit t
let invariant t =
assert (parser_committed_bytes t + parser_uncommitted_bytes t = length t);
assert (parser_committed_bytes t - client_committed_bytes t = bytes_for_client_to_commit t);
;;
let offset_in_buffer t pos =
t.off + pos - t.client_committed_bytes
let apply t pos len ~f =
let off = offset_in_buffer t pos in
f t.buffer ~off ~len
let unsafe_get_char t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get t.buffer off
let unsafe_get_int16_le t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int16_le t.buffer off
let unsafe_get_int32_le t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int32_le t.buffer off
let unsafe_get_int64_le t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int64_le t.buffer off
let unsafe_get_int16_be t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int16_be t.buffer off
let unsafe_get_int32_be t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int32_be t.buffer off
let unsafe_get_int64_be t pos =
let off = offset_in_buffer t pos in
Bigstringaf.unsafe_get_int64_be t.buffer off
let count_while t pos ~f =
let buffer = t.buffer in
let off = offset_in_buffer t pos in
let i = ref off in
let limit = t.off + t.len in
while !i < limit && f (Bigstringaf.unsafe_get buffer !i) do
incr i
done;
!i - off
;;
let commit t pos =
t.parser_committed_bytes <- pos
;;

88
unikernel/duniverse/angstrom/lib/input.mli Normal file
View file

@ -0,0 +1,88 @@
(*----------------------------------------------------------------------------
Copyright (c) 2017 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
(** An [Input.t] represents a series of buffers, of which we only have access
to one, and a pointer to how much has been committed, which is in the
current buffer.
parser commit point
V
+--------------------------------------+
|#################'####################| current buffer
+-----------------+--------------------------------------+-----
|#################|#################'####################|###.. input
+-----------------+--------------------------------------+-----
' ' ' '
|--------------------------------------------------------|
' ' length ' '
|-----------------| ' '
client_committed_bytes ' '
' ' |--------------------|
' ' parser_uncommitted_bytes
' |-----------------|
' bytes_for_client_to_commit
|-----------------------------------|
parser_committed_bytes
Note that a buffer is a subsequence of a [Bigstringaf.t], defined by [off] and [len].
All [int] position arguments should be relative to the beginning of the
whole input. *)
type t
val create : Bigstringaf.t -> off:int -> len:int -> committed_bytes:int -> t
val length : t -> int
val client_committed_bytes : t -> int
val parser_committed_bytes : t -> int
val parser_uncommitted_bytes : t -> int
val bytes_for_client_to_commit : t -> int
val unsafe_get_char : t -> int -> char
val unsafe_get_int16_le : t -> int -> int
val unsafe_get_int32_le : t -> int -> int32
val unsafe_get_int64_le : t -> int -> int64
val unsafe_get_int16_be : t -> int -> int
val unsafe_get_int32_be : t -> int -> int32
val unsafe_get_int64_be : t -> int -> int64
val count_while : t -> int -> f:(char -> bool) -> int
val apply : t -> int -> int -> f:(Bigstringaf.t -> off:int -> len:int -> 'a) -> 'a
val commit : t -> int -> unit
val invariant : t -> unit

3
unikernel/duniverse/angstrom/lib/more.ml Normal file
View file

@ -0,0 +1,3 @@
type t =
| Complete
| Incomplete

3
unikernel/duniverse/angstrom/lib/more.mli Normal file
View file

@ -0,0 +1,3 @@
type t =
| Complete
| Incomplete

173
unikernel/duniverse/angstrom/lib/parser.ml Normal file
View file

@ -0,0 +1,173 @@
module State = struct
type 'a t =
| Partial of 'a partial
| Lazy of 'a t Lazy.t
| Done of int * 'a
| Fail of int * string list * string
and 'a partial =
{ committed : int
; continue : Bigstringaf.t -> off:int -> len:int -> More.t -> 'a t }
end
type 'a with_state = Input.t -> int -> More.t -> 'a
type 'a failure = (string list -> string -> 'a State.t) with_state
type ('a, 'r) success = ('a -> 'r State.t) with_state
type 'a t =
{ run : 'r. ('r failure -> ('a, 'r) success -> 'r State.t) with_state }
let fail_k input pos _ marks msg =
State.Fail(pos - Input.client_committed_bytes input, marks, msg)
let succeed_k input pos _ v =
State.Done(pos - Input.client_committed_bytes input, v)
let rec to_exported_state = function
| State.Partial {committed;continue} ->
Exported_state.Partial
{ committed
; continue =
fun bs ~off ~len more ->
to_exported_state (continue bs ~off ~len more)}
| State.Done (i,x) -> Exported_state.Done (i,x)
| State.Fail (i, sl, s) -> Exported_state.Fail (i, sl, s)
| State.Lazy x -> to_exported_state (Lazy.force x)
let parse p =
let input = Input.create Bigstringaf.empty ~committed_bytes:0 ~off:0 ~len:0 in
to_exported_state (p.run input 0 Incomplete fail_k succeed_k)
let parse_bigstring p input =
let input = Input.create input ~committed_bytes:0 ~off:0 ~len:(Bigstringaf.length input) in
Exported_state.state_to_result (to_exported_state (p.run input 0 Complete fail_k succeed_k))
module Monad = struct
let return v =
{ run = fun input pos more _fail succ ->
succ input pos more v
}
let fail msg =
{ run = fun input pos more fail _succ ->
fail input pos more [] msg
}
let (>>=) p f =
{ run = fun input pos more fail succ ->
let succ' input' pos' more' v = (f v).run input' pos' more' fail succ in
p.run input pos more fail succ'
}
let (>>|) p f =
{ run = fun input pos more fail succ ->
let succ' input' pos' more' v = succ input' pos' more' (f v) in
p.run input pos more fail succ'
}
let (<$>) f m =
m >>| f
let (<*>) f m =
(* f >>= fun f -> m >>| f *)
{ run = fun input pos more fail succ ->
let succ0 input0 pos0 more0 f =
let succ1 input1 pos1 more1 m = succ input1 pos1 more1 (f m) in
m.run input0 pos0 more0 fail succ1
in
f.run input pos more fail succ0 }
let lift f m =
f <$> m
let lift2 f m1 m2 =
{ run = fun input pos more fail succ ->
let succ1 input1 pos1 more1 m1 =
let succ2 input2 pos2 more2 m2 = succ input2 pos2 more2 (f m1 m2) in
m2.run input1 pos1 more1 fail succ2
in
m1.run input pos more fail succ1 }
let lift3 f m1 m2 m3 =
{ run = fun input pos more fail succ ->
let succ1 input1 pos1 more1 m1 =
let succ2 input2 pos2 more2 m2 =
let succ3 input3 pos3 more3 m3 =
succ input3 pos3 more3 (f m1 m2 m3) in
m3.run input2 pos2 more2 fail succ3 in
m2.run input1 pos1 more1 fail succ2
in
m1.run input pos more fail succ1 }
let lift4 f m1 m2 m3 m4 =
{ run = fun input pos more fail succ ->
let succ1 input1 pos1 more1 m1 =
let succ2 input2 pos2 more2 m2 =
let succ3 input3 pos3 more3 m3 =
let succ4 input4 pos4 more4 m4 =
succ input4 pos4 more4 (f m1 m2 m3 m4) in
m4.run input3 pos3 more3 fail succ4 in
m3.run input2 pos2 more2 fail succ3 in
m2.run input1 pos1 more1 fail succ2
in
m1.run input pos more fail succ1 }
let ( *>) a b =
(* a >>= fun _ -> b *)
{ run = fun input pos more fail succ ->
let succ' input' pos' more' _ = b.run input' pos' more' fail succ in
a.run input pos more fail succ'
}
let (<* ) a b =
(* a >>= fun x -> b >>| fun _ -> x *)
{ run = fun input pos more fail succ ->
let succ0 input0 pos0 more0 x =
let succ1 input1 pos1 more1 _ = succ input1 pos1 more1 x in
b.run input0 pos0 more0 fail succ1
in
a.run input pos more fail succ0 }
end
module Choice = struct
let (<?>) p mark =
{ run = fun input pos more fail succ ->
let fail' input' pos' more' marks msg =
fail input' pos' more' (mark::marks) msg in
p.run input pos more fail' succ
}
let (<|>) p q =
{ run = fun input pos more fail succ ->
let fail' input' pos' more' marks msg =
(* The only two constructors that introduce new failure continuations are
* [<?>] and [<|>]. If the initial input position is less than the length
* of the committed input, then calling the failure continuation will
* have the effect of unwinding all choices and collecting marks along
* the way. *)
if pos < Input.parser_committed_bytes input' then
fail input' pos' more marks msg
else
q.run input' pos more' fail succ in
p.run input pos more fail' succ
}
end
module Monad_use_for_debugging = struct
let return = Monad.return
let fail = Monad.fail
let (>>=) = Monad.(>>=)
let (>>|) m f = m >>= fun x -> return (f x)
let (<$>) f m = m >>| f
let (<*>) f m = f >>= fun f -> m >>| f
let lift = (>>|)
let lift2 f m1 m2 = f <$> m1 <*> m2
let lift3 f m1 m2 m3 = f <$> m1 <*> m2 <*> m3
let lift4 f m1 m2 m3 m4 = f <$> m1 <*> m2 <*> m3 <*> m4
let ( *>) a b = a >>= fun _ -> b
let (<* ) a b = a >>= fun x -> b >>| fun _ -> x
end

27
unikernel/duniverse/angstrom/lib_test/dune Normal file
View file

@ -0,0 +1,27 @@
(library
(name angstrom_test)
(libraries angstrom)
(flags :standard -safe-string)
(modules test_let_syntax_native test_let_syntax_ppx)
(preprocess
(per_module
(future_syntax test_let_syntax_native)
((pps ppx_let) test_let_syntax_ppx))))
(executables
(libraries alcotest angstrom angstrom_test)
(modules test_angstrom)
(names test_angstrom))
(executables
(libraries bigstringaf angstrom RFC7159)
(modules test_json)
(names test_json))
(alias
(name runtest)
(package angstrom)
(deps
(:< test_angstrom.exe))
(action
(run %{<})))

449
unikernel/duniverse/angstrom/lib_test/test_angstrom.ml Normal file
View file

@ -0,0 +1,449 @@
open Angstrom
module Alcotest = struct
include Alcotest
let bigstring =
Alcotest.testable
(fun fmt _bs -> Fmt.pf fmt "<bigstring>")
( = )
end
let check ?size f p is =
let open Buffered in
let state =
List.fold_left (fun state chunk ->
feed state (`String chunk))
(parse ?initial_buffer_size:size p) is
in
f (state_to_result (feed state `Eof))
let check_ok ?size ~msg test p is r =
let r = Ok r in
check ?size (fun result -> Alcotest.(check (result test string)) msg r result)
p is
let check_fail ?size ~msg p is =
let r = Error "" in
check ?size (fun result -> Alcotest.(check (result reject pass)) msg r result)
p is
let check_c ?size ~msg p is r = check_ok ?size ~msg Alcotest.char p is r
let check_lc ?size ~msg p is r = check_ok ?size ~msg Alcotest.(list char) p is r
let check_co ?size ~msg p is r = check_ok ?size ~msg Alcotest.(option char) p is r
let check_s ?size ~msg p is r = check_ok ?size ~msg Alcotest.string p is r
let check_bs ?size ~msg p is r = check_ok ?size ~msg Alcotest.bigstring p is r
let check_ls ?size ~msg p is r = check_ok ?size ~msg Alcotest.(list string) p is r
let check_int ?size ~msg p is r = check_ok ?size ~msg Alcotest.int p is r
let bigstring_of_string s = Bigstringaf.of_string s ~off:0 ~len:(String.length s)
let basic_constructors =
[ "peek_char", `Quick, begin fun () ->
check_co ~msg:"singleton input" peek_char ["t"] (Some 't');
check_co ~msg:"longer input" peek_char ["true"] (Some 't');
check_co ~msg:"empty input" peek_char [""] None;
end
; "peek_char_fail", `Quick, begin fun () ->
check_c ~msg:"singleton input" peek_char_fail ["t"] 't';
check_c ~msg:"longer input" peek_char_fail ["true"] 't';
check_fail ~msg:"empty input" peek_char_fail [""]
end
; "char", `Quick, begin fun () ->
check_c ~msg:"singleton 'a'" (char 'a') ["a"] 'a';
check_c ~msg:"prefix 'a'" (char 'a') ["asdf"] 'a';
check_fail ~msg:"'a' failure" (char 'a') ["b"];
check_fail ~msg:"empty buffer" (char 'a') [""]
end
; "int8", `Quick, begin fun () ->
check_int ~msg:"singleton 'a'" (int8 0x0061) ["a"] 0x61;
check_int ~msg:"prefix 'a'" (int8 0xff61) ["asdf"] 0x61;
check_fail ~msg:"'a' failure" (int8 0xff61) ["b"];
check_fail ~msg:"empty buffer" (int8 0xff61) [""];
end
; "not_char", `Quick, begin fun () ->
check_c ~msg:"not 'a' singleton" (not_char 'a') ["b"] 'b';
check_c ~msg:"not 'a' prefix" (not_char 'a') ["baba"] 'b';
check_fail ~msg:"not 'a' failure" (not_char 'a') ["a"];
check_fail ~msg:"empty buffer" (not_char 'a') [""]
end
; "any_char", `Quick, begin fun () ->
check_c ~msg:"non-empty buffer" any_char ["a"] 'a';
check_fail ~msg:"empty buffer" any_char [""]
end
; "any_{,u}int8", `Quick, begin fun () ->
check_int ~msg:"positive sign preserved" any_int8 ["\127"] 127;
check_int ~msg:"negative sign preserved" any_int8 ["\129"] (-127);
check_int ~msg:"sign invariant" any_uint8 ["\127"] 127;
check_int ~msg:"sign invariant" any_uint8 ["\129"] (129)
end
; "string", `Quick, begin fun () ->
check_s ~msg:"empty string, non-empty buffer" (string "") ["asdf"] "";
check_s ~msg:"empty string, empty buffer" (string "") [""] "";
check_s ~msg:"exact string match" (string "asdf") ["asdf"] "asdf";
check_s ~msg:"string is prefix of input" (string "as") ["asdf"] "as";
check_fail ~msg:"input is prefix of string" (string "asdf") ["asd"];
check_fail ~msg:"non-empty string, empty input" (string "test") [""]
end
; "string_ci", `Quick, begin fun () ->
check_s ~msg:"empty string, non-empty input" (string_ci "") ["asdf"] "";
check_s ~msg:"empty string, empty input" (string_ci "") [""] "";
check_s ~msg:"exact string match" (string_ci "asdf") ["AsDf"] "AsDf";
check_s ~msg:"string is prefix of input" (string_ci "as") ["AsDf"] "As";
check_fail ~msg:"input is prefix of string" (string_ci "asdf") ["Asd"];
check_fail ~msg:"non-empty string, empty input" (string_ci "test") [""]
end
; "take_bigstring", `Quick, begin fun () ->
check_bs ~msg:"empty bigstring" (take_bigstring 0) ["asdf"] (bigstring_of_string "");
check_bs ~msg:"bigstring" (take_bigstring 2) ["asdf"] (bigstring_of_string "as");
check_fail ~msg:"asking for too much" (take_bigstring 5) ["asdf"];
end
; "take_while", `Quick, begin fun () ->
check_s ~msg:"true, non-empty input" (take_while (fun _ -> true)) ["asdf"] "asdf";
check_s ~msg:"true, empty input" (take_while (fun _ -> true)) [""] "";
check_s ~msg:"false, non-empty input" (take_while (fun _ -> false)) ["asdf"] "";
check_s ~msg:"false, empty input" (take_while (fun _ -> false)) [""] "";
end
; "take_while1", `Quick, begin fun () ->
check_s ~msg:"true, non-empty input" (take_while1 (fun _ -> true)) ["asdf"] "asdf";
check_fail ~msg:"false, non-empty input" (take_while1 (fun _ -> false)) ["asdf"];
check_fail ~msg:"true, empty input" (take_while1 (fun _ -> true)) [""];
check_fail ~msg:"false, empty input" (take_while1 (fun _ -> false)) [""];
end
; "advance", `Quick, begin fun () ->
check_s ~msg:"non-empty input" (advance 3 >>= fun () -> take 1) ["asdf"] "f";
check_fail ~msg:"advance more than available" (advance 5) ["asdf"];
check_fail ~msg:"advance on empty input" (advance 3) [""];
end
]
module type EndianBigstring = sig
val set_int16 : Bigstringaf.t -> int -> int -> unit
val set_int32 : Bigstringaf.t -> int -> int32 -> unit
val set_int64 : Bigstringaf.t -> int -> int64 -> unit
val set_float : Bigstringaf.t -> int -> float -> unit
val set_double : Bigstringaf.t -> int -> float -> unit
end
module Endian(Es : EndianBigstring) = struct
type 'a endian = {
name : string;
size : int;
zero : 'a;
min : 'a;
max : 'a;
dump : Bigstringaf.t -> int -> 'a -> unit;
testable : 'a Alcotest.testable
}
let int16 = {
name = "int16";
size = 2;
zero = 0;
min = ~-32768;
max = 32767;
dump = Es.set_int16;
testable = Alcotest.int
}
let int32 = {
name = "int32";
size = 4;
zero = Int32.zero;
min = Int32.min_int;
max = Int32.max_int;
dump = Es.set_int32;
testable = Alcotest.int32
}
let int64 = {
name = "int64";
size = 8;
zero = Int64.zero;
min = Int64.min_int;
max = Int64.max_int;
dump = Es.set_int64;
testable = Alcotest.int64
}
let float = {
name = "float";
size = 4;
zero = 0.0;
(* XXX: Not really min/max *)
min = ~-.2e10;
max = 2e10;
dump = Es.set_float;
testable = Alcotest.float 0.0
}
let double = {
name = "double";
size = 8;
zero = 0.0;
(* XXX: Not really min/max *)
min = ~-.2e30;
max = 2e30;
dump = Es.set_double;
testable = Alcotest.float 0.0
}
let uint16 = { int16 with name = "uint16"; min = 0; max = 65535 }
let uint32 = { int32 with name = "uint32" }
let dump actual size value =
let buf = Bigstringaf.of_string ~off:0 ~len:size (String.make size '\xff') in
actual buf 0 value;
Bigstringaf.substring ~off:0 ~len:size buf
let make_tests e parse = e.name, `Quick, begin fun () ->
check_ok ~msg:"zero" e.testable parse [dump e.dump e.size e.zero] e.zero;
check_ok ~msg:"min" e.testable parse [dump e.dump e.size e.min ] e.min;
check_ok ~msg:"max" e.testable parse [dump e.dump e.size e.max ] e.max;
check_ok ~msg:"trailing" e.testable parse [dump e.dump (e.size + 1) e.zero] e.zero;
end
module type EndianSig = module type of LE
let tests (module E : EndianSig) = [
make_tests int16 E.any_int16;
make_tests int32 E.any_int32;
make_tests int64 E.any_int64;
make_tests uint16 E.any_uint16;
make_tests float E.any_float;
make_tests double E.any_double;
]
end
let little_endian =
let module E = Endian(struct
let set_int16 = Bigstringaf.unsafe_set_int16_le
let set_int32 = Bigstringaf.unsafe_set_int32_le
let set_int64 = Bigstringaf.unsafe_set_int64_le
let set_float bs off f = Bigstringaf.unsafe_set_int32_le bs off (Int32.bits_of_float f)
let set_double bs off d = Bigstringaf.unsafe_set_int64_le bs off (Int64.bits_of_float d)
end) in
E.tests (module LE)
let big_endian =
let module E = Endian(struct
let set_int16 = Bigstringaf.unsafe_set_int16_be
let set_int32 = Bigstringaf.unsafe_set_int32_be
let set_int64 = Bigstringaf.unsafe_set_int64_be
let set_float bs off f = Bigstringaf.unsafe_set_int32_be bs off (Int32.bits_of_float f)
let set_double bs off d = Bigstringaf.unsafe_set_int64_be bs off (Int64.bits_of_float d)
end) in
E.tests (module BE)
let monadic =
[ "fail", `Quick, begin fun () ->
check_fail ~msg:"non-empty input" (fail "<msg>") ["asdf"];
check_fail ~msg:"empty input" (fail "<msg>") [""]
end
; "return", `Quick, begin fun () ->
check_s ~msg:"non-empty input" (return "test") ["asdf"] "test";
check_s ~msg:"empty input" (return "test") [""] "test";
end
; "bind", `Quick, begin fun () ->
check_s ~msg:"data dependency" (take 2 >>= fun s -> string s) ["asas"] "as";
end
]
let applicative =
[ "applicative", `Quick, begin fun () ->
check_s ~msg:"`foo *> bar` returns bar" (string "foo" *> string "bar") ["foobar"] "bar";
check_s ~msg:"`foo <* bar` returns bar" (string "foo" <* string "bar") ["foobar"] "foo";
end
]
let alternative =
[ "alternative", `Quick, begin fun () ->
check_c ~msg:"char a | char b" (char 'a' <|> char 'b') ["a"] 'a';
check_c ~msg:"char b | char a" (char 'b' <|> char 'a') ["a"] 'a';
check_s ~msg:"string 'a' | string 'b'" (string "a" <|> string "b") ["a"] "a";
check_s ~msg:"string 'b' | string 'a'" (string "b" <|> string "a") ["a"] "a";
end ]
let combinators =
[ "many", `Quick, begin fun () ->
check_lc ~msg:"empty input" (many (char 'a')) [""] [];
check_lc ~msg:"single char" (many (char 'a')) ["a"] ['a'];
check_lc ~msg:"two chars" (many (char 'a')) ["aa"] ['a'; 'a'];
end
; "many_till", `Quick, begin fun () ->
check_lc ~msg:"not greedy" (many_till any_char (char '-')) ["ab-ab-"] ['a'; 'b'];
end
; "sep_by1", `Quick, begin fun () ->
let parser = sep_by1 (char ',') (char 'a') in
check_lc ~msg:"single char" parser ["a"] ['a'];
check_lc ~msg:"many chars" parser ["a,a"] ['a'; 'a'];
check_lc ~msg:"no trailing sep" parser ["a,"] ['a'];
end
; "count", `Quick, begin fun () ->
check_lc ~msg:"empty input" (count 0 (char 'a')) [""] [];
check_lc ~msg:"exact input" (count 1 (char 'a')) ["a"] ['a'];
check_lc ~msg:"additonal input" (count 2 (char 'a')) ["aaa"] ['a'; 'a'];
check_fail ~msg:"bad input" (count 2 (char 'a')) ["abb"];
end
; "scan_state", `Quick, begin fun () ->
check_s ~msg:"scan_state" (scan_state "" (fun s -> function
| 'a' -> Some s
| '.' -> None
| c -> Some ((String.make 1 c) ^ s)
)) ["abaacba."] "bcb";
let p =
count 2 (scan_state "" (fun s -> function
| '.' -> None
| c -> Some (s ^ String.make 1 c)
))
>>| String.concat "" in
check_s ~msg:"state reset between runs" p ["bcd."] "bcd";
end
; "consumed", `Quick, begin fun () ->
check_s ~msg:"from beginning" (consumed any_char)
["abc"] "a";
check_s ~msg:"from middle" (any_char *> consumed any_char)
["abc"] "b";
check_c ~msg:"advances input" (any_char *> consumed any_char *> any_char)
["abc"] 'c';
check_s ~msg:"with backtracking" (consumed (char 'a' *> (char 'c' <|> char 'b')))
["abc"] "ab";
check_s ~msg:"with more input" (consumed (string "abc"))
["a"; "bc"] "abc";
check_fail ~msg:"with commit" (consumed (char 'a' *> commit *> char 'b'))
["a"; "b"];
let integer =
option '+' (char '-') *> take_while (function '0'..'9' -> true | _ -> false)
in
check_int ~msg:"parsing an integer" (consumed integer >>| int_of_string)
["-12345"] (-12345);
check_bs ~msg:"bigstring variant" (consumed_bigstring (string "ab"))
["abc"] (bigstring_of_string "ab");
end
]
let incremental =
[ "within chunk boundary", `Quick, begin fun () ->
check_s ~msg:"string on each side of 2 inputs"
(string "this" *> string "that") ["this"; "that"] "that";
check_s ~msg:"string on each side of 3 inputs"
(string "thi" *> string "st" *> string "hat") ["thi"; "st"; "hat"] "hat";
check_s ~msg:"string straddling 2 inputs"
(string "thisthat") ["this"; "that"] "thisthat";
check_s ~msg:"string straddling 3 inputs"
(string "thisthat") ["thi"; "st"; "hat"] "thisthat";
end
; "peek_char and empty chunks", `Quick, begin fun () ->
let decoder len =
let open Angstrom in
let buf = Buffer.create len in
fix @@ fun m ->
available >>= function
| 0 -> peek_char >>= (function
| Some _ -> commit *> m
| None ->
let ret = Buffer.contents buf in
Buffer.clear buf;
commit *> return ret)
| n -> take n >>= fun chunk -> Buffer.add_string buf chunk; commit *> m
in
check_s ~msg:"empty input multiple times and peek_char"
(decoder 0xFF) [ "Whole Lotta Love"; ""; ""; "" ] "Whole Lotta Love"
end
; "across chunk boundary", `Quick, begin fun () ->
check_s ~size:4 ~msg:"string on each side of 2 chunks"
(string "this" *> string "that") ["this"; "that"] "that";
check_s ~size:3 ~msg:"string on each side of 3 chunks"
(string "thi" *> string "st" *> string "hat") ["thi"; "st"; "hat"] "hat";
check_s ~size:4 ~msg:"string straddling 2 chunks"
(string "thisthat") ["this"; "that"] "thisthat";
check_s ~size:3 ~msg:"string straddling 3 chunks"
(string "thisthat") ["thi"; "st"; "hat"] "thisthat";
end
; "across chunk boundary with commit", `Quick, begin fun () ->
check_s ~size:4 ~msg:"string on each side of 2 chunks"
(string "this" *> commit *> string "that") ["this"; "that"] "that";
check_s ~size:3 ~msg:"string on each side of 3 chunks"
(string "thi" *> string "st" *> commit *> string "hat") ["thi"; "st"; "hat"] "hat";
end ]
let count_while_regression =
[ "proper position set after count_while", `Quick, begin fun () ->
check_s ~msg:"take_while then eof"
(take_while (fun _ -> true) <* end_of_input) ["asdf"; ""] "asdf";
check_s ~msg:"take_while1 then eof"
(take_while1 (fun _ -> true) <* end_of_input) ["asdf"; ""] "asdf";
end ]
let choice_commit =
[ "", `Quick, begin fun () ->
let p =
choice [ string "@@" *> commit *> char '*'
; string "@" *> commit *> char '!' ]
in
Alcotest.(check (result reject string))
"commit to branch"
(Error ": char '*'")
(parse_string ~consume:All p "@@^");
end ]
let input =
let test p input ~off ~len expect =
match Angstrom.Unbuffered.parse p with
| Done _ | Fail _ -> assert false
| Partial { continue; committed } ->
Alcotest.(check int) "committed is zero" 0 committed;
let bs = Bigstringaf.of_string input ~off:0 ~len:(String.length input) in
let state = continue bs ~off ~len Complete in
Alcotest.(check (result string string))
"offset and length respected"
(Ok expect)
(Angstrom.Unbuffered.state_to_result state);
in
[ "offset and length respected", `Quick, begin fun () ->
let open Angstrom in
let take_all = take_while (fun _ -> true) in
test take_all "abcd" ~off:1 ~len:2 "bc";
test (take 4 *> take_all) "abcdefg" ~off:0 ~len:7 "efg";
end ]
;;
let consume =
[ "consume with choice matching prefix", `Quick, begin fun () ->
let open Angstrom in
let parse ~consume =
parse_string ~consume (many (char 'a')) "aaabbb"
in
Alcotest.(check (result (list char) string))
"consume prefix passes"
(parse ~consume:Prefix)
(Ok [ 'a'; 'a'; 'a' ])
;
Alcotest.(check (result (list char) string))
"consume all fails"
(parse ~consume:All)
(Error ": end_of_input");
end
]
;;
let () =
Alcotest.run "test suite"
[ "basic constructors" , basic_constructors
; "little endian" , little_endian
; "big endian" , big_endian
; "monadic interface" , monadic
; "applicative interface" , applicative
; "alternative" , alternative
; "combinators" , combinators
; "incremental input" , incremental
; "count_while regression", count_while_regression
; "choice and commit" , choice_commit
; "input" , input
; "consume" , consume
]

19
unikernel/duniverse/angstrom/lib_test/test_json.ml Normal file
View file

@ -0,0 +1,19 @@
let read f =
try
let ic = open_in_bin f in
let n = in_channel_length ic in
let s = Bytes.create n in
really_input ic s 0 n;
close_in ic;
let b = Bigstringaf.create n in
Bigstringaf.blit_from_bytes s ~src_off:0 b ~dst_off:0 ~len:n;
b
with e ->
failwith (Printf.sprintf "Cannot read content of %s.\n%s" f (Printexc.to_string e))
;;
let () =
let twitter_big = read Sys.argv.(1) in
match Angstrom.(parse_bigstring ~consume:Consume.Prefix RFC7159.json twitter_big) with
| Ok _ -> ()
| Error err -> failwith err

11
unikernel/duniverse/angstrom/lib_test/test_let_syntax_native.ml Normal file
View file

@ -0,0 +1,11 @@
open Angstrom
let (_ : int t) =
let* () = end_of_input in
return 1
let (_ : int t) =
let+ (_ : char) = any_char
and+ (_ : string) = string "foo"
in
2

18
unikernel/duniverse/angstrom/lib_test/test_let_syntax_ppx.ml Normal file
View file

@ -0,0 +1,18 @@
open Angstrom
open Let_syntax
let (_ : int t) =
let%bind () = end_of_input in
return 1
let (_ : int t) =
let%map (_ : char) = any_char
and (_ : string) = string "foo"
in
2
let (_ : int t) =
let%mapn (_ : char) = any_char
and (_ : string) = string "foo"
in
2

81
unikernel/duniverse/angstrom/lwt/angstrom_lwt_unix.ml Normal file
View file

@ -0,0 +1,81 @@
(*----------------------------------------------------------------------------
Copyright (c) 2016 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
open Angstrom.Buffered
open Lwt
let default_pushback () = return_unit
let rec buffered_state_loop pushback state in_chan bytes =
let size = Bytes.length bytes in
match state with
| Partial k ->
Lwt_io.read_into in_chan bytes 0 size
>|= begin function
| 0 -> k `Eof
| len ->
assert (len > 0);
k (`String (Bytes.(unsafe_to_string (sub bytes 0 len))))
end
>>= fun state' -> pushback ()
>>= fun () -> buffered_state_loop pushback state' in_chan bytes
| state -> return state
let handle_parse_result state =
match state_to_unconsumed state with
| None -> assert false
| Some us -> us, state_to_result state
let parse ?(pushback=default_pushback) p in_chan =
let size = Lwt_io.buffer_size in_chan in
let bytes = Bytes.create size in
buffered_state_loop pushback (parse ~initial_buffer_size:size p) in_chan bytes
>|= handle_parse_result
let with_buffered_parse_state ?(pushback=default_pushback) state in_chan =
let size = Lwt_io.buffer_size in_chan in
let bytes = Bytes.create size in
begin match state with
| Partial _ -> buffered_state_loop pushback state in_chan bytes
| _ -> return state
end
>|= handle_parse_result
let async_many e k =
Angstrom.(skip_many (e <* commit >>| k) <?> "async_many")
let parse_many p write in_chan =
let wait = ref (default_pushback ()) in
let k x = wait := write x in
let pushback () = !wait in
parse ~pushback (async_many p k) in_chan

72
unikernel/duniverse/angstrom/lwt/angstrom_lwt_unix.mli Normal file
View file

@ -0,0 +1,72 @@
(*---------------------------------------------------------------------------
Copyright (c) 2016 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
open Angstrom
val parse
: ?pushback:(unit -> unit Lwt.t)
-> 'a t
-> Lwt_io.input_channel
-> (Buffered.unconsumed * ('a, string) result) Lwt.t
val parse_many
: 'a t
-> ('a -> unit Lwt.t)
-> Lwt_io.input_channel
-> (Buffered.unconsumed * (unit, string) result) Lwt.t
(** Useful for resuming a {!parse} that returns unconsumed data. Construct a
[Buffered.state] by using [Buffered.parse] and provide it into this
function. This is essentially what {!parse_many} does, so consider using
that if you don't require fine-grained control over how many times you want
the parser to succeed.
Usage example:
{[
parse parser in_channel >>= fun (unconsumed, result) ->
match result with
| Ok a ->
let { buf; off; len } = unconsumed in
let state = Buffered.parse parser in
let state = Buffered.feed state (`Bigstring (Bigstringaf.sub ~off ~len buf)) in
with_buffered_parse_state state in_channel
| Error err -> failwith err
]} *)
val with_buffered_parse_state
: ?pushback:(unit -> unit Lwt.t)
-> 'a Buffered.state
-> Lwt_io.input_channel
-> (Buffered.unconsumed * ('a, string) result) Lwt.t

5
unikernel/duniverse/angstrom/lwt/dune Normal file
View file

@ -0,0 +1,5 @@
(library
(name angstrom_lwt_unix)
(public_name angstrom-lwt-unix)
(flags :standard -safe-string)
(libraries angstrom lwt.unix))

52
unikernel/duniverse/angstrom/unix/angstrom_unix.ml Normal file
View file

@ -0,0 +1,52 @@
(*----------------------------------------------------------------------------
Copyright (c) 2016 Inhabited Type LLC.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the author nor the names of his contributors
may be used to endorse or promote products derived from this software
without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------*)
open Angstrom.Buffered
let parse ?(buf_size=0x1000) p in_chan =
let bytes = Bytes.create buf_size in
let rec loop = function
| Partial k ->
begin match input in_chan bytes 0 buf_size with
| 0 -> loop (k `Eof)
| n -> loop (k (`String (Bytes.(unsafe_to_string (sub bytes 0 n)))))
end
| state -> state
in
let state = loop (parse p) in
match state_to_unconsumed state with
| None -> assert false
| Some us -> us, state_to_result state
let parse_many ?buf_size p k in_chan =
parse ?buf_size Angstrom.(skip_many (p <* commit >>| k)) in_chan

Some files were not shown because too many files have changed in this diff Show more