From: Clinton Ebadi Date: Sat, 15 Feb 2020 19:22:15 +0000 (-0500) Subject: Import Upstream version 20180207 X-Git-Tag: upstream/20180207^0 X-Git-Url: https://git.hcoop.net/hcoop/debian/mlton.git/commitdiff_plain/7f918cf15a5aaed7f3029096fda625562ec5b82e Import Upstream version 20180207 --- 7f918cf15a5aaed7f3029096fda625562ec5b82e diff --git a/CHANGELOG.adoc b/CHANGELOG.adoc new file mode 100644 index 0000000..9875d2a --- /dev/null +++ b/CHANGELOG.adoc @@ -0,0 +1,3203 @@ += CHANGELOG + +== Version 20180206 + +Here are the changes from version 20130715 to version 20180206. + +=== Summary + +* Compiler. + ** Added an experimental LLVM codegen (`-codegen llvm`); requires LLVM tools + (`llvm-as`, `opt`, `llc`) version ≥ 3.7. + ** Made many substantial cosmetic improvements to front-end diagnostic + messages, especially with respect to source location regions, type inference + for `fun` and `val rec` declarations, signature constraints applied to a + structure, `sharing type` specifications and `where type` signature + expressions, type constructor or type variable escaping scope, and + nonexhaustive pattern matching. + ** Fixed minor bugs with exception replication, precedence parsing of function + clauses, and simultaneous `sharing` of multiple structures. + ** Made compilation deterministic (eliminate output executable name from + compile-time specified `@MLton` runtime arguments; deterministically generate + magic constant for executable). + ** Updated `-show-basis` (recursively expand structures in environments, + displaying components with long identifiers; append `(* @ region *)` + annotations to items shown in environment). + ** Forced amd64 codegen to generate PIC on amd64-linux targets. +* Runtime. + ** Added `gc-summary-file file` runtime option. + ** Reorganized runtime support for `IntInf` operations so that programs that + do not use `IntInf` compile to executables with no residual dependency on GMP. + ** Changed heap representation to store forwarding pointer for an object in + the object header (rather than in the object data and setting the header to a + sentinel value). +* Language. + ** Added support for selected SuccessorML features; see + http://mlton.org/SuccessorML for details. + ** Added `(*#showBasis "file" *)` directive; see + http://mlton.org/ShowBasisDirective for details. + ** FFI: + *** Added `pure`, `impure`, and `reentrant` attributes to `_import`. An + unattributed `_import` is treated as `impure`. A `pure` `_import` may be + subject to more aggressive optimizations (common subexpression elimination, + dead-code elimination). An `_import`-ed C function that (directly or + indirectly) calls an `_export`-ed SML function should be attributed + `reentrant`. + ** ML Basis annotations. + *** Added `allowSuccessorML {false|true}` to enable all SuccessorML features + and other annotations to enable specific SuccessorML features; see + http://mlton.org/SuccessorML for details. + *** Split `nonexhaustiveMatch {warn|error|igore}` and `redundantMatch + {warn|error|ignore}` into `nonexhaustiveMatch` and `redundantMatch` + (controls diagnostics for `case` expressions, `fn` expressions, and `fun` + declarations (which may raise `Match` on failure)) and `nonexhaustiveBind` + and `redundantBind` (controls diagnostics for `val` declarations (which may + raise `Bind` on failure)). + *** Added `valrecConstr {warn|error|ignore}` to report when a `val rec` (or + `fun`) declaration redefines an identifier that previously had constructor + status. +* Libraries. + ** Basis Library. + *** Improved performance of `Array.copy`, `Array.copyVec`, `Vector.append`, + `String.^`, `String.concat`, `String.concatWith`, and other related + functions by using `memmove` rather than element-by-element constructions. + ** `Unsafe` structure. + *** Added unsafe operations for array uninitialization and raw arrays; see + https://github.com/MLton/mlton/pull/207 for details. + ** Other libraries. + *** Updated: ckit library, MLLPT library, MLRISC library, SML/NJ library +* Tools. + ** mlnlffigen + *** Updated to warn and skip (rather than abort) when encountering functions + with `struct`/`union` argument or return type. + +=== Details + +* 2018-02-6 + ** Remove ancient and unused `cmcat` tool. + +* 2018-02-03 + ** Upgrade `gdtoa.tgz`. + +* 2018-02-02 + ** Remove docs from `all` target of `./Makefile`; this eliminates the + `all-no-docs` target (which was frequently used in favor of `all`). + +* 2018-01-31 + ** Use C compiler with `-std=gnu11` (rather than `-std=gnu99`). + ** Revert rudimentary support for `./configure`; the support was so minimal + that it seems unhelpful to pretend that there are exhaustive compatibility + checks being performed. All of the basic configuration can be accomplished + with simple `make` variable definitions. + +* 2018-01-25 + ** Remove (expert, undocumented) `-debug-format` option; the same effect can + be achieved with `-as-opt` and `-cc-opt`. + ** Propagate C compiler from `./configure` to `mlton` script. + +* 2018-01-24 + ** Extend `-target-*-opt` options to support `arch-os` pairs. + ** Remove `./package/rpm/*` and corresponding targets in `./Makefile`; + upstream MLton has not produced RPMs for years. + +* 2018-01-24 + ** Slightly improve performance of `Vector.concat` and + `String.{concat,concatWith,tokens,fields}` by avoiding `List.map`-s. + +* 2018-01-23 + ** Restore, but deprecate, `-drop-pass` compile-time expert option. + +* 2018-01-19 + ** Update SML/NJ libraries to SML/NJ 110.82. + +* 2017-12-29 + ** Add support for `(*#showBasis "file" *)` directives. This feature is + meant to facilitate auto-completion via + https://github.com/MatthewFluet/company-mlton[`company-mlton`] and similar + tools. + +* 2017-12-20 + ** Update performance comparison on website. Thanks to Curtis Dunham for the + pull request. + +* 2017-12-17 + ** Updates to `-show-basis`: + *** `-show-basis-flat`: Recursively expand structures in environments, + displaying components with long identifiers. + *** `-show-basis-def`: Appends `(* @ region *)` annotations to items shown + in environment. + *** `-show-basis-compact`: Tries to optimize vertical space (at the expense + of long lines). + +* 2017-12-11 + ** Drop `_BSD_SOURCE` and `_POSIX_C_SOURCE` feature macros in + `./runtime/cenv.h`. + +* 2017-12-10 + ** Add a `Dockerfile` to build/test MLton. Thanks to Richard Laughlin for the + pull request. + +* 2017-12-06 + ** Remove `$PREFIX` and `$prefix` from top-level `Makefile.in`; use + `./configure --prefix path`. Thanks to Richard Laughlin for the pull + request. + +* 2017-12-03 + ** Fix heap invariant predicates. + +* 2017-11-15 + ** Eliminate the use of (some) global mutable state for signal handling. + +* 2017-11-14 + ** Store forwarding pointer for an object in the object header (rather than in + the object data and setting the header to a sentinel value). + +* 2017-11-02 + ** Updates to stack management in backend: + *** Improve `Allocation.Stack.get`. + *** Do not force `Cont` block arguments to stack. + +* 2017-10-30 + ** In `signature SSA_TO_RSSA_STRUCTS` share by `Rssa.Atoms = Ssa.Atoms`. This + is the idiom used elsewhere in the compiler, rather than sharing individual + sub-structures of `Atoms`. + ** Minor updates to `DirectedGraph` and `Tree` in MLton library. + +* 2017-10-23 + ** Add `-seed-rand w` compile-time option, to seed the pseudo-random number + generator. + ** Add a new MachineShuffle pass (disabled by default) that shuffles the + collection of chunks within the program and shuffles the collection of blocks + within a chunk. With the `-seed-rand w` compile-time option, can be used to + generate executables with distinct code placements. + +* 2017-10-23 + ** Use a relative path in the `mlton` script, rather than an absolute path. + The absolute path needed to be set to the intended installation directory, + which made it difficult to install a binary release in a local directory. + Undertaken by Maksim Yegorov at RIT supported by NSF CISE Research + Infrastructure (CRI) award. + +* 2017-10-21 + ** Add unsafe operations for array uninitialization and raw arrays. + *** Rename `Array_uninit: SeqIndex.int -> 'a array` primitive to + `Array_alloc: SeqIndex.int -> 'a array`. + *** Add `Array_uninit: 'a array * SeqIndex.int -> unit` primitive to set all + objptrs in the element at the given index to a bogus non-objptr value + (`0wx1`). One motivation for this primitive is to support space-efficient + polymorphic resizeable arrays. When shrinking a resizeable array, we would + like to "`NULL`" out the elements that are no longer part of the logical + array, in order to avoid a (logical) space leak. + *** Add `Array_uninitIsNop: 'a array -> bool` primitive to answer if the + `Array_uninit` primitive applied to the same array would be a nop (i.e., if + the array has no objptrs in the elements). This can be used to skip a + bulk-`Array_uninit` loop when it is known that the `Array_uninit` operations + would be nops. + *** Add `Array_allocRaw: SeqIndex.int -> 'a array` primitive to allocate an + array, but with a header that indicates that the array has no objptrs. Add + `Array_toArray: 'a array -> 'a array` primitive to update the header of an + `Array_allocRaw` allocated array to reveal the objptrs. One motiviation for + this primitive is that, in a parallel setting, the uninitialization of an + array can be a sequential bottleneck. The `Array_allocRaw` is a constant + time operation and the subsequent `Array_uninit` operations can be performed + in parallel. + *** Extend `structure Unsafe.Array` with additional operations. See + `./basis-library/sml-nj/unsafe.sig`. + +* 2017-10-20 + ** Introduce ShareZeroVec SSA optimization to share zero-length vectors after + coercion-based optimizations. Undertaken by Maksim Yegorov at RIT supported + by NSF CISE Research Infrastructure (CRI) award. + +* 2017-10-18 + ** New canonicalization strategy for CommonSubexp SSA optimization. + Previously, the canonicalization of commutative arithmetic primitives was + sensitive to variable hashes (created by an unseeded pseudo-random number + generator); now, the canonicalization of commutative arithmetic primitives is + sensitive to relative definition order of variables. + +* 2017-10-12 + ** Fix bug in runtime argument option parsing. + +* 2017-10-05 + ** Many updates and improvements to diagnostic messages. See + https://github.com/MLton/mlton/pull/195 for details. + +* 2017-09-27 + ** Add rudimentary support for `./configure`; in particular, support + `--with-gmp-lib` and `--with-gmp-include` to set location of GMP and + `--prefix` to specify an install prefix. Undertaken by Maksim Yegorov at RIT + supported by NSF CISE Research Infrastructure (CRI) award. + +* 2017-08-21 + ** Introduce `Array_copyArray: 'a array * SeqIndex.int * 'a array * + SeqIndex.int * SeqIndex.int -> unit` and `Array_copyVector: 'a array * + SeqIndex.int * 'a vector * SeqIndex.int * SeqIndex.int -> unit` primitives + which are used to implement a number of array and vector construction + functions, particularly `append`, `concat`, and `concatWith`. The primitives + compile to `memmove` operations, which (significantly) outperforms MLton's + element-by-element construction for large sequences. Undertaken by Bryan Camp + at RIT supported by NSF CISE Research Infrastructure (CRI) award. + +* 2017-07-25 + ** Force PIC generation on amd64-linux targets. Thanks to Kuen-Bang Hou + (Favonia) for the pull request. + +* 2017-07-11 + ** Generalize the `subWord` primitives to ++ +---- + | WordArray_subWord of {seqSize:WordSize.t, eleSize: WordSize.t} + | WordArray_updateWord of {seqSize: WordSize.t, eleSize: WordSize.t} + | WordVector_subWord of {seqSize: WordSize.t, eleSize: WordSize.t} +---- ++ +Undertaken by Bryan Camp at RIT supported by NSF CISE Research Infrastructure +(CRI) award. + +* 2017-07-11 + ** Add a parser combinator library (`structure StreamParser`) to the MLton + Library. Undertaken by Jason Carr at RIT supported by NSF CISE Research + Infrastructure (CRI) award. + ** Add a parser for the SXML IR (`structure ParseSxml`). Undertaken by Jason + Carr at RIT supported by NSF CISE Research Infrastructure (CRI) award. + ** Allow compilation to start with a `.sxml` file. Undertaken by Jason Carr + at RIT supported by NSF CISE Research Infrastructure (CRI) award. + +* 2017-06-29 + ** Replace `-drop-pass regex` compile-time option with `-disable-pass regex` + compile option and add `-enable-pass regex` compile option. Various XML, + SXML, SSA, SSA2, RSSA, and Machine IR optimization passes are initialized with + a default status, which can be overriden by `-{disable,enable}-pass`. In + particular, it is now easy to add a work-in-progress (and potentially buggy) + pass to the simplification pipeline with `execute = false` default status, to + be selectively executed with `-enable-pass`. Undertaken by Bryan Camp at RIT + supported by NSF CISE Research Infrastructure (CRI) award. + ** Add LoopUnswitch and LoopUnroll SSA optimizations (undertaken by Matthew + Surawski as an RIT CS MS Capstone Project). Initial evaluation demonstrates + some non-trivial performance gains, no non-trivial performance losses, and + only minor code size increases, but currently disabled pending a more thorough + evaluation. + +* 2017-05-23 + ** Expand the set of MLB annotations: + *** `nonexhaustiveBind`, `nonexhaustiveExnBind`, `redundantBind`: controls + diagnostics for `val` declarations (which may raise `Bind` on failure). + *** `nonexhaustiveMatch`, `nonexhaustiveExnMatch`, `redundantMatch`: + controls diagnostics for `case` expressions, `fn` expressions, and `fun` + declarations (which may raise `Match` on failure). + *** `nonexhaustiveRaise`, `nonexhaustiveExnRaise`, `redundantRaise`: + controls diagnostics for `handle` expressions (which implicitly re-raise on + failure). Note that `nonexhaustiveRaise` and `nonexhaustiveExnRaise` + default to `ignore`. The combination of `nonexhaustiveRaise warn` and + `nonexhaustiveExnRaise ignore` can be useful for finding handlers that + handle some, but not all, values of an exception variant. + ** Make a number of improvements to diagnostic messages: + *** Display nonexhaustive exception patterns as `_ : exn`, rather than + `e`. + *** Normalize nonexhaustive patterns by sorting (e.g., by `ConApp` name). + *** Report complete enumeration of unhandled constants, rather than a single + example. + *** Report nonexhaustive patterns of record type as records, rather than as + tuples. + +* 2017-04-20 + ** Updates to SSA, SSA2, and RSSA IR support infrastructure + *** Display more context when reporting SSA and SSA2 IR type errors. + *** Add `-layout-width n` compile expert option to control the target width + for the pretty printer. + *** Make cosmetic improvments to SSA and SSA2 IR display (uses of global + variables bound to small constants and conapps are commented with the + corresponding value; include loop forest for functions with `-keep dot`). + *** Improve RSSA constant folding and copy propagation. + *** Limit Machine IR `Globals` to variables used outside of the `main` + function. + +* 2017-04-15 + ** Add `gc-summary-file file` runtime option. + +* 2017-04-15 + ** Rename and add `smlnj-mlton-x{2,4,8,16}` top-level `Makefile` targets. + ** Update SML/NJ librarys to SML/NJ 110.80 (making use of supported + SuccessorML features). + ** Not support for SML/NJ extensions via SuccessorML MLB annotations on + website. + +* 2017-04-14 + ** Add support for vector expressions (`#[e1, e2, ..., en]`) and vector + patterns (`#[p1, p2, ..., pn]`) and add `Vector_vector` n-ary primitive. + Initial support for vector expressions and the `Vector_vector` primitive were + undertaken by Krishna Ravikumar as an RIT CS MS Capstone Project. + +* 2017-03-29 + ** Update DOS eol handling and tweak error messages in lexer. + +* 2017-03-27 + ** Correct off-by-one error in column numbers. Thanks to Jacob Zimmerman for + the error report and pull request. + +* 2017-03-15 + ** Updates to SuccessorML support: + *** Add an `allowSuccessorML {false|true}` MLB annotation to enable all + Successor ML features with a single annotation. + *** Fix parsing of numeric labels to only accept an INT token that does not + begin with 0, is not an extended literal, is not negative, and is decimal. + *** Drop the alternate word prefixes (`0xw` and `0bw`). + *** Unconditionally allow line comments in MLB files. + *** Allow UTF-8 byte sequences in text constants. + *** Refactor `ml.lex` and `mlb.lex` to be more maintainable. + *** Rename `allowRecPunning` annotation to `allowRecordPunExps`. + +* 2017-02-27 + ** Update ML-Yacc examples (`calc`, `fol`, `pascal`) to comply with MLton + build process. Thanks to Hai Nguyen Van for the pull request. + +* 2017-01-25 + ** Update PortingMLton documentation and `./bin/add-cross` script. Thanks to + Daniel Moerner for the pull request. + +* 2016-09-29 + ** Constant fold `CPointer_equal(NULL, NULL)` to `true`. + +* 2016-09-29 + ** Introduce `NEEDS_SIGALTSTACK_EXEC` config in runtime system. + +* 2016-09-27 + ** Construct a devel build version string from last commit time and last + commit hash. + ** Omit build date and build node from version banner; makes self-compiles + deterministic. + ** Remove `upgrade-basis.sml` from build. The generated `upgrade-basis.sml` + was introduced to handle incompatibilities in the Basis Library provided by an + old version of MLton and the Basis Library assumed by the current sources. + However, there are no incompatibilities with MLton 20130715, MLton 20100608, + or MLton 20070826. Nonetheless, the feature testing performed by + `./bin/upgrade-basis` to generate `upgrade-basis.sml` is time consuming, + especially when trying to simply type check the compiler sources. + +* 2016-06-20 + ** Do not `gzip` man pages on OpenBSD. Thanks to Alexander Abushkevich for + the pull request. + +* 2016-06-20 + ** Generate position independent code for OpenBSD. Thanks to Alexander + Abushkevich for the pull request. + +* 2016-06-20 + ** Fix profiling for amd64-openbsd and x86-openbsd. Thanks to Alexander + Abushkevich for the pull request. + +* 2016-04-06 + ** Update SML/NJ librarys to SML/NJ 110.79. + +* 2016-03-22 + ** Update LLVM codegen to support (and require) >= llvm-3.7. Thanks to Eugene + Akentyev for the pull request. + +* 2016-02-26 + ** Configure GMP location via `Makefile`. + +* 2016-01-10 + ** Fix typo in `mlb-formal.tex`. Thanks to Jon Sterling for the pull request. + +* 2015-11-10 + ** Update SML/NJ librarys to SML/NJ 110.78. Use `allowOrPats` and + `allowSigWithtype` to minimize diffs. + +* 2015-10-20 + ** Fix elaboration of `withtype` in signature. + +* 2015-10-06 + ** Add support for setting CM anchor bindings in `cm2mlb` tool. + +* 2015-10-06 + ** Fix non-exhaustive match warnings with or-patterns. Thanks to Rob Simmons + for the bug report. + ** Distinguish between partial and fully redundant matches. + ** Report partial redundancy in `val` declarations. + ** Lower precedence of or-patterns in parser. + ** Make a variety of cosmetic improvements to non-exhaustive and redundant + error/warning messages, primarily to be consistent in formatting between + quoted AST and generated messages. + +* 2015-07-10 + ** Extend support for arm64 (aarch64). Thanks to Edmund Evans for the patch. + +* 2015-06-22 + ** Introduce `valrecConstr {warn|error|ignore}` MLB annotation to report when + a `val rec` (or `fun`) declaration redefines an identifier that previously had + constructor status. + +* 2015-06-19 + ** Add support for selected SuccessorML features (undertaken by Kevin Bradley + as an RIT CS MS Capstone Project). + *** `do`-declarations (`allowDoDecls`) + *** extended literals (`allowExtendedLiterals`) + *** line comments (`allowLineComments`) + *** optional leading bar in matches, fun decls, and datatype decls + (`allowOptBar`) + *** optional trailing semicolon in sequence expressions (`allowOptSemicolon`) + *** or patterns (`allowOrPats`) + *** record expression punning (`allowRecPunning`) + *** withtype in signatures (`allowSigWithtype`) + +* 2015-06-10 + ** Hide equality status of poly (and mono) vector and array slices. + ** Hide type equality of mono and poly `Word8.word` arrays and vectors. + +* 2015-06-08 + ** Added `reentrant` attribute to `_import`. An `_import`-ed C function that + (directly or indirectly) calls an `_export`-ed SML function should be + attributed `reentrant`. + +* 2015-06-08 + ** Make compilation deterministic: + *** Eliminate output executable name from compile-time specified `@MLton` + arguments. + *** Deterministically generate magic constant for executable. + +* 2015-06-08 + ** Add `-keep ast` compile option. Undertaken by Ross Bayer at RIT supported + by NSF CISE Research Infrastructure (CRI) award. + +* 2015-06-02 + ** Updates to Debian packaging. Thanks to Christopher Cramer for the pull + request. + +* 2015-03-30 + ** Use `LANG=en_us` when computing version and build date. Thanks to Eugene + Akentyev for the pull request. + +* 2015-02-17 + ** Update `mlnlffigen` to warn and skip functions with `struct`/`union` + arguments. Thanks to Armando Doval for the pull request. + +* 2014-12-22 + ** Move pervasive constructs from `./mlton/ast` to `./mlton/atoms`, so that + `./mlton/ast/sources.mlb` depends on `./mlton/atoms/sources.mlb` (and not the + other way around). Undertaken by Vedant Raiththa at RIT supported by NSF CISE + Research Infrastructure (CRI) award. + +* 2014-12-17 + ** Cache a worker thread to service calls of `_export`-ed functions. Thanks + to Bernard Berthomieu for the bug report. + +* 2014-12-02 + ** Post-process generated front-end files for compatibility with SML/NJ's + recent `ml-lex` and `ml-yacc` tools that generate log identifiers rather than + unqualified (top-level environment) identifiers. + ** Corrected documentation for SML/NJ `Makefile` target and fixed + `bootstrap-nj` target. Thanks to Daniel Rosenwasser for the pull request. + +* 2014-11-21 + ** Reorganized runtime support for `IntInf` operations so that programs that + do not use `IntInf` compile to executables with no residual dependency on GMP. + ** Fixed bug in `MLton.IntInf.fromRep` that could yield values that violate + the `IntInf` representation invariants. Thanks to Rob Simmons for the bug + report. + +* 2014-10-24 + ** Added `pure` and `impure` attributes to `_import`. An unattributed + `_import` is treated as `impure`. A `pure` `_import` may be subject to more + aggressive optimizations (common subexpression elimination, dead-code + elimination). Undertaken by Vedant Raiththa at RIT supported by NSF CISE + Research Infrastructure (CRI) award. + +* 2014-10-22 + ** Various updates to treatment of `IntInf` constants in the compiler. + *** Recognize both `Big` and `Small` representations of `IntInf`-s. + *** Translate `IntInf` consts to `Big` and `Small` representations in + conversion from SSA to RSSA. This is consistent with the treatment of other + `IntInf` operations in the conversion. After the conversion, `IntInf` is no + longer treated as a primitive. + *** Remove `initIntInfs` from program initialization. + *** Constant fold `IntInf_toVector` and `WordVector_toIntInf` primitives. + +* 2014-10-20 + ** Various updates to `structure WordXVector` in compiler proper. + *** Update the `WordXVector.layout` function. If the `elementSize` is + `WordX.word8` and more than 90% of the characters satisfy `Char.isGraph + orelse Char.isSpace`, then display as an SML string constant (with + non-printable characters SML-escaped). Otherwise, display as an SML/NJ-style + `#[0x0, 0xF]` vector literal. + *** Update initialization of `static struct GC_vectorInit vectorInits[]` + constants in runtime. If the `WordXVector`'s (primitive) `elementSize` is + `WordSize.W8`, then emit a C-escaped string constant. Otherwise, emit a + C-array initialization. + +* 2014-08-15 + ** More updates to benchmark infrastructure. + *** Make `update-counts.sh` script more robust. + *** Update `hamlet.sml` benchmark program to close input file after each + loop. + *** Update `fft.sml` benchmark program to only invoke `test` function with + power-of-2 arguments. + *** Update `model-elimination.sml` benchmark program to iterate `main ()` + according to `doit` size parameter. + +* 2014-08-11 + ** Include `winsock2.h` before `windows.h` in MinGW port. Thanks to Shu-Hung + You for the pull request. + +* 2014-07-31 + ** Refactor array and vector implementation in Basis Library into a primitive + implementation (using `SeqInt.int` for indexing) and a wrapper implementation + (using the default `Int.int` for indexing). Thanks to Rob Simmons for the + pull request. + ** Correct description of `MLton.{Vector,Array}.unfoldi` on website. Thanks + to Rob Simmons for the pull request. + +* 2014-07-14 + ** Updates to benchmark infrastructure. + *** Add `even-odd.sml` benchmark that exercises mutual tail recursion. + *** Add `update-counts.sh` script to calculate appropriate benchmark + iteration counts and update benchmark iteration counts so that all + benchmarks run for at least 30 seconds. + *** Updates to benchmark driver program. + +* 2014-07-07 + ** Change `./basis-library/integer/int-inf.sml` to reduce dependency on + GMP-specific details of `./basis-library/integer/int-inf0.sml`. Thanks to Rob + Simmons for the pull request. + ** Correct type and description of `MLton.IntInf.fromRep` on website. Thanks + to Rob Simmons for the pull request. + +* 2014-07-01 + ** Add experimental LLVM codegen (undertaken by Brian Leibig as an RIT CS MS + Project). + +* 2014-06-09 + ** Update `CallingFromSMLToC` page on website. Thanks to Bikal Gurung for the + pull request. + +* 2014-03-18 + ** Updates for MinGW port. + +* 2014-02-07 + ** Update AsciiDoc sources for website. + +* 2013-10-31 + ** Various updates to website. Thanks to Mauricio C Antunes for the pull + request. + *** Add Tofte's tutorial and Rossberg's grammar. + *** Fix links to implementations. + +* 2013-10-10 + ** Update links from `References` page on website. Thanks to Mauricio C + Antunes for the pull request. + +* 2013-09-02 + ** Fix example for `Lazy` page on website. Thanks to Daniel Rosenwasser for + the pull request. + +== Version 20130715 + +Here are the changes from version 20100608 to version 20130715. + +=== Summary + +* Compiler. + ** Cosmetic improvements to type-error messages. + ** Removed features: + *** Bytecode codegen: The bytecode codegen had not seen significant use and + it was not well understood by any of the active developers. + *** Support for `.cm` files as input: The ML Basis system provides much + better infrastructure for "programming in the very large" than the (very) + limited support for CM. The `cm2mlb` tool (available in the source + distribution) can be used to convert CM projects to MLB projects, preserving + the CM scoping of module identifiers. + ** Bug fixes: see changelog +* Runtime. + ** Bug fixes: see changelog +* Language. + ** Interpret `(*#line line:col "file" *)` directives as relative + file names. + ** ML Basis annotations. + *** Added: `resolveScope` +* Libraries. + ** Basis Library. + *** Improved performance of `String.concatWith`. + *** Use bit operations for `REAL.class` and other low-level operations. + *** Support additional variables with `Posix.ProcEnv.sysconf`. + *** Bug fixes: see changelog + ** `MLton` structure. + *** Removed: `MLton.Socket` + ** Other libraries. + *** Updated: ckit library, MLRISC library, SML/NJ library + *** Added: MLLPT library +* Tools. + ** mllex + *** Generate `(*#line line:col "file.lex" *)` directives with simple + (relative) file names, rather than absolute paths. + ** mlyacc + *** Generate `(*#line line:col "file.grm" *)` directives with simple + (relative) file names, rather than absolute paths. + *** Fixed bug in comment-handling in lexer. + +=== Details + +* 2013-07-06 + ** Update SML/NJ libraries to SML/NJ 110.76. + +* 2013-06-19 + ** Upgrade `gdtoa.tgz`; fixed bug in `Real32.{fmt,toDecimal,toString}`, which + in some cases produced too many digits + +* 2013-06-18 + ** Removed `MLton.Socket` structure (deprecated in last release). + +* 2013-06-10 + ** Improved performance of `String.concatWith`. + +* 2013-05-22 + ** Update SML/NJ libraries to SML/NJ 110.75. + +* 2013-04-30 + ** Detect PowerPC 64 architecture. + +* 2012-10-09 + ** Fixed bug in elaboration that erroneously accepted the following: + + signature S = sig structure A : sig type t end + and B : sig type t end where type t = A.t end + +* 2012-09-04 + ** Introduce an MLB annotation to control overload and flex record resolution + scope: `resolveScope {strdec|dec|topdec|program}`. + +* 2012-07-04 + ** Simplify use of `getsockopt` and `setsockopt` in Basis Library. + ** Direct implementation of `Socket.Ctl.{getATMARK,getNREAD}` in runtime + system, rather than indirect implementation in Basis Library via `ioctl`. + ** Replace use of casting through a union with `memcpy` in runtime. + +* 2012-06-11 + ** Use bit operations for `REAL.class` and other low-level operations. + ** Fixed bugs in `REAL.copySign`, `REAL.signBit`, and `REAL.{to,from}Decimal`. + +* 2012-06-01 + ** Cosmetic improvements to type-error messages. + ** Fixed bug in elaboration that erroneously rejected the following: + + datatype ('a, ''a) t = T + type ('a, ''a) u = unit + + and erroneously accepted the following: + + fun f (x: 'a) : ''a = x + fun g (x: 'a) : ''a = if x = x then x else x + +* 2012-02-24 + ** Fixed bug in redundant SSA optimization. + +* 2011-06-20 + ** Support additional variables with `Posix.ProcEnv.sysconf`. + +* 2011-06-17 + ** Change `mllex` and `mlyacc` to generate `#line` directives with simple file + names, rather than absolute paths. + ** Interpret `#line` directives as relative file names. + +* 2011-06-14 + ** Fixed bug in SSA/SSA2 shrinker that could erroneously turn a non-tail + function call with a `Bug` transfer as its continuation into a tail function + call. + +* 2011-06-11 + ** Update SML/NJ libraries to SML/NJ 110.73 and add ML-LPT library. + +* 2011-06-10 + ** Fixed bug in translation from SSA2 to RSSA with case expressions over + non-primitive-sized words. + ** Fixed bug in SSA/SSA2 type checking of case expressions over words. + +* 2011-06-04 + ** Upgrade `gdtoa.tgz`. + ** Remove bytecode codegen. + ** Remove support for `.cm` files as input. + +* 2011-05-03 + ** Fixed a bug with the treatment of `as`-patterns, which should not allow the + redefinition of constructor status. + +* 2011-02-18 + ** Fixed bug with treatment of nan in common subexpression elimination SSA + optimization. + +* 2011-02-18 + ** Fixed bug in translation from SSA2 to RSSA with weak pointers. + +* 2011-02-05 + ** Fixed bug in amd64 codegen calling convention for varargs C calls. + +* 2011-01-17 + ** Fixed bug in comment-handling in lexer for `mlyacc`'s input language. + +* 2010-06-22 + ** Fixed bug in elaboration of function clauses with different numbers of + arguments that would raise an uncaught `Subscript` exception. + + +== Version 20100608 + +Here are the changes from version 20070826 to version 20100608. + +=== Summary + +* New platforms. + ** ia64-hpux + ** powerpc64-aix +* Compiler. + ** Command-line switches. + *** Added: `-mlb-path-var ' '` + *** Removed: `-keep sml`, `-stop sml` + ** Improved constant folding of floating-point operations. + ** Experimental: Support for compiling to a C library; see wiki documentation. + ** Extended `-show-def-use` output to include types of variable definitions. + ** Deprecated features (to be removed in a future release) + *** Bytecode codegen: The bytecode codegen has not seen significant use and + it is not well understood by any of the active developers. + *** Support for `.cm` files as input: The ML Basis system provides much + better infrastructure for "programming in the very large" than the (very) + limited support for CM. The `cm2mlb` tool (available in the source + distribution) can be used to convert CM projects to MLB projects, preserving + the CM scoping of module identifiers. + ** Bug fixes: see changelog +* Runtime. + ** `@MLton` switches. + *** Added: `may-page-heap {false|true}` + ** `may-page-heap`: By default, MLton will not page the heap to disk when + unable to grow the heap to accomodate an allocation. (Previously, this + behavior was the default, with no means to disable, with security an + least-surprise issues.) + ** Bug fixes: see changelog +* Language. + ** Allow numeric characters in ML Basis path variables. +* Libraries. + ** Basis Library. + *** Bug fixes: see changelog. + ** `MLton` structure. + *** Added: `MLton.equal`, `MLton.hash`, `MLton.Cont.isolate`, + `MLton.GC.Statistics, `MLton.Pointer.sizeofPointer`, + `MLton.Socket.Address.toVector` + *** Changed: + *** Deprecated: `MLton.Socket` + ** `Unsafe` structure. + *** Added versions of all of the monomorphic array and vector structures. + ** Other libraries. + *** Updated: ckit library, MLRISC library, SML/NJ library. +* Tools. + ** `mllex` + *** Eliminated top-level `type int = Int.int` in output. + *** Include `(*#line line:col "file.lex" *)` directives in output. + *** Added `%posint` command, to set the `yypos` type and allow the lexing of + multi-gigabyte files. + ** `mlnlffigen` + *** Added command-line switches `-linkage archive` and `-linkage shared`. + *** Deprecated command-line switch `-linkage static`. + *** Added support for ia64 and hppa targets. + ** `mlyacc` + *** Eliminated top-level `type int = Int.int` in output. + *** Include `(*#line line:col "file.grm" *)` directives in output. + +=== Details + +* 2010-05-12 + ** Fixed bug in the mark-compact garbage collector where the C library's + `memcpy` was used to move objects during the compaction phase; this could lead + to heap corruption and segmentation faults with newer versions of `gcc` and/or + `glibc`, which assume that src and dst in a `memcpy` do not overlap. + +* 2010-03-12 + ** Fixed bug in elaboration of `datatype` declarations with `withtype` + bindings. + +* 2009-12-11 + ** Fixed performance bug in RefFlatten SSA2 optimization. + +* 2009-12-09 + ** Fixed performance bug in SimplifyTypes SSA optimization. + +* 2009-12-02 + ** Fixed bug in amd64 codegen register allocation of indirect C calls. + +* 2009-09-17 + ** Fixed bug in `IntInf.scan` and `IntInf.fromString` where leading spaces + were only accepted if the stream had an explicit sign character. + +* 2009-07-10 + ** Added CombineConversions SSA optimization. + +* 2009-06-09 + ** Removed deprecated command line switch `-show-anns {false, true}`. + +* 2009-04-18 + ** Removed command line switches `-keep sml` and `-stop sml`. Their meaning + was unclear with `.mlb` files; their effect with `.cm` files can be achieved + with `-stop f`. + +* 2009-04-16 + ** Fixed bug in `IntInf.~>>` that could cause a `glibc` assertion failure. + +* 2009-04-01 + ** Fixed exported type of `MLton.Process.reap`. + +* 2009-01-27 + ** Added `MLton.Socket.Address.toVector` to get the network-byte-order + representation of an IP address. + +* 2008-11-10 + ** Fixed bug in `MLton.size` and `MLton.share` when tracing the current stack. + +* 2008-10-27 + ** Fixed phantom typing of sockets by hiding the representation of socket + types. Previously the representation of sockets was revealed rendering the + phantom types useless. + +* 2008-10-10 + ** Fixed bug in nested `_export`/`_import` functions. + +* 2008-09-12 + ** Improved constant folding of floating point operations. + +* 2008-08-20 + ** Store the card/cross map at the end of the allocated ML heap; avoids + possible out of memory errors when resizing the ML heap cannot be followed by + a card/cross map allocation. + +* 2008-07-24 + ** Added support for compiling to a C library. The relevant new compiler + options are `-ar` and `-format`. Libraries are named based on the name of the + `-export-header` file. Libraries have two extra methods: + *** `NAME_open(argc, argv)` initializes the library and runs the SML code + until it reaches the end of the program. If the SML code exits or raises an + uncaught exception, the entire program will terminate. + *** `NAME_close()` will execute any registered atExit functions, any + outstanding finalizers, and frees the ML heap. + +* 2008-07-16 + ** Fixed bug in the name mangling of `_import`-ed functions with the `stdcall` + convention. + +* 2008-06-12 + ** Added `MLton.Pointer.sizeofPointer`. + +* 2008-06-06 + ** Added expert command line switch `-emit-main {true|false}`. + +* 2008-05-17 + ** Fixed bug in Windows code to page the heap to disk when unable to grow the + heap to a desired size. Thanks to Sami Evangelista for the bug report. + +* 2008-05-10 + ** Implemented `MLton.Cont.isolate`. + +* 2008-04-20 + ** Fixed bug in *NIX code to page the heap to disk when unable to grow the + heap to a desired size. Thanks to Nicolas Bertolotti for the bug report and + patch. + +* 2008-04-07 + ** More flexible active/paused stack resizing policy. + + Removed `thread-shrink-ratio` runtime option. + Added + `stack-current-grow-ratio`, `stack-current-max-reserved-ratio`, + `stack-current-permit-ratio`, `stack-current-shrink-ratio`, + `stack-max-reserved-ratio`, and `stack-shrink-ratio` runtime options. + +* 2008-04-07 + ** Fixed bugs in Basis Library where the representations of `OS.IO.iodesc`, + `Posix.IO.file_desc`, `Posix.Signal.signal`, `Socket.sock`, + `Socket.SOGK.sock_type` as integers were exposed. + +* 2008-03-14 + ** Added unsafe versions of all of the monomorphic array and vector + structures. + +* 2008-03-02 + ** Fixed bug in Basis Library where the representation of `OS.Process.status` + as an integer was exposed. + +* 2008-02-13 + ** Fixed space-safety bug in RefFlatten optimization (to flatten refs into + containing data structure). Thanks to Daniel Spoonhower for the bug report and + initial diagnosis and patch. + +* 2008-01-25 + ** Various updates to GC statistics gathering. Some basic GC statistics can + be accessed from SML by `MLton.GC.Statistics.*` functions. + +* 2008-01-24 + ** Added primitive (structural) polymorphic hash. + +* 2008-01-21 + ** Fixed frontend to accept `op _longvid_` patterns and expressions. Thanks to + Florian Weimer for the bug report. + +* 2008-01-17 + ** Extended `-show-def-use` output to include types of variable definitions. + +* 2008-01-09 + ** Extended `MLton_equal` to be a structural equality on all types, including + `real` and `->` types. + +* 2007-12-18 + ** Changed ML-Yacc and ML-Lex to output line directives so that MLton's + def-use information points to the source files (`.grm` and `.lex`) instead of + the generated implementations (`.grm.sml` and `.lex.sml`). + +* 2007-12-14 + ** Added runtime option `may-page-heap {false|true}`. By default, MLton will + not page the heap to disk when unable to grow the heap to a desired size. + (Previously, this behavior was the default, with no means to disable, with + security and least-surprise concerns.) Thanks to Wesley Terpstra for the + patch. + ** Fixed bug the FFI visible representation of `Int16.int ref` (and references + of other primitive types smaller than 32-bits) on big-endian platforms. Thanks + to Dave Herman for the bug report. + +* 2007-12-13 + ** Fixed bug in `ImperativeIOExtra.canInput` (`TextIO.canInput`). Thanks to + Ville Laurikari for the bug report. + +* 2007-12-09 + ** Better constant folding of `IntInf` operations. + +* 2007-12-07 + ** Fixed bug in algebraic simplification of `RealX` primitives. `Real.<= (x, + x)` is `false` when `x` is `NaN`. + +* 2007-11-29 + ** Fixed bug in type inference of flexible records. This would later cause + the compiler to raise the `TypeError` exception. Thanks to Wesley Terpstra for + the bug report. + +* 2007-11-28 + ** Fixed bug in cross-compilation of `gdtoa` library. Thanks to Wesley + Terpstra for the bug report and patch. + +* 2007-11-20 + ** Fixed bug in RefFlatten optimization (pass to flatten refs into containing + data structure). Thanks to Ruy LeyWild for the bug report. + +* 2007-11-19 + ** Fixed bug in the handling of weak pointers by the mark-compact garbage + collector. Thanks to Sean McLaughlin for the bug report and Florian Weimer for + the initial diagnosis. + +* 2007-11-07 + ** Added `%posint` command to `ml-lex`, to set the `yypos` type and allow the + lexing of multi-gigabyte input files. Thanks to Florian Weimer for the feature + concept and original patch. + +* 2007-11-07 + ** Added command-line switch `-mlb-path-var ' '` for specifying + MLB path variables. + +* 2007-11-06 + ** Allow numeric characters in MLB path variables. + +* 2007-09-20 + ** Fixed bug in elaboration of structures with signature constraints. This + would later cause the compiler to raise the `TypeError` exception. Thanks to + Vesa Karvonen for the bug report. + +* 2007-09-11 + ** Fixed bug in interaction of `_export`-ed functions and signal + handlers. Thanks to Sean McLaughlin for the bug report. + +* 2007-09-03 + ** Fixed bug in implementation of `_export`-ed functions using `char` + type. Thanks to Katsuhiro Ueno for the bug report. + + +== Version 20070826 + +Here are the changes from version 20051202 to version 20070826. + +=== Summary + +* New platforms: + ** amd64-linux, amd64-freebsd + ** hppa-hpux + ** powerpc-aix + ** x86-darwin (Mac OS X) +* Compiler. + ** Support for 64-bit platforms. + *** Native amd64 codegen. + ** Command-line switches. + *** Added: `-codegen amd64`, `-codegen x86`, `-default-type `, + `-profile-val {false|true}`. + *** Changed: `-stop f` (file listing now includes `.mlb` files) + ** Bytecode codegen. + *** Support for profiling. + *** Support for exception history. +* Language. + ** ML Basis annotations. + *** Removed: `allowExport`, `allowImport`, `sequenceUnit`, `warnMatch`. +* Libraries. + ** Basis Library. + *** Added: `PackWord16Big, `PackWord16Little`, `PackWord64Big`, + `PackWord64Little`. + *** Bug Fixes: see changelog. + ** `MLton` structure. + *** Added: `MLTON_MONO_ARRAY`, `MLTON_MONO_VECTOR`, `MLTON_REAL`, + `MLton.BinIO.tempPrefix`, `MLton.CharArray`, `MLton.CharVector`, + `MLton.IntInf.BigWord`, `MLton.IntInf.SmallInt`, + `MLton.Exn.defaultTopLevelHandler`, `MLton.Exn.getTopLevelHandler`, + `MLton.Exn.setTopLevelHandler`, `MLton.LargeReal`, `MLton.LargeWord`, + `MLton.Real`, `MLton.Real32`, `MLton.Real64`, `MLton.Rlimit.Rlim`, + `MLton.TextIO.tempPrefix`, `MLton.Vector.create`, `MLton.Word.bswap`, + `MLton.Word8.bswap`, `MLton.Word16`, `MLton.Word32`, `MLton.Word64`, + `MLton.Word8Array`, `MLton.Word8Vector`. + *** Changed: `MLton.Array.unfoldi`, `MLton.IntInf.rep`, `MLton.Rlimit`, + `MLton.Vector.unfoldi`. + *** Deprecated: `MLton.Socket` + ** Other libraries. + *** Added: MLRISC libary. + *** Updated: ckit library, SML/NJ library. +* Tools. + +=== Details + +* 2007-08-12 + ** Removed deprecated ML Basis annotations. + +* 2007-08-06 + ** Fixed bug in treatment of `Real.{scan,fromString}` operations. + `Real.{scan,fromString}` were using `TO_NEAREST` semantics, but should obey + current rounding mode. (Only `Real.fromDecimal` is specified to always + have `TO_NEAREST` semantics.) Thanks to Sean McLaughlin for the bug report. + +* 2007-07-27 + ** Fixed bugs in constant-folding of floating-point operations with C codegen. + +* 2007-07-26 + ** Fixed bug in treatment of floating-point operations. Floating-point + operations depend on the current rounding mode, but were being treated as + pure. Thanks to Sean McLaughlin for the bug report. + +* 2007-07-13 + ** Added `MLton.Exn.{default,get,set}TopLevelHandler`. + +* 2007-07-12 + ** Restored `native` option to `-codegen` flag. + +* 2007-07-11 + ** Fixed bug in `Real32.toInt`: conversion of real values close to + `Int.maxInt` could be incorrect. + +* 2007-07-07 + ** Updates to bytecode code generator: support for amd64-* targets, support + for profiling (including exception history). + ** Fixed bug in `Socket` module of Basis Library; unmarshalling of socket + options (for `get*` functions) used `andb` rather than `orb`. Thanks to Anders + Petersson for the bug report (and patch). + +* 2007-07-06 + ** Fixed bug in `Date` module of Basis Library; some functions would + erroneously raise `Date` when given a year <= 1900. Thanks to Joe Hurd for the + bug report. + ** Fixed a long-standing bug in monomorphisation pass. Thanks to Vesa Karvonen + for the bug report. + +* 2007-05-18 + ** Native amd64 code generator for amd64-* targets. + ** Eliminate `native` option from `-codegen` flag. + ** Add `x86` and `amd64` options to `-codegen` flag. + +* 2007-04-29 + ** Improved type checking of RSSA and Machine ILs. + +* 2007-04-14 + ** Fixed aliasing issues with `basis/Real/*.c` files. + ** Added real/word casts in `MLton` structure. + +* 2007-04-12 + ** Added primitives for bit cast of word to/from real. + ** Implement `PackReal{Big,Little}` using `PackWord{Big,Little}` and bit + casts. + +* 2007-04-11 + ** Move all system header `#include`-s to `platform/` os headers. + ** Use C99 ``, rather than custom `"assert.{h,c}"`. + +* 2007-03-13 + ** Implement `PackWord{Big,Little}` entirely in ML, using an ML byte swap + function. + +* 2007-02-25 + ** Change amd64-* target platforms from 32-bit compatibility mode (i.e., + `-m32`) to 64-bit mode (i.e., `-m64`). Currently, only the C codegen is able + to generate 64-bit executables. + +* 2007-02-23 + ** Removed expert command line switch `-coalesce `. + ** Added expert command line switch `-chunkify {coalesce|func|one}`. + +* 2007-02-20 + ** Fixed bug in `PackReal.toBytes`. Thanks to Eric McCorkle for the bug + report (and patch). + +* 2007-02-18 + ** Added command line switch `-profile-val`, to profile the evaluation of + `val` bindings; this is particularly useful with exception history for + debugging uncaught exceptions at the top-level. + +* 2006-12-29 + ** Added command line switch `-show {anns|path-map}` and deprecated command + line switch `-show-anns {false|true}`. Use `-show path-map` to see the + complete MLB path map as seen by the compiler. + +* 2006-12-20 + ** Changed the output of command line switch `-stop f` to include `.mlb` + files. This is useful for generating Makefile dependencies. The old output + is easy to recover if necessary (e.g. `grep -v '\.mlb$'`). + +* 2006-12-08 + ** Added command line switches `-{,target}-{as,cc,link}-opt-quote`, which pass + their argument as a single argument to `gcc` (i.e., without tokenization at + spaces). These options support using headers and libraries (including the + MLton runtime headers and libraries) from a path with spaces. + +* 2006-12-02 + ** Extensive reorganization of garbage collector, runtime system, and Basis + Library implementation. (This is in preparation for future 64bit support.) + They should be more C standards compliant and easier to port to new systems. + ** FFI revisions + *** Disallow nested indirect types (e.g., `int array array`). + +* 2006-11-30 + ** Fixed a bug in elaboration of FFI forms; unary FFI types (e.g., `array`, + `ref`, `vector`) could be used in places where `MLton.Pointer.t` was required. + This would later cause the compiler to raise the `TypeError` exception, along + with a lot of XML IL. + +* 2006-11-19 + ** On *-darwin, work with GnuMP installed via Fink or MacPorts. + +* 2006-10-30 + ** Ported to x86-darwin. + +* 2006-09-23 + ** Added missing specification of `find` to the `MONO_VECTOR` signature. + +* 2006-08-03 + ** Fixed a bug in Useless SSA optimization, caused by calling an imported C + function and then ignoring the result. + +* 2006-06-24 + ** Fixed a bug in pass to flatten data structures. Thanks to Joe Hurd for the + bug report. + +* 2006-06-08 + ** Fixed a bug in the native codegen's implementation of the C-calling + convention. + +* 2006-05-11 + ** Ported to PowerPC-AIX. + ** Fixed a bug in the runtime for the cases where nonblocking IO with sockets + was implemented using `MSG_DONTWAIT`. This flag does not exist on AIX, + Cygwin, HPUX, and MinGW and was previously just ignored. Now the runtime + simulates the flag for these platforms (except MinGW, yet, where it's still + ignored). + +* 2006-05-06 + ** Added `-default-type ''` for specifying the binding of default types + in the Basis Library (e.g., `Int.int`). + +* 2006-04-25 + ** Ported to HPPA-HPUX. + ** Fixed `PackReal{,32,64}{Big,Little}` to follow the Basis Library + specification. + +* 2006-04-19 + ** Fixed a bug in `MLton.share` that could cause a segfault. + +* 2006-03-30 + ** Changed `MLton.Vector.unfoldi` to return the state in addition to the + result vector. + +* 2006-03-30 + ** Added `MLton.Vector.create`, a more powerful vector-creation function than + is available in the basis library. + +* 2006-03-04 + ** Added MLRISC from SML/NJ 110.57 to standard distribution. + +* 2006-03-03 + ** Fixed bug in SSA simplifier that could eliminate an irredundant test. + +* 2006-03-02 + ** Ported a bugfix from SML/NJ for a bug with the combination of `withNack` + and `never` in CML. + +* 2006-02-09 + ** Support compiler specific annotations in ML Basis files. If an annotation + contains `:`, then the text preceding the `:` is meant to denote a compiler. + For MLton, if the text preceding the `:` is equal to `mlton`, then the + remaining annotation is scanned as a normal annotation. If the text preceding + the `:` is not-equal to `mlton`, then the annotation is ignored, and no + warning is issued. + +* 2006-02-04 + ** Fixed bug in elaboration of functors; a program with a very large number of + functors could exhibit the error `ElaborateEnv.functorClosure: firstTycons`. + + +== Version 20051202 + +Here are the changes from version 20041109 to version 20051202. + +=== Summary + +* New license: BSD-style instead of GPL. +* New platforms: + ** hppa: Debian Linux. + ** x86: MinGW. +* Compiler. + ** improved exception history. + ** Command-line switches. + *** Added: `-as-opt`, `-mlb-path-map`, `-target-as-opt`, `-target-cc-opt`. + *** Deprecated: none. + *** Removed: `-native`, `-sequence-unit`, `-warn-match`, `-warn-unused`. +* Language. + ** FFI syntax changes and extensions. + *** Added: `_symbol`. + *** Changed: `_export`, `_import`. + *** Removed: `_ffi`. + ** ML Basis annotations. + *** Added: `allowFFI`, `nonexhaustiveExnMatch`, `nonexhaustiveMatch`, + `redundantMatch`, `sequenceNonUnit`. + *** Deprecated: `allowExport`, `allowImport`, `sequenceUnit`, `warnMatch`. +* Libraries. + ** Basis Library. + *** Added: `Int1`, `Word1`. + ** `MLton` structure. + *** Added: `Process.create`, `ProcEnv.setgroups`, `Rusage.measureGC`, + `Socket.fdToSock`, `Socket.Ctl.getError`. + *** Changed: `MLton.Platform.Arch`. + ** Other libraries. + *** Added: ckit library, ML-NLFFI library, SML/NJ library. +* Tools. + ** updates of `mllex` and `mlyacc` from SML/NJ. + ** added `mlnlffigen`. + ** profiling supports better inclusion/exclusion of code. + +=== Details + +* 2005-11-19 + ** Updated SML/NJ Library and CKit Library from SML/NJ 110.57. + +* 2005-11-15 + ** Fixed a bug in `MLton.ProcEnv.setgroups`. + +* 2005-11-11 + ** Fixed a bug in the interleaving of lexing/parsing and elaborating of ML + Basis files, which would raise an unhandled `Force` exception on cyclic basis + references. Thanks to John Dias for the bug report. + +* 2005-11-10 + ** Fixed two bugs in `Time.scan`. One would raise `Time` on a string with a + large fractional component. Thanks to Carsten Varming for the bug report. + The other failed to scan strings with an explicit sign followed by a decimal + point. + +* 2005-11-03 + ** Removed `MLton.GC.setRusage`. + ** Added `MLton.Rusage.measureGC`. + +* 2005-09-11 + ** Fixed bug in display of types with large numbers of type variables, which + could cause unhandled exception `Chr`. + +* 2005-09-08 + ** Fixed bug in type inference of flexible records that would show up as + `"Type error: variable applied to wrong number of type args"`. + +* 2005-09-06 + ** Fixed bug in `Real.signBit`, which had assumed that the underlying C + signbit returned 0 or 1, when in fact any nonzero value is allowed to indicate + the signbit is set. + +* 2005-09-05 + ** Added `-mlb-path-map` switch. + +* 2005-08-25 + ** Fixed bug in `MLton.Finalizable.touch`, which was not keeping alive + finalizable values in all cases. + +* 2005-08-18 + ** Added SML/NJ Library and CKit Library from SML/NJ 110.55 to standard + distribution. + ** Fixed bug in `Socket.Ctl.*`, which got the endianness wrong on big-endian + machines. Thanks to Wesley Terpstra for the bug report and fix. + ** Added `MLton.GC.setRusage`. + ** Fixed bug in `mllex`, which had file positions starting at 2. They now + start at zero. + +* 2005-08-15 + ** Fixed bug in `LargeInt.scan`, which should skip leading `"0x"` and `"0X"`. + Thanks to Wesley Terpstra for the bug report and fix. + +* 2005-08-06 + ** Additional revisions of FFI: + *** Deprecated `_export` with incomplete annotation. + *** Added `_address` for address of C objects. + *** Eliminated address component of `_symbol`. + *** Changed the type of the `_symbol*` expression. + *** See documentation for more detail. + +* 2005-08-06 + ** Annotation changes: + *** Deprecated: `sequenceUnit` + *** Added: `sequenceNonUnit` + +* 2005-08-03 + ** Annotation changes: + *** Deprecated: `allowExport`, `allowImport`, `warnMatch` + *** Added: `allowFFI`, `nonexhaustiveExnMatch`, `nonexhaustiveMatch`, + `redundantMatch` + +* 2005-08-01 + ** Update `mllex` and `mlyacc` with SML/NJ 110.55+ versions. This + incorporates a small number of minor bug fixes. + +* 2005-07-23 + ** Fixed bug in pass to flatten refs into containing data structure. + +* 2005-07-23 + ** Overhaul of FFI: + *** Deprecated `_import` of C base types. + *** Added `_symbol` for address, getter, and setter of C base types. + *** See documentation for more detail. + +* 2005-07-21 + ** Update `mllex` and `mlyacc` with SML/NJ 110.55 versions. This incorporates + a small number of minor bug fixes. + +* 2005-07-20 + ** Fixed bug in front end that allowed unary constructors to be used without + an argument in patterns. + +* 2005-07-19 + ** Eliminated `_ffi`, which has been deprecated for some time. + +* 2005-07-14 + ** Fixed bug in runtime that caused getrusage to be called on every GC, even + if timing info isn't needed. + +* 2005-07-13 + ** Fixed bug in closure conversion tickled by making a weak pointer to a + closure. + +* 2005-07-12 + ** Changed `{OS,Posix}.Process.sleep` to call `nanosleep()` instead of + `sleep()`. + ** Added `MLton.ProcEnv.setgroups`. + +* 2005-07-11 + ** `InetSock.{any,toAddr}` raise `SysErr` if port is not in [0, 2^16^). + +* 2005-07-02 + ** Fixed bug in `Socket.recvVecFrom{,',NB,NB'}`. The type was too polymorphic + and allowed the creation of a bogus `sock_addr`. + +* 2005-06-28 + ** The front end now reports errors on encountering undefined or cyclicly + defined MLB path variables. + +* 2005-05-22 + ** Fixed bug in `Posix.IO.{getlk,setlk,setlkw}` that caused a link-time error: + undefined reference to `Posix_IO_FLock_typ`. + ** Improved exception history so that the first entry in the history is the + source position of the raise, and the rest is the call stack. + +* 2005-05-19 + ** Improved exception history for `Overflow` exceptions. + +* 2005-04-20 + ** Fixed a bug in pass to flatten refs into containing data structure. + +* 2005-04-14 + ** Fixed a front-end bug that could cause an internal bug message of the form + `"missing flexInst"`. + +* 2005-04-13 + ** Fixed a bug in the representation of flat arrays/vectors that caused + incorrect behavior when the element size was 2 or 4 bytes and there were + multiple components to the element (e.g. `(char * char) vector`). + +* 2005-04-01 + ** Fixed a bug in `GC_arrayAllocate` that could cause a segfault. + +* 2005-03-22 + ** Added structures `Int1`, `Word1`. + +* 2005-03-19 + ** Fixed a bug that caused `Socket.Ctl.{get,set}LINGER` to raise `Subscript`. + The problem was in the use of `PackWord32Little.update`, which scales the + supplied index by `bytesPerElem`. + +* 2005-03-13 + ** Fixed a bug in CML mailboxes. + +* 2005-02-26 + ** Fixed an off-by-one error in `mkstemp` defined in `mingw.c`. + +* 2005-02-13 + ** Added `mlnlffigen` tool (heavily adapted from SML/NJ). + +* 2005-02-12 + ** Added MLNLFFI Library (heavily adapted from SML/NJ) to standard + distribution. + +* 2005-02-04 + ** Fixed a bug in `OS.path.toString`, which did not raise `InvalidArc` when + needed. + +* 2005-02-03 + ** Fixed a bug in `OS.Path.joinDirFile`, which did not raise `InvalidArc` when + passed a file that was not an arc. + +* 2005-01-26 + ** Fixed a front end bug that incorrectly rejected expansive __valbind__s with + useless bound type variables. + +* 2005-01-22 + ** Fixed x86 codegen bug which failed to account for the possibility that a + 64-bit move could interfere with itself (as simulated by 32-bit moves). + +* 2004-12-22 + ** Fixed `Real32.fmt StringCvt.EXACT`, which had been producing too many + digits of precision because it was converting to a `Real64.real`. + +* 2004-12-15 + ** Replaced MLB path variable `MLTON_ROOT` with `SML_LIB`, to use a more + compiler-independent name. We will keep `MLTON_ROOT` aliased to `SML_LIB` + until after the next release. + +* 2004-12-02 + ** `Unix.create` now works on all platforms (including Cygwin and MinGW). + +* 2004-11-24 + ** Added support for `MLton.Process.create`, which works on all platforms + (including Windows-based ones like Cygwin and MinGW) and allows better control + over `std{in,out,err}` for child process. + + +== Version 20041109 + +Here are the changes from version 20040227 to 20041109. + +=== Summary + +* New platforms: + ** x86: FreeBSD 5.x, OpenBSD + ** PowerPC: Darwin (MacOSX) +* Support for MLBasis files. +* Support for dynamic libraries. +* Support for Concurrent ML (CML). +* New structures: `Int2`, `Int3`, ..., `Int31` and `Word2`, `Word3`, ..., `Word31`. +* A new form of profiling: `-profile count`. +* A bytecode generator. +* Data representation improvements. +* `MLton` structure changes. + ** Added: `share`, `shareAll` + ** Changed: `Exn`, `IntInf`, `Signal`, `Thread`. +* Command-line switch changes. + ** Deprecated: + *** `-native` (use `-codegen`) + *** `-sequence-unit` (use `-default-ann`) + *** `-warn-match` (use `-default-ann`) + *** `-warn-unused` (use `-default-ann`) + ** Removed: + *** `-detect-overflow` + *** `-exn-history` (use `-const`) + *** `-safe` + *** `-show-basis-used` + ** Added: + *** `-codegen` + *** `-const` + *** `-default-ann` + *** `-disable-ann` + *** `-profile-branch` + *** `-target-link-opt` + +=== Details + +* 2004-09-22 + ** Extended `_import` to support indirect function calls. + +* 2004-09-13 + ** Made `Date.{fromString,scan}` accept a space (treated as zero) in the first + character of the day of the month. + +* 2004-09-12 + ** Fixed bug in `IntInf` that could cause a segfault. + ** Remove `MLton.IntInf.size`. + +* 2004-09-05 + ** Made `-detect-overflow` and `-safe` expert options. + +* 2004-08-30 + ** Added `val MLton.share: 'a -> unit`, which maximizes sharing in a heap + object. + +* 2004-08-27 + ** Fixed bug in `Real.toLargeInt`. It would incorrectly raise `Option` + instead of `Overflow` in the case when the real was not an `INF`, but rounding + produced an `INF`. + ** Fixed bugs in `Date.{fmt,fromString,scan,toString}`. They incorrectly + allowed a space for the first character in the day of the month. + +* 2004-08-18 + ** Changed `MLton.{Thread,Signal,World}` to distinguish between implicitly and + explicitly paused threads. + +* 2004-07-28 + ** Added support for programming in the large using the ML Basis system. + +* 2004-07-11 + ** Fixed bugs in `ListPair.*Eq` functions, which incorrectly raised the + `UnequalLengths` exception. + +* 2004-07-01 + ** Added `val MLton.Exn.addExnMessager: (exn -> string option) -> unit`. + +* 2004-06-23 + ** Runtime system options that take memory sizes now accept a "`g`" suffix + indicating gigabytes. They also now take a real instead of an integer, + e.g. `fixed-heap 0.5g`. They also now accept uppercase, e.g. `150M`. + +* 2004-06-12 + ** Added support for OpenBSD. + +* 2004-06-10 + ** Added support for FreeBSD 5.x. + +* 2004-05-28 + ** Deprecated the `-native` flag. Instead, use the new flag `-codegen + {native|bytecode|C}`. This is in anticipation of adding a bytecode compiler. + +* 2004-05-26 + ** Fixed a front-end bug that could cause cascading error to print a very + large and unreadable internal bug message of the form `"datatype ... realized + with scheme Unknown"`. + +* 2004-05-17 + ** Automatically restart functions in the Basis Library that correspond + directly to interruptable system calls. + +* 2004-05-13 + ** Added `-profile count`, for dynamic counts of function calls and branches. + ** Equate the types `Posix.Signal.signal` and `Unix.signal`. + +* 2004-05-11 + ** Fixed a bug with `-basis 1997` that would cause type errors due to + differences between types in the MLton structure and types in the rest of the + basis library. + +* 2004-05-01 + ** Fixed a bug with sharing constraints in signatures that would sometimes + mistakenly treat two structures as identical when they shouldn't have been. + This would cause some programs to be mistakenly rejected. + +* 2004-04-30 + ** Added `MLton.Signal.{handled,restart}`. + +* 2004-04-23 + ** Added `Timer.checkCPUTimes`, and updated the `Timer` structure to match the + latest basis spec. Also fixed `totalCPUTimer` and `totalRealTimer`, which + were wrong. + +* 2004-04-13 + ** Added `MLton.Signal.Mask.{getBlocked,isMember}`. + +* 2004-04-12 + ** Fix bug that mistakenly generalized variable types containing unknown types + when matching against a signature. + ** Reasonable front-end error message when unification causes recursive + (circular) type. + +* 2004-04-03 + ** Fixed bug in sharing constraints so that `sharing A = B = C` means that all + pairs `A = B`, `A = C`, `B = C` are shared, not just `A = B` and `B = C`. + This matters in some situations. + +* 2004-03-20 + ** Fixed `Time.now` which was treating microseconds as nanoseconds. + +* 2004-03-14 + ** Fixed SSA optimizer bug that could cause the error `" has no + tyconInfo property"`. + +* 2004-03-11 + ** Fixed `Time.fromReal` to raise `Time`, not `Overflow`, on unrepresentable + times. + +* 2004-03-04 + ** Added structures `Word2`, `Word3`, ..., `Word31`. + +* 2004-03-03 + ** Added structures `Int2`, `Int3`, ..., `Int31`. + ** Fixed bug in elaboration of `and` with signatures, structures, and functors + so that it now evaluates all right-hand sides before binding any left-hand + sides. + + +== Version 20040227 + +Here are the changes from version 20030716 to 20040227. + +=== Summary + +* The front end now follows the Definition of SML and produces readable error +messages. +* Added support for NetBSD. +* Basis library changes tracking revisions to the specification. +* Added structures: `Int64`, `Real32`, `Word64`. +* File positions use `Int64`. +* Major improvements to `-show-basis`, which now displays the basis in a very +readable way with full type information. +* Command-line switch changes. + ** Deprecated: `-basis`. + ** Removed: `-lib-search`, `-link`, `-may-load-world`, `-static`. + ** Added: `-link-opt`, `-runtime`, `-sequence-unit`, `-show-def-use`, + `-stop tc`, `-warn-match`, `-warn-unused`. + ** Changed: `-export-header`, `-show-basis`, `-show-basis-used`. + ** Renamed: `-host` to `-target`. +* FFI changes. + ** Renamed `_ffi` as `_import`. + ** Added `cdecl` and `stdcall` attributes to `_import` and `_export` + expressions. +* MLton structure changes. + ** Added: Pointer. + ** Removed: Ptrace. + ** Changed: `Finalizable`, `IntInf`, `Platform`, `Random`, `Signal`, `Word`. + +=== Details + +* 2004-02-16 + ** Changed `-export-header`, `-show-basis`, `-show-basis-used` to take a file + name argument, and they no longer force compilation to halt. + ** Added `-show-def-use` and `-warn-unused`, which deal with def-use + information. + +* 2004-02-13 + ** Added flag `-sequence-unit`, which imposes the constraint that in the + sequence expression `(e1; e2)`, `e1` must be of type `unit`. + +* 2004-02-10 + ** Lots of changes to `MLton.Signal`: name changes, removal of superfluous + functions, additional functions. + +* 2004-02-09 + ** Extended `-show-basis` so that when used with an input program, it shows + the basis defined by the input program. + ** Added `stop` runtime argument. + ** Made `-call-graph {false|true}` an option to `mlprof` that determines + whether or not a call graph file is written. + +* 2004-01-20 + ** Fixed a bug in `IEEEReal.{fromString,scan}`, which would improperly return + `INF` instead of `ZERO` for things like `"0.0000e123456789012345"`. + ** Fixed a bug in `Real.{fromDecimal,fromString,scan}`, which didn't return an + appropriately signed zero for `~0.0`. + ** Fixed a bug in `Real.{toDecimal,fmt}`, which didn't correctly handle + `~0.0`. + ** Report a compile-time error on unrepresentable real constants. + +* 2004-01-05 + ** Removed option `-may-load-world`. You can now use `-runtime no-load-world` + instead. + ** Removed option `-static`. You can now use `-link-opt -static` instead. + ** Changed `MLton.IntInf.size` to return 0 instead of 1 on small ints. + +* 2003-12-28 + ** Fixed horrible bug in `MLton.Random.alphaNumString` that caused it to + return 0 for all characters beyond position 11. + +* 2003-12-17 + ** Removed `-basis` as a normal flag. It is still available as an expert + flag, but its use is deprecated. It will almost certainly disappear after the + next release. + +* 2003-12-10 + ** Allow multiple `@MLton --` runtime args in sequnce. This makes it easier + for scripts to prefix `@MLton` args without having to splice them with other + ones. + +* 2003-12-04 + ** Added support for files larger than 2G. This included changing + `Position` from `Int32` to `Int64`. + +* 2003-12-01 + ** Added `structure MLton.Pointer`, which includes a `type t` for pointers + (memory addresses, not SML heap pointers) and operations for loading from and + storing to memory. + +* 2003-11-03 + ** Fixed `Timer.checkGCTime` so that only the GC user time is included, not GC + system time. + +* 2003-10-13 + ** Added `-warn-match` to control display nonexhaustive and redundant + match warnings. + ** Fixed space leak in `StreamIO` causing the entire stream to be retained. + Thanks to Jared Showalter for the bug report and fix. + +* 2003-10-10 + ** Added `-stop tc` switch to stop after type checking. + +* 2003-09-25 + ** Fixed `Posix.IO.getfl`, which had mistakenly called `fcntl` with `F_GETFD` + instead of `F_GETFL`. + ** Tracking basis library changes: + *** `Socket` module datagram functions no longer return amount written, + since they always write the entire amount or fail. So, + `send{Arr,Vec}To{,'}` now return `unit` instead of `int`. + *** Added nonblocking versions of all the send and recv functions, as well + as accept and connect. So, we now have: `acceptNB`, `connectNB`, + `recv{Arr,Vec}{,From}NB{,'}`, `send{Arr,Vec}{,To}NB{,'}`. + +* 2003-09-24 + ** Tracking basis library changes: + *** `TextIO.inputLine` now returns a `string option`. + *** Slices used in `Byte`, `PRIM_IO`, `PrimIO`, `Posix.IO`, `StreamIO`. + *** `Posix.IO.readVec` raises `Size`, not `Subscript`, with negative + argument. + +* 2003-09-22 + ** Fixed `Real.toManExp` so that the mantissa is in [0.5, 1), not [1, 2). The + spec says that 1.0 <= man * radix < radix, which since radix is 2, implies + that the mantissa is in [0.5, 1). + ** Added `Time.{from,to}Nanoseconds`. + +* 2003-09-11 + ** Added `Real.realRound`. + ** Added `Char{Array,Vector}Slice` to `Text`. + +* 2003-09-11 + ** `OS.IO.poll` and `Socket.select` now raise errors on negative timeouts. + ** `Time.time` is now implemented using `IntInf` instead of `Int`, which means + that a much larger range of time values is representable. + +* 2003-09-10 + ** `Word64` is now there. + +* 2003-09-09 + ** Replaced `Pack32{Big,Little}` with `PackWord32{Big,Little}`. + ** Fixed bug in `OS.FileSys.fullPath`, which mistakenly stopped as soon as it + hit a symbolic link. + +* 2003-09-08 + ** Fixed `@MLton max-heap`, which was mistakenly ignored. Cleaned up `@MLton + fixed-heap`. Both `fixed-heap` and `max-heap` can use copying or mark-compact + collection. + +* 2003-09-06 + ** `Int64` is completely there. + ** Fixed `OS.FileSys.tmpName` so that it creates the file, and doesn't use + `tmpnam`. This eliminates an annoying linker warning message. + +* 2003-09-05 + ** Added structures `{LargeInt,LargeReal,LargeWord,Word}{Array,Array2,ArraySlice,Vector,VectorSlice}` + ** Fixed bug in `Real.toDecimal`, which return class `NORMAL` for subnormals. + ** Fixed bug in `Real.toLargeInt`, which didn't return as precise an integer + as possible. + +* 2003-09-03 + ** Lots of fixes to `REAL` functions. + *** `Real32` is now completely in place, except for `Real32.nextAfter` on + SunOS. + *** Fixed `Real.Math.exp` on x86 to return the right value when applied to + `posInf` and `negInf`. + *** Changed `Real.Math.{cos,sin,tan}` on x86 to always use a call to the C + math library instead of using the x86 instruction. This eliminates some + anomalies between compiling `-native false` and `-native true`. + *** Change `Real.Math.pow` to handle exceptional cases in the SML code. + *** Fixed `Real.signBit` on Sparcs. + +* 2003-08-28 + ** Fixed `PackReal{,64}Little` to work correctly on Sparc. + ** Added `PackReal{,64}Big`, `PackReal32{Big,Little}`. + ** Added `-runtime` switch, which passes arguments to the runtime via + `@MLton`. These arguments are processed before command line switches. + ** Eliminated MLton switch `-may-load-world`. Can use `-runtime` combined + with new runtime switch `-no-load-world` to disable load world in an + executable. + +* 2003-08-26 + ** Changed `-host` to `-target`. + ** Split `MLton.Platform.{arch,os}` into `MLton.Platform.{Arch,OS}.t`. + +* 2003-08-21 + ** Fixed bug in C codegen that would cause undefined references to + `Real_{fetch,move,store}` when compiling on Sparcs with `-align 4`. + +* 2003-08-17 + ** Eliminated `-link` and `-lib-search`, which are no longer needed. + Eliminated support for passing `-l*`, `-L*`, and `*.a` on the command line. + Use `-link-opt` instead. + +* 2003-08-16 + ** Added `-link-opt`, for passing options to `gcc` when linking. + +* 2003-07-19 + ** Renamed `_ffi` as `_import`. The old `_ffi` will remain for a while, but + is deprecated and should be replaced with `_import`. + ** Added attributes to `_export` and `_import`. For now, the only attributes + are `cdecl` and `stdcall`. + + +== Version 20030716 + +Here are the changes from version 20030711 to 20030716. + +== Summary + +* Fixed several serious bugs with the 20030711 release. + +== Details + +* 2003-07-15 + ** Fixed bug that caused a segfault when attempting to create an + array that was too large, e.g + + 1 + Array.sub (Array.tabulate (valOf Int.maxInt, fn i => i), 0) + + ** mlton now checks the command line arguments following the file to compile + that are passed to the linker to make sure they are reasonable. + +* 2003-07-14 + ** Fixed packaging for Cygwin and Sparc to include `libgmp.a`. + ** Eliminated bootstrap target. The `Makefile` automatically determines + whether to bootstrap or not. + ** Fixed XML type checker bug that could cause error: `"empty tyvars in + PolyVal dec"`. + +* 2003-07-12 + ** Turned off `FORCE_GENERATIONAL` in gc. It had been set, which caused the + gc to always use generational collection. This could seriously slow apps down + that don't need it. + + +== Version 20030711 + +Here are the changes from version 20030312 to 20030711. + +=== Summary + +* Added support for Sparc/SunOS using the C code generator. +* Completed the basis library implementation. At this point, the only missing +basis library function is `use`. +* Added `_export`, which allows one to call SML functions from C. +* Added weak pointers (via `MLton.Weak`) and finalization (via +`MLton.Finalizable`). +* Added new integer modules: `Int8`, `Int16`. +* Better profiling call graphs +* Fixed conversions between reals and their decimal representations to be +correct using the gdtoa library. + +=== Details + +* 2003-07-07 + ** Profiling improvements: + *** Eliminated `mlton -profile-split`. Added `mlprof -split`. Now the + profiling infrastructure keeps track of the splits and allows one to decide + which splits to make (if any) when `mlprof` is run, which is much better + than having to decide at compile time. + *** Changed `mlprof -graph` to `mlprof -keep`, and changed the behavior so + that `-keep` also controls which functions are displayed in the table. + *** Eliminated `mlprof -ignore`: it's behavior is now subsumed by `-keep`, + whose meaning has changed to be more like -ignore on nodes that are not + kept. + ** When calling `gcc` for linking, put `-link` args in same order as they + appeared on the MLton command line (they used to be reversed). + +* 2003-07-03 + ** Making `OS.Process.{atExit,exit}` conform to the basis library spec in that + exceptions raised during cleaners are caught and ignored. Also, calls to + `exit` from cleaners cause the rest of cleaners to run. + +* 2003-07-02 + ** Fixed bug with negative `IntInf` constants that could cause compile time + error message: `"x86Translate.translateChunk ... strange Offset: base: ..."` + ** Changed argument type of `MLton.IntInf.Small` from `word` to `int`. + ** Added fix to profiling so that the `mlmon.out` file is written even when + the program terminates due to running out of memory. + +* 2003-06-25 + ** Added `{Int{8,16},Word8}{,Array,ArraySlice,Vector,VectorSlice,Array2}` + structures. + +* 2003-06-25 + ** Fixed bug in `IntInf.sign`, which returned the wrong value for zero. + +* 2003-06-24 + ** Added `_export`, for calling from C to SML. + +* 2003-06-18 + ** Regularization of options: + *** `-diag` --> `-diag-pass` + *** `-drop-pass` takes a regexp + +* 2003-06-06 + ** Fixed bug in `OS.IO.poll` that caused it to return the input event types + polled for instead of what was actually available. + +* 2003-06-04 + ** Fixed bug in KnownCase SSA optimization that could case incorrect results + in compiled programs. + +* 2003-06-03 + ** Fixed bug in SSA optimizer that could cause the error message: + + Type error: Type.equals + {from = char vector, to = unit vector} + Type error: analyze raised exception loopStatement: ... + unhandled exception: TypeError + +* 2003-06-02 + ** Fixed `Real.rem` to work correctly on `inf`-s and `nan`-s. + ** Fixed bug in profiling that caused the function name to be omitted on + functions defined by `val rec`. + +* 2003-05-31 + ** `Fixed Real.{fmt,fromString,scan,toString}` to match the basis library + spec. + ** Added `IEEEReal.{fromString,scan}`. + ** Added `Real.{from,to}Decimal`. + +* 2003-05-25 + ** Added `Real.nextAfter`. + ** Added `OS.Path.{from,to}UnixPath`, which are the identity function on Unix. + +* 2003-05-20 + ** Added type `MLton.pointer`, the type of C pointers, for use with the FFI. + +* 2003-05-18 + ** Fixed two bugs in type inference that could cause the compiler to raise the + `TypeError` exception, along with a lot of XML IL. The `type-check.sml` + regression contains simple examples of what failed. + ** Fixed a bug in the simplifier that could cause the message: `"shrinker + raised Prim.apply raised assertion failure: SmallIntInf.fromWord"`. + +* 2003-05-15 + ** Fixed bug in `Real.class` introduced on 04-28 that cause many regression + failures with reals when using newer `gcc`-s. + ** Replaced `MLton.Finalize` with `MLton.Finalizable`, which has a more robust + approach to finalization. + +* 2003-05-13 + ** Fixed bug in `MLton.FFI` on Cygwin that caused `Thread_returnToC` to be + undefined. + +* 2003-05-12 + ** Added support for finalization with `MLton.Finalize`. + +* 2003-05-09 + ** Fixed a runtime system bug that could cause a segfault. This bug would + happen after a GC during heap resizing when copying a heap, if the heap was + allocated at a very low (<10M) address. The bug actually showed up on a + Cygwin system. + +* 2003-05-08 + ** Fixed bug in `HashType` that raised `"Vector.forall2"` when the arity of a + type constructor is changed by `SimplifyTypes`, but a newly constructed type + has the same hash value. + +* 2003-05-02 + ** Switched over to new layered IO implementation, which completes the + implementation of the `BinIO` and `TextIO` modules. + +* 2003-04-28 + ** Fixed bug that caused an assertion failure when generating a jump table for + a case dispatch on a non-word sized index with non-zero lower bound on the + range. + +* 2003-04-24 + ** Added `-align {4|8}`, which controls alignment of objects. With `-align + 8`, memory accesses to doubles are guaranteed to be aligned mod 8, and so + don't need special routines to load or store. + +* 2003-04-22 + ** Fixed bug that caused a total failure of time profiling with `-native + false`. The bug was introduced with the C codegen improvements that split the + C into multiple files. Now, the C codegen declares all profile labels used in + each file so that they are global symbols. + +* 2003-04-18 + ** Added `MLton.Weak`, which supports weak pointers. + +* 2003-04-10 + ** Replaced the basis library's `MLton.hostType` with `MLton.Platform.arch` + and `MLton.Platform.os`. + +* 2003-04 + ** Added support for SPARC/SunOS using the C codegen. + +* 2003-03-25 + ** Added `MLton.FFI`, which allows callbacks to SML from C. + +* 2003-03-21 + ** Fixed `mlprof` so that the default `-graph arg` for data from + `-profile-stack true` is `(thresh-stack x)`, not `(thresh x)`. + + +== Version 20030312 + +Here are the changes from version 20020923 to 20030312. + +=== Summary + +* Added source-level profiling of both time and allocation. +* Updated basis library to 2002 specification. To obtain the old +library, compile with `-basis 1997`. +* Added many modules to basis library: + ** `BinPrimIO`, `GenericSock`, `ImperativeIO`, `INetSock`, `NetHostDB`, + `NetProtDB`, `NetServDB`, `Socket`, `StreamIO`, `TextPrimIO`, `UnixSock`. +* Completed implementation of `IntInf` and `OS.IO`. + +=== Details + +* 2003-02-23 + ** Replaced `-profile-combine` wih `-profile-split`. + +* 2003-02-11 + ** Regularization of options: + *** `-l` --> `-link` + *** `-L` --> `-lib-search` + *** `-o` --> `-output` + *** `-v` --> `-verbose` + +* 2003-02-10 + ** Added option to `mlton`: `-profile-combine {false|true}` + +* 2003-02-09 + ** Added options to `mlprof`: `-graph-title`, `-gray`, `-ignore`, `-mlmon`, + `-tolerant`. + +* 2002-11 - 2003-01 + ** Added source-level allocation and time profiling. This includes the new + options to mlton: `-profile` and `-profile-stack`. + +* 2002-12-28 + ** Added `NetHostDB`, `NetProtDB`, `NetServDB` structures. + ** Added `Socket`, `GenericSock`, `INetSock`, `UnixSock` structures. + +* 2002-12-19 + ** Fixed bug in signal check insertion that could cause some signals to be + missed. The fix was to add a signal check on entry to each function in + addition to at each loop header. + +* 2002-12-10 + ** Fixed bug in runtime that might cause the message `"Unable to set + cardMapForMutator"`. + +* 2002-11-23 + ** Added support for the latest Basis Library specification. + ** Added option `-basis` to choose Basis Library version. Currently available + basis libraries are `2002`, `2002-strict`, `1997`, and `none`. + ** Added `IntInf.{orb,xorb,andb,notb,<<,~>>}` values. + ** Added `OS.IO.{poll_desc,poll_info}` types. + ** Added `OS.IO.{pollDesc,pollToIODesc,infoToPollDesc,Poll}` values. + ** Added `OS.IO.{pollIn,pollOut,pollPri,poll,isIn,isOut,isPri}` values. + ** Added `BinPrimIO`, `TextPrimIO` structures. + ** Added `StreamIO`, `ImperativeIO` functors. + +* 2002-11-22 + ** Fixed bug that caused time profiling to fail (with a segfault) when + resuming a saved world. + +* 2002-11-07 + ** Fixed bug in `MLton.eq` that could arise when using `eq` on functions. + +* 2002-11-05 + ** Improvements to polymorphic equality. Equality on IntInfs, vectors, and + dataypes all do an `eq` test first before a more expensive comparison. + +* 2002-11-01 + ** Added allocation profiling. Now, can compile with either `-profile alloc` + or `-profile time`. Renamed `MLton.Profile` as `MLton.ProfileTime`. Added + `MLton.ProfileAlloc`. Cleaned up and changed most `mlprof` option names. + +* 2002-10-31 + ** Eliminated `MLton.debug`. + ** Fixed bug in the optimizer that affected `IntInf.fmt`. The optimizer had + been always using base 10, instead of the passed in radix. + +* 2002-10-22 + ** Fixed `Real.toManExp` so that the mantissa is in [1, 2), not [0.5, 1). + ** Added `Real.fromLargeInt`, `Real.toLargeInt`. + ** Fixed `Real.split`, which would return an incorrect whole part due to the + underlying primitive, `Real_modf`, being treated as functional instead of + side-effecting. + +* 2002-09-30 + ** Fixed `rpath` problem with packaging. All executables in packages + previously made had included a setting for `RPATH`. + + +== Version 20020923 + +Here are the changes from version 20020410 to 20020923. + +=== Summary + +* MLton now runs on FreeBSD. +* Major runtime system improvements. The runtime now implements mark-compact +and generational collection, in addition to the copying collection that was +there before. It automatically switches between the the collection strategies +to improve performance and to try to avoid paging. +* Performance when compiling `-exn-history true` has been improved. +* Added `IntInf.log2`, `MLton.GC.pack`, `MLton.GC.unpack`. +* Fixed bug in load world that could cause "sread failed" on Cygwin. +* Fixed optimizer bug that could cause `"no analyze var value property"` +message. + +=== Details + +* 2002-09 + ** Integrated Sam Rushing's changes to port MLton to FreeBSD. + +* 2002-08-25 + ** Changed the implementation of exception history to be completely + functional. Now, the extra field in exceptions (when compiling `-exn-history + true`) is a `string list` instead of a `string list ref`, and `raise` conses a + new exception with a new element in the list instead of assigning to the list. + This changes the semantics of exception history (for the better) on some + programs. See `regression/exnHistory3.sml` for an example. It also + significantly improves performance when compiling `-exn-history true`. + +* 2002-07 and 2002-08 + ** Added generational GC, and code to the runtime that automatically turns it + on and off. + +* 2002-08-20 + ** Fixed SSA optimizer bug that could cause the following error message: `"x_0 + has no analyze var value property"` + +* 2002-07-28 + ** Added `MLton.GC.{pack,unpack}`. `pack` shrinks the heap so that other + processes can use the RAM, and its dual, `unpack`, resizes the heap to the + desired size. + +* 2002-06 and 2002-07 + ** Added mark compact GC. + ** Changed array layout so that arrays have three, not two header words. The + new word is a counter word that preceeds the array length and header. + ** Changed all header words to be indices into an array of object descriptors. + +* 2002-06-27 + ** Added patches from Michael Neumann to port runtime to FreeBSD 4.5. + +* 2002-06-05 + ** Output file and intermediate file are now saved in the current directory + instead of in the directory containing the input file. + +* 2002-05-31 + ** Fixed bug in overloading of `/` so that the following now type checks: + + fun f (x, y) = x + y / y + +* 2002-04-26 + ** Added back `max-heap` runtime option. + +* 2002-04-25 + ** Fixed load/save world so that they use binary mode. This should fix the + `sread failed` problem that Byron Hale saw on Cygwin that caused `mlton` to + fail to start. + ** Added `IntInf.log2`. + ** Changed call to linker to use `libgmp.a` (if it exists) instead of + `libgmp.so`. This is because the linker adds a dependency to a shared library + even if there are no references to it + +* 2002-04-23 + ** Rewrote heap resizing code. This fixed bug that was triggered with large + heaps and could cause a spurious out of memory error. + ** Removed GnuMP from MLton sources (again :-). + + +== Version 20020410 + +Here are the changes from version 20011006 to version 20020410. + +=== Details + +* 2002-03-28 + ** Added BinIO. + +* 2002-03-27 + ** Regularization of options + *** `-g` --> `-degug {false|true}` + *** `-h n` --> `-fixed-heap n` + *** `-p` --> `-profile {false|true}` + +* 2002-03-22 + ** Set up the stubs so that MLton can be compiled in the standard basis + library, with no `MLton` structure. Thus it is now easy to compile MLton with + an older (or newer) version of itself that has a different `MLton` structure. + +* 2002-03-17 + ** Added `MLton.Process.{spawn,spawne,spawnp}`, which use primitives when + running on Cygwin and fork/exec when running on Linux. + +* 2002-02 - 2002-03 + ** Added the ability to cross-compile to Cygwin/Windows. + +* 2002-02-24 + ** Added GnuMP back for use with Cygwin. + +* 2002-02-10 + ** Reworked object header words so that `Array.maxLen = valOf Int.maxInt`. + Also fixed a long-standing minor bug in MLton, where `Array.array + (Array.maxLen, ...)` would raise `Size` instead of attempting to allocate the + array. It was an off-by-one error in the meaning of `Array.maxLen`. + +* 2002-02-08 + ** Modifications to runtime to behave better in situations where the amount of + live data is a signifant fraction of the amount of RAM, based on code from + PolySpace. MLton executables by default can now use more than the available + amount of RAM. Executables will still respect the `max-heap` runtime arg if + it is set. + +* 2002-02-04 + ** Improvements to runtime so that it fails to get space, it attempts to get + less space instead of failing. Based on PolySpace's modifications. + ** Added `MLton.eq`. + +* 2002-02-03 + ** Added `MLton.IntInf.gcd`. + ** Removed GnuMP from MLton sources. We now link with `/usr/lib/libgmp.a`. + ** Added `TextIO.getPosOut`. + ** Renamed type `MLton.Itimer.which` to `MLton.Itimer.t` and + `MLton.Itimer.whichSignal` to `MLton.Itimer.signal`. + ** Added `-coalesce` flag, for use with the C backend. + +* 2002-01-26 + ** Added `-show-basis-used`, which prints out the parts of the basis library + that the input program uses. + ** Changed several other flags (`-print-at-fun-entry`, `-show-basis`, + `-static`) to follow the `{false|true}` convention. + +* 2002-01-22 + ** Improved `MLton.profile` so that multiple profile arrays can exist + simultaneously and so that the current one being used can be set from the SML + side. + +* 2002-01-18 + ** The Machine IL has been replaced with an RSSA (representation explicit SSA) + IL and an improved Machine IL. + +* 2002-01-16 + ** Added KnownCase SSA optimization + +* 2002-01-14 + ** Added rudimentary profiling control from with a MLton compile program via + the `MLton.Profile` structure. + +* 2002-01-09 + ** Fixed bug in match compiler that caused case expressions on datatypes with + redundant cases to be compiled incorrectly. + +* 2002-01-08 + ** Added redundant tuple construction elimination to SSA shrinker. + ** Improved Flatten SSA optimization. + +* 2001-12-06 + ** Changed the interface for `MLton.Signal`. There is no longer a separate + `Handler` substructure. This was done so that programs that just use + `default` and `ignore` signal handlers don't bring in the entire thread + mechanism. + +* 2001-12-05 + ** Added LocalRef elimination SSA optimization. + +* 2001-11-19 + ** The CPS IL has been replaced with an SSA (static-single assignment) IL. + All of the optimizations have been ported from CPS to SSA. + +* 2001-10-24 + ** Fixed bug in `Thread_atomicEnd` -- `limit` was mistakenly set to `base` + instead of to 0. This caused assertion failures when for executables compiled + `-g` because `GC_enter` didn't reset `limit`. + ** Fixed bug in register allocation of byte registers. + +* 2001-10-23 + ** Added `-D` option to `cmcat` for preprocessor defines. Thanks to Anoq for + sending the code. + ** Changed limit check insertion so that limit checks are only coalesced + within a single basic block -- not across blocks. This slows many benchmarks + down, but is needed to fix a bug in the way that limit checks were coalesced + across blocks. Hopefully we will figure out a better fix soon. + +* 2001-10-18 + ** Fixed type inference of flexrecord so that it now follows the Definition. + Many programs containing flexrecords were incorrectly rejected. Added many + new tests to regression/flexrecord.sml. + ** Changed the behavior of `-keep dot` combined with `-keep pass` for SSA + passes. Dot files are now saved for the program before and after, instead of + just after. + +* 2001-10-11 + ** Fixed a bug in the type inference that caused type variables to be + mistakenly generalized. The bug was exposed in Norman Ramsey's `sled.sml`. + Added a test to `regression/flexrecord.sml` to catch the problem. + + +== Version 20011006 + +Here are the changes from version 20010806 to version 20011006. + +=== Summary + +* Added `MLton.Exn.history`, which is similar to `SMLofNJ.exnHistory`. +* Support for `#line` directives of the form `(*#line line.col "file"*)`. +* Performance improvements in native codegenerator. +* Bug fixes in front-end, optimizer, register allocator, +`Real.{maxFinite,minPos,toManExp}`, and in heap save and restore. + +=== Details + +* 2001-10-05 + ** Fixed a bug in polymorphic layered patterns, like + + val 'a a as b = [] + + These would always fail due to the variable `a` not being handled correctly. + ** Fixed the syntax of `val rec` so that a pattern is allowed on the left-hand + side of the `=`. Thus, we used to reject, but now accept, the following. + + val rec a as b as c = fn _ => () + val rec a : unit -> unit : unit -> unit = fn () => () + + Thanks again to Andreas Rossberg's test files. This is now tested for in + `valrec.sml`. + ** Fixed dynamic semantics of `val rec` so that if `val rec` is used to + override constructor status, then at run time, the `Bind` exception is raised + as per rule 126 of the Definition. So, for example, the following program + type checks and compiles, but raises `Bind` at run time. + + val rec NONE = fn () => () + val _ = NONE () + + Again, this is checked in `valrec.sml`. + ** Added `\r\n` to ml.lex so that Windows style newlines are acceptable in + input files. + +* 2001-10-04 + ** Fixed bug in the implementation of `open` declarations, which in the case + of `open A B` had opened `A` and then looked up `B` in the resulting + environment. The correct behaviour (see rule 22 of the Definition) is to + lookup each _longstrid_ in the current environment, and then open them all in + sequence. This is now checked for in the `open.sml` regression test. Thanks + to Andreas Rossberg for pointing this bug out. + ** Fixed bug that caused tyvars of length 1 (i.e. `'`) to be rejected. This + is now checked in the `id.sml` regression test. Again, thanks to Andreas + Rossberg for the test. + +* 2001-10-02 + ** Fixed bugs in `Real.toManExp` (which always returned the wrong result + because the call to `frexp` was not treated as side-effecting by the + optimizer) and in `Real.minPos`, which was zero because of a mistake with + extra precision bits. + +* 2001-10-01 + ** Added `MLton.Exn.history`. + ** Fixed register allocation bug with `fucom` instruction. Was allowing + `fucomp` when the first source was not removable. + ** Changed `Real.isFinite` to use the C `math.h` `finite` function. This + fixed the nontermination bug which occurred in any program that used + `Real.maxFinite`. + +* 2001-09-22 + ** Bug fixes found from Ramsey's `lrtl` in `contify.fun` and + `unused-args.fun`, both of which caused compile-time exceptions to be raised. + +* 2001-09-21 + ** Fixed `MLton.World.{load,save}` so that the saved world does not store the + max heap size. Instead, the max heap size is computed upon load world in + exactly the same way as at program startup. This fixes a long-standing (but + only recently noticed) problem in which `mlton` (which uses a saved world) + would attempt to use as much memory as was on the machine used to build + `world.mlton`. + +* 2001-08-29 + ** Overlow checking is now on by default in the C backend. This is a huge + performance hit, but who cares, since we never use the C backend except for + testing anyways. + +* 2001-08-22 + ** Added support for #line directives of the form + + (*#line line.col "file"*) + + These directives only affect error messages produced by the parser and + elaborator. + +* 2001-08-17 + ** Fixed bug in RemoveUnused optimzation that caused the following program to + fail to compile. + + fun f l = case l of [] => f l | _ :: l => f l + val _ = f [13] + +* 2001-08-14 + ** New x86-codegen infrastructure. + *** support for tracking liveness of stack slots and carrying them in + registers across basic blocks + *** more specific `Entry` and `Transfer` datatypes to make calling convention + distinctions more explicit + *** new heuristic for carrying values in registers across basic blocks (look + Ma, no Overflows!) + *** new "predict" model for generating register allocation hints + *** additional bug fixes + +* 2001-08-07 + ** `MLton.Socket.shutdownWrite` flushes the outstream. + + +== Version 20010806 + +Here are the changes from version 20010706 to version 20010806. + +=== Summary + +* `Word.andb (w, 0xFF)` now works correctly +* `MLton.Rusage.rusage` has a patch to work around a linux kernel bug +* Programs of the form `_exp_ ; _program_` are now accepted +* Added the `MLton.Rlimit` structure +* Added the `-keep dot` flag, which produces call graphs, intraprocedural +control-flow graphs, and dominator trees + +=== Details + +* 2001-08-06 + ** Added simple CommonBlock elimination CPS optimization. + +* 2001-08-02 + ** Took out `-keep il`. + +* 2001-07-31 + ** Performance improvements to `TextIO.{input, output, output1}`. + +* 2001-07-25 + ** Added RedundantTest elimination CPS optimization. + +* 2001-07-21 + ** Added CommonSubexp elimination CPS optimization. + +* 2001-07-20 + ** Bug fix to x86 codegen. The `commuteBinALMD` peephole optimization would + rewrite `mov 2,Y; add Y,Y` as `mov Y,Y; add 2,Y`. Now the appropriate + interference checks are made. + ** Added intraprocedural unused argument removal. + ** Added intraprocedural flattener. This avoids some stupid tuple allocations + in loops. Decent speedup on a few benchmarks (`count-graphs`, `psdes-random`, + `wc-scanStream`) and no noticeable slowdowns. + ** Added `-keep dot` flag. + +* 2001-07-17 + ** Modified grammar to properly handle `val rec`. There were several problems. + *** MLton had accepted `val rec 'a ...` instead of `val 'a rec ...` + *** MLton had not accepted `val x = 13 and rec f = fn () => ()` + *** MLton had not accepted `val rec rec f = fn () => ()` + *** MLton had not accepted `val rec f = fn () => () and rec g = fn () => ()` + +* 2001-07-16 + ** Workaround for Linux kernel bug that can cause `getrusage` to return a wrong + system time value (low by one second). See `fixedGetrusage` in `gc.c`. + ** Bug fix to x86 codegen. The register allocator could get confused when + doing comparisons of floating point numbers and use the wrong operand. The + bug seems to have never been detected because it only happens when both of the + operands are already on the floating point stack, which is rare, since one is + almost always in memory since we don't carry floating point values in the + stack across basic blocks. + ** Added production to the grammar on page 58 of the Definition that had been + missing from MLton since day one. + + program ::= exp ; + + Also updated docs to reflect change. + ** Modified grammar to accept the empty program. + ** Added `-type-check` expert flag to turn on type checking in ILs. + +* 2001-07-15 + ** Bug fix to the algebraic simplifier. It had been rewriting + `Word32.andb (w, 0wxFF)` to `w` instead of + `Word32.andb (w, 0wxFFFFFFFF)` to `w`. + +* 2001-07-13 + ** Improved CPS shrinker so that `if`-tests where the `then` and `else` branch + jump to the same label is turned into a direct jump. + ** Improved CPS shrinker (`Prim.apply`) to handle constructors + *** `A = A` --> `true` + *** `A = B` --> `false` + *** `A x` = `B y` --> `false` + ** Rewrote a lot of loops in the basis library to use inequalities instead of + equality for the loop termination test so that the (forthcoming) overflow + detection elimination will work on the loop index variable. + +* 2001-07-11 + ** Fixed minor bugs in `Array2.{array,tabulate}`, `Substring.{slice}` that + caused the `Overflow` exception to be raised instead of `Size` or `Subscript` + ** Fixed bug in `Pack32Big.update` that caused the wrong location to be updated. + ** Fixed several bugs in `Pack32{Big,Little}.{subArr,subVec,update}` that + caused `Overflow` to be raised instead of `Subscript`. Also, improved the + implementation so that bounds checking only occurs once per call (instead of + four times, which was sometimes happening. + ** Fixed bugs in `Time.{toMilliseconds,toMicroseconds}` that could cause a + spurious `Overflow` exception. + ** Fixed bugs in `Time.{fromMilliseconds,fromMicroseconds}` that could cause a + spurious `Time` exception. + ** Improved `Pack32.sub*` by reordering the `orb`-s. + ** Improved `{Int,IntInf}.mod` to increase chances of constant folding. + ** Switched many uses of `+`, `-`, `*` in basis library to the non-overflow + checked versions. Modules changed were: `Array`, `Array2`, `Byte`, `Char`, + `Int`, `IntInf`, `List`, `Pack32{Big,Little}`, `Util`, `String`, `StringCvt`, + `Substring`, `TextIO`, `Time`, `Vector`. + ** Added regression tests for `Array2`, `Int` (overflow checking), `Pack32`, + `Substring`, `Time`. + ** Changed CPS output so that it includes a dot graph for each CPS function. + +* 2001-07-09 + ** Change `OS.Process.exit` so that it raises an exception if the exit status + is not in [0, 256). + ** Added `MLton.Rlimit` to provide access to `getrlimit` and `setrlimit`. + + +== Version 20010706 + +Here are the changes from the 20000906 version to the 20010706 version. + +=== Summary + +* Native X86 code generator (instead of using `gcc`) +* Significantly improved compile times +* Significantly improved run times for generated executables +* Many bug fixes +* Correct raising of the `Overflow` exception for integer arithmetic +* New modules in the `MLton` structure + +=== Details + +* 2001-07-06 + ** GC mods from Henry. Mostly adding `inline` declarations. + +* 2001-07-05 + ** Fixed several runtime bugs involving threads, critical sections, and + signals. + +* 2001-06-29 + ** Fixed performance bug in `cps/two-point-lattice.fun` that caused quadratic + behavior. This affects the raise-to-jump and useless analayses. In + particular, the useless analysis was blowing up when compiling `fxp`. + +* 2001-06-27 + ** Henry improved `wordAlign` -- this sped up GC by 27% (during a self + compile). + +* 2001-06-20 + ** Moved `MLton.random` to `MLton.Random.rand` and added other stuff to + `MLton.Random` + ** Added `MLton.TextIO.mkstemp`. + ** Made `Int.{div,quot}` respect the `-detect-overflow` switch. + +* 2001-06-20 + ** Added `MLton.Syslog`. + +* 2001-06-07 + ** Fixed bug in `MLton.Socket.accept` that was in the runtime implementation + `Socket_accept`. It did a `setsockopt SO_REUSEADDR` after the `accept`. It + should have been after the call to `socket` in `Socket_listen`. Thanks to + Doug Bagley for the fix. + +* 2001-05-30 + ** Fixed bug in remove-unused that caused polymorphic equality to return + `true` sometimes when constructors were never used in a pattern match. For + example, the following (in which `A` and `B` are not used as patterns): + + datatype t = A | B + datatype u = C of t + val _ = if C A = C B then raise Fail "bug" else () + +* 2001-03-27 + ** Fixed bug that caused all of the following to fail: + `{LargeWord,Word,SysWord}.{toLargeInt,toLargeIntX,fromLargeInt}` The problem + was the basis library file `integer/patch.sml` which fixed `Word32` but not + the other structures that are the same. + +* 2001-02-12 + ** Fixed bug in match compiler that caused it to spend a lot of extra time in + deep patterns. It still could be exponential however. Hopefully this will + get fixed in the release after next. This bug could cause very slow compile + times in some cases. Anyways, this fix cut the `finish infer` time of a self + compile down from 22 to under 4 seconds. I.E. most of the time used to be + spent due to this bug. + +* 2001-02-06 + ** Fixed bug in frontend that caused the wrong file and line number to be + reported with errors in functor bodys. + +* 2001-01-03 - 2000-02-05 + ** Changes to CoreML, XML, SXML, and CPS ILs to replace lists by vectors in + order to decrease space usage. + +* 2001-01-16 + ** Fixed a bug in constant propagation where the length of vectors was not + propagated properly. + +* 2000-12-11 - 2001-01-03 + ** Major rewrite of elaborator to use a single hash table for each namespace + instead of a hash table for every environment. + +* 2000-12-20 + ** Fixed some bugs in the SML/NJ compatibility library, + `src/lib/mlton-subs-in-smlnj`. + +* 2000-12-08 + ** More careful removal of tracing code when compiling `MLton_debug=0`. This + cut down self compile data size by 100k and compile time by a few seconds. + ** Added built in character and word cases propagated throughout all ILs. + +* 2000-12-06 + ** Added max stack size information to `gc-summary`. + +* 2000-12-05 + ** Added `src/benchmark`, which contains an SML program that benchmarks all of + the SML compilers I have my hands on. The script has lots of hardwired paths + for now. + +* 2000-12-04 + ** Fixed bug in `Posix.ProcEnv.environ,` which did not work correctly in a + saved world (the original `environ` was saved). In fact, it did not work at + all because the ML primitive expected a constant and the C was a nullary + function. This caused a segfault with any program using + `Posix.ProcEnv.environ`. + ** `Added MLton.ProcEnv.setenv`, since there doesn't seem to be any `setenv` + in the basis library. + +* 2000-11-29 + ** Changed backend so that it should no longer generate machine programs with + `void` operands. + ** Added `-detect-overflow` and `-safe` flags. + +* 2000-11-27 - 2000-11-28 + ** Changes in many places to use `List.revMap` instead of `List.map` to cut + down on allocation. + +* 2000-11-21 + ** Added `MLton.Word.~` and `MLton.Word8.~` to the `MLton` structure. + +* 2000-11-20 + ** Fixed a bug in the CPS shrinker that could cause a compile-time failure. + It was maintaining occurrence counts incorrectly. + +* 2000-11-15 + ** Fixed a (performance) bug in constant propagation that caused the hashing + to be bad. + ** Improved translation to XML so that the match compiler isn't called on + tuple or if expressions. This should speed up the translation and make the + output smaller. + ** Fixed a bug in the match compiler that caused it to not generate integer + case statements. This should speed up the mlyacc benchmark and the MLton + front end. + +* 2000-11-09 + ** Added `IntInf_equal` and `IntInf_compare` primitives. + ** Took out the automatic `-keep c` when compiling `-g`. + +* 2000-11-08 + ** Added a whole bunch of algebraic laws to the CPS shrinker, including some + specifically targeted to `IntInf` primitives. + +* 2000-11-03 + ** Improved implementation of properties so that sets don't allocate. + ** Improved implementation of type homomorphism in type inference. What was + there before appears to have been a bug -- it didn't use the property on + types. + +* 2000-11-02 + ** Fixed timers used with `-v` option to use user + sys time. + +* 2000-10-27 + ** Split the runtime basis library C files into many separate files so that + only the needed code would be included by the linker. + ** Fixed several bugs in the front end grammar and elaborator that caused type + specifications to be handled incorrectly. The following three programs used + to be handled incorrectly, but are now handled correctly. + + signature S = sig type t and u = int end (* reject *) + signature S = sig type t = int and u = t end (* accept *) + signature S = sig eqtype t and u = int end (* reject *) + +* 2000-10-25 + ** Changes to `main.sml` to run complete compiles with `-native` switch. + +* 2000-10-24 + ** Removed defunctorizer. + +* 2000-10-20 + ** Fixed bug in `cps-tree.fun` with `PrimExp.maySideEffect`. This bug could + cause `"no operand"` failures in the backend. + ** Fixed bug in the runtime implementation of `MLton.size`. The size for + stack objects was using the `used` instead of `reserved`, and so was too low. + +* 2000-10-19 + ** Replaced automatically generated dependencies in `src/runtime/Makefile` + with hand generated ones. Took out `make depend` from `src/Makefile`. `make + depend` was behaving really badly on RHAT 7.0. + ** Tweaked compiler to shorten width of C output lines to work around bug in + RHAT 7.0 `cpp` which silently truncates (very) long lines. + ** Fixed bug in grammar that didn't allow `op` to occur in datatype and + exception bindings, causing the following to fail + + datatype t = op T + exception op E = op Fail + + ** Improved error messages in CM processor. Fixed bug in CM Alias handling. + +* 2000-10-18 + ** Fixed two bugs in the gc that did comparisons with `(s->limit - + s->frontier)`, which of course doesn't work if `frontier` is beyond `limit`, + since these are unsigned. This could have caused segfaults, except that the + mutator checks the `frontier` upon return from the GC. + +* 2000-10-17 + ** Fixed bug in backend in the calculation of `maxFrameSize`. It could be + wrong (low) in some situations. + ** Improved CPS inliner's estimate of function sizes. The size of a function + now takes into account other inlined functions that the function calls. This + also changed the meaning of the size argument to the `-inline` switch. It now + corresponds (roughly) to the product of the size of the function and the + number of calls. In general, it should be larger than before. + +* 2000-10-13 + ** Made some calls to `Array.sub` unsafe in the implementation of `Array2`. + ** Integrated Matthew's new x86 backend with floating point support. + +* 2000-10-09 + ** Fixed CM file processor so that MLton works if it is run from a different + directory than the main CM file. + +* 2000-10-04 + ** Changed LimitCheck so it loops on the `frontier > limit` check. This fixed + a potential bug in threads caused when there is enough space available for a + thread, `t`, before switching to another thread but not enough space when it + resumes. This could have caused a segfault. + +* 2000-10-03 + ** More rewrites of `TextIO.StreamIO` to improve speed. + ** Changed `TextIO` so that only `TextIO.stdErr` is unbuffered. + ** Changed `TextIO` so that FIFOs and sockets are buffered. + +* 2000-10-02 + ** Combined remove-unused-constructors, remove-unused-functions, and + remove-unused-globals into a single pass that runs to fixed-point and produces + results at least as good as running the previous three in (any) sequence. + +* 2000-09-29 + ** Added `GC_FIRST_CHECK`, which does a gc at each limit check the first time + it reached. + ** Reimplemented `TextIO.StreamIO` (from 2000-09-12) to use lists of strings + instead of lists of characters so that the per char space overhead is small. + +* 2000-09-21 + ** Fixed bug in profiling labels in C code. The label was always the basic + block label instead of the cps function label. + ** Added `-b` switch to `mlprof` to gather data at the basic block level. + ** Improved performance of `TextIO.input1` by about 3X. + +* 2000-09-15 - 2000-09-19 + ** Added overflow exceptions to CPS and Machine ILs. + +* 2000-09-12 + ** Fixed `TextIO.scanStream`. It was very broken. + ** Added `TextIO.{getInstream,mkInstream,setInstream}` and + `TextIO.StreamIO.{canInput,closeIn,endOfStream,input1,input,inputAll,inputLine,inputN}`. + +* 2000-09-11 + ** Fixed `Real_qequal` in `mlton-lib.h`. It was missing a paren that caused + code using it to not even compile. It was also semantically incorrect. + ** Noted that `Real_{equal,lt,le,gt,ge}` may not follow basis library spec, + since ANSI does not require IEEE compliance, and hence these could return + wrong results when nans are involved. + + +== Version 20000906 + +Here are the changes from the 20000712 version to the 20000906 version. + +=== Summary + +* Version 20000906 is mostly a bugfix release over 20000712. The other major +changes are that `mllex` and `mlyacc` are now included and that `mlton` can now +process a limited subset of CM files as input. + +=== Details + +* 2000-09-06 + ** Fixed `Socket_listen` in `mlton-lib.c` so that it closes the socket if the + `bind`, `listen`, or `getsockname` fails. This could have caused a file + descriptor leak. + +* 2000-09-05 + ** Added `-static` commandline switch. + ** Changed default max heap size to .85 RAM from .95 RAM. + ** Added `PackRealLittle` structure to basis library. + +* 2000-08-25 + ** Added cases on integers to ILs (instead of using sequences of tests) so + that backend can emit more efficient test (jump table, binary tree, ...). + +* 2000-08-24 + ** Fixed bug in `gc.c`. `dfsInitializeStack` would `smummap` a `NULL` pointer + whenver `toSpace` was `NULL`. This could cause `MLton.size` to segfault. + ** Fixed bug in `Popt` that caused `-k` to fail with no keeps. + +* 2000-08-22 - 2000-08-23 + ** Ported `mllex` and `mlyacc` from SML/NJ + +* 2000-08-20 - 2000-08-21 + ** Added ability to use a `.cm` file as input to MLton. + +* 2000-08-16 + ** Ported `mlprof` to SML. + ** Fixed bug in `library/basic/assert.sml` that caused asserts to be run even + when `MLton.debug = false`. + +* 2000-08-15 + ** Fixed bug in backend -- computation of `maxFrameSize` was wrong. It didn't + count slots in frames that didn't make nontail calls. This could lead to the + stack being overwritten because a stack limit check didn't guarantee enough + space, and lead to a segfault. + ** Fixed bug in `gc.c` `newThreadOfSize`. If the thread allocation caused a + gc, then the stack wasn't forwarded, leading to a segfault. The solution was + to ensure enough memory all at once, and then fill in both objects. + +* 2000-08-14 + ** Changed limit checks so that checks < 512 bytes are replaced by a check for + 0 bytes. The runtime also moves the limit down by 512. This is done so that + the common case, a small limit check, has less code and is faster. + ** Fixed bug in `cps/cps-tree.fun`. `Program.hasPrim` returned `true` for any + program that had *any* primapp, not just programs satisfying the predicate. + This caused `cps/once.fun` to be overly conservative, since it thought that + every program used continuations. + +* 2000-08-10 + ** Fixed bug in CPS typechecker. It didn't enforce that handlers should be + defined before any reference to them -- including implicit references in + `HandlerPops`. This caused an evil bug in the liveness analysis where a + variable that was only live in the handler was missed in a continuation + because the liveness for the handler wasn't computed yet. + ** Limited the size for moving up limit checks for arrays whose size is known + at compile time to avoid huge limit checks getting moved into loops. + ** added `-indent`, `-kp`, `-show-types` switches. + ** Put optimization in CPS IL suggested by Neal Glew. It determines for each + toplevel function if it can raise an exception to its caller. Also, it + removes `HanderPush` and `HandlerPop` for handlers that are not on top of the + stack for any nontail call. + +* 2000-08-08 + ** Changed register allocator so that continuation formals can be allocated in + pseudo registers -- they aren't necessarily forced to the stack. + +* 2000-08-03 + ** Fixed bug in constant folding. `Word8.>>` had been used to implement + `Word8.~>>`. + ** Fixed bug in allocate registers that was not forcing the size argument to + `Primitive.Array.array` to be a stack slot. This could cause problems if + there was a thread switch in the limit check, since upon return the size + pseudo register would have a bogus value. + +* 2000-08-01 + ** Turned back on XML simplification after monomorphisation. + +* 2000-07-31 + ** Fixed bug in `MLton.Itimer.set` that caused the time to be doubled. + ** Fixed bug in `MLton.Thread` that made it look like asynchronous exceptions + were allowed by `throw`-ing an exception raising thunk to an interrupted + thread obtained via a signal handler. Attempting asynchronous exceptions will + now cause process death, with a helpful error message. + +* 2000-07-27 + ** Updated docs to include `structure World: MLTON_WORLD` in `MLton` + structure. + ** Added toplevel signatures `MLTON_{CONT, ..., WORLD}` to basis library. + ** Fixed broken link in docs to CM in `cmcat` section. + +* 2000-07-26 + ** Eliminated `GC_switchToThread` and `Thread_switchTo1`, since the inlined + version `Thread_switchTo` is all that's needed, and Matt's X86 backend now + handles it. + ** Added `MLton.Signal.vtalrm`, needed for `Itimer.Set{which = + Itimer.Virtual, ...}`. + +* 2000-07-25 + ** Added `MLton.Socket.shutdownWrite`. + +* 2000-07-21 + ** Updated `mlton-lib.c` `MLton_bug` with new email (MLton@sourcelight.com). + +* 2000-07-19 + ** Fixed `Posix.Process.kill` to check for errors. + +* 2000-07-18 + ** Fixed the following `Posix.ProcEnv` functions to check for errors: + `setgid`, `setpgid`, `setsid`, `setuid`. + ** Fixed `doc/examples/callcc.sml`. + + +== Version 20000712 + +Here are the changes from the 1999-07-12 to the 20000712 version. + +=== Details + +* 2000-06-10 - 2000-07-12 + ** Too many changes to count: bug fixes, new basis library modules, optimizer + improvements. + +* 2000-06-30 + ** Fixed bug in monomorphiser that caused programs with non-value carrying + exception declarations in polymorphic functions to have a compile-time error + because of a duplicate label. The problem was that the exception constructor + wasn't duplicated. + +* 2000-05-22 - 2000-06-10 + ** Finished the changes for the new CPS IL. + +* 2000-01-01 + ** Fixed some errors in the basis library: + *** `Real.copySign` + *** `Posix.FileSys.fpathconf` + *** `Posix.IO.{lseek, getlk, setlk, setlkw}` + *** `Posix.ProcEnv.setpgid` + *** `Posix.TTY.getattr` + *** `System.FileSys.realPath` + +* 1999-12-22 + ** Fixed bug in `src/closure-convert/abstract-value.fun` that caused a + compiler failure whenever a program had a vector where the element type + contained an `->`. + +* 1999-12-10 + ** Changed dead code elimination in `core-ml/dead-code.fun` so that wildcard + declarations (`val _ = ...`) in the basis are kept. Changed places in the + basis library to take advantage of this. + ** Added `setTopLevelHander` primitive so that the basis library code can + define the toplevel handler. + ** Changed `basis-library/misc/suffix.sml` to call `OS.Process.exit`. Took + out `Halt` transfer from CPS, since the program never should reach it. + ** Cleaned up `basis-library/system/{process.sml, unix.sml}` to use the new + signal handling stuff. + +* 1999-11-28 - 1999-12-20 + ** Added support for threads and cleaned up signal handling. This involved a + number of changes: + *** The stack is now allocated as just another kind of heap object. + *** Limit checks are inserted at all loop headers, whether or not there is + any allocation. This is to ensure that the signal handler always has a + chance to get called. + *** The register allocator puts more variables in stack slots. The new rule + is that a variable goes in a stack slot if it is ever live across a nontail + call, in a handler, or (this is the new part) across a limit check. + *** Arguments are passed on the stack, with the convention determined by + argument types. + *** The "locals" array of pointers that was copied to/from for GC is now + gone, because no registers (in particular no pointer valued registers) can + be live at a limit check point. + +* 1999-11-21 + ** Runtime system + *** Fixed a bug introduced by the signal code (presumably on 1999-08-09) + that caused a gc to *not* be performed when doing a save world. This caused + the heaps created by save world to be the same size as the heap -- not the + live data. This was quite bad. + *** Cleaned up the `Makefile`. Add make depend. + *** Added max gc pause to `gc-summary` info. + *** Move heap translation variables that had been file statics into the + `GC_state`. + ** Made `structure Position` available at toplevel. + ** Basis Library + *** Added `MLton.loadWorld` + ** Added `Primitive.usesCallcc` + ** Added `Primitive.safe` + ** Removed special size functions from `cps/save-world` -- they are no longer + necessary since size doesn't do a gc. + ** Fixed another (sigh) bug in `cps/simplify-types.fun` that could cause it to + not terminate. + +* 1999-11-16 + ** Cleaned up `backend/machine.fun` a bit so that it spits out macros for + allocation of objects and bumping of frontier. Added macros `MLTON_object` + and `MLTON_incFrontier` to `include/mlton-lib.h`. + ** Fixed a bug in `backend/limit-check.fun` that caused loops to not be + detected if they were only reached by a case branch. This could cause there + to be loop that allocates with no limit check. Needless to say, this could + cause a segfault if the loop ran for long enough. + +* 1999-10-18 + ** Added basis library function `Array2.copy`. + +* 1999-08-15 + ** Turned off globalization of ref cells (`closure-convert/globalize.fun`) + because it interacts badly with serialization. + +* 1999-08-13 + ** Fixed bug in `mlton-lib.h` in `MLTON_allocArrayNoPointers` that was + triggered when `bytesPerElt == 0`. The problem was that it wasn't reserving + space for the forwarding pointer. This could cause a segfault. + +* 1999-08-08 and 1999-08-09 + ** Added support for signal handling. + +* 1999-08-07 + ** Fixed bugs in `Array.tabulate` (and other `tabulate` variants) caused if + the function argument used `callcc`. + +* 1999-08-01 + ** Added serialization, which was mostly code in `src/runtime/gc.c`. + + `GC_serialize` converts an object to a `Word8Vector.vector`. + + `GC_deserialize` undoes the conversion. + (de)Serialization should work for + all objects except for functions, because I haven't yet added the support in + the flow analysis. + +* 1999-07-31 + ** Cleaned up the GC. Changed headers, by stealing a bit from the number of + non pointers and making it a mark bit (used in `GC_size`). + ** Rewrote `GC_size` so that it runs in time proportional to the number of + pointers in the object. It does a depth-first-search now, using toSpace to + hold the stack. + +* 1999-07-30 + ** Fixed bug in `SUBSTRING`. `getc` had the wrong type. This bug wasn't + noticed because MLton doesn't do enough type checking. + ** Fixed bug (segfault) caused when a GC immediately followed a throw. + +* 1999-07-29 + ** Fixed bug in `Date.fmt` (`basis-library/system/date.sml`). It was not + setting `Tm.buf`, and hence the time was always 0 unless there had been a + previous call to `setTmBuf`. + +* 1999-07-28 + ** Fixed bugs in `Posix.IO.FLock.{getlk,setlk,setlkw}`, which would cause + compilation to fail because `FLock.toInt` was defined as the C `castInt`, + which no longer exists. Instead, expand `FLock.toInt` to + `MLTON_pointerToInt`, which was added to `include/mlton-lib.h`. + ** Changed `Posix.Primitive.Flock` to `Posix.Primitive.FLock`. + ** Added `MLTON_chown`, `MLTON_ftruncate` to `include/mlton-posix.h`. They + were missing. This would cause compilation of any program using + `Posix.FileSys.{chown,ftruncate}` to fail. Also made it so all of the + primitives in `basis-library/posix/primitive.sml` use `MLTON_` versions of + functions, even if a wrapper is unnecessary. + +* 1999-07-25 + ** Added some other missing signature definitions to toplevel. + +* 1999-07-24 + ** Added missing `OS_*` signature definitions to + `basis-library/top-level/top-level.sml`. + +* 1999-07-19 + ** Fixed bug in `basis-library/arrays-and-vectors/mono-array.sml`. Used `:>` + instead of `:` so that the monomorphic array types are abstract. + + +== Version 19990712 + +Here are the changes from the 1999-03-19 version to the 1999-07-12 version. + +=== Details + +* 1999-07-12 + ** Changed `src/backend/machine.fun` so that the 'pointer locals' array is + only as large as neccessary in order to copy all pointer-valued locals, not as + large as the number of pointer-valued locals. + +* 1999-07-11 + ** Rewrote `src/backend/allocate-registers.fun` so that it does a better job + of sharing "registers" (i.e. C local variables) and stack slots. This should + cut down on the amount of copying that has to happen before and after a gc. + It should also cut down on the size of stack slots. + +* 1999-07-10 + ** Fixed a bug in `src/backend/parallel-move.fun` that should have been + triggered on most any parallel move. I guess parallel moves almost never + happened due to the old register allocation strategy -- but, with the new one + (see note for 1999-07-12) parallel moves will be frequent. + +* 1999-06-27 + ** Fixed `src/main.sml` so that when compiling `-p`, the `.c` file is compiled + `-g` and the `.o` is linked `-p`. + ** In `bakend/machine.fun`, added profiling comments before chunkswitches and + put in an optimization to avoid printing repeated profiling comments. Also, + profiling comments are only output when compiling `-p`. + +* 1999-06-17 + ** Changed `-i` to `-inline`, `-f` to `-flatten`, `-np` to `-no-polyvariance`, + `-u` to `-unsafe`. + ** Added `-i`, `-I`, `-l`, `-L` flags for includes and libraries. + ** Updated documentation for these options and for ffi. + +* 1999-06-16 + ** Hardwired version number in `src/control/control.sml`. As it stood, the + version number was computed when MLton was built after someone downloaded it, + which was clearly wrong. + +* 1999-06-16 + ** Fixed undefined variable `time` in `GC_done` in `src/runtime/gc.c`. + +* 19990-06-08 + ** in `include/mlton-lib.h`: + *** removed `#include ` + *** added `#include ` + *** and deleted all of the function signatures I had copied from `math.h` + ** Changed `Real.{minNormalPos, minPos, maxFinite}` so that they are computed + in `real.sml` instead of appearing as constants in the C. + +* 1999-06-07 + `IntInf.pow` added to basis library. + +* 1999-06-04 + ** `bin/mlton` changed to use `.arch-n-opsys` if it exists. + +* 1999-06-03 + ** `src/Makefile` changed to use `sml-cm` instead of `sml` + +* 1999-05-10 + ** Patch to `src/atoms/small-int-inf.fun` to work around a bug in the SML/NJ + implementation of bignums. This bug was causing some hex bignum constants to + be lexed incorrectly. + +* 1999-04-15 + ** Comments emitted in C code for profiling. The comments identify the CPS + function responsible for each C statement. + +* 1999-04-15 + ** `callcc` and `throw` added. + +* 1999-04-15 + ** Bug in `src/cps/simplify-types` fixed. The bug caused nontermination + whenever there was a circular datatype with a vector on the rhs. + E.g. `datatype t = T of t vector` + + +== Version 19990319 + +Here are the changes from the 1998-08-26 version to the 1999-03-19 version. + +=== Summary + +* Compile time and code size have decreased. +* Runtime performance of executables has improved. +* Large programs can now be compiled. +* MLton is self hosting. +* The basis library is mostly complete and many bugs have been fixed. +* The monomorphiser (`-m`) is no longer available. +* The heap and stack are automatically resized. +* There are now facilities for heap checkpointing (`MLton.saveWorld`) and object +size computation (`MLton.size`). +* MLton uses the GNU multiprecision (GnuMP) library to provide a fast +implementation of `IntInf`. diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..ab55327 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,15 @@ +FROM ubuntu:latest + +# Install the dependencies. We'll use the ubuntu provided mlton to bootstrap our local build. +RUN apt-get update -qq \ + && apt-get install -qq git build-essential libgmp-dev mlton mlton-tools + +# Copy the current directory (MLton source root) to a location within the container & move there +COPY . /root/mlton +WORKDIR /root/mlton + +# Build from source & install +RUN make \ + && make install + +ENTRYPOINT ["make", "check"] diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4df6393 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +This is the license for MLton, a whole-program optimizing compiler for +the Standard ML programming language. Send comments and questions to +MLton@mlton.org. + +MLton COPYRIGHT NOTICE, LICENSE AND DISCLAIMER. + +Copyright (C) 1999-2018 Henry Cejtin, Matthew Fluet, Suresh + Jagannathan, and Stephen Weeks. +Copyright (C) 1997-2000 by the NEC Research Institute + +Permission to use, copy, modify, and distribute this software and its +documentation for any purpose and without fee is hereby granted, +provided that the above copyright notice appear in all copies and that +both the copyright notice and this permission notice and warranty +disclaimer appear in supporting documentation, and that the name of +the above copyright holders, or their entities, not be used in +advertising or publicity pertaining to distribution of the software +without specific, written prior permission. + +The above copyright holders disclaim all warranties with regard to +this software, including all implied warranties of merchantability and +fitness. In no event shall the above copyright holders be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether in an +action of contract, negligence or other tortious action, arising out +of or in connection with the use or performance of this software. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..4ca9fbe --- /dev/null +++ b/Makefile @@ -0,0 +1,545 @@ +## Copyright (C) 2009,2011,2013,2017-2018 Matthew Fluet. + # Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # Copyright (C) 1997-2000 NEC Research Institute. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +# Specify C compiler and binutils. +# Can be used for alternative tools (e.g., `CC=clang` or `CC=gcc-7`). +CC := gcc +AR := ar +RANLIB := ranlib +STRIP := strip + +# Specify GMP include and library paths, if not on default search paths. +WITH_GMP_DIR := +ifneq ($(WITH_GMP_DIR),) +WITH_GMP_INC_DIR := $(WITH_GMP_DIR)/include +WITH_GMP_LIB_DIR := $(WITH_GMP_DIR)/lib +endif + +# Specify installation prefix and staged install destination. +PREFIX := /usr/local +DESTDIR := + +# Specify runtime and compile arguments given to (the to-be-built) `mlton` when +# compiling distributed executables ((self-compiled) `mlton`, `mllex`, `mlyacc`, +# `mlprof`, and `mlnlffigen`). +# Can be used for testing (e.g., `MLTON_COMPILE_ARGS="-codegen c"`) or for +# downstream packaging. +MLTON_RUNTIME_ARGS := +MLTON_COMPILE_ARGS := + +# Specify runtime and compile arguments given to "old" `mlton` when compiling +# "bootstrapped" `mlton`. +# Can be used to work around bugs in "old" `mlton` when compiling "bootstrapped" +# `mlton` (e.g., `BOOTSTRAP_MLTON_COMPILE_ARGS="-drop-pass 'deepFlatten'"`). +BOOTSTRAP_MLTON_RUNTIME_ARGS := +BOOTSTRAP_MLTON_COMPILE_ARGS := + +# Specify standard tools. +# Can be used for alternative tools (e.g., `SED=gsed`). +DIFF := diff +FIND := find +GIT := git +GREP := grep +GZIP := gzip +PATCH := patch +SED := sed +TAR := tar +XARGS := xargs + +###################################################################### +###################################################################### + +SRC := $(shell pwd) +BUILD := $(SRC)/build +BIN := $(BUILD)/bin +LIB := $(BUILD)/lib/mlton +INC := $(LIB)/include + +PATH := $(BIN):$(shell echo $$PATH) + +MLTON_VERSION := 20180207 + +HOST_ARCH := $(shell ./bin/host-arch) +HOST_OS := $(shell ./bin/host-os) +TARGET := self +TARGET_ARCH := $(HOST_ARCH) +TARGET_OS := $(HOST_OS) + +ifeq (mingw, $(TARGET_OS)) +EXE := .exe +else +EXE := +endif + +CP := cp -fpR +MKDIR := mkdir -p +MV := mv -f +RM := rm -rf + +###################################################################### + +# If we're compiling with another version of MLton, then we want to do another +# round of compilation so that we get a MLton built without stubs. +ifeq (other, $(shell if [ ! -x "$(BIN)/mlton" ]; then echo other; fi)) +BOOTSTRAP:=true +else +BOOTSTRAP:=false +endif +CHECK_FIXPOINT:=false + +.PHONY: all +all: + $(MAKE) dirs runtime + $(MAKE) compiler CHECK_FIXPOINT=false # tools0 + mlton0 -> mlton1 + $(MAKE) script basis-no-check constants basis-check libraries + $(MAKE) tools CHECK_FIXPOINT=false # tools0 + mlton1 -> tools1 +ifeq (true, $(findstring true,$(BOOTSTRAP) $(CHECK_FIXPOINT))) + $(RM) "$(SRC)/mlton/mlton-compile$(EXE)" + $(MAKE) -C "$(SRC)/mlton/front-end" clean + $(MAKE) compiler CHECK_FIXPOINT=false # tools1 + mlton1 -> mlton2 +ifeq (true, $(CHECK_FIXPOINT)) + $(MAKE) tools-clean + $(MAKE) tools CHECK_FIXPOINT=true # tools1 + mlton1 -> tools2; tools2 == tools1 + $(RM) "$(SRC)/mlton/mlton-compile$(EXE)" + $(MAKE) -C "$(SRC)/mlton/front-end" clean + $(MAKE) compiler CHECK_FIXPOINT=true # tools2 + mlton2 -> mlton3; mlton3 == mlton2 +endif +endif + @echo 'Build of MLton succeeded.' + +.PHONY: basis-no-check +basis-no-check: + $(RM) "$(LIB)/sml/basis" + $(MKDIR) "$(LIB)/sml/basis" + ( \ + cd "$(SRC)/basis-library" && \ + $(FIND) . -type f '(' -name '*.mlb' -o -name '*.sml' -o -name '*.sig' -o -name '*.fun' ')' | \ + $(XARGS) $(TAR) cf - | \ + ( cd "$(LIB)/sml/basis" && $(TAR) xf - ) \ + ) + +.PHONY: basis-check +basis-check: + @echo 'Type checking basis.' + "$(BIN)/mlton" -disable-ann deadCode -stop tc '$$(SML_LIB)/basis/libs/all.mlb' >/dev/null + +.PHONY: basis +basis: + $(MAKE) basis-no-check + $(MAKE) basis-check + +.PHONY: bootstrap-smlnj +bootstrap-smlnj: + $(MAKE) smlnj-mlton + $(RM) "$(BIN)/mlton" + $(MAKE) BOOTSTRAP_MLTON=mlton.smlnj all + smlnj_heap_suffix=`echo 'TextIO.output (TextIO.stdErr, SMLofNJ.SysInfo.getHeapSuffix ());' | sml 2>&1 1> /dev/null` && $(RM) "$(LIB)/mlton/mlton-smlnj.$$smlnj_heap_suffix" + $(RM) "$(BIN)/mlton.smlnj" + +.PHONY: bootstrap-polyml +bootstrap-polyml: + $(MAKE) polyml-mlton + $(RM) "$(BIN)/mlton" + $(MAKE) BOOTSTRAP_MLTON=mlton.polyml all + $(RM) "$(LIB)/mlton-polyml$(EXE)" + $(RM) "$(BIN)/mlton.polyml" + +.PHONY: clean +clean: + ./bin/clean --exclude package + +.PHONY: clean-git +clean-git: + $(FIND) . -type d -name .git -prune -exec $(RM) '{}' ';' + +.PHONY: compiler +compiler: + $(MAKE) -C "$(SRC)/mlton" MLTON_OUTPUT=mlton-compile +ifeq (true, $(CHECK_FIXPOINT)) + $(DIFF) -b "$(SRC)/mlton/mlton-compile$(EXE)" "$(LIB)/mlton-compile$(EXE)" +endif + $(CP) "$(SRC)/mlton/mlton-compile$(EXE)" "$(LIB)/" + +.PHONY: constants +constants: + @echo 'Creating constants file.' + "$(BIN)/mlton" -target "$(TARGET)" -build-constants true > build-constants.c + "$(BIN)/mlton" -target "$(TARGET)" -output build-constants build-constants.c + ./build-constants$(EXE) >"$(LIB)/targets/$(TARGET)/constants" + $(RM) build-constants$(EXE) build-constants.c + +.PHONY: debugged +debugged: + $(MAKE) -C "$(SRC)/mlton" MLTON_OUTPUT=mlton-compile.debug \ + MLTON_COMPILE_ARGS="$(MLTON_COMPILE_ARGS) -debug true -const 'Exn.keepHistory true' -profile-val true -const 'MLton.debug true' -disable-pass 'deepFlatten'" + $(CP) "$(SRC)/mlton/mlton-compile.debug$(EXE)" "$(LIB)/" + $(SED) -e 's/mlton-compile/mlton-compile.debug/' \ + < "$(BIN)/mlton" \ + > "$(BIN)/mlton.debug" + chmod u+x "$(BIN)/mlton.debug" + +.PHONY: dirs +dirs: + $(MKDIR) "$(BIN)" "$(LIB)" "$(INC)" + $(MKDIR) "$(LIB)/targets/$(TARGET)/include" + $(MKDIR) "$(LIB)/targets/$(TARGET)/sml" + +.PHONY: docs +docs: + $(MAKE) -C "$(SRC)/mllex" docs + $(MAKE) -C "$(SRC)/mlyacc" docs + $(MAKE) -C "$(SRC)/doc/guide" + +define LIBRARIES_NO_CHECK_TEMPLATE + $(RM) "$(LIB)/sml/$(1)" + $(MKDIR) "$(LIB)/sml/$(1)" + ( \ + cd "$(SRC)/lib/$(1)$(2)" && \ + $(FIND) . '!' -path '*/.cm/*' $(3) -type f '(' -name '*.mlb' -o -name '*.sml' -o -name '*.sig' -o -name '*.fun' ')' | \ + $(XARGS) $(TAR) cf - | \ + ( cd "$(LIB)/sml/$(1)" && $(TAR) xf - ) \ + ) + +endef + +.PHONY: libraries-no-check +libraries-no-check: + $(MAKE) -C "$(SRC)/lib/ckit-lib" + $(call LIBRARIES_NO_CHECK_TEMPLATE,ckit-lib,/ckit/src,) + $(call LIBRARIES_NO_CHECK_TEMPLATE,cml,,'!' -path '*/tests/*') + $(MAKE) -C "$(SRC)/lib/mllpt-lib" + $(call LIBRARIES_NO_CHECK_TEMPLATE,mllpt-lib,/ml-lpt/lib,) + $(MAKE) -C "$(SRC)/lib/mlnlffi-lib" + $(call LIBRARIES_NO_CHECK_TEMPLATE,mlnlffi-lib,,) + $(MAKE) -C "$(SRC)/lib/mlrisc-lib" + $(call LIBRARIES_NO_CHECK_TEMPLATE,mlrisc-lib,/MLRISC,'!' -path '*/demo/*' '!' -path '*/Tools/*' '!' -path './autoload.sml' '!' -path './make*.sml') + $(call LIBRARIES_NO_CHECK_TEMPLATE,mlyacc-lib,,) + $(MAKE) -C "$(SRC)/lib/smlnj-lib" + $(call LIBRARIES_NO_CHECK_TEMPLATE,smlnj-lib,/smlnj-lib,'!' -path '*/examples/*' '!' -path '*/tests/*' '!' -path '*/Tests/*') + +define LIBRARIES_CHECK_TEMPLATE + @echo "Type checking $(1) library." + "$(BIN)/mlton" -disable-ann deadCode -stop tc '$$(SML_LIB)/$(1)/$(1).mlb' >/dev/null +endef + +.PHONY: libraries-check +libraries-check: + $(call LIBRARIES_CHECK_TEMPLATE,ckit-lib) + $(call LIBRARIES_CHECK_TEMPLATE,cml) + $(call LIBRARIES_CHECK_TEMPLATE,mllpt-lib) + $(call LIBRARIES_CHECK_TEMPLATE,mlnlffi-lib) + $(call LIBRARIES_CHECK_TEMPLATE,mlrisc-lib) + $(call LIBRARIES_CHECK_TEMPLATE,mlyacc-lib) + $(call LIBRARIES_CHECK_TEMPLATE,smlnj-lib) + +.PHONY: libraries +libraries: + $(MAKE) libraries-no-check + $(MAKE) libraries-check + +.PHONY: polyml-mlton +polyml-mlton: + $(MAKE) dirs runtime + $(MAKE) -C "$(SRC)/mlton" polyml-mlton + $(CP) "$(SRC)/mlton/mlton-polyml$(EXE)" "$(LIB)/" + $(MAKE) script basis-no-check constants libraries-no-check + $(SED) \ + -e 's;doitMLton "$$@";# doitMLton "$$@";' \ + -e 's;doitSMLNJ "$$@";# doitSMLNJ "$$@";' \ + < "$(BIN)/mlton" \ + > "$(BIN)/mlton.polyml" + chmod u+x "$(BIN)/mlton.polyml" + @echo 'Build of MLton (with Poly/ML) succeeded.' + +define PROFILED_TEMPLATE + $(MAKE) -C "$(SRC)/mlton" MLTON_OUTPUT=mlton-compile.$(1) \ + MLTON_COMPILE_ARGS="$(MLTON_COMPILE_ARGS) -profile $(1)" + $(CP) "$(SRC)/mlton/mlton-compile.$(1)$(EXE)" "$(LIB)/" + $(SED) -e "s/mlton-compile/mlton-compile.$(1)/" \ + < "$(BIN)/mlton" \ + >"$(BIN)/mlton.$(1)" + chmod u+x "$(BIN)/mlton.$(1)" +endef + +.PHONY: profiled-alloc +profiled-alloc: + $(call PROFILED_TEMPLATE,alloc) + +.PHONY: profiled-count +profiled-count: + $(call PROFILED_TEMPLATE,count) + +.PHONY: profiled-time +profiled-time: + $(call PROFILED_TEMPLATE,time) + +.PHONY: profiled + $(MAKE) profiled-alloc + $(MAKE) profiled-count + $(MAKE) profiled-time + +.PHONY: runtime +runtime: + @echo 'Compiling MLton runtime system for $(TARGET).' + $(MAKE) -C "$(SRC)/runtime" + $(CP) "$(SRC)/include/"*.h "$(INC)/" + $(CP) "$(SRC)/runtime/"*.a "$(LIB)/targets/$(TARGET)/" + $(CP) "$(SRC)/runtime/gen/sizes" "$(LIB)/targets/$(TARGET)/" + $(CP) "$(SRC)/runtime/gen/c-types.sml" "$(LIB)/targets/$(TARGET)/sml/" + echo "$(TARGET_OS)" > "$(LIB)/targets/$(TARGET)/os" + echo "$(TARGET_ARCH)" > "$(LIB)/targets/$(TARGET)/arch" + $(CP) "$(SRC)/runtime/gen/basis-ffi.sml" \ + basis-library/primitive/basis-ffi.sml + $(CP) "$(SRC)/runtime/"*.h "$(INC)/" + $(MV) "$(INC)/c-types.h" "$(LIB)/targets/$(TARGET)/include" + for d in basis basis/Real basis/Word gc platform util; do \ + $(MKDIR) "$(INC)/$$d"; \ + $(CP) "$(SRC)/runtime/$$d/"*.h "$(INC)/$$d"; \ + done + +.PHONY: script +script: + $(SED) \ + -e "s;^EXE=.*;EXE=\"$(EXE)\";" \ + -e "s;^CC=.*;CC=\"$(CC)\";" \ + -e "s;^GMP_INC_DIR=.*;GMP_INC_DIR=\"$(WITH_GMP_INC_DIR)\";" \ + -e "s;^GMP_LIB_DIR=.*;GMP_LIB_DIR=\"$(WITH_GMP_LIB_DIR)\";" \ + < "$(SRC)/bin/mlton-script" > "$(BIN)/mlton" + chmod a+x "$(BIN)/mlton" + $(CP) "$(SRC)/bin/static-library" "$(LIB)" +ifeq (mingw, $(TARGET_OS)) + $(CP) "$(SRC)/bin/static-library.bat" "$(LIB)" +endif + +.PHONY: smlnj-mlton +smlnj-mlton: + $(MAKE) dirs runtime + $(MAKE) -C "$(SRC)/mlton" smlnj-mlton + smlnj_heap_suffix=`echo 'TextIO.output (TextIO.stdErr, SMLofNJ.SysInfo.getHeapSuffix ());' | sml 2>&1 1> /dev/null` && $(CP) "$(SRC)/mlton/mlton-smlnj.$$smlnj_heap_suffix" "$(LIB)/" + $(MAKE) script basis-no-check constants libraries-no-check + $(SED) \ + -e 's;doitMLton "$$@";# doitMLton "$$@";' \ + -e 's;doitPolyML "$$@";# doitPolyML "$$@";' \ + < "$(BIN)/mlton" \ + > "$(BIN)/mlton.smlnj" + chmod u+x "$(BIN)/mlton.smlnj" + @echo 'Build of MLton (with SML/NJ) succeeded.' + +.PHONY: smlnj-mlton-x2 +smlnj-mlton-x2: + $(MAKE) SMLNJ_CM_SERVERS_NUM=2 smlnj-mlton + +.PHONY: smlnj-mlton-x4 +smlnj-mlton-x4: + $(MAKE) SMLNJ_CM_SERVERS_NUM=4 smlnj-mlton + +.PHONY: smlnj-mlton-x8 +smlnj-mlton-x8: + $(MAKE) SMLNJ_CM_SERVERS_NUM=8 smlnj-mlton + +.PHONY: smlnj-mlton-x16 +smlnj-mlton-x16: + $(MAKE) SMLNJ_CM_SERVERS_NUM=16 smlnj-mlton + +.PHONY: traced +traced: + $(MAKE) -C "$(SRC)/mlton" MLTON_OUTPUT=mlton-compile.trace \ + MLTON_COMPILE_ARGS="$(MLTON_COMPILE_ARGS) -const 'Exn.keepHistory true' -profile-val true -const 'MLton.debug true' -disable-pass 'deepFlatten'" + $(CP) "$(SRC)/mlton/mlton-compile.trace$(EXE)" "$(LIB)/" + $(SED) -e 's/mlton-compile/mlton-compile.trace/' \ + < "$(BIN)/mlton" \ + > "$(BIN)/mlton.trace" + chmod u+x "$(BIN)/mlton.trace" + +ifeq (true, $(CHECK_FIXPOINT)) +define TOOLS_TEMPLATE_CHECK_FIXPOINT + $(DIFF) -b "$(SRC)/$(1)/$(1)$(EXE)" "$(BIN)/$(1)$(EXE)" +endef +else +define TOOLS_TEMPLATE_CHECK_FIXPOINT +endef +endif + +define TOOLS_TEMPLATE + $(MAKE) -C "$(SRC)/$(1)" + $(call TOOLS_TEMPLATE_CHECK_FIXPOINT,$(1)) + $(CP) "$(1)/$(1)$(EXE)" "$(BIN)/" +endef + +.PHONY: tools +tools: + $(call TOOLS_TEMPLATE,mllex) + $(call TOOLS_TEMPLATE,mlyacc) + $(call TOOLS_TEMPLATE,mlprof) + $(call TOOLS_TEMPLATE,mlnlffigen) + +.PHONY: tools-clean +tools-clean: + $(MAKE) -C "$(SRC)/mllex" clean + $(MAKE) -C "$(SRC)/mlyacc" clean + $(MAKE) -C "$(SRC)/mlprof" clean + $(MAKE) -C "$(SRC)/mlnlffigen" clean + +.PHONY: check +check: + ./bin/regression $(CHECK_ARGS) + + +.PHONY: version +version: + @echo 'Instantiating version numbers.' + for f in \ + "$(SRC)/Makefile" \ + "$(SRC)/mlton/Makefile" \ + "$(SRC)/doc/guide/Makefile" \ + ; do \ + $(SED) -e "s/^MLTON_VERSION := .*/MLTON_VERSION := $(MLTON_VERSION)/" <"$$f" >z && \ + mv z "$$f"; \ + done + + +prefix := $(PREFIX) +exec_prefix := $(prefix) +bindir := $(exec_prefix)/bin +datarootdir := $(prefix)/share +docdir := $(datarootdir)/doc/mlton +libdir := $(exec_prefix)/lib +mandir := $(datarootdir)/man +man1dir := $(mandir)/man1 + +TBIN := $(DESTDIR)$(bindir) +TLIB := $(DESTDIR)$(libdir)/mlton +TMAN := $(DESTDIR)$(man1dir) +TDOC := $(DESTDIR)$(docdir) +TEXM := $(TDOC)/examples + +GZIP_MAN := true +ifeq ($(findstring $(TARGET_OS), openbsd solaris), $(TARGET_OS)) +GZIP_MAN := false +endif + +.PHONY: install +install: install-no-strip install-strip install-docs + +MAN_PAGES := \ + mllex.1 \ + mlnlffigen.1 \ + mlprof.1 \ + mlton.1 \ + mlyacc.1 + +.PHONY: install-no-strip +install-no-strip: + $(MKDIR) "$(TBIN)" "$(TLIB)" "$(TMAN)" + $(CP) "$(BIN)/." "$(TBIN)/" + $(CP) "$(LIB)/." "$(TLIB)/" + cd "$(SRC)/man" && $(CP) $(MAN_PAGES) "$(TMAN)/" +ifeq (true, $(GZIP_MAN)) + cd "$(TMAN)" && $(GZIP) --force --best $(MAN_PAGES); +endif + +.PHONY: install-strip +install-strip: install-no-strip + for f in "$(TLIB)/mlton-compile$(EXE)" \ + "$(TBIN)/mllex$(EXE)" \ + "$(TBIN)/mlyacc$(EXE)" \ + "$(TBIN)/mlprof$(EXE)" \ + "$(TBIN)/mlnlffigen$(EXE)"; do \ + $(STRIP) "$$f"; \ + done + +REGRESSION_EXAMPLES := \ + callcc.sml command-line.sml hello-world.sml same-fringe.sml \ + signals.sml size.sml taut.sml thread1.sml thread2.sml \ + thread-switch.sml timeout.sml + +.PHONY: install-docs +install-docs: + $(MKDIR) "$(TDOC)" "$(TDOC)/license" + ( \ + cd "$(SRC)" && \ + $(CP) CHANGELOG.adoc README.adoc "$(TDOC)/" && \ + $(CP) LICENSE "$(TDOC)/license/MLton-LICENSE" \ + ) + ( \ + cd "$(SRC)/doc" && \ + $(FIND) examples -type f '!' -name .gitignore \ + | $(XARGS) $(TAR) cf - \ + | ( cd "$(TDOC)/" && $(TAR) xf - ) \ + ) + ( \ + cd "$(SRC)/doc" && \ + $(FIND) license -type f '!' -name .gitignore \ + | $(XARGS) $(TAR) cf - \ + | ( cd "$(TDOC)/" && $(TAR) xf - ) \ + ) + if [ -d "$(SRC)/doc/guide/localhost" ]; then \ + $(CP) "$(SRC)/doc/guide/localhost" "$(TDOC)/guide"; \ + fi + if [ -r "$(SRC)/doc/guide/mlton-guide.pdf" ]; then \ + $(CP) "$(SRC)/doc/guide/mlton-guide.pdf" "$(TDOC)/"; \ + fi + if [ -r "mllex/mllex.pdf" ]; then \ + $(CP) "mllex/mllex.pdf" "$(TDOC)/"; \ + fi + if [ -r "mlyacc/mlyacc.pdf" ]; then \ + $(CP) "mlyacc/mlyacc.pdf" "$(TDOC)/"; \ + fi + ( \ + cd "$(SRC)/util" && \ + $(FIND) cm2mlb -type f '!' -name .gitignore \ + | $(XARGS) $(TAR) cf - \ + | ( cd "$(TDOC)/" && $(TAR) xf - ) \ + ) + ( \ + cd "$(SRC)/regression" && \ + $(CP) $(REGRESSION_EXAMPLES) "$(TEXM)/" \ + ) + + +.PHONY: source-release +source-release: + $(MAKE) clean + $(MAKE) MLTON_VERSION=$(MLTON_VERSION) version + ( cd "$(SRC)/mllex" ; latexmk -pdf lexgen ; latexmk -c lexgen ) + $(MAKE) -C "$(SRC)/mllex" mllex.pdf + ( cd "$(SRC)/mlyacc/doc"; latexmk -pdf mlyaccc ; latexmk -c mlyacc ) + $(MAKE) -C "$(SRC)/mlyacc" mlyacc.pdf + $(MAKE) -C doc/guide + $(TAR) cvzf ../mlton-$(MLTON_VERSION).src.tgz \ + --exclude .git --exclude package \ + --transform "s@^@mlton-$(MLTON_VERSION)/@S" \ + * + +MLTON_BINARY_RELEASE := 1 +MLTON_BINARY_RELEASE_SUFFIX := +.PHONY: binary-release +binary-release: + $(MAKE) all docs + $(RM) "$(SRC)/mlton-$(MLTON_VERSION)-$(MLTON_BINARY_RELEASE).$(TARGET_ARCH)-$(TARGET_OS)$(MLTON_BINARY_RELEASE_SUFFIX)" + $(MKDIR) "$(SRC)/mlton-$(MLTON_VERSION)-$(MLTON_BINARY_RELEASE).$(TARGET_ARCH)-$(TARGET_OS)$(MLTON_BINARY_RELEASE_SUFFIX)" + $(MAKE) DESTDIR="$(SRC)/mlton-$(MLTON_VERSION)-$(MLTON_BINARY_RELEASE).$(TARGET_ARCH)-$(TARGET_OS)$(MLTON_BINARY_RELEASE_SUFFIX)" PREFIX="" install + $(CP) "$(SRC)/Makefile.binary" "$(SRC)/mlton-$(MLTON_VERSION)-$(MLTON_BINARY_RELEASE).$(TARGET_ARCH)-$(TARGET_OS)$(MLTON_BINARY_RELEASE_SUFFIX)/Makefile" + $(CP) "$(SRC)/CHANGELOG.adoc" "$(SRC)/LICENSE" "$(SRC)/README.adoc" "$(SRC)/mlton-$(MLTON_VERSION)-$(MLTON_BINARY_RELEASE).$(TARGET_ARCH)-$(TARGET_OS)$(MLTON_BINARY_RELEASE_SUFFIX)/" + $(TAR) cvzf ../mlton-$(MLTON_VERSION)-$(MLTON_BINARY_RELEASE).$(TARGET_ARCH)-$(TARGET_OS)$(MLTON_BINARY_RELEASE_SUFFIX).tgz \ + mlton-$(MLTON_VERSION)-$(MLTON_BINARY_RELEASE).$(TARGET_ARCH)-$(TARGET_OS)$(MLTON_BINARY_RELEASE_SUFFIX) + $(RM) mlton-$(MLTON_VERSION)-$(MLTON_BINARY_RELEASE).$(TARGET_ARCH)-$(TARGET_OS)$(MLTON_BINARY_RELEASE_SUFFIX) + +BSDSRC := /tmp/mlton-$(MLTON_VERSION) +MLTON_FREEBSD_RELEASE := 1 +.PHONY: freebsd +freebsd: + $(MAKE) clean clean-git version + $(RM) "$(BSDSRC)" + $(MKDIR) "$(BSDSRC)" + ( cd $(SRC) && tar -cpf - . ) | ( cd "$(BSDSRC)" && tar -xpf - ) + cd /tmp && tar -cpf - mlton-$(MLTON_VERSION) | \ + $(GZIP) --force --best >/usr/ports/distfiles/mlton-$(MLTON_VERSION)-$(MLTON_FREEBSD_RELEASE).freebsd.src.tgz + # do not change "make" to "$(MAKE)" in the following line + cd "$(BSDSRC)/package/freebsd" && MAINTAINER_MODE=yes make build-package diff --git a/Makefile.binary b/Makefile.binary new file mode 100644 index 0000000..8baf3e7 --- /dev/null +++ b/Makefile.binary @@ -0,0 +1,64 @@ +# Specify C compiler and binutils. +# Can be used for alternative tools (e.g., `CC=clang` or `CC=gcc-7`). +CC := gcc + +# Specify GMP include and library paths, if not on default search paths. +WITH_GMP_DIR := +ifneq ($(WITH_GMP_DIR),) +WITH_GMP_INC_DIR := $(WITH_GMP_DIR)/include +WITH_GMP_LIB_DIR := $(WITH_GMP_DIR)/lib +endif + +# Specify installation prefix and staged install destination. +PREFIX := /usr/local + +SED := sed + +###################################################################### +###################################################################### + +ROOT := $(shell pwd) + +CP := cp -fpR +MKDIR := mkdir -p + +###################################################################### + +SBIN := $(ROOT)/bin +SLIB := $(ROOT)/lib/mlton +SMAN := $(ROOT)/share/man/man1 +SDOC := $(ROOT)/share/doc/mlton + +prefix := $(PREFIX) +exec_prefix := $(prefix) +bindir := $(exec_prefix)/bin +datarootdir := $(prefix)/share +docdir := $(datarootdir)/doc/mlton +libdir := $(exec_prefix)/lib +mandir := $(datarootdir)/man +man1dir := $(mandir)/man1 + +TBIN := $(bindir) +TLIB := $(libdir)/mlton +TMAN := $(man1dir) +TDOC := $(docdir) +TEXM := $(TDOC)/examples + +.PHONY: install +install: + mkdir -p "$(TBIN)" "$(TLIB)" "$(TMAN)" "$(TDOC)" + $(CP) "$(SBIN)/." "$(TBIN)/" + $(CP) "$(SLIB)/." "$(TLIB)/" + $(CP) "$(SMAN)/." "$(TMAN)/" + if [ -d "$(SDOC)" ]; then $(CP) "$(SDOC)/." "$(TDOC)/"; fi + +.PHONY: update +update: + $(CP) "$(SBIN)/mlton" "$(SBIN)/mlton.bak" + $(SED) \ + -e "s;^CC=.*;CC=\"$(CC)\";" \ + -e "s;^GMP_INC_DIR=.*;GMP_INC_DIR=\"$(WITH_GMP_INC_DIR)\";" \ + -e "s;^GMP_LIB_DIR=.*;GMP_LIB_DIR=\"$(WITH_GMP_LIB_DIR)\";" \ + < "$(SBIN)/mlton.bak" > "$(SBIN)/mlton" + chmod a+x "$(SBIN)/mlton" + $(RM) "$(SBIN)/mlton.bak" diff --git a/README.adoc b/README.adoc new file mode 100644 index 0000000..bfc0220 --- /dev/null +++ b/README.adoc @@ -0,0 +1,227 @@ += http://mlton.org[MLton] + +ifdef::env-github[] +image:https://travis-ci.org/MLton/mlton.svg?branch=master[Build Status, link = https://travis-ci.org/MLton/mlton] +endif::[] + +**** +MLton is a whole-program optimizing compiler for the Standard{nbsp}ML +programming language. +**** + +== Features + + * Portability. Runs on the following platforms: + + - ARM: Linux (Debian). + - Alpha: Linux (Debian). + - AMD64: Darwin (Mac OS X), FreeBSD, Linux (Debian, Fedora, Ubuntu, ...), + OpenBSD, Solaris (10 and above). + + - HPPA: HPUX (11.11 and above), Linux (Debian). + - IA64: HPUX (11.11 and above), Linux (Debian). + - PowerPC: AIX (5.2 and above), Darwin (Mac OS X), Linux (Debian, Fedora). + - PowerPC64: AIX (5.2 and above). + - S390: Linux (Debian). + - Sparc: Linux (Debian), Solaris (8 and above). + - X86: Cygwin/Windows, Darwin (Mac OS X), FreeBSD, Linux (Debian, Fedora, + Ubuntu, ...), MinGW/Windows, NetBSD, OpenBSD, Solaris (10 and above). + + * Robustness. + + - Supports the full SML 97 language as given in The Definition of + Standard{nbsp}ML (Revised). + - A complete implementation of the Basis Library. + - Generates standalone executables. + - Compiles large programs. + - Support for large amounts of memory (up to 4G on 32-bit systems; + more on 64-bit systems). + - Support for large array lengths (up to 2^31^ - 1 on 32-bit systems; + up to 2^63^-1 on 64-bit systems). + - Support for large files, using 64-bit file positions. + + * Performance. + + - Executables have excellent running times. + - Generates small executables. + - Untagged and unboxed native integers, reals, and words. + - Unboxed native arrays. + - Multiple garbage collection strategies. + - Fast arbitrary-precision arithmetic based on the GMP. + + * Tools. + + - Source-level profiling for both time and allocation. + - MLLex lexer generator. + - MLYacc parser generator. + - MLNLFFIGEN foreign-function-interface generator. + + * Extensions. + + - A simple and fast C FFI that supports calling from SML to C and from C + to SML. + - The ML Basis system for programming in the very large. + - Libraries for continuations, finalization, interval timers, random numbers, + resource limits, resource usage, signal handlers, object size, system + logging, threads, weak pointers, and world save and restore. + + +== Build and Install (from source) + +=== Requirements + +==== Software + + * http://gcc.gnu.org/[GCC] or http://clang.llvm.org[Clang] (The C compiler must support `-std=gnu11`.) + * http://gmplib.org[GMP] (GNU Multiple Precision arithmetic library) + * http://savannah.gnu.org/projects/make[GNU Make] + * http://www.gnu.org/software/bash/[GNU Bash] + * binutils (`ar`, `ranlib`, `strip`, ...) + * miscellaneous Unix utilities (`diff`, `find`, `grep`, `gzip`, `patch`, `sed`, `tar`, `xargs`, ...) + * Standard{nbsp}ML compiler and tools to bootstrap: + - http://mlton.org[MLton] (`mlton`, `mllex`, and `mlyacc`) recommended. Pre-built binary packages for MLton can be installed via an OS package manager or (for select platforms) obtained from `http://mlton.org`. + - http://www.smlnj.org[SML/NJ] (`sml`, `ml-lex`, `ml-yacc`) supported, but not recommended. + * (optional, for documentation only) https://ctan.org/tex/[TeX], http://asciidoc.org/[AsciiDoc], http://pygments.org/[Pygments], http://www.graphicsmagick.org/[GraphicsMagick] or https://www.imagemagick.org/[ImageMagick], ... + +==== Hardware + + * ≥ 1GB RAM (for 32-bit platforms) or ≥ 2GB RAM (for 64-bit platforms) + +=== Build Instructions + +On typical platforms, building MLton requires no configuration and can be +accomplished via: + +[source,shell] +---- +$ make all +---- + +A small set of `Makefile` variables can be used to customize the build: + + * `CC`: Specify C compiler. Can be used for alternative tools (e.g., + `CC=clang` or `CC=gcc-7`). + * `WITH_GMP_DIR`, `WITH_GMP_INC_DIR`, `WITH_GMP_LIB_DIR`: Specify GMP include + and library paths, if not on default search paths. (If `WITH_GMP_DIR` is + set, then `WITH_GMP_INC_DIR` defaults to `$(WITH_GMP_DIR)/include` and + `WITH_GMP_LIB_DIR` defaults to `$(WITH_GMP_DIR)/lib`.) + * `MLTON_RUNTIME_ARGS`, `MLTON_COMPILE_ARGS`: Specify runtime and compile + arguments given to (the to-be-built) `mlton` when compiling distributed + executables ((self-compiled) `mlton`, `mllex`, `mlyacc`, `mlprof`, and + `mlnlffigen`). Can be used for testing (e.g., `MLTON_COMPILE_ARGS="-codegen + c"`) or for downstream packaging. + * `BOOTSTRAP_MLTON_RUNTIME_ARGS`, `BOOTSTRAP_MLTON_COMPILE_ARGS`: Specify + runtime and compile arguments given to "old" `mlton` when compiling + "bootstrapped" `mlton`. Can be used to work around bugs in "old" `mlton` when + compiling "bootstrapped" `mlton`. + +For example: + +[source,shell] +---- +$ make CC=clang WITH_GMP_DIR=/opt/gmp MLTON_COMPILE_ARGS="-codegen c" all +---- + +The build artifacts are located under `./build`. The just-built `mlton` can be +executed via `./build/bin/mlton`. + +Building documentation can be accomplished via: + +[source,shell] +---- +$ make docs +---- + +=== Install Instructions + +On typical platforms, installing MLton (after performing `make all` and, +optionally, `make docs`) to `/usr/local` can be accomplished via: + +[source,shell] +---- +$ make install +---- + +A small set of `Makefile` variables can be used to customize the installation: + + * `PREFIX`: Specify the installation prefix. + +For example: + +[source,shell] +---- +$ make PREFIX=/opt/mlton install +---- + +== Install (from binary package) + +=== Requirements + +==== Software + + * http://gcc.gnu.org/[GCC] or http://clang.llvm.org[Clang] (The C compiler must support `-std=gnu11`.) + * http://gmplib.org[GMP] (GNU Multiple Precision arithmetic library) + * http://savannah.gnu.org/projects/make[GNU Make] + * http://www.gnu.org/software/bash/[GNU Bash] + * miscellaneous Unix utilities (`bzip2`, `gzip`, `sed`, `tar`, ...) + +=== Binary Package + +A `.tgz` or `.tbz` binary package can be extracted at any location, yielding +`README.adoc` (this file), `CHANGELOG.adoc`, `LICENSE`, `Makefile`, `bin/`, +`lib/`, and `share/`. The compiler and tools can be executed in-place (e.g., +`./bin/mlton`). + +A small set of `Makefile` variables can be used to customize the binary package +via `make update`: + + * `CC`: Specify C compiler. Can be used for alternative tools (e.g., + `CC=clang` or `CC=gcc-7`). + * `WITH_GMP_DIR`, `WITH_GMP_INC_DIR`, `WITH_GMP_LIB_DIR`: Specify GMP include + and library paths, if not on default search paths. (If `WITH_GMP_DIR` is + set, then `WITH_GMP_INC_DIR` defaults to `$(WITH_GMP_DIR)/include` and + `WITH_GMP_LIB_DIR` defaults to `$(WITH_GMP_DIR)/lib`.) + +For example: + +[source,shell] +---- +$ make CC=clang WITH_GMP_DIR=/opt/gmp update +---- + +=== Install Instructions + +On typical platforms, installing MLton (after optionally performing +`make update`) to `/usr/local` can be accomplished via: + +[source,shell] +---- +$ make install +---- + +A small set of `Makefile` variables can be used to customize the installation: + + * `PREFIX`: Specify the installation prefix. + +For example: + +[source,shell] +---- +$ make PREFIX=/opt/mlton install +---- + +== Resources + + * `http://mlton.org` + * mailing lists + - `MLton-devel@mlton.org` -- MLton developers + (https://sourceforge.net/mailarchive/forum.php?forum_name=mlton-devel[archive], + https://lists.sourceforge.net/lists/listinfo/mlton-devel[subscribe]) + - `MLton-user@mlton.org` -- MLton user community + (https://sourceforge.net/mailarchive/forum.php?forum_name=mlton-user[archive], + https://lists.sourceforge.net/lists/listinfo/mlton-user[subscribe]) + +== Need help? Found a bug? + +https://github.com/MLton/mlton/issues[Submit an issue] if you need any help. +We welcome pull requests with bug fixes or changes. diff --git a/basis-library/.gitignore b/basis-library/.gitignore new file mode 100644 index 0000000..313aa33 --- /dev/null +++ b/basis-library/.gitignore @@ -0,0 +1 @@ +/basis-library.def-use diff --git a/basis-library/Makefile b/basis-library/Makefile new file mode 100644 index 0000000..3834675 --- /dev/null +++ b/basis-library/Makefile @@ -0,0 +1,76 @@ +## Copyright (C) 2010,2013,2016-2017 Matthew Fluet. + # Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # Copyright (C) 1997-2000 NEC Research Institute. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +SRC = $(shell cd .. && pwd) +BUILD = $(SRC)/build +BIN = $(BUILD)/bin +MLTON = mlton +PATH = $(BIN):$(shell echo $$PATH) + +all: + +.PHONY: clean +clean: + ../bin/clean + + +RESOLVE_SCOPES = program topdec strdec dec +OBJPTR_MAPS = objptr-rep32.map objptr-rep64.map +NORMAL_METADATA_MAPS = normal-metadata-size32.map normal-metadata-size64.map normal-metadata-size128.map +ARRAY_METADATA_MAPS = array-metadata-size96.map array-metadata-size128.map array-metadata-size196.map array-metadata-size256.map +SEQINDEX_MAPS = seqindex-int32.map seqindex-int64.map +DEFAULT_CHAR = char8 +DEFAULT_INT = int32 int64 intinf +DEFAULT_REAL = real32 real64 +DEFAULT_WORD = word32 word64 + +.PHONY: def-use +def-use: + "$(MLTON)" -disable-ann deadCode -stop tc -show-types true \ + -prefer-abs-paths true -show-def-use basis-library.def-use \ + libs/all.mlb + +.PHONY: type-check-def +type-check-def: + "$(MLTON)" -disable-ann deadCode -stop tc -show-types true \ + libs/all.mlb + +.PHONY: type-check-all +type-check-all: + for resolvescope in $(RESOLVE_SCOPES); do \ + for objptr in $(OBJPTR_MAPS); do \ + for normalmetadata in $(NORMAL_METADATA_MAPS); do \ + for arraymetadata in $(ARRAY_METADATA_MAPS); do \ + for seqindex in $(SEQINDEX_MAPS); do \ + for defchar in $(DEFAULT_CHAR); do \ + for defint in $(DEFAULT_INT); do \ + for defreal in $(DEFAULT_REAL); do \ + for defword in $(DEFAULT_WORD); do \ + echo "Type checking: $$resolvescope $$objptr $$normalmetadata $$arraymetadata $$seqindex $$defchar $$defint $$defreal $$defword"; \ + echo "$(MLTON)" -disable-ann deadCode -disable-ann resolveScope -default-ann "\"resolveScope $$resolvescope\"" -stop tc -show-types true \ + -mlb-path-map "maps/$$objptr" \ + -mlb-path-map "maps/$$normalmetadata" \ + -mlb-path-map "maps/$$arraymetadata" \ + -mlb-path-map "maps/$$seqindex" \ + -default-type "$$defchar" \ + -default-type "$$defint" \ + -default-type "$$defreal" \ + -default-type "$$defword" \ + libs/all.mlb; \ + "$(MLTON)" -disable-ann deadCode -disable-ann resolveScope -default-ann "resolveScope $$resolvescope" -stop tc -show-types true \ + -mlb-path-map "maps/$$objptr" \ + -mlb-path-map "maps/$$normalmetadata" \ + -mlb-path-map "maps/$$arraymetadata" \ + -mlb-path-map "maps/$$seqindex" \ + -default-type "$$defchar" \ + -default-type "$$defint" \ + -default-type "$$defreal" \ + -default-type "$$defword" \ + libs/all.mlb; \ + done; done; done; done; done; done; done; done; done; diff --git a/basis-library/README b/basis-library/README new file mode 100644 index 0000000..50490f7 --- /dev/null +++ b/basis-library/README @@ -0,0 +1,35 @@ +This directory contains the MLton implementation of the Basis Library. +The files are grouped in directories in the same way that the +corresponding modules are grouped in the basis library documentation. +All other implementation files are in the misc/ and libs/ directories. + +The basis is constructed using the ML Basis system. + +There are several special files that make use of non-SML extensions. + +misc/primitive.sml +posix/primitve.sml + These are not Standard ML. They describe all of the primitives and + C routines used in the basis. + +top-level/overloads.sml + Not Standard ML. + Uses the notation _overload : as (and )* + + +Dead Code Elimination +---------------------------------------- +In order to compile small programs rapidly, a pass of dead code +elimination (core-ml/dead-code.{sig,fun}) is run in order to eliminate +as much of the basis library as possible. The dead code elimination +algorithm used is not safe in general, and only works because the +basis library implementation has special properties: + * it terminates + * it performs no I/O +The dead code elimination includes the minimal set of +declarations from the basis so that there are no free variables in the +user program (or basis). It has a special hack to include all +bindings of the form + + val _ = ... + diff --git a/basis-library/arrays-and-vectors/array-slice.sig b/basis-library/arrays-and-vectors/array-slice.sig new file mode 100644 index 0000000..b4ab39b --- /dev/null +++ b/basis-library/arrays-and-vectors/array-slice.sig @@ -0,0 +1,54 @@ +signature ARRAY_SLICE_GLOBAL = + sig + end + +signature ARRAY_SLICE = + sig + include ARRAY_SLICE_GLOBAL + + type 'a slice + + val all: ('a -> bool) -> 'a slice -> bool + val app : ('a -> unit) -> 'a slice -> unit + val appi: (int * 'a -> unit) -> 'a slice -> unit + val base: 'a slice -> 'a Array.array * int * int + val collate: ('a * 'a -> order) -> 'a slice * 'a slice -> order + val copy: {dst: 'a Array.array, di: int, src: 'a slice} -> unit + val copyVec: {dst: 'a Array.array, di: int, src: 'a VectorSlice.slice} -> unit + val exists: ('a -> bool) -> 'a slice -> bool + val find: ('a -> bool) -> 'a slice -> 'a option + val findi: (int * 'a -> bool) -> 'a slice -> (int * 'a) option + val foldl: ('a * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldli: (int * 'a * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldr: ('a * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldri: (int * 'a * 'b -> 'b) -> 'b -> 'a slice -> 'b + val full: 'a Array.array -> 'a slice + val getItem: 'a slice -> ('a * 'a slice) option + val isEmpty: 'a slice -> bool + val length: 'a slice -> int + val modify : ('a -> 'a) -> 'a slice -> unit + val modifyi: (int * 'a -> 'a) -> 'a slice -> unit + val slice: 'a Array.array * int * int option -> 'a slice + val sub: 'a slice * int -> 'a + val subslice: 'a slice * int * int option -> 'a slice + val update: 'a slice * int * 'a -> unit + val vector: 'a slice -> 'a Vector.vector + end + +signature ARRAY_SLICE_EXTRA = + sig + include ARRAY_SLICE + + val uninitIsNop: 'a slice -> bool + val uninit: 'a slice * int -> unit + val unsafeSub: 'a slice * int -> 'a + val unsafeCopy: {dst: 'a Array.array, di: int, src: 'a slice} -> unit + val unsafeCopyVec: {dst: 'a Array.array, di: int, src: 'a VectorSlice.slice} -> unit + val unsafeSlice: 'a array * int * int option -> 'a slice + val unsafeSubslice: 'a slice * int * int option -> 'a slice + val unsafeUninit: 'a slice * int -> unit + val unsafeUpdate: 'a slice * int * 'a -> unit + + val concat: 'a slice list -> 'a array + val toList: 'a slice -> 'a list + end diff --git a/basis-library/arrays-and-vectors/array.sig b/basis-library/arrays-and-vectors/array.sig new file mode 100644 index 0000000..a0ea123 --- /dev/null +++ b/basis-library/arrays-and-vectors/array.sig @@ -0,0 +1,71 @@ +signature ARRAY_GLOBAL = + sig + type 'a array = 'a Array.array + end + +signature ARRAY = + sig + include ARRAY_GLOBAL + + type 'a vector = 'a Vector.vector + + val all: ('a -> bool) -> 'a array -> bool + val app: ('a -> unit) -> 'a array -> unit + val appi: (int * 'a -> unit) -> 'a array -> unit + val array: int * 'a -> 'a array + val collate: ('a * 'a -> order) -> 'a array * 'a array -> order + val copy: {src: 'a array, dst: 'a array, di: int} -> unit + val copyVec: {src: 'a vector, dst: 'a array, di: int} -> unit + val exists: ('a -> bool) -> 'a array -> bool + val find: ('a -> bool) -> 'a array -> 'a option + val findi: (int * 'a -> bool) -> 'a array -> (int * 'a) option + val foldl: ('a * 'b -> 'b) -> 'b -> 'a array -> 'b + val foldli: (int * 'a * 'b -> 'b) -> 'b -> 'a array -> 'b + val foldr: ('a * 'b -> 'b) -> 'b -> 'a array -> 'b + val foldri: (int * 'a * 'b -> 'b) -> 'b -> 'a array -> 'b + val fromList: 'a list -> 'a array + val length: 'a array -> int + val maxLen: int + val modify: ('a -> 'a) -> 'a array -> unit + val modifyi: (int * 'a -> 'a) -> 'a array -> unit + val sub: 'a array * int -> 'a + val tabulate: int * (int -> 'a) -> 'a array + val update: 'a array * int * 'a -> unit + val vector: 'a array -> 'a vector + end + +signature ARRAY_EXTRA = + sig + include ARRAY + + structure ArraySlice: ARRAY_SLICE_EXTRA + + val alloc: int -> 'a array + val uninitIsNop: 'a array -> bool + val uninit: 'a array * int -> unit + val unsafeAlloc: int -> 'a array + val unsafeArray: int * 'a -> 'a array + val unsafeCopy: {dst: 'a array, di: int, src: 'a array} -> unit + val unsafeCopyVec: {dst: 'a array, di: int, src: 'a vector} -> unit + val unsafeSub: 'a array * int -> 'a + val unsafeUninit: 'a array * int -> unit + val unsafeUpdate: 'a array * int * 'a -> unit + + val concat: 'a array list -> 'a array + val duplicate: 'a array -> 'a array + val toList: 'a array -> 'a list + val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b + val unfold: int * 'b * ('b -> 'a * 'b) -> 'a array * 'b + + structure Raw: + sig + type 'a rawarr + val alloc: int -> 'a rawarr + val length: 'a rawarr -> int + val uninit: 'a rawarr * int -> unit + val uninitIsNop: 'a rawarr -> bool + val unsafeAlloc: int -> 'a rawarr + val unsafeToArray: 'a rawarr -> 'a array + val unsafeUninit: 'a rawarr * int -> unit + end + end diff --git a/basis-library/arrays-and-vectors/array.sml b/basis-library/arrays-and-vectors/array.sml new file mode 100644 index 0000000..7de72a3 --- /dev/null +++ b/basis-library/arrays-and-vectors/array.sml @@ -0,0 +1,77 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Array: ARRAY_EXTRA = + struct + structure A = Sequence (Primitive.Array) + open A + + val op +? = Int.+? + val op < = Int.< + val op <= = Int.<= + + fun wrap2 f = fn (i, x) => f (SeqIndex.toIntUnsafe i, x) + + type 'a array = 'a array + type 'a vector = 'a Vector.vector + + structure ArraySlice = + struct + open Slice + val vector = Primitive.Array.Slice.vector + val copyVec = Vector.VectorSlice.copy + val unsafeCopyVec = Vector.VectorSlice.unsafeCopy + fun modifyi f sl = Primitive.Array.Slice.modifyi (wrap2 f) sl + val modify = Primitive.Array.Slice.modify + end + + val array = new + val unsafeArray = unsafeNew + val vector = Primitive.Array.vector + val copyVec = Vector.copy + val unsafeCopyVec = Vector.unsafeCopy + fun modifyi f sl = Primitive.Array.modifyi (wrap2 f) sl + val modify = Primitive.Array.modify + + structure Raw = Primitive.Array.Raw + structure Raw = + struct + type 'a rawarr = 'a Raw.rawarr + + fun length a = + if Primitive.Controls.safe + then (SeqIndex.toInt (Raw.length a)) + handle Overflow => raise Fail "Raw.length" + else SeqIndex.toIntUnsafe (Raw.length a) + + fun alloc n = Raw.alloc (SeqIndex.fromIntForLength n) + fun unsafeAlloc n = Raw.unsafeAlloc (SeqIndex.fromIntUnsafe n) + + val uninitIsNop = Raw.uninitIsNop + fun unsafeUninit (a, i) = + Raw.unsafeUninit (a, SeqIndex.fromIntUnsafe i) + fun uninit (a, i) = + if Primitive.Controls.safe + then let + val i = + (SeqIndex.fromInt i) + handle Overflow => raise Subscript + in + Raw.uninit (a, i) + end + else unsafeUninit (a, i) + + val unsafeToArray = Primitive.Array.Raw.unsafeToArray + end + end + +structure ArraySlice: ARRAY_SLICE_EXTRA = Array.ArraySlice + +structure ArrayGlobal: ARRAY_GLOBAL = Array +open ArrayGlobal diff --git a/basis-library/arrays-and-vectors/array2.sig b/basis-library/arrays-and-vectors/array2.sig new file mode 100644 index 0000000..0faf5a3 --- /dev/null +++ b/basis-library/arrays-and-vectors/array2.sig @@ -0,0 +1,33 @@ +signature ARRAY2 = + sig + eqtype 'a array + + type 'a region = {base: 'a array, + row: int, + col: int, + nrows: int option, + ncols: int option} + + datatype traversal = RowMajor | ColMajor + + val array: int * int * 'a -> 'a array + val fromList: 'a list list -> 'a array + val tabulate: traversal -> (int * int * (int * int -> 'a)) -> 'a array + val sub: 'a array * int * int -> 'a + val update: 'a array * int * int * 'a -> unit + val dimensions: 'a array -> int * int + val nRows: 'a array -> int + val nCols: 'a array -> int + val row: 'a array * int -> 'a vector + val column: 'a array * int -> 'a vector + val copy: {src: 'a region, + dst: 'a array, + dst_row: int, + dst_col: int} -> unit + val appi: traversal -> (int * int * 'a -> unit) -> 'a region -> unit + val app: traversal -> ('a -> unit) -> 'a array -> unit + val foldi: traversal -> (int * int * 'a * 'b -> 'b) -> 'b -> 'a region -> 'b + val fold: traversal -> ('a * 'b -> 'b) -> 'b -> 'a array -> 'b + val modifyi: traversal -> (int * int * 'a -> 'a) -> 'a region -> unit + val modify: traversal -> ('a -> 'a) -> 'a array -> unit + end diff --git a/basis-library/arrays-and-vectors/array2.sml b/basis-library/arrays-and-vectors/array2.sml new file mode 100644 index 0000000..21df180 --- /dev/null +++ b/basis-library/arrays-and-vectors/array2.sml @@ -0,0 +1,342 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Array2 : ARRAY2 = + struct + + val op +? = SeqIndex.+? + val op + = SeqIndex.+ + val op -? = SeqIndex.-? + val op - = SeqIndex.- + val op *? = SeqIndex.*? + val op * = SeqIndex.* + val op < = SeqIndex.< + val op <= = SeqIndex.<= + val op > = SeqIndex.> + val op >= = SeqIndex.>= + val ltu = SeqIndex.ltu + val leu = SeqIndex.leu + val gtu = SeqIndex.gtu + val geu = SeqIndex.geu + + type 'a array = {array: 'a Array.array, + rows: SeqIndex.int, + cols: SeqIndex.int} + + fun dimensions' ({rows, cols, ...}: 'a array) = (rows, cols) + fun dimensions ({rows, cols, ...}: 'a array) = + (SeqIndex.toIntUnsafe rows, SeqIndex.toIntUnsafe cols) + fun nRows' ({rows, ...}: 'a array) = rows + fun nRows ({rows, ...}: 'a array) = SeqIndex.toIntUnsafe rows + fun nCols' ({cols, ...}: 'a array) = cols + fun nCols ({cols, ...}: 'a array) = SeqIndex.toIntUnsafe cols + + type 'a region = {base: 'a array, + row: int, + col: int, + nrows: int option, + ncols: int option} + + local + fun checkSliceMax' (start: int, + num: SeqIndex.int option, + max: SeqIndex.int): SeqIndex.int * SeqIndex.int = + case num of + NONE => if Primitive.Controls.safe + then let + val start = + (SeqIndex.fromInt start) + handle Overflow => raise Subscript + in + if gtu (start, max) + then raise Subscript + else (start, max) + end + else (SeqIndex.fromIntUnsafe start, max) + | SOME num => if Primitive.Controls.safe + then let + val start = + (SeqIndex.fromInt start) + handle Overflow => raise Subscript + in + if (start < 0 orelse num < 0 + orelse start +? num > max) + then raise Subscript + else (start, start +? num) + end + else (SeqIndex.fromIntUnsafe start, + SeqIndex.fromIntUnsafe start +? num) + fun checkSliceMax (start: int, + num: int option, + max: SeqIndex.int): SeqIndex.int * SeqIndex.int = + if Primitive.Controls.safe + then (checkSliceMax' (start, Option.map SeqIndex.fromInt num, max)) + handle Overflow => raise Subscript + else checkSliceMax' (start, Option.map SeqIndex.fromIntUnsafe num, max) + in + fun checkRegion' {base, row, col, nrows, ncols} = + let + val (rows, cols) = dimensions' base + val (startRow, stopRow) = checkSliceMax' (row, nrows, rows) + val (startCol, stopCol) = checkSliceMax' (col, ncols, cols) + in + {startRow = startRow, stopRow = stopRow, + startCol = startCol, stopCol = stopCol} + end + fun checkRegion {base, row, col, nrows, ncols} = + let + val (rows, cols) = dimensions' base + val (startRow, stopRow) = checkSliceMax (row, nrows, rows) + val (startCol, stopCol) = checkSliceMax (col, ncols, cols) + in + {startRow = startRow, stopRow = stopRow, + startCol = startCol, stopCol = stopCol} + end + end + + fun wholeRegion (a : 'a array): 'a region = + {base = a, row = 0, col = 0, nrows = NONE, ncols = NONE} + + datatype traversal = RowMajor | ColMajor + + local + fun make (rows, cols, doit) = + if Primitive.Controls.safe + andalso (rows < 0 orelse cols < 0) + then raise Size + else {array = doit (rows * cols handle Overflow => raise Size), + rows = rows, + cols = cols} + in + fun alloc' (rows, cols) = + make (rows, cols, Primitive.Array.alloc) + fun array' (rows, cols, init) = + make (rows, cols, fn size => Primitive.Array.new (size, init)) + end + local + fun make (rows, cols, doit) = + if Primitive.Controls.safe + then let + val rows = + (SeqIndex.fromInt rows) + handle Overflow => raise Size + val cols = + (SeqIndex.fromInt cols) + handle Overflow => raise Size + in + doit (rows, cols) + end + else doit (SeqIndex.fromIntUnsafe rows, + SeqIndex.fromIntUnsafe cols) + in + fun alloc (rows, cols) = + make (rows, cols, fn (rows, cols) => alloc' (rows, cols)) + fun array (rows, cols, init) = + make (rows, cols, fn (rows, cols) => array' (rows, cols, init)) + end + + fun array0 (): 'a array = + {array = Primitive.Array.alloc 0, + rows = 0, + cols = 0} + + fun unsafeSpot' ({cols, ...}: 'a array, r, c) = + r *? cols +? c + fun spot' (a as {rows, cols, ...}: 'a array, r, c) = + if Primitive.Controls.safe + andalso (geu (r, rows) orelse geu (c, cols)) + then raise Subscript + else unsafeSpot' (a, r, c) + + fun unsafeSub' (a as {array, ...}: 'a array, r, c) = + Primitive.Array.unsafeSub (array, unsafeSpot' (a, r, c)) + fun sub' (a as {array, ...}: 'a array, r, c) = + Primitive.Array.unsafeSub (array, spot' (a, r, c)) + fun unsafeUpdate' (a as {array, ...}: 'a array, r, c, x) = + Primitive.Array.unsafeUpdate (array, unsafeSpot' (a, r, c), x) + fun update' (a as {array, ...}: 'a array, r, c, x) = + Primitive.Array.unsafeUpdate (array, spot' (a, r, c), x) + + local + fun make (r, c, doit) = + if Primitive.Controls.safe + then let + val r = + (SeqIndex.fromInt r) + handle Overflow => raise Subscript + val c = + (SeqIndex.fromInt c) + handle Overflow => raise Subscript + in + doit (r, c) + end + else doit (SeqIndex.fromIntUnsafe r, + SeqIndex.fromIntUnsafe c) + in + fun sub (a, r, c) = + make (r, c, fn (r, c) => sub' (a, r, c)) + fun update (a, r, c, x) = + make (r, c, fn (r, c) => update' (a, r, c, x)) + end + + fun 'a fromList (rows: 'a list list): 'a array = + case rows of + [] => array0 () + | row1 :: _ => + let + val cols = length row1 + val a as {array, cols = cols', ...} = + alloc (length rows, cols) + val _ = + List.foldl + (fn (row: 'a list, i) => + let + val max = i +? cols' + val i' = + List.foldl (fn (x: 'a, i) => + (if i >= max + then raise Size + else (Primitive.Array.unsafeUpdate (array, i, x) + ; i +? 1))) + i row + in if i' = max + then i' + else raise Size + end) + 0 rows + in + a + end + + fun row' ({array, rows, cols}, r) = + if Primitive.Controls.safe andalso geu (r, rows) + then raise Subscript + else + ArraySlice.vector (Primitive.Array.Slice.slice (array, r *? cols, SOME cols)) + fun row (a, r) = + if Primitive.Controls.safe + then let + val r = + (SeqIndex.fromInt r) + handle Overflow => raise Subscript + in + row' (a, r) + end + else row' (a, SeqIndex.fromIntUnsafe r) + fun column' (a as {rows, cols, ...}: 'a array, c) = + if Primitive.Controls.safe andalso geu (c, cols) + then raise Subscript + else + Primitive.Vector.tabulate (rows, fn r => unsafeSub' (a, r, c)) + fun column (a, c) = + if Primitive.Controls.safe + then let + val c = + (SeqIndex.fromInt c) + handle Overflow => raise Subscript + in + column' (a, c) + end + else column' (a, SeqIndex.fromIntUnsafe c) + + fun foldi' trv f b (region as {base, ...}) = + let + val {startRow, stopRow, startCol, stopCol} = checkRegion region + in + case trv of + RowMajor => + let + fun loopRow (r, b) = + if r >= stopRow then b + else let + fun loopCol (c, b) = + if c >= stopCol then b + else loopCol (c +? 1, f (r, c, sub' (base, r, c), b)) + in + loopRow (r +? 1, loopCol (startCol, b)) + end + in + loopRow (startRow, b) + end + | ColMajor => + let + fun loopCol (c, b) = + if c >= stopCol then b + else let + fun loopRow (r, b) = + if r >= stopRow then b + else loopRow (r +? 1, f (r, c, sub' (base, r, c), b)) + in + loopCol (c +? 1, loopRow (startRow, b)) + end + in + loopCol (startCol, b) + end + end + + fun foldi trv f b a = + foldi' trv (fn (r, c, x, b) => + f (SeqIndex.toIntUnsafe r, + SeqIndex.toIntUnsafe c, + x, b)) b a + fun fold trv f b a = + foldi trv (fn (_, _, x, b) => f (x, b)) b (wholeRegion a) + + fun appi trv f = + foldi trv (fn (r, c, x, ()) => f (r, c, x)) () + + fun app trv f = fold trv (f o #1) () + + fun modifyi trv f (r as {base, ...}) = + appi trv (fn (r, c, x) => update (base, r, c, f (r, c, x))) r + + fun modify trv f a = modifyi trv (f o #3) (wholeRegion a) + + fun tabulate trv (rows, cols, f) = + let + val a = alloc (rows, cols) + val () = modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a) + in + a + end + + fun copy {src = src as {base, ...}: 'a region, + dst, dst_row, dst_col} = + let + val {startRow, stopRow, startCol, stopCol} = checkRegion src + val nrows = stopRow -? startRow + val ncols = stopCol -? startCol + val {startRow = dst_row, startCol = dst_col, ...} = + checkRegion' {base = dst, row = dst_row, col = dst_col, + nrows = SOME nrows, + ncols = SOME ncols} + fun forUp (start, stop, f: SeqIndex.int -> unit) = + let + fun loop i = + if i >= stop + then () + else (f i; loop (i + 1)) + in loop start + end + fun forDown (start, stop, f: SeqIndex.int -> unit) = + let + fun loop i = + if i < start + then () + else (f i; loop (i - 1)) + in loop (stop -? 1) + end + val forRows = if startRow <= dst_row then forDown else forUp + val forCols = if startCol <= dst_col then forUp else forDown + in forRows (0, nrows, fn r => + forCols (0, ncols, fn c => + unsafeUpdate' (dst, dst_row +? r, dst_col +? c, + unsafeSub' (base, startRow +? r, startCol +? c)))) + end + end diff --git a/basis-library/arrays-and-vectors/mono-array-slice.sig b/basis-library/arrays-and-vectors/mono-array-slice.sig new file mode 100644 index 0000000..af17dd5 --- /dev/null +++ b/basis-library/arrays-and-vectors/mono-array-slice.sig @@ -0,0 +1,50 @@ +signature MONO_ARRAY_SLICE = + sig + type array + type elem + type slice + type vector + type vector_slice + + val length: slice -> int + val sub: slice * int -> elem + val update: slice * int * elem -> unit + val full: array -> slice + val slice: array * int * int option -> slice + val subslice: slice * int * int option -> slice + val base: slice -> array * int * int + val vector: slice -> vector + val copy: {src: slice, dst: array, di: int} -> unit + val copyVec: {src: vector_slice, dst: array, di: int} -> unit + val isEmpty: slice -> bool + val getItem: slice -> (elem * slice) option + val appi: (int * elem -> unit) -> slice -> unit + val app: (elem -> unit) -> slice -> unit + val modifyi: (int * elem -> elem) -> slice -> unit + val modify: (elem -> elem) -> slice -> unit + val foldli: (int * elem * 'b -> 'b) -> 'b -> slice -> 'b + val foldr: (elem * 'b -> 'b) -> 'b -> slice -> 'b + val foldl: (elem * 'b -> 'b) -> 'b -> slice -> 'b + val foldri: (int * elem * 'b -> 'b) -> 'b -> slice -> 'b + val findi: (int * elem -> bool) -> slice -> (int * elem) option + val find: (elem -> bool) -> slice -> elem option + val exists: (elem -> bool) -> slice -> bool + val all: (elem -> bool) -> slice -> bool + val collate: (elem * elem -> order) -> slice * slice -> order + end + +signature MONO_ARRAY_SLICE_EXTRA = + sig + include MONO_ARRAY_SLICE + + val concat: slice list -> array + val toList: slice -> elem list + val toPoly: slice -> elem ArraySlice.slice + val uninitIsNop: slice -> bool + val uninit: slice * int -> unit + val unsafeSlice: array * int * int option -> slice + val unsafeSub: slice * int -> elem + val unsafeSubslice: slice * int * int option -> slice + val unsafeUninit: slice * int -> unit + val unsafeUpdate: slice * int * elem -> unit + end diff --git a/basis-library/arrays-and-vectors/mono-array.fun b/basis-library/arrays-and-vectors/mono-array.fun new file mode 100644 index 0000000..f77954b --- /dev/null +++ b/basis-library/arrays-and-vectors/mono-array.fun @@ -0,0 +1,42 @@ +(* Copyright (C) 2015 Matthew Fluet. + * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor MonoArray (type elem + structure MV: MONO_VECTOR_EXTRA + where type elem = elem + and type vector = elem Vector.vector + and type MonoVectorSlice.slice = elem VectorSlice.slice + ): MONO_ARRAY_EXTRA + where type elem = elem + and type vector = MV.vector + and type vector_slice = MV.MonoVectorSlice.slice = + struct + open Array + + type elem = MV.elem + type array = elem array + type vector = MV.vector + type vector_slice = MV.MonoVectorSlice.slice + + val fromPoly = fn a => a + val toPoly = fn a => a + + structure MonoArraySlice = + struct + open ArraySlice + + type elem = elem + type array = array + type slice = elem slice + type vector = vector + type vector_slice = vector_slice + + val toPoly = fn s => s + end + end diff --git a/basis-library/arrays-and-vectors/mono-array.sig b/basis-library/arrays-and-vectors/mono-array.sig new file mode 100644 index 0000000..75906ca --- /dev/null +++ b/basis-library/arrays-and-vectors/mono-array.sig @@ -0,0 +1,57 @@ +signature MONO_ARRAY = + sig + eqtype array + type elem + type vector + + val all: (elem -> bool) -> array -> bool + val app: (elem -> unit) -> array -> unit + val appi: (int * elem -> unit) -> array -> unit + val array: int * elem -> array + val collate: (elem * elem -> order) -> array * array -> order + val copy: {src: array, dst: array, di: int} -> unit + val copyVec: {src: vector, dst: array, di: int} -> unit + val exists: (elem -> bool) -> array -> bool + val find: (elem -> bool) -> array -> elem option + val findi: (int * elem -> bool) -> array -> (int * elem) option + val foldl: (elem * 'b -> 'b) -> 'b -> array -> 'b + val foldli: (int * elem * 'b -> 'b) -> 'b -> array -> 'b + val foldr: (elem * 'b -> 'b) -> 'b -> array -> 'b + val foldri: (int * elem * 'b -> 'b) -> 'b -> array -> 'b + val fromList: elem list -> array + val length: array -> int + val maxLen: int + val modify: (elem -> elem) -> array -> unit + val modifyi: (int * elem -> elem) -> array -> unit + val sub: array * int -> elem + val tabulate: int * (int -> elem) -> array + val update: array * int * elem -> unit + val vector: array -> vector + end + +signature MONO_ARRAY_EXTRA = + sig + include MONO_ARRAY + type vector_slice + structure MonoArraySlice: MONO_ARRAY_SLICE_EXTRA + where type elem = elem + and type array = array + and type vector = vector + and type vector_slice = vector_slice + + val alloc: int -> array + val uninitIsNop: array -> bool + val uninit: array * int -> unit + + val concat: array list -> array + val duplicate: array -> array + val fromPoly: elem Array.array -> array + val toList: array -> elem list + val toPoly: array -> elem Array.array + val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array * 'a + + val unsafeAlloc: int -> array + val unsafeSub: array * int -> elem + val unsafeUninit: array * int -> unit + val unsafeUpdate: array * int * elem -> unit + end diff --git a/basis-library/arrays-and-vectors/mono-array2.fun b/basis-library/arrays-and-vectors/mono-array2.fun new file mode 100644 index 0000000..a53b57b --- /dev/null +++ b/basis-library/arrays-and-vectors/mono-array2.fun @@ -0,0 +1,24 @@ +(* Copyright (C) 2015 Matthew Fluet. + * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor MonoArray2 (type elem + structure MV: MONO_VECTOR + where type elem = elem + and type vector = elem Vector.vector): MONO_ARRAY2 = + struct + type elem = MV.elem + type vector = MV.vector + open Array2 + type array = elem array + type region = {base: array, + row: int, + col: int, + nrows: int option, + ncols: int option} + end diff --git a/basis-library/arrays-and-vectors/mono-array2.sig b/basis-library/arrays-and-vectors/mono-array2.sig new file mode 100644 index 0000000..6cb7db1 --- /dev/null +++ b/basis-library/arrays-and-vectors/mono-array2.sig @@ -0,0 +1,33 @@ +signature MONO_ARRAY2 = + sig + eqtype array + + type elem + type vector + + type region = {base: array, + row: int, + col: int, + nrows: int option, + ncols: int option} + + datatype traversal = datatype Array2.traversal + + val app: traversal -> (elem -> unit) -> array -> unit + val appi: traversal -> (int * int * elem -> unit) -> region -> unit + val array: int * int * elem -> array + val column: array * int -> vector + val copy: {src: region, dst: array, dst_row: int, dst_col: int} -> unit + val dimensions: array -> int * int + val fold: traversal -> (elem * 'b -> 'b) -> 'b -> array -> 'b + val foldi: traversal -> (int * int * elem * 'b -> 'b) -> 'b -> region -> 'b + val fromList: elem list list -> array + val modify: traversal -> (elem -> elem) -> array -> unit + val modifyi: traversal -> (int * int * elem -> elem) -> region -> unit + val nCols: array -> int + val nRows: array -> int + val row: array * int -> vector + val sub: array * int * int -> elem + val tabulate: traversal -> int * int * (int * int -> elem) -> array + val update: array * int * int * elem -> unit + end diff --git a/basis-library/arrays-and-vectors/mono-vector-slice.sig b/basis-library/arrays-and-vectors/mono-vector-slice.sig new file mode 100644 index 0000000..e73dc8d --- /dev/null +++ b/basis-library/arrays-and-vectors/mono-vector-slice.sig @@ -0,0 +1,66 @@ +signature MONO_VECTOR_SLICE = + sig + type elem + type slice + type vector + + val all: (elem -> bool) -> slice -> bool + val app: (elem -> unit) -> slice -> unit + val appi: (int * elem -> unit) -> slice -> unit + val base: slice -> vector * int * int + val collate: (elem * elem -> order) -> slice * slice -> order + val concat: slice list -> vector + val exists: (elem -> bool) -> slice -> bool + val find : (elem -> bool) -> slice -> elem option + val findi: (int * elem -> bool) -> slice -> (int * elem) option + val foldl: (elem * 'b -> 'b) -> 'b -> slice -> 'b + val foldli: (int * elem * 'b -> 'b) -> 'b -> slice -> 'b + val foldr: (elem * 'b -> 'b) -> 'b -> slice -> 'b + val foldri: (int * elem * 'b -> 'b) -> 'b -> slice -> 'b + val full: vector -> slice + val getItem: slice -> (elem * slice) option + val isEmpty: slice -> bool + val length: slice -> int + val map: (elem -> elem) -> slice -> vector + val mapi: (int * elem -> elem) -> slice -> vector + val slice: vector * int * int option -> slice + val sub: slice * int -> elem + val subslice: slice * int * int option -> slice + val vector: slice -> vector + end + +signature MONO_VECTOR_SLICE_EXTRA = + sig + include MONO_VECTOR_SLICE + + val concatWith: vector -> slice list -> vector + val dropl: (elem -> bool) -> slice -> slice + val dropr: (elem -> bool) -> slice -> slice + val fields: (elem -> bool) -> slice -> slice list + val fromPoly: elem VectorSlice.slice -> slice + val isPrefix: (elem * elem -> bool) -> vector -> slice -> bool + val isSubvector: (elem * elem -> bool) -> vector -> slice -> bool + val isSuffix: (elem * elem -> bool) -> vector -> slice -> bool + val position: (elem * elem -> bool) -> vector -> slice -> slice * slice + val splitAt: slice * int -> slice * slice + val splitl: (elem -> bool) -> slice -> slice * slice + val splitr: (elem -> bool) -> slice -> slice * slice + val takel: (elem -> bool) -> slice -> slice + val taker: (elem -> bool) -> slice -> slice + val toList: slice -> elem list + val toPoly: slice -> elem VectorSlice.slice + val tokens: (elem -> bool) -> slice -> slice list + val translate: (elem -> vector) -> slice -> vector + val triml: int -> slice -> slice + val trimr: int -> slice -> slice + val unsafeSlice: vector * int * int option -> slice + val unsafeSub: slice * int -> elem + val unsafeSubslice: slice * int * int option -> slice + end + +signature EQTYPE_MONO_VECTOR_SLICE_EXTRA = + sig + include MONO_VECTOR_SLICE_EXTRA + + val span: slice * slice -> slice + end diff --git a/basis-library/arrays-and-vectors/mono-vector.fun b/basis-library/arrays-and-vectors/mono-vector.fun new file mode 100644 index 0000000..68a0832 --- /dev/null +++ b/basis-library/arrays-and-vectors/mono-vector.fun @@ -0,0 +1,49 @@ +(* Copyright (C) 2015 Matthew Fluet. + * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor MonoVector (type elem): MONO_VECTOR_EXTRA + where type elem = elem = + struct + open Vector + type array = elem array + type elem = elem + type vector = elem vector + val fromPoly = fn v => v + val toPoly = fn v => v + structure MonoVectorSlice = + struct + open VectorSlice + type elem = elem + type vector = vector + type slice = elem slice + val fromPoly = fn s => s + val toPoly = fn s => s + end + end + +functor EqtypeMonoVector (eqtype elem): EQTYPE_MONO_VECTOR_EXTRA + where type elem = elem = + struct + open Vector + type array = elem array + type elem = elem + type vector = elem vector + type vector_eqtype = vector + val fromPoly = fn v => v + val toPoly = fn v => v + structure MonoVectorSlice = + struct + open VectorSlice + type elem = elem + type vector = vector + type slice = elem slice + val fromPoly = fn s => s + val toPoly = fn s => s + end + end diff --git a/basis-library/arrays-and-vectors/mono-vector.sig b/basis-library/arrays-and-vectors/mono-vector.sig new file mode 100644 index 0000000..54731dd --- /dev/null +++ b/basis-library/arrays-and-vectors/mono-vector.sig @@ -0,0 +1,70 @@ +signature MONO_VECTOR = + sig + type vector + type elem + + val all: (elem -> bool) -> vector -> bool + val app: (elem -> unit) -> vector -> unit + val appi: (int * elem -> unit) -> vector -> unit + val collate: (elem * elem -> order) -> vector * vector -> order + val concat: vector list -> vector + val exists: (elem -> bool) -> vector -> bool + val find: (elem -> bool) -> vector -> elem option + val findi: (int * elem -> bool) -> vector -> (int * elem) option + val foldl: (elem * 'a -> 'a) -> 'a -> vector -> 'a + val foldli: (int * elem * 'a -> 'a) -> 'a -> vector -> 'a + val foldr: (elem * 'a -> 'a) -> 'a -> vector -> 'a + val foldri: (int * elem * 'a -> 'a) -> 'a -> vector -> 'a + val fromList: elem list -> vector + val length: vector -> int + val map: (elem -> elem) -> vector -> vector + val mapi: (int * elem -> elem) -> vector -> vector + val maxLen: int + val sub: vector * int -> elem + val tabulate: int * (int -> elem) -> vector + val update: vector * int * elem -> vector + end + +signature MONO_VECTOR_EXTRA_COMMON = + sig + include MONO_VECTOR + + type array + + val append: vector * vector -> vector + val concatWith: vector -> vector list -> vector + val duplicate: vector -> vector + val fields: (elem -> bool) -> vector -> vector list + val fromPoly: elem Vector.vector -> vector + val isPrefix: (elem * elem -> bool) -> vector -> vector -> bool + val isSubvector: (elem * elem -> bool) -> vector -> vector -> bool + val isSuffix: (elem * elem -> bool) -> vector -> vector -> bool + val toList: vector -> elem list + val toPoly: vector -> elem Vector.vector + val tokens: (elem -> bool) -> vector -> vector list + val translate: (elem -> vector) -> vector -> vector + val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector * 'a + val unsafeFromArray: array -> vector + val unsafeSub: vector * int -> elem + val vector: int * elem -> vector + end + +signature MONO_VECTOR_EXTRA = + sig + include MONO_VECTOR_EXTRA_COMMON + + structure MonoVectorSlice: MONO_VECTOR_SLICE_EXTRA + where type elem = elem + and type vector = vector + end + +signature EQTYPE_MONO_VECTOR_EXTRA = + sig + eqtype vector_eqtype + include MONO_VECTOR_EXTRA_COMMON + sharing type vector_eqtype = vector + + structure MonoVectorSlice: EQTYPE_MONO_VECTOR_SLICE_EXTRA + where type elem = elem + and type vector = vector + end diff --git a/basis-library/arrays-and-vectors/mono.sml b/basis-library/arrays-and-vectors/mono.sml new file mode 100644 index 0000000..da3244b --- /dev/null +++ b/basis-library/arrays-and-vectors/mono.sml @@ -0,0 +1,266 @@ +(* Copyright (C) 2015 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature EQTYPE_MONO = + sig + type elem + structure MonoArray: MONO_ARRAY_EXTRA + structure MonoArray2: MONO_ARRAY2 + structure MonoVector: EQTYPE_MONO_VECTOR_EXTRA + sharing type MonoArray.array = MonoVector.array + sharing type elem = MonoArray.elem = MonoArray2.elem = MonoVector.elem + sharing type MonoArray.vector = MonoArray2.vector = MonoVector.vector + sharing type MonoArray.MonoArraySlice.vector_slice = MonoVector.MonoVectorSlice.slice + end + +signature MONO = + sig + type elem + structure MonoArray: MONO_ARRAY_EXTRA + structure MonoArray2: MONO_ARRAY2 + structure MonoVector: MONO_VECTOR_EXTRA + sharing type MonoArray.array = MonoVector.array + sharing type elem = MonoArray.elem = MonoArray2.elem = MonoVector.elem + sharing type MonoArray.vector = MonoArray2.vector = MonoVector.vector + sharing type MonoArray.MonoArraySlice.vector_slice = MonoVector.MonoVectorSlice.slice + end + +functor EqtypeMonoX (eqtype elem) = + struct + type elem = elem + structure MonoVector = EqtypeMonoVector (type elem = elem) + structure MonoArray = MonoArray (type elem = elem + structure MV = MonoVector) + structure MonoArray2 = MonoArray2 (type elem = elem + structure MV = MonoVector) + end + +functor EqtypeMono (eqtype elem) :> EQTYPE_MONO where type elem = elem = + struct + type elem = elem + structure MonoVector = EqtypeMonoVector (type elem = elem) + structure MonoArray = MonoArray (type elem = elem + structure MV = MonoVector) + structure MonoArray2 = MonoArray2 (type elem = elem + structure MV = MonoVector) + end + +functor Mono (type elem) :> MONO where type elem = elem = + struct + type elem = elem + structure MonoVector = MonoVector (type elem = elem) + structure MonoArray = MonoArray (type elem = elem + structure MV = MonoVector) + structure MonoArray2 = MonoArray2 (type elem = elem + structure MV = MonoVector) + end + +local + structure S = EqtypeMono (type elem = Primitive.Bool.bool) + open S +in + structure BoolVector = MonoVector + structure BoolVectorSlice = MonoVector.MonoVectorSlice + structure BoolArray = MonoArray + structure BoolArraySlice = MonoArray.MonoArraySlice + structure BoolArray2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Primitive.Int8.int) + open S +in + structure Int8Vector = MonoVector + structure Int8VectorSlice = MonoVector.MonoVectorSlice + structure Int8Array = MonoArray + structure Int8ArraySlice = MonoArray.MonoArraySlice + structure Int8Array2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Primitive.Int16.int) + open S +in + structure Int16Vector = MonoVector + structure Int16VectorSlice = MonoVector.MonoVectorSlice + structure Int16Array = MonoArray + structure Int16ArraySlice = MonoArray.MonoArraySlice + structure Int16Array2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Primitive.Int32.int) + open S +in + structure Int32Vector = MonoVector + structure Int32VectorSlice = MonoVector.MonoVectorSlice + structure Int32Array = MonoArray + structure Int32ArraySlice = MonoArray.MonoArraySlice + structure Int32Array2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Primitive.Int64.int) + open S +in + structure Int64Vector = MonoVector + structure Int64VectorSlice = MonoVector.MonoVectorSlice + structure Int64Array = MonoArray + structure Int64ArraySlice = MonoArray.MonoArraySlice + structure Int64Array2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Primitive.IntInf.int) + open S +in + structure IntInfVector = MonoVector + structure IntInfVectorSlice = MonoVector.MonoVectorSlice + structure IntInfArray = MonoArray + structure IntInfArraySlice = MonoArray.MonoArraySlice + structure IntInfArray2 = MonoArray2 +end +local + structure S = Mono (type elem = Primitive.Real32.real) + open S +in + structure Real32Vector = MonoVector + structure Real32VectorSlice = MonoVector.MonoVectorSlice + structure Real32Array = MonoArray + structure Real32ArraySlice = MonoArray.MonoArraySlice + structure Real32Array2 = MonoArray2 +end +local + structure S = Mono (type elem = Primitive.Real64.real) + open S +in + structure Real64Vector = MonoVector + structure Real64VectorSlice = MonoVector.MonoVectorSlice + structure Real64Array = MonoArray + structure Real64ArraySlice = MonoArray.MonoArraySlice + structure Real64Array2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Primitive.Word8.word) + open S +in + structure Word8Vector = MonoVector + structure Word8VectorSlice = MonoVector.MonoVectorSlice + structure Word8Array = MonoArray + structure Word8ArraySlice = MonoArray.MonoArraySlice + structure Word8Array2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Primitive.Word16.word) + open S +in + structure Word16Vector = MonoVector + structure Word16VectorSlice = MonoVector.MonoVectorSlice + structure Word16Array = MonoArray + structure Word16ArraySlice = MonoArray.MonoArraySlice + structure Word16Array2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Primitive.Word32.word) + open S +in + structure Word32Vector = MonoVector + structure Word32VectorSlice = MonoVector.MonoVectorSlice + structure Word32Array = MonoArray + structure Word32ArraySlice = MonoArray.MonoArraySlice + structure Word32Array2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Primitive.Word64.word) + open S +in + structure Word64Vector = MonoVector + structure Word64VectorSlice = MonoVector.MonoVectorSlice + structure Word64Array = MonoArray + structure Word64ArraySlice = MonoArray.MonoArraySlice + structure Word64Array2 = MonoArray2 +end + + +local + structure S = EqtypeMonoX (type elem = Char.char) + open S +in + structure CharVector = MonoVector + structure CharVectorSlice = MonoVector.MonoVectorSlice + structure CharArray = MonoArray + structure CharArraySlice = MonoArray.MonoArraySlice + structure CharArray2 = MonoArray2 +end +local + structure S = EqtypeMonoX (type elem = WideChar.char) + open S +in + structure WideCharVector = MonoVector + structure WideCharVectorSlice = MonoVector.MonoVectorSlice + structure WideCharArray = MonoArray + structure WideCharArraySlice = MonoArray.MonoArraySlice + structure WideCharArray2 = MonoArray2 +end + +local + structure S = EqtypeMono (type elem = Int.int) + open S +in + structure IntVector = MonoVector + structure IntVectorSlice = MonoVector.MonoVectorSlice + structure IntArray = MonoArray + structure IntArraySlice = MonoArray.MonoArraySlice + structure IntArray2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = LargeInt.int) + open S +in + structure LargeIntVector = MonoVector + structure LargeIntVectorSlice = MonoVector.MonoVectorSlice + structure LargeIntArray = MonoArray + structure LargeIntArraySlice = MonoArray.MonoArraySlice + structure LargeIntArray2 = MonoArray2 +end +local + structure S = Mono (type elem = Real.real) + open S +in + structure RealVector = MonoVector + structure RealVectorSlice = MonoVector.MonoVectorSlice + structure RealArray = MonoArray + structure RealArraySlice = MonoArray.MonoArraySlice + structure RealArray2 = MonoArray2 +end +local + structure S = Mono (type elem = LargeReal.real) + open S +in + structure LargeRealVector = MonoVector + structure LargeRealVectorSlice = MonoVector.MonoVectorSlice + structure LargeRealArray = MonoArray + structure LargeRealArraySlice = MonoArray.MonoArraySlice + structure LargeRealArray2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = Word.word) + open S +in + structure WordVector = MonoVector + structure WordVectorSlice = MonoVector.MonoVectorSlice + structure WordArray = MonoArray + structure WordArraySlice = MonoArray.MonoArraySlice + structure WordArray2 = MonoArray2 +end +local + structure S = EqtypeMono (type elem = LargeWord.word) + open S +in + structure LargeWordVector = MonoVector + structure LargeWordVectorSlice = MonoVector.MonoVectorSlice + structure LargeWordArray = MonoArray + structure LargeWordArraySlice = MonoArray.MonoArraySlice + structure LargeWordArray2 = MonoArray2 +end diff --git a/basis-library/arrays-and-vectors/sequence.fun b/basis-library/arrays-and-vectors/sequence.fun new file mode 100644 index 0000000..6cd6917 --- /dev/null +++ b/basis-library/arrays-and-vectors/sequence.fun @@ -0,0 +1,502 @@ +(* Copyright (C) 2013,2017-2018 Matthew Fluet. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure SeqIndex = + struct + open SeqIndex + + local + structure S = + Int_ChooseInt + (type 'a t = 'a -> int + val fInt8 = SeqIndex.sextdFromInt8 + val fInt16 = SeqIndex.sextdFromInt16 + val fInt32 = SeqIndex.sextdFromInt32 + val fInt64 = SeqIndex.sextdFromInt64 + val fIntInf = SeqIndex.sextdFromIntInf) + in + val fromIntUnsafe = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = 'a -> int + val fInt8 = SeqIndex.schckFromInt8 + val fInt16 = SeqIndex.schckFromInt16 + val fInt32 = SeqIndex.schckFromInt32 + val fInt64 = SeqIndex.schckFromInt64 + val fIntInf = SeqIndex.schckFromIntInf) + in + val fromInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = int -> 'a + val fInt8 = SeqIndex.sextdToInt8 + val fInt16 = SeqIndex.sextdToInt16 + val fInt32 = SeqIndex.sextdToInt32 + val fInt64 = SeqIndex.sextdToInt64 + val fIntInf = SeqIndex.sextdToIntInf) + in + val toIntUnsafe = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = int -> 'a + val fInt8 = SeqIndex.schckToInt8 + val fInt16 = SeqIndex.schckToInt16 + val fInt32 = SeqIndex.schckToInt32 + val fInt64 = SeqIndex.schckToInt64 + val fIntInf = SeqIndex.schckToIntInf) + in + val toInt = S.f + end + + fun fromIntForLength n = + if Primitive.Controls.safe + then (fromInt n) handle Overflow => raise Size + else fromIntUnsafe n + end + +functor Sequence (S: PRIM_SEQUENCE): SEQUENCE = + struct + val op +? = SeqIndex.+? + val op +! = SeqIndex.+! + val op -? = SeqIndex.-? + val op <= = SeqIndex.<= + val op > = SeqIndex.> + val op >= = SeqIndex.>= + + (* fun wrap1 f = fn (i) => f (SeqIndex.toIntUnsafe i) *) + fun wrap2 f = fn (i, x) => f (SeqIndex.toIntUnsafe i, x) + fun wrap3 f = fn (i, x, y) => f (SeqIndex.toIntUnsafe i, x, y) + fun unwrap1 f = fn (i) => f (SeqIndex.fromIntUnsafe i) + fun unwrap2 f = fn (i, x) => f (SeqIndex.fromIntUnsafe i, x) + + type 'a sequence = 'a S.sequence + type 'a elt = 'a S.elt + + (* S.maxLen must be representable as an Int.int already *) + val maxLen = SeqIndex.toInt S.maxLen + + fun length s = + if Primitive.Controls.safe + then (SeqIndex.toInt (S.length s)) + handle Overflow => raise Fail "Sequence.length" + else SeqIndex.toIntUnsafe (S.length s) + + fun alloc n = S.alloc (SeqIndex.fromIntForLength n) + fun unsafeAlloc n = S.unsafeAlloc (SeqIndex.fromIntUnsafe n) + + fun create n = + let + val {done, sub, update} = S.create (SeqIndex.fromIntForLength n) + in + {done = done, + sub = unwrap1 sub, + update = unwrap2 update} + end + + fun unfoldi (n, b, f) = S.unfoldi (SeqIndex.fromIntForLength n, b, wrap2 f) + fun unfold (n, b, f) = S.unfold (SeqIndex.fromIntForLength n, b, f) + fun unsafeUnfold (n, b, f) = S.unfold (SeqIndex.fromIntUnsafe n, b, f) + + fun seq0 () = #1 (unfold (0, (), fn _ => raise Fail "Sequence.seq0")) + + fun tabulate (n, f) = + #1 (unfoldi (n, (), fn (i, ()) => (f i, ()))) + + fun new (n, x) = + #1 (unfold (n, (), fn () => (x, ()))) + fun unsafeNew (n, x) = + #1 (unsafeUnfold (n, (), fn () => (x, ()))) + + fun fromList l = + #1 (unfold (List.length l, l, fn l => + case l of + nil => raise Fail "Sequence.fromList" + | h::t => (h, t))) + + structure Slice = + struct + type 'a sequence = 'a S.Slice.sequence + type 'a elt = 'a S.Slice.elt + type 'a slice = 'a S.Slice.slice + + fun length sl = + if Primitive.Controls.safe + then (SeqIndex.toInt (S.Slice.length sl)) + handle Overflow => raise Fail "Sequence.Slice.length" + else SeqIndex.toIntUnsafe (S.Slice.length sl) + + fun unsafeSub (sl, i) = + S.Slice.unsafeSub (sl, SeqIndex.fromIntUnsafe i) + fun sub (sl, i) = + if Primitive.Controls.safe + then let + val i = + (SeqIndex.fromInt i) + handle Overflow => raise Subscript + in + S.Slice.sub (sl, i) + end + else unsafeSub (sl, i) + + fun unsafeUpdate (sl, i, x) = + S.Slice.unsafeUpdate (sl, SeqIndex.fromIntUnsafe i, x) + fun update (sl, i, x) = + if Primitive.Controls.safe + then let + val i = + (SeqIndex.fromInt i) + handle Overflow => raise Subscript + in + S.Slice.update (sl, i, x) + end + else unsafeUpdate (sl, i, x) + + val uninitIsNop = S.Slice.uninitIsNop + fun unsafeUninit (sl, i) = + S.Slice.unsafeUninit (sl, SeqIndex.fromIntUnsafe i) + fun uninit (sl, i) = + if Primitive.Controls.safe + then let + val i = + (SeqIndex.fromInt i) + handle Overflow => raise Subscript + in + S.Slice.uninit (sl, i) + end + else unsafeUninit (sl, i) + + fun unsafeCopy {dst, di, src} = + S.Slice.unsafeCopy + {dst = dst, + di = SeqIndex.fromIntUnsafe di, + src = src} + fun copy {dst, di, src} = + (S.Slice.copy + {dst = dst, + di = SeqIndex.fromInt di, + src = src}) + handle Overflow => raise Subscript + + val full = S.Slice.full + fun unsafeSubslice (sl, start, len) = + S.Slice.unsafeSubslice + (sl, SeqIndex.fromIntUnsafe start, + Option.map SeqIndex.fromIntUnsafe len) + fun unsafeSlice (seq, start, len) = + unsafeSubslice (full seq, start, len) + fun subslice (sl, start, len) = + if Primitive.Controls.safe + then (S.Slice.subslice (sl, + SeqIndex.fromInt start, + Option.map SeqIndex.fromInt len)) + handle Overflow => raise Subscript + else unsafeSubslice (sl, start, len) + fun slice (seq: 'a sequence, start, len) = + subslice (full seq, start, len) + fun base sl = + let + val (seq, start, len) = S.Slice.base sl + in + if Primitive.Controls.safe + then (seq, SeqIndex.toInt start, SeqIndex.toInt len) + handle Overflow => raise Fail "Sequence.Slice.base" + else (seq, + SeqIndex.toIntUnsafe start, + SeqIndex.toIntUnsafe len) + end + val isEmpty = S.Slice.isEmpty + val getItem = S.Slice.getItem + fun foldli f b sl = S.Slice.foldli (wrap3 f) b sl + fun foldri f b sl = S.Slice.foldri (wrap3 f) b sl + val foldl = S.Slice.foldl + val foldr = S.Slice.foldr + fun appi f sl = S.Slice.appi (wrap2 f) sl + val app = S.Slice.app + fun mapi f sl = S.Slice.mapi (wrap2 f) sl + val map = S.Slice.map + fun findi p sl = + Option.map (wrap2 (fn z => z)) (S.Slice.findi (wrap2 p) sl) + val find = S.Slice.find + fun existsi p sl = S.Slice.existsi (wrap2 p) sl + val exists = S.Slice.exists + fun alli p sl = S.Slice.alli (wrap2 p) sl + val all = S.Slice.all + val collate = S.Slice.collate + val sequence = S.Slice.sequence + val append = S.Slice.append + + fun concatGen (xs: 'b list, toSlice: 'b -> 'a slice): 'a sequence = + case xs of + [] => seq0 () + | [x] => sequence (toSlice x) + | xs => + let + val add = + if Primitive.Controls.safe + then (fn (x, s) => + (s +! S.Slice.length (toSlice x)) + handle Overflow => raise Size) + else (fn (x, s) => s +? S.Slice.length (toSlice x)) + val n = List.foldl add 0 xs + val a = Primitive.Array.alloc n + fun loop (di, xs) = + case xs of + [] => S.unsafeFromArray a + | x::xs => + let val sl = toSlice x + in + S.Slice.unsafeCopy {dst = a, di = di, src = sl} + ; loop (di +? S.Slice.length sl, xs) + end + in + loop (0, xs) + end + fun concat (sls: 'a slice list): 'a sequence = + concatGen (sls, fn sl => sl) + fun concatWithGen (sep: 'a sequence) (xs: 'b list, toSlice: 'b -> 'a slice): 'a sequence = + case xs of + [] => seq0 () + | [x] => sequence (toSlice x) + | x::xs => + let + val sep = S.Slice.full sep + val sepn = S.Slice.length sep + val add = + if Primitive.Controls.safe + then (fn (x, s) => + (s +! sepn +! S.Slice.length (toSlice x)) + handle Overflow => raise Size) + else (fn (x, s) => + (s +? sepn +? S.Slice.length (toSlice x))) + val n = List.foldl add (S.Slice.length (toSlice x)) xs + val a = Primitive.Array.alloc n + fun loop (di, xs) = + case xs of + [] => raise Fail "Sequence.Slice.concatWithGen" + | [x] => + let + val sl = toSlice x + val _ = S.Slice.unsafeCopy {dst = a, di = di, src = sl} + in + S.unsafeFromArray a + end + | x::xs => + let + val sl = toSlice x + val _ = S.Slice.unsafeCopy {dst = a, di = di, src = sl} + val di = di +? S.Slice.length sl + val _ = S.Slice.unsafeCopy {dst = a, di = di, src = sep} + val di = di +? sepn + in + loop (di, xs) + end + in + loop (0, x::xs) + end + fun concatWith sep sls = concatWithGen sep (sls, fn sl => sl) + fun triml k sl = + if Primitive.Controls.safe andalso Int.< (k, 0) + then raise Subscript + else let + val len = S.Slice.length sl + val k = + if Primitive.Controls.safe + then SeqIndex.fromInt k + else SeqIndex.fromIntUnsafe k + in + if SeqIndex.> (k, len) + then S.Slice.unsafeSubslice (sl, len, SOME 0) + else S.Slice.unsafeSubslice (sl, k, SOME (len -? k)) + end handle Overflow => + (* k is positive, so behavior is specified! *) + S.Slice.unsafeSubslice (sl, S.Slice.length sl, SOME 0) + fun trimr k sl = + if Primitive.Controls.safe andalso Int.< (k, 0) + then raise Subscript + else let + val len = S.Slice.length sl + val k = + if Primitive.Controls.safe + then SeqIndex.fromInt k + else SeqIndex.fromIntUnsafe k + in + if SeqIndex.> (k, len) + then S.Slice.unsafeSubslice (sl, 0, SOME 0) + else S.Slice.unsafeSubslice (sl, 0, SOME (len -? k)) + end handle Overflow => + (* k is positive, so behavior is specified! *) + S.Slice.unsafeSubslice (sl, 0, SOME 0) + fun isSubsequence (eq: 'a elt * 'a elt -> bool) + (seq: 'a sequence) + (sl: 'a slice) = + let + val n = S.length seq + val n' = S.Slice.length sl + in + if n <= n' + then let + val n'' = n' -? n + fun loop (i, j) = + if i > n'' + then false + else if j >= n + then true + else if eq (S.unsafeSub (seq, j), + S.Slice.unsafeSub (sl, i +? j)) + then loop (i, j +? 1) + else loop (i +? 1, 0) + in + loop (0, 0) + end + else false + end + fun isPrefix (eq: 'a elt * 'a elt -> bool) + (seq: 'a sequence) + (sl: 'a slice) = + let + val n = S.length seq + val n' = S.Slice.length sl + in + if n <= n' + then let + fun loop (j) = + if j >= n + then true + else if eq (S.unsafeSub (seq, j), + S.Slice.unsafeSub (sl, j)) + then loop (j +? 1) + else false + in + loop (0) + end + else false + end + fun isSuffix (eq: 'a elt * 'a elt -> bool) + (seq: 'a sequence) + (sl: 'a slice) = + let + val n = S.length seq + val n' = S.Slice.length sl + in + if n <= n' + then let + val n'' = n' -? n + fun loop (j) = + if j >= n + then true + else if eq (S.unsafeSub (seq, j), + S.Slice.unsafeSub (sl, n'' +? j)) + then loop (j +? 1) + else false + in + loop (0) + end + else false + end + val splitl = S.Slice.splitl + val splitr = S.Slice.splitr + fun splitAt (sl, i) = + if Primitive.Controls.safe + then (S.Slice.splitAt (sl, SeqIndex.fromInt i)) + handle Overflow => raise Subscript + else S.Slice.splitAt (sl, SeqIndex.fromIntUnsafe i) + val dropl = S.Slice.dropl + val dropr = S.Slice.dropr + val takel = S.Slice.takel + val taker = S.Slice.taker + val position = S.Slice.position + fun translate f (sl: 'a slice) = + concat (List.rev (foldl (fn (c, l) => (full (f c)) :: l) [] sl)) + local + fun make finish p sl = + let + val (seq, start, len) = S.Slice.base sl + val max = start +? len + fun loop (i, start, sls) = + if i >= max + then List.rev (finish (seq, start, i, sls)) + else + if p (S.unsafeSub (seq, i)) + then loop (i +? 1, i +? 1, finish (seq, start, i, sls)) + else loop (i +? 1, start, sls) + in loop (start, start, []) + end + in + fun tokensGen fromSlice p sl = + make (fn (seq, start, stop, sls) => + if start = stop + then sls + else + (fromSlice + (S.Slice.unsafeSlice + (seq, start, SOME (stop -? start)))) + :: sls) + p sl + fun fieldsGen fromSlice p sl = + make (fn (seq, start, stop, sls) => + (fromSlice + (S.Slice.unsafeSlice + (seq, start, SOME (stop -? start)))) + :: sls) + p sl + end + fun tokens p sl = tokensGen (fn sl => sl) p sl + fun fields p sl = fieldsGen (fn sl => sl) p sl + fun toList (sl: 'a slice) = foldr (fn (a,l) => a::l) [] sl + end + + local + fun make f seq = f (Slice.full seq) + fun make2 f (seq1, seq2) = f (Slice.full seq1, Slice.full seq2) + in + fun sub (seq, i) = Slice.sub (Slice.full seq, i) + fun unsafeSub (seq, i) = Slice.unsafeSub (Slice.full seq, i) + fun update (seq, i, x) = Slice.update (Slice.full seq, i, x) + fun unsafeUpdate (seq, i, x) = Slice.unsafeUpdate (Slice.full seq, i, x) + fun uninitIsNop seq = Slice.uninitIsNop (Slice.full seq) + fun uninit (seq, i) = Slice.uninit (Slice.full seq, i) + fun unsafeUninit (seq, i) = Slice.unsafeUninit (Slice.full seq, i) + fun copy {dst, di, src} = + Slice.copy {dst = dst, di = di, src = Slice.full src} + fun unsafeCopy {dst, di, src} = + Slice.unsafeCopy {dst = dst, di = di, src = Slice.full src} + fun append seqs = make2 Slice.append seqs + fun concat seqs = Slice.concatGen (seqs, Slice.full) + fun appi f = make (Slice.appi f) + fun app f = make (Slice.app f) + fun mapi f = make (Slice.mapi f) + fun map f = make (Slice.map f) + fun foldli f b = make (Slice.foldli f b) + fun foldl f b = make (Slice.foldl f b) + fun foldri f b = make (Slice.foldri f b) + fun foldr f b = make (Slice.foldr f b) + fun findi p = make (Slice.findi p) + fun find p = make (Slice.find p) + fun existsi p = make (Slice.existsi p) + fun exists p = make (Slice.exists p) + fun alli p = make (Slice.alli p) + fun all p = make (Slice.all p) + fun collate cmp = make2 (Slice.collate cmp) + fun concatWith sep seqs = Slice.concatWithGen sep (seqs, Slice.full) + fun isPrefix eq seq = make (Slice.isPrefix eq seq) + fun isSubsequence eq seq = make (Slice.isSubsequence eq seq) + fun isSuffix eq seq = make (Slice.isSuffix eq seq) + fun translate f = make (Slice.translate f) + fun tokens f seq = make (Slice.tokensGen Slice.sequence f) seq + fun fields f seq = make (Slice.fieldsGen Slice.sequence f) seq + fun duplicate seq = make Slice.sequence seq + fun toList seq = make Slice.toList seq + end + end diff --git a/basis-library/arrays-and-vectors/sequence.sig b/basis-library/arrays-and-vectors/sequence.sig new file mode 100644 index 0000000..9378419 --- /dev/null +++ b/basis-library/arrays-and-vectors/sequence.sig @@ -0,0 +1,72 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2014 Rob Simmons. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature SEQUENCE = + sig + type 'a sequence + type 'a elt + + structure Slice : SLICE where type 'a sequence = 'a sequence + and type 'a elt = 'a elt + + val maxLen: int + val length: 'a sequence -> int + val sub: 'a sequence * int -> 'a elt + val unsafeSub: 'a sequence * int -> 'a elt + val update: 'a sequence * int * 'a elt -> unit + val unsafeUpdate: 'a sequence * int * 'a elt -> unit + val uninitIsNop: 'a sequence -> bool + val uninit: 'a sequence * int -> unit + val unsafeUninit: 'a sequence * int -> unit + val copy: {dst: 'a elt Array.array, di: int, src: 'a sequence} -> unit + val unsafeCopy: {dst: 'a elt Array.array, di: int, src: 'a sequence} -> unit + val tabulate: int * (int -> 'a elt) -> 'a sequence + val appi: (int * 'a elt -> unit) -> 'a sequence -> unit + val app: ('a elt -> unit) -> 'a sequence -> unit + val mapi : (int * 'a elt -> 'b elt) -> 'a sequence -> 'b sequence + val map: ('a elt -> 'b elt) -> 'a sequence -> 'b sequence + val foldli: (int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b + val foldl: ('a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b + val foldri: (int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b + val foldr: ('a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b + val findi: (int * 'a elt -> bool) -> 'a sequence -> (int * 'a elt) option + val find: ('a elt -> bool) -> 'a sequence -> 'a elt option + val existsi: (int * 'a elt -> bool) -> 'a sequence -> bool + val exists: ('a elt -> bool) -> 'a sequence -> bool + val alli: (int * 'a elt -> bool) -> 'a sequence -> bool + val all: ('a elt -> bool) -> 'a sequence -> bool + val collate: ('a elt * 'a elt -> order) -> 'a sequence * 'a sequence -> order + val fromList: 'a elt list -> 'a sequence + val toList: 'a sequence -> 'a elt list + val concat: 'a sequence list -> 'a sequence + + (* Extra *) + val alloc: int -> 'a sequence + val append: 'a sequence * 'a sequence -> 'a sequence + val create: + int -> {done: unit -> 'a sequence, + sub: int -> 'a elt, + update: int * 'a elt -> unit} + val duplicate: 'a sequence -> 'a sequence + val new: int * 'a elt -> 'a sequence + val unfoldi: int * 'b * (int * 'b -> 'a elt * 'b) -> 'a sequence * 'b + val unfold: int * 'b * ('b -> 'a elt * 'b) -> 'a sequence * 'b + val unsafeAlloc: int -> 'a sequence + val unsafeNew: int * 'a elt -> 'a sequence + + (* Used to implement Substring/String functions *) + val isPrefix: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a sequence -> bool + val concatWith: 'a sequence -> 'a sequence list -> 'a sequence + val isSubsequence: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a sequence -> bool + val isSuffix: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a sequence -> bool + val translate: ('a elt -> 'b sequence) -> 'a sequence -> 'b sequence + val tokens: ('a elt -> bool) -> 'a sequence -> 'a sequence list + val fields: ('a elt -> bool) -> 'a sequence -> 'a sequence list + end diff --git a/basis-library/arrays-and-vectors/sequence0.sig b/basis-library/arrays-and-vectors/sequence0.sig new file mode 100644 index 0000000..781e81b --- /dev/null +++ b/basis-library/arrays-and-vectors/sequence0.sig @@ -0,0 +1,63 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2014 Rob Simmons. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature PRIM_SEQUENCE = + sig + type 'a sequence + type 'a elt + + structure Slice: PRIM_SLICE where type 'a sequence = 'a sequence + and type 'a elt = 'a elt + + val maxLen: SeqIndex.int (* Must also be representable as an Int.int *) + val length: 'a sequence -> SeqIndex.int + val sub: 'a sequence * SeqIndex.int -> 'a elt + val unsafeSub: 'a sequence * SeqIndex.int -> 'a elt + val uninitIsNop: 'a sequence -> bool + val uninit: 'a sequence * SeqIndex.int -> unit + val unsafeUninit: 'a sequence * SeqIndex.int -> unit + val update: 'a sequence * SeqIndex.int * 'a elt -> unit + val unsafeUpdate: 'a sequence * SeqIndex.int * 'a elt -> unit + val copy: {dst: 'a elt array, di: SeqIndex.int, src: 'a sequence} -> unit + val unsafeCopy: {dst: 'a elt array, di: SeqIndex.int, src: 'a sequence} -> unit + val tabulate: SeqIndex.int * (SeqIndex.int -> 'a elt) -> 'a sequence + val appi: (SeqIndex.int * 'a elt -> unit) -> 'a sequence -> unit + val app: ('a elt -> unit) -> 'a sequence -> unit + val mapi: (SeqIndex.int * 'a elt -> 'b elt) -> 'a sequence -> 'b sequence + val map: ('a elt -> 'b elt) -> 'a sequence -> 'b sequence + val foldli: (SeqIndex.int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b + val foldl: ('a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b + val foldri: (SeqIndex.int * 'a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b + val foldr: ('a elt * 'b -> 'b) -> 'b -> 'a sequence -> 'b + val findi: (SeqIndex.int * 'a elt -> bool) -> 'a sequence -> (SeqIndex.int * 'a elt) option + val find: ('a elt -> bool) -> 'a sequence -> 'a elt option + val existsi: (SeqIndex.int * 'a elt -> bool) -> 'a sequence -> bool + val exists: ('a elt -> bool) -> 'a sequence -> bool + val alli: (SeqIndex.int * 'a elt -> bool) -> 'a sequence -> bool + val all: ('a elt -> bool) -> 'a sequence -> bool + val collate: ('a elt * 'a elt -> order) -> 'a sequence * 'a sequence -> order + + + + + (* Extra *) + val alloc: SeqIndex.int -> 'a sequence + val append: 'a sequence * 'a sequence -> 'a sequence + val create: + SeqIndex.int -> {done: unit -> 'a sequence, + sub: SeqIndex.int -> 'a elt, + update: SeqIndex.int * 'a elt -> unit} + val duplicate: 'a sequence -> 'a sequence + val new: SeqIndex.int * 'a elt -> 'a sequence + val unfoldi: SeqIndex.int * 'b * (SeqIndex.int * 'b -> 'a elt * 'b) -> 'a sequence * 'b + val unfold: SeqIndex.int * 'b * ('b -> 'a elt * 'b) -> 'a sequence * 'b + val unsafeAlloc: SeqIndex.int -> 'a sequence + val unsafeFromArray: 'a elt array -> 'a sequence + end diff --git a/basis-library/arrays-and-vectors/sequence0.sml b/basis-library/arrays-and-vectors/sequence0.sml new file mode 100644 index 0000000..ce4bb9d --- /dev/null +++ b/basis-library/arrays-and-vectors/sequence0.sml @@ -0,0 +1,585 @@ +(* Copyright (C) 2015,2017 Matthew Fluet. + * Copyright (C) 2014 Rob Simmons. + * Copyright (C) 2013 Matthew Fluet. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor PrimSequence (S: sig + type 'a sequence + type 'a elt + val copyUnsafe: 'a elt array * SeqIndex.int * 'a sequence * SeqIndex.int * SeqIndex.int -> unit + (* fromArray should be constant time. *) + val fromArray: 'a elt array -> 'a sequence + val isMutable: bool + val length: 'a sequence -> SeqIndex.int + val sameArray: 'a elt array * 'a sequence -> bool + val subUnsafe: 'a sequence * SeqIndex.int -> 'a elt + val uninitIsNop: 'a sequence -> bool + val uninitUnsafe: 'a sequence * SeqIndex.int -> unit + val updateUnsafe: 'a sequence * SeqIndex.int * 'a elt -> unit + end) :> PRIM_SEQUENCE where type 'a sequence = 'a S.sequence + where type 'a elt = 'a S.elt = + struct + structure Array = Primitive.Array + + val op +? = SeqIndex.+? + val op + = SeqIndex.+ + val op -? = SeqIndex.-? + val op < = SeqIndex.< + val op <= = SeqIndex.<= + val op > = SeqIndex.> + val op >= = SeqIndex.>= + val gtu = SeqIndex.gtu + val geu = SeqIndex.geu + val ! = Primitive.Ref.deref + val op := = Primitive.Ref.assign + fun (f o g) x = f (g x) + + type 'a sequence = 'a S.sequence + type 'a elt = 'a S.elt + + local + fun valOf x: Primitive.Int32.int = case x of SOME y => y | NONE => 0 + fun doit (precision, fromInt, maxInt') = + if Primitive.Int32.>= (valOf SeqIndex.precision, precision) + then fromInt maxInt' + else SeqIndex.maxInt' + structure S = + Int_ChooseInt + (type 'a t = SeqIndex.int + val fInt8 = doit (valOf Primitive.Int8.precision, + SeqIndex.schckFromInt8, + Primitive.Int8.maxInt') + val fInt16 = doit (valOf Primitive.Int16.precision, + SeqIndex.schckFromInt16, + Primitive.Int16.maxInt') + val fInt32 = doit (valOf Primitive.Int32.precision, + SeqIndex.schckFromInt32, + Primitive.Int32.maxInt') + val fInt64 = doit (valOf Primitive.Int64.precision, + SeqIndex.schckFromInt64, + Primitive.Int64.maxInt') + val fIntInf = SeqIndex.maxInt') + in + val maxLen = S.f + end + + fun length s = S.length s + + fun unsafeArrayAlloc n = Array.allocUnsafe n + fun arrayAlloc n = + if Primitive.Controls.safe + andalso gtu (n, maxLen) + then raise Size + else unsafeArrayAlloc n + fun unsafeAlloc n = S.fromArray (unsafeArrayAlloc n) + fun alloc n = S.fromArray (arrayAlloc n) + val unsafeFromArray = S.fromArray + exception CreateAlreadyGotVector + exception CreateVectorNotFull + fun create n = + let + val a = arrayAlloc n + val subLim : SeqIndex.t ref = ref 0 + fun sub i = + if Primitive.Controls.safe andalso geu (i, !subLim) then + raise Subscript + else + Array.subUnsafe (a, i) + val updateLim : SeqIndex.t ref = ref 0 + fun update (i, x) = + if Primitive.Controls.safe andalso geu (i, !updateLim) then + if i = !updateLim andalso i < n then + (Array.updateUnsafe (a, i, x); + subLim := i + 1; + updateLim := i + 1) + else + raise Subscript + else + Array.updateUnsafe (a, i, x) + val gotIt = ref false + fun done () = + if !gotIt then + raise CreateAlreadyGotVector + else + if n = !updateLim then + (gotIt := true; + updateLim := 0; + S.fromArray a) + else + raise CreateVectorNotFull + in + {done = done, + sub = sub, + update = update} + end + + fun unfoldi (n, b, f) = + let + val a = arrayAlloc n + fun loop (i, b) = + if i >= n + then b + else + let + val (x, b) = f (i, b) + val () = Array.updateUnsafe (a, i, x) + in + loop (i +? 1, b) + end + val b = loop (0, b) + in + (S.fromArray a, b) + end + + fun unfold (n, b, f) = unfoldi (n, b, f o #2) + + fun tabulate (n, f) = + #1 (unfoldi (n, (), fn (i, ()) => (f i, ()))) + + fun new (n, x) = tabulate (n, fn _ => x) + + structure Slice = + struct + type 'a sequence = 'a sequence + type 'a elt = 'a elt + datatype 'a t = T of {seq: 'a sequence, + start: SeqIndex.int, len: SeqIndex.int} + type 'a slice = 'a t + + fun length (T {len, ...}) = len + fun unsafeSub (T {seq, start, ...}, i) = + S.subUnsafe (seq, start +? i) + fun sub (sl as T {len, ...}, i) = + if Primitive.Controls.safe andalso geu (i, len) + then raise Subscript + else unsafeSub (sl, i) + fun unsafeUpdate (T {seq, start, ...}, i, x) = + S.updateUnsafe (seq, start +? i, x) + fun update (sl as T {len, ...}, i, x) = + if Primitive.Controls.safe andalso geu (i, len) + then raise Subscript + else unsafeUpdate (sl, i, x) + fun uninitIsNop (T {seq, ...}) = + S.uninitIsNop seq + fun unsafeUninit (T {seq, start, ...}, i) = + S.uninitUnsafe (seq, start +? i) + fun uninit (sl as T {len, ...}, i) = + if Primitive.Controls.safe andalso geu (i, len) + then raise Subscript + else unsafeUninit (sl, i) + local + fun smallCopy {dst: 'a elt array, di: SeqIndex.int, + src: 'a sequence, si: SeqIndex.int, + len: SeqIndex.int, + overlap: unit -> bool} = + let + fun move i = Array.updateUnsafe (dst, di +? i, S.subUnsafe (src, si +? i)) + val len = len -? 1 + in + if overlap () + then let + fun loop i = + if i < 0 + then () + else (move i; loop (i -? 1)) + in + loop len + end + else let + fun loop i = + if i > len + then () + else (move i; loop (i +? 1)) + in + loop 0 + end + end + val smallCopyLimit = 5 + fun maybeSmallCopy {dst: 'a elt array, di: SeqIndex.int, + src: 'a sequence, si: SeqIndex.int, + len: SeqIndex.int, + overlap: unit -> bool} = + if len < smallCopyLimit + then smallCopy {dst = dst, di = di, + src = src, si = si, + len = len, + overlap = overlap} + else S.copyUnsafe (dst, di, src, si, len) + in + fun unsafeCopy {dst: 'a elt array, di: SeqIndex.int, + src = T {seq = src, start = si, len}} = + maybeSmallCopy {dst = dst, di = di, + src = src, si = si, + len = len, + overlap = fn () => false} + fun copy {dst: 'a elt array, di: SeqIndex.int, + src = T {seq = src, start = si, len}} = + if Primitive.Controls.safe + andalso (gtu (di, Array.length dst) + orelse gtu (di +? len, Array.length dst)) + then raise Subscript + else let + fun overlap () = + S.sameArray (dst, src) + andalso si < di + andalso di <= si +? len + in + maybeSmallCopy {dst = dst, di = di, + src = src, si = si, + len = len, + overlap = overlap} + end + end + fun full (seq: 'a sequence) : 'a slice = + T {seq = seq, start = 0, len = S.length seq} + fun unsafeSubslice (T {seq, start, len}, start', len') = + T {seq = seq, + start = start +? start', + len = (case len' of + NONE => len -? start' + | SOME len' => len')} + fun unsafeSlice (seq, start, len) = + unsafeSubslice (full seq, start, len) + fun subslice (T {seq, start, len}, start', len') = + case len' of + NONE => + if Primitive.Controls.safe + andalso gtu (start', len) + then raise Subscript + else T {seq = seq, + start = start +? start', + len = len -? start'} + | SOME len' => + if Primitive.Controls.safe + andalso (gtu (start', len) + orelse gtu (len', len -? start')) + then raise Subscript + else T {seq = seq, + start = start +? start', + len = len'} + fun slice (seq: 'a sequence, start, len) = + subslice (full seq, start, len) + fun base (T {seq, start, len}) = + (seq, start, len) + fun isEmpty sl = length sl = 0 + fun getItem (sl as T {seq, start, len}) = + if isEmpty sl + then NONE + else SOME (S.subUnsafe (seq, start), + T {seq = seq, + start = start +? 1, + len = len -? 1}) + fun foldli f b (T {seq, start, len}) = + let + val min = start + val len = len -? 1 + val max = start +? len + fun loop (i, b) = + if i > max then b + else loop (i +? 1, f (i -? min, S.subUnsafe (seq, i), b)) + in loop (min, b) + end + fun foldri f b (T {seq, start, len}) = + let + val min = start + val len = len -? 1 + val max = start +? len + fun loop (i, b) = + if i < min then b + else loop (i -? 1, f (i -? min, S.subUnsafe (seq, i), b)) + in loop (max, b) + end + local + fun make foldi f b sl = foldi (fn (_, x, b) => f (x, b)) b sl + in + fun foldl f = make foldli f + fun foldr f = make foldri f + end + fun appi f sl = foldli (fn (i, x, ()) => f (i, x)) () sl + fun app f sl = appi (f o #2) sl + fun mapi f (T {seq, start, len}) = + tabulate (len, fn i => f (i, S.subUnsafe (seq, start +? i))) + fun map f sl = mapi (f o #2) sl + fun findi p (T {seq, start, len}) = + let + val min = start + val len = len -? 1 + val max = start +? len + fun loop i = + if i > max + then NONE + else let val z = (i -? min, S.subUnsafe (seq, i)) + in if p z + then SOME z + else loop (i +? 1) + end + in loop min + end + fun find p sl = + case findi (p o #2) sl of + NONE => NONE + | SOME (_, x) => SOME x + fun existsi p sl = + case findi p sl of + NONE => false + | SOME _ => true + fun exists p sl = existsi (p o #2) sl + fun alli p sl = not (existsi (not o p) sl) + fun all p sl = alli (p o #2) sl + fun collate cmp (T {seq = seq1, start = start1, len = len1}, + T {seq = seq2, start = start2, len = len2}) = + let + val min1 = start1 + val min2 = start2 + val max1 = start1 +? len1 + val max2 = start2 +? len2 + fun loop (i, j) = + case (i >= max1, j >= max2) of + (true, true) => EQUAL + | (true, false) => LESS + | (false, true) => GREATER + | (false, false) => + (case cmp (S.subUnsafe (seq1, i), + S.subUnsafe (seq2, j)) of + EQUAL => loop (i +? 1, j +? 1) + | ans => ans) + in loop (min1, min2) + end + fun sequence (sl as T {seq, start, len}): 'a sequence = + if S.isMutable orelse (start <> 0 orelse len <> S.length seq) + then let + val a = arrayAlloc len + in + S.copyUnsafe (a, 0, seq, start, len) + ; S.fromArray a + end + else seq + fun append (sl1: 'a slice, sl2: 'a slice): 'a sequence = + if length sl1 = 0 + then sequence sl2 + else if length sl2 = 0 + then sequence sl1 + else + let + val (seq1, start1, len1) = base sl1 + val (seq2, start2, len2) = base sl2 + val n = len1 +? len2 + val a = arrayAlloc n + in + S.copyUnsafe (a, 0, seq1, start1, len1) + ; S.copyUnsafe (a, len1, seq2, start2, len2) + ; S.fromArray a + end + fun split (T {seq, start, len}, i) = + (unsafeSlice (seq, start, SOME (i -? start)), + unsafeSlice (seq, i, SOME (len -? (i -? start)))) + fun splitl f (sl as T {seq, start, len}) = + let + val stop = start +? len + fun loop i = + if i >= stop + then i + else if f (S.subUnsafe (seq, i)) + then loop (i +? 1) + else i + in split (sl, loop start) + end + fun splitr f (sl as T {seq, start, len}) = + let + fun loop i = + if i < start + then start + else if f (S.subUnsafe (seq, i)) + then loop (i -? 1) + else i +? 1 + in split (sl, loop (start +? len -? 1)) + end + fun splitAt (T {seq, start, len}, i) = + if Primitive.Controls.safe andalso gtu (i, len) + then raise Subscript + else (unsafeSlice (seq, start, SOME i), + unsafeSlice (seq, start +? i, SOME (len -? i))) + fun dropl p s = #2 (splitl p s) + fun dropr p s = #1 (splitr p s) + fun takel p s = #1 (splitl p s) + fun taker p s = #2 (splitr p s) + fun position (eq: 'a elt * 'a elt -> bool) + (seq': 'a sequence) + (sl as T {seq, start, len}) = + let + val len' = S.length seq' + val max = start +? len -? len' +? 1 + (* loop returns the index of the front of the suffix. *) + fun loop i = + if i >= max + then start +? len + else let + fun loop' j = + if j >= len' + then i + else if eq (S.subUnsafe (seq, i +? j), + S.subUnsafe (seq', j)) + then loop' (j +? 1) + else loop (i +? 1) + in loop' 0 + end + in split (sl, loop start) + end + fun span (eq: 'a sequence * 'a sequence -> bool) + (T {seq, start, ...}, + T {seq = seq', start = start', len = len'}) = + if Primitive.Controls.safe andalso + (not (eq (seq, seq')) orelse start' +? len' < start) + then raise Span + else unsafeSlice (seq, start, SOME ((start' +? len') -? start)) + end + + local + fun make f seq = f (Slice.full seq) + fun make2 f (seq1, seq2) = f (Slice.full seq1, Slice.full seq2) + in + fun sub (seq, i) = Slice.sub (Slice.full seq, i) + fun unsafeSub (seq, i) = Slice.unsafeSub (Slice.full seq, i) + fun update (seq, i, x) = Slice.update (Slice.full seq, i, x) + fun unsafeUpdate (seq, i, x) = Slice.unsafeUpdate (Slice.full seq, i, x) + fun uninitIsNop seq = Slice.uninitIsNop (Slice.full seq) + fun uninit (seq, i) = Slice.uninit (Slice.full seq, i) + fun unsafeUninit (seq, i) = Slice.unsafeUninit (Slice.full seq, i) + fun copy {dst, di, src} = Slice.copy {dst = dst, di = di, src = Slice.full src} + fun unsafeCopy {dst, di, src} = Slice.unsafeCopy {dst = dst, di = di, src = Slice.full src} + fun appi f = make (Slice.appi f) + fun app f = make (Slice.app f) + fun mapi f = make (Slice.mapi f) + fun map f = make (Slice.map f) + fun foldli f b = make (Slice.foldli f b) + fun foldl f b = make (Slice.foldl f b) + fun foldri f b = make (Slice.foldri f b) + fun foldr f b = make (Slice.foldr f b) + fun findi p = make (Slice.findi p) + fun find p = make (Slice.find p) + fun existsi p = make (Slice.existsi p) + fun exists p = make (Slice.exists p) + fun alli p = make (Slice.alli p) + fun all p = make (Slice.all p) + fun collate cmp = make2 (Slice.collate cmp) + fun append seqs = make2 Slice.append seqs + fun duplicate seq = make Slice.sequence seq + end + + end + +structure Primitive = struct +open Primitive + +structure Array = + struct + local + structure P = PrimSequence (type 'a sequence = 'a array + type 'a elt = 'a + val sameArray = op = + val copyUnsafe = Primitive.Array.copyArrayUnsafe + val fromArray = fn a => a + val isMutable = true + val length = Primitive.Array.length + val subUnsafe = Primitive.Array.subUnsafe + val uninitIsNop = Primitive.Array.uninitIsNop + val uninitUnsafe = Primitive.Array.uninitUnsafe + val updateUnsafe = Primitive.Array.updateUnsafe) + in + open P + type 'a array = 'a array + structure Slice = + struct + open Slice + fun vector sl = + let + val a = unsafeAlloc (length sl) + val () = unsafeCopy {dst = a, di = 0, src = sl} + in + Vector.fromArrayUnsafe a + end + fun modifyi f sl = + appi (fn (i, x) => unsafeUpdate (sl, i, f (i, x))) sl + fun modify f sl = modifyi (fn (_, x) => f x) sl + end + fun vector s = Slice.vector (Slice.full s) + fun modifyi f s = Slice.modifyi f (Slice.full s) + fun modify f s = Slice.modify f (Slice.full s) + end + structure Raw = + struct + type 'a rawarr = 'a Primitive.Array.Raw.rawarr + + val length = Primitive.Array.Raw.length + + val unsafeAlloc = Primitive.Array.Raw.allocUnsafe + fun alloc n = + if Primitive.Controls.safe + andalso SeqIndex.gtu (n, maxLen) + then raise Size + else unsafeAlloc n + + val unsafeToArray = Primitive.Array.Raw.toArrayUnsafe + + val uninitIsNop = Primitive.Array.Raw.uninitIsNop + val unsafeUninit = Primitive.Array.Raw.uninitUnsafe + fun uninit (a, i) = + if Primitive.Controls.safe andalso SeqIndex.geu (i, length a) + then raise Subscript + else unsafeUninit (a, i) + + end + end + +structure Vector = + struct + local + exception Vector_uninitIsNop + exception Vector_uninitUnsafe + exception Vector_updateUnsafe + structure P = PrimSequence (type 'a sequence = 'a vector + type 'a elt = 'a + val copyUnsafe = Primitive.Array.copyVectorUnsafe + val fromArray = Primitive.Vector.fromArrayUnsafe + val isMutable = false + val length = Vector.length + val sameArray = fn _ => false + val subUnsafe = Primitive.Vector.subUnsafe + val uninitIsNop = fn _ => + raise Vector_uninitIsNop + val uninitUnsafe = fn _ => + raise Vector_uninitUnsafe + val updateUnsafe = fn _ => + raise Vector_updateUnsafe) + in + open P + type 'a vector = 'a vector + fun updateVector (v, i, x) = + if Primitive.Controls.safe andalso SeqIndex.geu (i, length v) + then raise Subscript + else let + val a = Array.unsafeAlloc (length v) + val () = copy {dst = a, di = 0, src = v} + val () = Array.unsafeUpdate (a, i, x) + in + unsafeFromArray a + end + end + end + +end + +structure Array = + struct + type 'a array = 'a array + end +structure Vector = + struct + type 'a vector = 'a vector + end diff --git a/basis-library/arrays-and-vectors/slice.sig b/basis-library/arrays-and-vectors/slice.sig new file mode 100644 index 0000000..3999b97 --- /dev/null +++ b/basis-library/arrays-and-vectors/slice.sig @@ -0,0 +1,74 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2014 Rob Simmons. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature SLICE = + sig + type 'a sequence + type 'a elt + type 'a slice + val length: 'a slice -> int + val sub: 'a slice * int -> 'a elt + val unsafeSub: 'a slice * int -> 'a elt + val update: 'a slice * int * 'a elt -> unit + val unsafeUpdate: 'a slice * int * 'a elt -> unit + val uninitIsNop: 'a slice -> bool + val uninit: 'a slice * int -> unit + val unsafeUninit: 'a slice * int -> unit + val copy: {dst: 'a elt Array.array, di: int, src: 'a slice} -> unit + val unsafeCopy: {dst: 'a elt Array.array, di: int, src: 'a slice} -> unit + val full: 'a sequence -> 'a slice + val slice: 'a sequence * int * int option -> 'a slice + val unsafeSlice: 'a sequence * int * int option -> 'a slice + val subslice: 'a slice * int * int option -> 'a slice + val unsafeSubslice: 'a slice * int * int option -> 'a slice + val base: 'a slice -> 'a sequence * int * int + val isEmpty: 'a slice -> bool + val getItem: 'a slice -> ('a elt * 'a slice) option + val appi: (int * 'a elt -> unit) -> 'a slice -> unit + val app: ('a elt -> unit) -> 'a slice -> unit + val mapi: (int * 'a elt -> 'b elt) -> 'a slice -> 'b sequence + val map: ('a elt -> 'b elt) -> 'a slice -> 'b sequence + val foldli: (int * 'a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldl: ('a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldri: (int * 'a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldr: ('a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b + val findi: (int * 'a elt -> bool) -> 'a slice -> (int * 'a elt) option + val find: ('a elt -> bool) -> 'a slice -> 'a elt option + val existsi: (int * 'a elt -> bool) -> 'a slice -> bool + val exists: ('a elt -> bool) -> 'a slice -> bool + val alli: (int * 'a elt -> bool) -> 'a slice -> bool + val all: ('a elt -> bool) -> 'a slice -> bool + val collate: ('a elt * 'a elt -> order) -> 'a slice * 'a slice -> order + + val splitl: ('a elt -> bool) -> 'a slice -> 'a slice * 'a slice + val splitr: ('a elt -> bool) -> 'a slice -> 'a slice * 'a slice + val splitAt: 'a slice * int -> 'a slice * 'a slice + val dropl: ('a elt -> bool) -> 'a slice -> 'a slice + val dropr: ('a elt -> bool) -> 'a slice -> 'a slice + val takel: ('a elt -> bool) -> 'a slice -> 'a slice + val taker: ('a elt -> bool) -> 'a slice -> 'a slice + val position: ('a elt * 'a elt -> bool) -> + 'a sequence -> 'a slice -> 'a slice * 'a slice + val append: 'a slice * 'a slice -> 'a sequence + val sequence: 'a slice -> 'a sequence + val toList: 'a slice -> 'a elt list + + (* Used to implement Substring/String functions *) + val concat: 'a slice list -> 'a sequence + val concatWith: 'a sequence -> 'a slice list -> 'a sequence + val triml: int -> 'a slice -> 'a slice + val trimr: int -> 'a slice -> 'a slice + val isPrefix: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a slice -> bool + val isSubsequence: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a slice -> bool + val isSuffix: ('a elt * 'a elt -> bool) -> 'a sequence -> 'a slice -> bool + val translate: ('a elt -> 'b sequence) -> 'a slice -> 'b sequence + val tokens: ('a elt -> bool) -> 'a slice -> 'a slice list + val fields: ('a elt -> bool) -> 'a slice -> 'a slice list + end diff --git a/basis-library/arrays-and-vectors/slice0.sig b/basis-library/arrays-and-vectors/slice0.sig new file mode 100644 index 0000000..f54ae89 --- /dev/null +++ b/basis-library/arrays-and-vectors/slice0.sig @@ -0,0 +1,66 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2014 Rob Simmons. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature PRIM_SLICE = + sig + type 'a sequence + type 'a elt + type 'a slice + val length: 'a slice -> SeqIndex.int + val sub: 'a slice * SeqIndex.int -> 'a elt + val unsafeSub: 'a slice * SeqIndex.int -> 'a elt + val update: 'a slice * SeqIndex.int * 'a elt -> unit + val unsafeUpdate: 'a slice * SeqIndex.int * 'a elt -> unit + val uninitIsNop: 'a slice -> bool + val uninit: 'a slice * SeqIndex.int -> unit + val unsafeUninit: 'a slice * SeqIndex.int -> unit + val copy: {dst: 'a elt array, di: SeqIndex.int, src: 'a slice} -> unit + val unsafeCopy: {dst: 'a elt array, di: SeqIndex.int, src: 'a slice} -> unit + val full: 'a sequence -> 'a slice + val slice: 'a sequence * SeqIndex.int * SeqIndex.int option -> 'a slice + val unsafeSlice: 'a sequence * SeqIndex.int * SeqIndex.int option -> 'a slice + val subslice: 'a slice * SeqIndex.int * SeqIndex.int option -> 'a slice + val unsafeSubslice: 'a slice * SeqIndex.int * SeqIndex.int option -> 'a slice + val base: 'a slice -> 'a sequence * SeqIndex.int * SeqIndex.int + val isEmpty: 'a slice -> bool + val getItem: 'a slice -> ('a elt * 'a slice) option + val appi: (SeqIndex.int * 'a elt -> unit) -> 'a slice -> unit + val app: ('a elt -> unit) -> 'a slice -> unit + val mapi: (SeqIndex.int * 'a elt -> 'b elt) -> 'a slice -> 'b sequence + val map: ('a elt -> 'b elt) -> 'a slice -> 'b sequence + val foldli: (SeqIndex.int * 'a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldl: ('a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldri: (SeqIndex.int * 'a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldr: ('a elt * 'b -> 'b) -> 'b -> 'a slice -> 'b + val findi: (SeqIndex.int * 'a elt -> bool) -> 'a slice -> (SeqIndex.int * 'a elt) option + val find: ('a elt -> bool) -> 'a slice -> 'a elt option + val existsi: (SeqIndex.int * 'a elt -> bool) -> 'a slice -> bool + val exists: ('a elt -> bool) -> 'a slice -> bool + val alli: (SeqIndex.int * 'a elt -> bool) -> 'a slice -> bool + val all: ('a elt -> bool) -> 'a slice -> bool + val collate: ('a elt * 'a elt -> order) -> 'a slice * 'a slice -> order + + val splitl: ('a elt -> bool) -> 'a slice -> 'a slice * 'a slice + val splitr: ('a elt -> bool) -> 'a slice -> 'a slice * 'a slice + val splitAt: 'a slice * SeqIndex.int -> 'a slice * 'a slice + val dropl: ('a elt -> bool) -> 'a slice -> 'a slice + val dropr: ('a elt -> bool) -> 'a slice -> 'a slice + val takel: ('a elt -> bool) -> 'a slice -> 'a slice + val taker: ('a elt -> bool) -> 'a slice -> 'a slice + val position: ('a elt * 'a elt -> bool) -> + 'a sequence -> 'a slice -> 'a slice * 'a slice + val append: 'a slice * 'a slice -> 'a sequence + val sequence: 'a slice -> 'a sequence + + (* span: + * ('a sequence * 'a sequence -> bool) should be polymorphic equality + *) + val span: ('a sequence * 'a sequence -> bool) -> 'a slice * 'a slice -> 'a slice + end diff --git a/basis-library/arrays-and-vectors/vector-slice.sig b/basis-library/arrays-and-vectors/vector-slice.sig new file mode 100644 index 0000000..cc44f87 --- /dev/null +++ b/basis-library/arrays-and-vectors/vector-slice.sig @@ -0,0 +1,69 @@ +signature VECTOR_SLICE_GLOBAL = + sig + end + +signature VECTOR_SLICE = + sig + include VECTOR_SLICE_GLOBAL + + type 'a slice + + val length: 'a slice -> int + val sub: 'a slice * int -> 'a + val full: 'a Vector.vector -> 'a slice + val slice: 'a Vector.vector * int * int option -> 'a slice + val subslice: 'a slice * int * int option -> 'a slice + val base: 'a slice -> 'a Vector.vector * int * int + val vector: 'a slice -> 'a Vector.vector + val concat: 'a slice list -> 'a Vector.vector + val isEmpty: 'a slice -> bool + val getItem: 'a slice -> ('a * 'a slice) option + val appi: (int * 'a -> unit) -> 'a slice -> unit + val app: ('a -> unit) -> 'a slice -> unit + val mapi: (int * 'a -> 'b) -> 'a slice -> 'b Vector.vector + val map: ('a -> 'b) -> 'a slice -> 'b Vector.vector + val foldli: (int * 'a * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldl: ('a * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldri: (int * 'a * 'b -> 'b) -> 'b -> 'a slice -> 'b + val foldr: ('a * 'b -> 'b) -> 'b -> 'a slice -> 'b + val findi: (int * 'a -> bool) -> 'a slice -> (int * 'a) option + val find: ('a -> bool) -> 'a slice -> 'a option + val exists: ('a -> bool) -> 'a slice -> bool + val all: ('a -> bool) -> 'a slice -> bool + val collate: ('a * 'a -> order) -> 'a slice * 'a slice -> order + end + +signature VECTOR_SLICE_EXTRA = + sig + include VECTOR_SLICE + + val copy: {dst: 'a Array.array, di: int, src: 'a slice} -> unit + + val unsafeSub: 'a slice * int -> 'a + val unsafeCopy: {dst: 'a Array.array, di: int, src: 'a slice} -> unit + val unsafeSlice: 'a Vector.vector * int * int option -> 'a slice + val unsafeSubslice: 'a slice * int * int option -> 'a slice + + (* Used to implement Substring/String functions *) + val concatWith: 'a Vector.vector -> 'a slice list -> 'a Vector.vector + val triml: int -> 'a slice -> 'a slice + val trimr: int -> 'a slice -> 'a slice + val isPrefix: ('a * 'a -> bool) -> 'a Vector.vector -> 'a slice -> bool + val isSubvector: ('a * 'a -> bool) -> 'a Vector.vector -> 'a slice -> bool + val isSuffix: ('a * 'a -> bool) -> 'a Vector.vector -> 'a slice -> bool + val splitl: ('a -> bool) -> 'a slice -> 'a slice * 'a slice + val splitr: ('a -> bool) -> 'a slice -> 'a slice * 'a slice + val splitAt: 'a slice * int -> 'a slice * 'a slice + val dropl: ('a -> bool) -> 'a slice -> 'a slice + val dropr: ('a -> bool) -> 'a slice -> 'a slice + val takel: ('a -> bool) -> 'a slice -> 'a slice + val taker: ('a -> bool) -> 'a slice -> 'a slice + val position: ('a * 'a -> bool) -> + 'a Vector.vector -> 'a slice -> 'a slice * 'a slice + val span: ''a slice * ''a slice -> ''a slice + val translate: ('a -> 'b Vector.vector) -> 'a slice -> 'b Vector.vector + val tokens: ('a -> bool) -> 'a slice -> 'a slice list + val fields: ('a -> bool) -> 'a slice -> 'a slice list + + val toList: 'a slice -> 'a list + end diff --git a/basis-library/arrays-and-vectors/vector.sig b/basis-library/arrays-and-vectors/vector.sig new file mode 100644 index 0000000..60d741b --- /dev/null +++ b/basis-library/arrays-and-vectors/vector.sig @@ -0,0 +1,61 @@ +signature VECTOR_GLOBAL = + sig + type 'a vector = 'a vector + end + +signature VECTOR = + sig + include VECTOR_GLOBAL + + val maxLen: int + val fromList: 'a list -> 'a vector + val tabulate: int * (int -> 'a) -> 'a vector + val length: 'a vector -> int + val sub: 'a vector * int -> 'a + val update: 'a vector * int * 'a -> 'a vector + val concat: 'a vector list -> 'a vector + val appi: (int * 'a -> unit) -> 'a vector -> unit + val app: ('a -> unit) -> 'a vector -> unit + val mapi : (int * 'a -> 'b) -> 'a vector -> 'b vector + val map: ('a -> 'b) -> 'a vector -> 'b vector + val foldli: (int * 'a * 'b -> 'b) -> 'b -> 'a vector -> 'b + val foldri: (int * 'a * 'b -> 'b) -> 'b -> 'a vector -> 'b + val foldl: ('a * 'b -> 'b) -> 'b -> 'a vector -> 'b + val foldr: ('a * 'b -> 'b) -> 'b -> 'a vector -> 'b + val findi: (int * 'a -> bool) -> 'a vector -> (int * 'a) option + val find: ('a -> bool) -> 'a vector -> 'a option + val exists: ('a -> bool) -> 'a vector -> bool + val all: ('a -> bool) -> 'a vector -> bool + val collate: ('a * 'a -> order) -> 'a vector * 'a vector -> order + end + +signature VECTOR_EXTRA = + sig + include VECTOR + structure VectorSlice: VECTOR_SLICE_EXTRA + + val copy: {dst: 'a Array.array, di: int, src: 'a vector} -> unit + + val unsafeFromArray: 'a array -> 'a vector + val unsafeSub: 'a vector * int -> 'a + val unsafeCopy: {dst: 'a Array.array, di: int, src: 'a vector} -> unit + + (* Used to implement Substring/String functions *) + val concatWith: 'a vector -> 'a vector list -> 'a vector + val isPrefix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool + val isSubvector: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool + val isSuffix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool + val translate: ('a -> 'b vector) -> 'a vector -> 'b vector + val tokens: ('a -> bool) -> 'a vector -> 'a vector list + val fields: ('a -> bool) -> 'a vector -> 'a vector list + + val append: 'a vector * 'a vector -> 'a vector + val create: int -> {done: unit -> 'a vector, + sub: int -> 'a, + update: int * 'a -> unit} + val duplicate: 'a vector -> 'a vector + val toList: 'a vector -> 'a list + val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b + val unfold: int * 'b * ('b -> 'a * 'b) -> 'a vector * 'b + val vector: int * 'a -> 'a vector + end diff --git a/basis-library/arrays-and-vectors/vector.sml b/basis-library/arrays-and-vectors/vector.sml new file mode 100644 index 0000000..1cf2b22 --- /dev/null +++ b/basis-library/arrays-and-vectors/vector.sml @@ -0,0 +1,44 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Vector: VECTOR_EXTRA = + struct + structure V = Sequence (Primitive.Vector) + open V + + type 'a vector = 'a vector + + structure VectorSlice = + struct + open Slice + type 'a vector = 'a vector + val vector = sequence + + val isSubvector = isSubsequence + val span = fn (sl, sl') => + Primitive.Vector.Slice.span + (op = : ''a vector * ''a vector -> bool) + (sl, sl') + end + + fun update (v, i, x) = + (Primitive.Vector.updateVector (v, SeqIndex.fromInt i, x)) + handle Overflow => raise Subscript + + val isSubvector = isSubsequence + + val unsafeFromArray = Primitive.Vector.unsafeFromArray + + val vector = new + end +structure VectorSlice: VECTOR_SLICE_EXTRA = Vector.VectorSlice + +structure VectorGlobal: VECTOR_GLOBAL = Vector +open VectorGlobal +val vector = Vector.fromList diff --git a/basis-library/basis-1997.mlb b/basis-library/basis-1997.mlb new file mode 100644 index 0000000..d2a388d --- /dev/null +++ b/basis-library/basis-1997.mlb @@ -0,0 +1,28 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + basis-2002.mlb + libs/basis-1997/basis-1997.mlb + in + libs/basis-1997/top-level/basis-funs.sml + libs/basis-1997/top-level/basis-sigs.sml + libs/basis-1997/top-level/top-level.sml + libs/basis-1997/top-level/infixes.sml + ann "allowOverload true" + in + libs/basis-1997/top-level/overloads.sml + end + end +end diff --git a/basis-library/basis-2002.mlb b/basis-library/basis-2002.mlb new file mode 100644 index 0000000..56cd73a --- /dev/null +++ b/basis-library/basis-2002.mlb @@ -0,0 +1,27 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + libs/basis-extra/basis-extra.mlb + libs/basis-2002/basis-2002.mlb + in + libs/basis-2002/top-level/basis-funs.sml + libs/basis-2002/top-level/basis-sigs.sml + libs/basis-2002/top-level/top-level.sml + libs/basis-2002/top-level/infixes.sml + ann "allowOverload true" in + libs/basis-2002/top-level/overloads.sml + end + end +end diff --git a/basis-library/basis-none.mlb b/basis-library/basis-none.mlb new file mode 100644 index 0000000..92126fb --- /dev/null +++ b/basis-library/basis-none.mlb @@ -0,0 +1,26 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + libs/basis-extra/basis-extra.mlb + ann "allowSpecifySpecialIds true" in + libs/basis-none/top-level/basis.sig + end + libs/basis-none/top-level/basis.sml + in + libs/basis-none/top-level/top-level.sml + libs/basis-none/top-level/infixes.sml + end +end diff --git a/basis-library/basis.mlb b/basis-library/basis.mlb new file mode 100644 index 0000000..8f06c40 --- /dev/null +++ b/basis-library/basis.mlb @@ -0,0 +1,8 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +basis-2002.mlb diff --git a/basis-library/build/sources.mlb b/basis-library/build/sources.mlb new file mode 100644 index 0000000..033c0ee --- /dev/null +++ b/basis-library/build/sources.mlb @@ -0,0 +1,388 @@ +(* Copyright (C) 2013,2016-2017 Matthew Fluet. + * Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused false" "forceUsed" +in + ../primitive/primitive.mlb + ../top-level/infixes.sml + ../top-level/infixes-overflow.sml + ../top-level/infixes-unsafe.sml + ../util/dynamic-wind.sig + ../util/dynamic-wind.sml + + ../integer/iwconv0.sml + ../integer/num0.sml + local + ../config/bind/int-prim.sml + ../config/bind/pointer-prim.sml + ../config/bind/real-prim.sml + ../config/bind/word-prim.sml + in ann "forceUsed" in + ../config/objptr/objptr-$(OBJPTR_REP).sml + ../config/metadata/array-metadata-$(ARRAY_METADATA_SIZE).sml + ../config/metadata/normal-metadata-$(NORMAL_METADATA_SIZE).sml + ../config/seqindex/seqindex-$(SEQINDEX_INT).sml + $(LIB_MLTON_DIR)/targets/$(TARGET)/sml/c-types.sml + end end + + ../arrays-and-vectors/slice0.sig + ../arrays-and-vectors/sequence0.sig + local + local + ../config/bind/int-prim.sml + ../config/bind/int-inf-prim.sml + in ann "forceUsed" in + ../config/default/default-$(DEFAULT_INT).sml + end end + in + ../arrays-and-vectors/sequence0.sml + end + + ../integer/int-inf0.sml + local + local + ../config/bind/int-prim.sml + ../config/bind/int-inf-prim.sml + ../config/bind/word-prim.sml + in ann "forceUsed" in + ../config/default/default-$(DEFAULT_INT).sml + ../config/default/default-$(DEFAULT_WORD).sml + ../config/default/fixed-int.sml + ../config/default/large-int.sml + ../config/default/large-word.sml + ../config/c/position.sml + ../config/c/sys-word.sml + end end + in + ../integer/num1.sml + end + + local + ../config/bind/char-prim.sml + ../config/bind/int-prim.sml + ../config/bind/int-inf-prim.sml + ../config/bind/real-prim.sml + ../config/bind/string-prim.sml + ../config/bind/word-prim.sml + in ann "forceUsed" in + ../config/default/default-$(DEFAULT_CHAR).sml + ../config/default/default-$(DEFAULT_WIDECHAR).sml + ../config/default/default-$(DEFAULT_INT).sml + ../config/default/default-$(DEFAULT_REAL).sml + ../config/default/default-$(DEFAULT_WORD).sml + ../config/default/fixed-int.sml + ../config/default/large-int.sml + ../config/default/large-real.sml + ../config/default/large-word.sml + end end + ../general/general.sig + ../general/general.sml + ../util/one.sml + ../general/option.sig + ../general/option.sml + ../list/list.sig + ../list/list.sml + ../list/list-pair.sig + ../list/list-pair.sml + local + ../config/bind/int-prim.sml + in ann "forceUsed" in + ../config/seqindex/seqindex-$(SEQINDEX_INT).sml + end end + ../arrays-and-vectors/slice.sig + ../arrays-and-vectors/sequence.sig + ../arrays-and-vectors/sequence.fun + ../arrays-and-vectors/vector-slice.sig + ../arrays-and-vectors/vector.sig + ../arrays-and-vectors/vector.sml + ../arrays-and-vectors/array-slice.sig + ../arrays-and-vectors/array.sig + ../arrays-and-vectors/array.sml + ../arrays-and-vectors/array2.sig + ../arrays-and-vectors/array2.sml + ../arrays-and-vectors/mono-vector-slice.sig + ../arrays-and-vectors/mono-vector.sig + ../arrays-and-vectors/mono-vector.fun + ../arrays-and-vectors/mono-array-slice.sig + ../arrays-and-vectors/mono-array.sig + ../arrays-and-vectors/mono-array.fun + ../arrays-and-vectors/mono-array2.sig + ../arrays-and-vectors/mono-array2.fun + ../arrays-and-vectors/mono.sml + ../text/char0.sig + ../text/string0.sml + ../text/char0.sml + ../util/reader.sig + ../util/reader.sml + ../text/string-cvt.sig + ../text/string-cvt.sml + ../general/bool.sig + ../general/bool.sml + ../integer/integer.sig + ../integer/int.sml + ../integer/word.sig + ../integer/word.sml + local + ../config/bind/int-top.sml + ../config/bind/pointer-prim.sml + ../config/bind/real-prim.sml + ../config/bind/word-top.sml + in ann "forceUsed" in + ../config/objptr/objptr-$(OBJPTR_REP).sml + $(LIB_MLTON_DIR)/targets/$(TARGET)/sml/c-types.sml + ../config/c/position.sml + ../config/c/sys-word.sml + end end + ../integer/int-inf.sig + ../integer/int-inf.sml + local + ../config/bind/int-top.sml + ../config/bind/int-inf-top.sml + ../config/bind/word-top.sml + in ann "forceUsed" in + ../config/default/default-$(DEFAULT_INT).sml + ../config/default/default-$(DEFAULT_WORD).sml + ../config/default/fixed-int.sml + ../config/default/large-int.sml + ../config/default/large-word.sml + end end + ../integer/int-global.sml + ../integer/word-global.sml + ../top-level/arithmetic.sml + ../util/natural.sml + ../integer/embed-int.sml + ../integer/embed-word.sml + ../integer/pack-word.sig + ../integer/pack-word.sml + local + ../config/bind/int-top.sml + ../config/bind/pointer-prim.sml + ../config/bind/real-prim.sml + ../config/bind/word-top.sml + in ann "forceUsed" in + ../config/objptr/objptr-$(OBJPTR_REP).sml + $(LIB_MLTON_DIR)/targets/$(TARGET)/sml/c-types.sml + ../config/c/position.sml + ../config/c/sys-word.sml + end end + + ../text/char.sig + ../text/string.sig + ../text/substring.sig + ../text/text.sig + + ../util/heap.sml + ../text/char.sml + ../text/string.sml + ../text/substring.sml + ../text/text.sml + ../text/char-global.sml + ../text/string-global.sml + ../text/substring-global.sml + ../text/byte.sig + ../text/byte.sml + + ../text/nullstring.sml + ../util/CUtil.sig + ../util/CUtil.sml + + ../util/unique-id.sig + ../util/unique-id.fun + ../util/cleaner.sig + ../util/cleaner.sml + ../util/abs-rep.sig + ../util/abs-rep.fun + + ../config/c/sys-types.sml + ../system/pre-os.sml + ../posix/pre-posix.sml + + ../posix/error.sig + ../posix/error.sml + + ../real/IEEE-real.sig + ../real/IEEE-real.sml + ../real/math.sig + ../real/real.sig + ../real/real.sml + local + ../config/bind/real-top.sml + in ann "forceUsed" in + ../config/default/default-$(DEFAULT_REAL).sml + ../config/default/large-real.sml + end end + ../real/real-global.sml + ../real/pack-real.sig + ../real/pack-real.sml + local + ../config/bind/int-top.sml + ../config/bind/pointer-prim.sml + ../config/bind/real-top.sml + ../config/bind/word-top.sml + in ann "forceUsed" in + ../config/objptr/objptr-$(OBJPTR_REP).sml + $(LIB_MLTON_DIR)/targets/$(TARGET)/sml/c-types.sml + ../config/c/position.sml + ../config/c/sys-word.sml + end end + + ../system/time.sig + ../system/time.sml + ../system/date.sig + ../system/date.sml + ../io/io.sig + ../io/io.sml + ../io/prim-io.sig + ../io/prim-io.fun + ../io/bin-prim-io.sml + ../io/text-prim-io.sml + + ../posix/stub-mingw.sml + ../posix/flags.sig + ../posix/flags.sml + ../posix/signal.sig + ../posix/signal.sml + ../posix/proc-env.sig + ../posix/proc-env.sml + ../posix/file-sys.sig + ../posix/file-sys.sml + ../posix/io.sig + ../posix/io.sml + ../posix/process.sig + ../posix/process.sml + ../posix/sys-db.sig + ../posix/sys-db.sml + ../posix/tty.sig + ../posix/tty.sml + ../posix/posix.sig + ../posix/posix.sml + + ../platform/cygwin.sml + ../platform/mingw.sml + + ../io/stream-io.sig + ../io/stream-io.fun + ../io/imperative-io.sig + ../io/imperative-io.fun + ../io/bin-stream-io.sig + ../io/bin-io.sig + ../io/bin-io.sml + ../io/text-stream-io.sig + ../io/text-io.sig + ../io/text-io.sml + + ../system/path.sig + ../system/path.sml + ../system/file-sys.sig + ../system/file-sys.sml + ../system/command-line.sig + ../system/command-line.sml + + ../general/sml90.sig + ../general/sml90.sml + + ../mlton/pointer.sig + ../mlton/pointer.sml + ../mlton/call-stack.sig + ../mlton/call-stack.sml + ../mlton/exit.sml + ../mlton/exn.sig + ../mlton/exn.sml + ../mlton/thread.sig + ../mlton/thread.sml + ../mlton/signal.sig + ../mlton/signal.sml + ../mlton/process.sig + ../mlton/process.sml + ../mlton/gc.sig + ../mlton/gc.sml + ../mlton/rusage.sig + ../mlton/rusage.sml + + ../system/process.sig + ../system/process.sml + ../system/io.sig + ../system/io.sml + ../system/os.sig + ../system/os.sml + ../system/unix.sig + ../system/unix.sml + ../system/timer.sig + ../system/timer.sml + + ../net/net.sig + ../net/net.sml + ../net/net-host-db.sig + ../net/net-host-db.sml + ../net/net-prot-db.sig + ../net/net-prot-db.sml + ../net/net-serv-db.sig + ../net/net-serv-db.sml + ../net/socket.sig + ../net/socket.sml + ../net/generic-sock.sig + ../net/generic-sock.sml + ../net/inet-sock.sig + ../net/inet-sock.sml + ../net/unix-sock.sig + ../net/unix-sock.sml + + ../mlton/platform.sig + ../mlton/platform.sml + ../mlton/array.sig + ../mlton/cont.sig + ../mlton/cont.sml + ../mlton/random.sig + ../mlton/random.sml + ../mlton/io.sig + ../mlton/io.fun + ../mlton/text-io.sig + ../mlton/bin-io.sig + ../mlton/itimer.sig + ../mlton/itimer.sml + ../mlton/ffi.sig + ann + "ffiStr MLtonFFI" + in + ../mlton/ffi.sml + end + ../mlton/int-inf.sig + ../mlton/proc-env.sig + ../mlton/proc-env.sml + ../mlton/profile.sig + ../mlton/profile.sml + (* ../mlton/ptrace.sig *) + (* ../mlton/ptrace.sml *) + ../mlton/rlimit.sig + ../mlton/rlimit.sml + ../mlton/syslog.sig + ../mlton/syslog.sml + ../mlton/vector.sig + ../mlton/weak.sig + ../mlton/weak.sml + ../mlton/finalizable.sig + ../mlton/finalizable.sml + ../mlton/real.sig + ../mlton/word.sig + ../mlton/world.sig + ../mlton/world.sml + ../mlton/mono-array.sig + ../mlton/mono-vector.sig + ../mlton/mlton.sig + ../mlton/mlton.sml + + ../sml-nj/sml-nj.sig + ../sml-nj/sml-nj.sml + ../sml-nj/unsafe.sig + ../sml-nj/unsafe.sml +end diff --git a/basis-library/c-types.mlb b/basis-library/c-types.mlb new file mode 100644 index 0000000..b387210 --- /dev/null +++ b/basis-library/c-types.mlb @@ -0,0 +1,95 @@ +(* Copyright (C) 2010 Matthew Fluet. + * Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + basis.mlb + mlton.mlb + local + config/choose-int.sml + config/choose-real.sml + config/choose-word.sml + config/c/word-to-bool.sml + config/bind/int-top.sml + config/bind/real-top.sml + config/bind/word-top.sml + in ann "forceUsed" in + $(LIB_MLTON_DIR)/targets/$(TARGET)/sml/c-types.sml + end end + local + local + primitive/primitive.mlb + in + structure Primitive + end + in + c/pointer.sig + c/pointer.sml + end + in + structure C_Char + structure C_SChar + functor C_SChar_ChooseIntN + structure C_UChar + functor C_UChar_ChooseWordN + + structure C_Short + structure C_SShort + functor C_SShort_ChooseIntN + structure C_UShort + functor C_UShort_ChooseWordN + + structure C_Int + structure C_SInt + functor C_SInt_ChooseIntN + structure C_UInt + functor C_UInt_ChooseWordN + + structure C_Long + structure C_SLong + functor C_SLong_ChooseIntN + structure C_ULong + functor C_ULong_ChooseWordN + + structure C_LongLong + structure C_SLongLong + functor C_SLongLong_ChooseIntN + structure C_ULongLong + functor C_ULongLong_ChooseWordN + + structure C_Float + functor C_Float_ChooseRealN + structure C_Double + functor C_Double_ChooseRealN + + structure C_Size + functor C_Size_ChooseWordN + + structure C_Ptrdiff + functor C_Ptrdiff_ChooseIntN + + structure C_Intmax + functor C_Intmax_ChooseIntN + structure C_UIntmax + functor C_UIntmax_ChooseWordN + + structure C_Intptr + functor C_Intptr_ChooseIntN + structure C_UIntptr + functor C_UIntptr_ChooseWordN + + signature C_POINTER + structure C_Pointer + end +end diff --git a/basis-library/c/pointer.sig b/basis-library/c/pointer.sig new file mode 100644 index 0000000..8e5d71c --- /dev/null +++ b/basis-library/c/pointer.sig @@ -0,0 +1,77 @@ +(* Copyright (C) 2010 Matthew Fluet. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature C_POINTER = +sig + type t = MLton.Pointer.t + val add: t * C_Ptrdiff.t -> t + val compare: t * t -> order + val diff: t * t -> C_Ptrdiff.t + val fromWord: C_Size.t -> t + val getC_SChar: t * C_Ptrdiff.t -> C_SChar.t + val getC_UChar: t * C_Ptrdiff.t -> C_UChar.t + val getC_SShort: t * C_Ptrdiff.t -> C_SShort.t + val getC_UShort: t * C_Ptrdiff.t -> C_UShort.t + val getC_SInt: t * C_Ptrdiff.t -> C_SInt.t + val getC_UInt: t * C_Ptrdiff.t -> C_UInt.t + val getC_SLong: t * C_Ptrdiff.t -> C_SLong.t + val getC_ULong: t * C_Ptrdiff.t -> C_ULong.t + val getC_SLongLong: t * C_Ptrdiff.t -> C_SLongLong.t + val getC_ULongLong: t * C_Ptrdiff.t -> C_ULongLong.t + val getC_Float: t * C_Ptrdiff.t -> C_Float.t + val getC_Double: t * C_Ptrdiff.t -> C_Double.t + val getC_Size: t * C_Ptrdiff.t -> C_Size.t + val getC_Ptrdiff: t * C_Ptrdiff.t -> C_Ptrdiff.t + val getC_Intmax: t * C_Ptrdiff.t -> C_Intmax.t + val getC_UIntmax: t * C_Ptrdiff.t -> C_UIntmax.t + val getC_Intptr: t * C_Ptrdiff.t -> C_Intptr.t + val getC_UIntptr: t * C_Ptrdiff.t -> C_UIntptr.t + val getC_Pointer: t * C_Ptrdiff.t -> t + val getInt8: t * C_Ptrdiff.t -> Int8.int + val getInt16: t * C_Ptrdiff.t -> Int16.int + val getInt32: t * C_Ptrdiff.t -> Int32.int + val getInt64: t * C_Ptrdiff.t -> Int64.int + val getReal32: t * C_Ptrdiff.t -> Real32.real + val getReal64: t * C_Ptrdiff.t -> Real64.real + val getWord8: t * C_Ptrdiff.t -> Word8.word + val getWord16: t * C_Ptrdiff.t -> Word16.word + val getWord32: t * C_Ptrdiff.t -> Word32.word + val getWord64: t * C_Ptrdiff.t -> Word64.word + val isNull: t -> bool + val null: t + val setC_SChar: t * C_Ptrdiff.t * C_SChar.t -> unit + val setC_UChar: t * C_Ptrdiff.t * C_UChar.t -> unit + val setC_SShort: t * C_Ptrdiff.t * C_SShort.t -> unit + val setC_UShort: t * C_Ptrdiff.t * C_UShort.t -> unit + val setC_SInt: t * C_Ptrdiff.t * C_SInt.t -> unit + val setC_UInt: t * C_Ptrdiff.t * C_UInt.t -> unit + val setC_SLong: t * C_Ptrdiff.t * C_SLong.t -> unit + val setC_ULong: t * C_Ptrdiff.t * C_ULong.t -> unit + val setC_SLongLong: t * C_Ptrdiff.t * C_SLongLong.t -> unit + val setC_ULongLong: t * C_Ptrdiff.t * C_ULongLong.t -> unit + val setC_Float: t * C_Ptrdiff.t * C_Float.t -> unit + val setC_Double: t * C_Ptrdiff.t * C_Double.t -> unit + val setC_Size: t * C_Ptrdiff.t * C_Size.t -> unit + val setC_Ptrdiff: t * C_Ptrdiff.t * C_Ptrdiff.t -> unit + val setC_Intmax: t * C_Ptrdiff.t * C_Intmax.t -> unit + val setC_UIntmax: t * C_Ptrdiff.t * C_UIntmax.t -> unit + val setC_Intptr: t * C_Ptrdiff.t * C_Intptr.t -> unit + val setC_UIntptr: t * C_Ptrdiff.t * C_UIntptr.t -> unit + val setC_Pointer: t * C_Ptrdiff.t * t -> unit + val setInt8: t * C_Ptrdiff.t * Int8.int -> unit + val setInt16: t * C_Ptrdiff.t * Int16.int -> unit + val setInt32: t * C_Ptrdiff.t * Int32.int -> unit + val setInt64: t * C_Ptrdiff.t * Int64.int -> unit + val setReal32: t * C_Ptrdiff.t * Real32.real -> unit + val setReal64: t * C_Ptrdiff.t * Real64.real -> unit + val setWord8: t * C_Ptrdiff.t * Word8.word -> unit + val setWord16: t * C_Ptrdiff.t * Word16.word -> unit + val setWord32: t * C_Ptrdiff.t * Word32.word -> unit + val setWord64: t * C_Ptrdiff.t * Word64.word -> unit + val sizeofPointer: C_Size.t + val sub: t * C_Ptrdiff.t -> t + val toWord: t -> C_Size.t +end \ No newline at end of file diff --git a/basis-library/c/pointer.sml b/basis-library/c/pointer.sml new file mode 100644 index 0000000..ea484eb --- /dev/null +++ b/basis-library/c/pointer.sml @@ -0,0 +1,426 @@ +(* Copyright (C) 2010 Matthew Fluet. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure C_Pointer : C_POINTER = +struct + +open Primitive.MLton.Pointer + +val sizeofPointer = C_Size.div (C_Size.fromInt C_Size.wordSize, 0w8) + +local + structure S = + C_SChar_ChooseIntN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fInt8 = getInt8 + val fInt16 = getInt16 + val fInt32 = getInt32 + val fInt64 = getInt64) +in + val getC_SChar = S.f +end +local + structure S = + C_UChar_ChooseWordN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fWord8 = getWord8 + val fWord16 = getWord16 + val fWord32 = getWord32 + val fWord64 = getWord64) +in + val getC_UChar = S.f +end + +local + structure S = + C_SShort_ChooseIntN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fInt8 = getInt8 + val fInt16 = getInt16 + val fInt32 = getInt32 + val fInt64 = getInt64) +in + val getC_SShort = S.f +end +local + structure S = + C_UShort_ChooseWordN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fWord8 = getWord8 + val fWord16 = getWord16 + val fWord32 = getWord32 + val fWord64 = getWord64) +in + val getC_UShort = S.f +end + +local + structure S = + C_SInt_ChooseIntN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fInt8 = getInt8 + val fInt16 = getInt16 + val fInt32 = getInt32 + val fInt64 = getInt64) +in + val getC_SInt = S.f +end +local + structure S = + C_UInt_ChooseWordN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fWord8 = getWord8 + val fWord16 = getWord16 + val fWord32 = getWord32 + val fWord64 = getWord64) +in + val getC_UInt = S.f +end + +local + structure S = + C_SLong_ChooseIntN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fInt8 = getInt8 + val fInt16 = getInt16 + val fInt32 = getInt32 + val fInt64 = getInt64) +in + val getC_SLong = S.f +end +local + structure S = + C_ULong_ChooseWordN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fWord8 = getWord8 + val fWord16 = getWord16 + val fWord32 = getWord32 + val fWord64 = getWord64) +in + val getC_ULong = S.f +end + +local + structure S = + C_SLongLong_ChooseIntN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fInt8 = getInt8 + val fInt16 = getInt16 + val fInt32 = getInt32 + val fInt64 = getInt64) +in + val getC_SLongLong = S.f +end +local + structure S = + C_ULongLong_ChooseWordN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fWord8 = getWord8 + val fWord16 = getWord16 + val fWord32 = getWord32 + val fWord64 = getWord64) +in + val getC_ULongLong = S.f +end + +local + structure S = + C_Float_ChooseRealN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fReal32 = getReal32 + val fReal64 = getReal64) +in + val getC_Float = S.f +end +local + structure S = + C_Double_ChooseRealN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fReal32 = getReal32 + val fReal64 = getReal64) +in + val getC_Double = S.f +end + +local + structure S = + C_Size_ChooseWordN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fWord8 = getWord8 + val fWord16 = getWord16 + val fWord32 = getWord32 + val fWord64 = getWord64) +in + val getC_Size = S.f +end +local + structure S = + C_Ptrdiff_ChooseIntN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fInt8 = getInt8 + val fInt16 = getInt16 + val fInt32 = getInt32 + val fInt64 = getInt64) +in + val getC_Ptrdiff = S.f +end + +local + structure S = + C_Intmax_ChooseIntN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fInt8 = getInt8 + val fInt16 = getInt16 + val fInt32 = getInt32 + val fInt64 = getInt64) +in + val getC_Intmax = S.f +end +local + structure S = + C_UIntmax_ChooseWordN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fWord8 = getWord8 + val fWord16 = getWord16 + val fWord32 = getWord32 + val fWord64 = getWord64) +in + val getC_UIntmax = S.f +end + +local + structure S = + C_Intptr_ChooseIntN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fInt8 = getInt8 + val fInt16 = getInt16 + val fInt32 = getInt32 + val fInt64 = getInt64) +in + val getC_Intptr = S.f +end +local + structure S = + C_UIntptr_ChooseWordN + (type 'a t = t * C_Ptrdiff.t -> 'a + val fWord8 = getWord8 + val fWord16 = getWord16 + val fWord32 = getWord32 + val fWord64 = getWord64) +in + val getC_UIntptr = S.f +end + +val getC_Pointer = getCPointer + + +local + structure S = + C_SChar_ChooseIntN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fInt8 = setInt8 + val fInt16 = setInt16 + val fInt32 = setInt32 + val fInt64 = setInt64) +in + val setC_SChar = S.f +end +local + structure S = + C_UChar_ChooseWordN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fWord8 = setWord8 + val fWord16 = setWord16 + val fWord32 = setWord32 + val fWord64 = setWord64) +in + val setC_UChar = S.f +end + +local + structure S = + C_SShort_ChooseIntN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fInt8 = setInt8 + val fInt16 = setInt16 + val fInt32 = setInt32 + val fInt64 = setInt64) +in + val setC_SShort = S.f +end +local + structure S = + C_UShort_ChooseWordN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fWord8 = setWord8 + val fWord16 = setWord16 + val fWord32 = setWord32 + val fWord64 = setWord64) +in + val setC_UShort = S.f +end + +local + structure S = + C_SInt_ChooseIntN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fInt8 = setInt8 + val fInt16 = setInt16 + val fInt32 = setInt32 + val fInt64 = setInt64) +in + val setC_SInt = S.f +end +local + structure S = + C_UInt_ChooseWordN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fWord8 = setWord8 + val fWord16 = setWord16 + val fWord32 = setWord32 + val fWord64 = setWord64) +in + val setC_UInt = S.f +end + +local + structure S = + C_SLong_ChooseIntN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fInt8 = setInt8 + val fInt16 = setInt16 + val fInt32 = setInt32 + val fInt64 = setInt64) +in + val setC_SLong = S.f +end +local + structure S = + C_ULong_ChooseWordN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fWord8 = setWord8 + val fWord16 = setWord16 + val fWord32 = setWord32 + val fWord64 = setWord64) +in + val setC_ULong = S.f +end + +local + structure S = + C_SLongLong_ChooseIntN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fInt8 = setInt8 + val fInt16 = setInt16 + val fInt32 = setInt32 + val fInt64 = setInt64) +in + val setC_SLongLong = S.f +end +local + structure S = + C_ULongLong_ChooseWordN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fWord8 = setWord8 + val fWord16 = setWord16 + val fWord32 = setWord32 + val fWord64 = setWord64) +in + val setC_ULongLong = S.f +end + +local + structure S = + C_Float_ChooseRealN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fReal32 = setReal32 + val fReal64 = setReal64) +in + val setC_Float = S.f +end +local + structure S = + C_Double_ChooseRealN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fReal32 = setReal32 + val fReal64 = setReal64) +in + val setC_Double = S.f +end + +local + structure S = + C_Size_ChooseWordN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fWord8 = setWord8 + val fWord16 = setWord16 + val fWord32 = setWord32 + val fWord64 = setWord64) +in + val setC_Size = S.f +end +local + structure S = + C_Ptrdiff_ChooseIntN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fInt8 = setInt8 + val fInt16 = setInt16 + val fInt32 = setInt32 + val fInt64 = setInt64) +in + val setC_Ptrdiff = S.f +end + +local + structure S = + C_Intmax_ChooseIntN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fInt8 = setInt8 + val fInt16 = setInt16 + val fInt32 = setInt32 + val fInt64 = setInt64) +in + val setC_Intmax = S.f +end +local + structure S = + C_UIntmax_ChooseWordN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fWord8 = setWord8 + val fWord16 = setWord16 + val fWord32 = setWord32 + val fWord64 = setWord64) +in + val setC_UIntmax = S.f +end + +local + structure S = + C_Intptr_ChooseIntN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fInt8 = setInt8 + val fInt16 = setInt16 + val fInt32 = setInt32 + val fInt64 = setInt64) +in + val setC_Intptr = S.f +end +local + structure S = + C_UIntptr_ChooseWordN + (type 'a t = t * C_Ptrdiff.t * 'a -> unit + val fWord8 = setWord8 + val fWord16 = setWord16 + val fWord32 = setWord32 + val fWord64 = setWord64) +in + val setC_UIntptr = S.f +end + +val setC_Pointer = setCPointer + + +end diff --git a/basis-library/config/bind/char-prim.sml b/basis-library/config/bind/char-prim.sml new file mode 100644 index 0000000..212267f --- /dev/null +++ b/basis-library/config/bind/char-prim.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Char8 = Primitive.Char8 +structure Char16 = Primitive.Char16 +structure Char32 = Primitive.Char32 diff --git a/basis-library/config/bind/int-inf-prim.sml b/basis-library/config/bind/int-inf-prim.sml new file mode 100644 index 0000000..e502db5 --- /dev/null +++ b/basis-library/config/bind/int-inf-prim.sml @@ -0,0 +1,8 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure IntInf = Primitive.IntInf diff --git a/basis-library/config/bind/int-inf-top.sml b/basis-library/config/bind/int-inf-top.sml new file mode 100644 index 0000000..f11e532 --- /dev/null +++ b/basis-library/config/bind/int-inf-top.sml @@ -0,0 +1,8 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure IntInf = IntInf diff --git a/basis-library/config/bind/int-prim.sml b/basis-library/config/bind/int-prim.sml new file mode 100644 index 0000000..0304d9f --- /dev/null +++ b/basis-library/config/bind/int-prim.sml @@ -0,0 +1,11 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Int8 = Primitive.Int8 +structure Int16 = Primitive.Int16 +structure Int32 = Primitive.Int32 +structure Int64 = Primitive.Int64 diff --git a/basis-library/config/bind/int-top.sml b/basis-library/config/bind/int-top.sml new file mode 100644 index 0000000..98996ae --- /dev/null +++ b/basis-library/config/bind/int-top.sml @@ -0,0 +1,11 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Int8 = Int8 +structure Int16 = Int16 +structure Int32 = Int32 +structure Int64 = Int64 diff --git a/basis-library/config/bind/pointer-mlton.sml b/basis-library/config/bind/pointer-mlton.sml new file mode 100644 index 0000000..f92540d --- /dev/null +++ b/basis-library/config/bind/pointer-mlton.sml @@ -0,0 +1,8 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Pointer = MLton.Pointer diff --git a/basis-library/config/bind/pointer-prim.sml b/basis-library/config/bind/pointer-prim.sml new file mode 100644 index 0000000..525dc2a --- /dev/null +++ b/basis-library/config/bind/pointer-prim.sml @@ -0,0 +1,8 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Pointer = Primitive.Pointer diff --git a/basis-library/config/bind/real-prim.sml b/basis-library/config/bind/real-prim.sml new file mode 100644 index 0000000..76882bf --- /dev/null +++ b/basis-library/config/bind/real-prim.sml @@ -0,0 +1,9 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Real32 = Primitive.Real32 +structure Real64 = Primitive.Real64 diff --git a/basis-library/config/bind/real-top.sml b/basis-library/config/bind/real-top.sml new file mode 100644 index 0000000..7dfe308 --- /dev/null +++ b/basis-library/config/bind/real-top.sml @@ -0,0 +1,9 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Real32 = Real32 +structure Real64 = Real64 diff --git a/basis-library/config/bind/string-prim.sml b/basis-library/config/bind/string-prim.sml new file mode 100644 index 0000000..fab5827 --- /dev/null +++ b/basis-library/config/bind/string-prim.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure String8 = Primitive.String8 +structure String16 = Primitive.String16 +structure String32 = Primitive.String32 diff --git a/basis-library/config/bind/word-prim.sml b/basis-library/config/bind/word-prim.sml new file mode 100644 index 0000000..19dadb8 --- /dev/null +++ b/basis-library/config/bind/word-prim.sml @@ -0,0 +1,11 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Word8 = Primitive.Word8 +structure Word16 = Primitive.Word16 +structure Word32 = Primitive.Word32 +structure Word64 = Primitive.Word64 diff --git a/basis-library/config/bind/word-top.sml b/basis-library/config/bind/word-top.sml new file mode 100644 index 0000000..2d79f07 --- /dev/null +++ b/basis-library/config/bind/word-top.sml @@ -0,0 +1,11 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Word8 = Word8 +structure Word16 = Word16 +structure Word32 = Word32 +structure Word64 = Word64 diff --git a/basis-library/config/c/errno.sml b/basis-library/config/c/errno.sml new file mode 100644 index 0000000..0d1e549 --- /dev/null +++ b/basis-library/config/c/errno.sml @@ -0,0 +1,18 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure C_Errno :> + sig + type 'a t + val check: 'a t -> 'a + val inject: 'a -> 'a t + end = + struct + type 'a t = 'a + val check = fn x => x + val inject = fn x => x + end diff --git a/basis-library/config/c/position.sml b/basis-library/config/c/position.sml new file mode 100644 index 0000000..15ae6af --- /dev/null +++ b/basis-library/config/c/position.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Position = C_Off + +functor Position_ChooseIntN (A: CHOOSE_INT_ARG) : + sig val f : Position.int A.t end = + C_Off_ChooseIntN (A) diff --git a/basis-library/config/c/sys-types.sml b/basis-library/config/c/sys-types.sml new file mode 100644 index 0000000..18c80f5 --- /dev/null +++ b/basis-library/config/c/sys-types.sml @@ -0,0 +1,84 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature C_SYSTYPE = + sig + type t + val castFromSysWord: SysWord.word -> t + val castToSysWord: t -> SysWord.t + end +signature C_FLAGTYPE = + sig + include C_SYSTYPE + val andb: t * t -> t + val notb: t -> t + val orb: t * t -> t + end + +(* from *) +structure C_DirP : C_SYSTYPE = C_DirP + +(* from *) +structure C_NFds : sig + include C_SYSTYPE + val fromInt: Int.int -> t + end = C_NFds + +(* from *) +structure C_RLim : C_SYSTYPE = C_RLim + +(* from *) +structure C_Clock : sig + include C_SYSTYPE + val castFromFixedInt: FixedInt.int -> t + val toLargeInt: t -> LargeInt.int + end = C_Clock +structure C_Dev : C_SYSTYPE = C_Dev +structure C_GId : C_SYSTYPE = C_GId +structure C_INo : C_SYSTYPE = C_INo +structure C_Mode : C_FLAGTYPE = C_Mode +structure C_NLink : sig + include C_SYSTYPE + val toInt: t -> int + end = C_NLink +structure C_Off = C_Off +structure C_PId : sig + include C_SYSTYPE + val castFromFixedInt: FixedInt.int -> t + val ~ : t -> t + end = C_PId +structure C_SSize : sig + include C_SYSTYPE + val castFromFixedInt: FixedInt.int -> t + val toInt: t -> Int.int + end = C_SSize +structure C_SUSeconds : sig + include C_SYSTYPE + val castFromFixedInt: FixedInt.int -> t + val fromLargeInt: LargeInt.int -> t + val toLargeInt: t -> LargeInt.int + end = C_SUSeconds +structure C_Time : sig + include C_SYSTYPE + val castFromFixedInt: FixedInt.int -> t + val fromInt: Int.int -> t + val fromLargeInt: LargeInt.int -> t + val toInt: t -> Int.int + val toLargeInt: t -> LargeInt.int + end = C_Time +structure C_UId : C_SYSTYPE = C_UId + +(* from *) +structure C_Socklen = C_Socklen + +(* from *) +structure C_CC : C_SYSTYPE = C_CC +structure C_Speed : sig + include C_SYSTYPE + val compare: t * t -> order + end = C_Speed +structure C_TCFlag : C_FLAGTYPE = C_TCFlag diff --git a/basis-library/config/c/sys-word.sml b/basis-library/config/c/sys-word.sml new file mode 100644 index 0000000..9aaf584 --- /dev/null +++ b/basis-library/config/c/sys-word.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure SysWord = C_UIntmax + +functor SysWord_ChooseWordN (A: CHOOSE_WORDN_ARG) : + sig val f : SysWord.word A.t end = + C_UIntmax_ChooseWordN (A) diff --git a/basis-library/config/c/word-to-bool.sml b/basis-library/config/c/word-to-bool.sml new file mode 100644 index 0000000..7b5c700 --- /dev/null +++ b/basis-library/config/c/word-to-bool.sml @@ -0,0 +1,22 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor WordToBool (S : sig + eqtype t + val one: t + val zero: t + end) : sig + eqtype t + val fromBool: bool -> t + val toBool: t -> bool + end = + struct + open S + + val fromBool: bool -> t = fn b => if b then zero else one + val toBool: t -> bool = fn w => w <> zero + end diff --git a/basis-library/config/choose-char.sml b/basis-library/config/choose-char.sml new file mode 100644 index 0000000..13cf7ef --- /dev/null +++ b/basis-library/config/choose-char.sml @@ -0,0 +1,25 @@ +(* Copyright (C) 2010 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature CHOOSE_CHARN_ARG = + sig + type 'a t + val fChar8: Char8.char t + val fChar16: Char16.char t + val fChar32: Char32.char t + end + +functor ChooseCharN_Char8 (A : CHOOSE_CHARN_ARG) : + sig val f : Char8.char A.t end = + struct val f = A.fChar8 val _ = A.fChar16 val _ = A.fChar32 end +functor ChooseCharN_Char16 (A : CHOOSE_CHARN_ARG) : + sig val f : Char16.char A.t end = + struct val _ = A.fChar8 val f = A.fChar16 val _ = A.fChar32 end +functor ChooseCharN_Char32 (A : CHOOSE_CHARN_ARG) : + sig val f : Char32.char A.t end = + struct val _ = A.fChar8 val _ = A.fChar16 val f = A.fChar32 end diff --git a/basis-library/config/choose-int.sml b/basis-library/config/choose-int.sml new file mode 100644 index 0000000..3284fb0 --- /dev/null +++ b/basis-library/config/choose-int.sml @@ -0,0 +1,55 @@ +(* Copyright (C) 2010 Matthew Fluet. +* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature CHOOSE_INTN_ARG = + sig + type 'a t + val fInt8: Int8.int t + val fInt16: Int16.int t + val fInt32: Int32.int t + val fInt64: Int64.int t + end + +functor ChooseIntN_Int8 (A : CHOOSE_INTN_ARG) : + sig val f : Int8.int A.t end = + struct val f = A.fInt8 val _ = A.fInt16 val _ = A.fInt32 val _ = A.fInt64 end +functor ChooseIntN_Int16 (A : CHOOSE_INTN_ARG) : + sig val f : Int16.int A.t end = + struct val _ = A.fInt8 val f = A.fInt16 val _ = A.fInt32 val _ = A.fInt64 end +functor ChooseIntN_Int32 (A : CHOOSE_INTN_ARG) : + sig val f : Int32.int A.t end = + struct val _ = A.fInt8 val _ = A.fInt16 val f = A.fInt32 val _ = A.fInt64 end +functor ChooseIntN_Int64 (A : CHOOSE_INTN_ARG) : + sig val f : Int64.int A.t end = + struct val _ = A.fInt8 val _ = A.fInt16 val _ = A.fInt32 val f = A.fInt64 end + +signature CHOOSE_INT_ARG = + sig + type 'a t + val fInt8: Int8.int t + val fInt16: Int16.int t + val fInt32: Int32.int t + val fInt64: Int64.int t + val fIntInf: IntInf.int t + end + +functor ChooseInt_Int8 (A : CHOOSE_INT_ARG) : + sig val f : Int8.int A.t end = + struct val f = A.fInt8 val _ = A.fInt16 val _ = A.fInt32 val _ = A.fInt64 val _ = A.fIntInf end +functor ChooseInt_Int16 (A : CHOOSE_INT_ARG) : + sig val f : Int16.int A.t end = + struct val _ = A.fInt8 val f = A.fInt16 val _ = A.fInt32 val _ = A.fInt64 val _ = A.fIntInf end +functor ChooseInt_Int32 (A : CHOOSE_INT_ARG) : + sig val f : Int32.int A.t end = + struct val _ = A.fInt8 val _ = A.fInt16 val f = A.fInt32 val _ = A.fInt64 val _ = A.fIntInf end +functor ChooseInt_Int64 (A : CHOOSE_INT_ARG) : + sig val f : Int64.int A.t end = + struct val _ = A.fInt8 val _ = A.fInt16 val _ = A.fInt32 val f = A.fInt64 val _ = A.fIntInf end +functor ChooseInt_IntInf (A : CHOOSE_INT_ARG) : + sig val f : IntInf.int A.t end = + struct val _ = A.fInt8 val _ = A.fInt16 val _ = A.fInt32 val _ = A.fInt64 val f = A.fIntInf end diff --git a/basis-library/config/choose-real.sml b/basis-library/config/choose-real.sml new file mode 100644 index 0000000..0b41058 --- /dev/null +++ b/basis-library/config/choose-real.sml @@ -0,0 +1,21 @@ +(* Copyright (C) 2010 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature CHOOSE_REALN_ARG = + sig + type 'a t + val fReal32: Real32.real t + val fReal64: Real64.real t + end + +functor ChooseRealN_Real32 (A : CHOOSE_REALN_ARG) : + sig val f : Real32.real A.t end = + struct val f = A.fReal32 val _ = A.fReal64 end +functor ChooseRealN_Real64 (A : CHOOSE_REALN_ARG) : + sig val f : Real64.real A.t end = + struct val _ = A.fReal32 val f = A.fReal64 end diff --git a/basis-library/config/choose-string.sml b/basis-library/config/choose-string.sml new file mode 100644 index 0000000..09e489c --- /dev/null +++ b/basis-library/config/choose-string.sml @@ -0,0 +1,24 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature CHOOSE_STRINGN_ARG = + sig + type 'a t + val fString8: String8.string t + val fString16: String16.string t + val fString32: String32.string t + end + +functor ChooseStringN_String8 (A : CHOOSE_STRINGN_ARG) : + sig val f : String8.string A.t end = + struct val f = A.fString8 end +functor ChooseStringN_String16 (A : CHOOSE_STRINGN_ARG) : + sig val f : String16.string A.t end = + struct val f = A.fString16 end +functor ChooseStringN_String32 (A : CHOOSE_STRINGN_ARG) : + sig val f : String32.string A.t end = + struct val f = A.fString32 end diff --git a/basis-library/config/choose-word.sml b/basis-library/config/choose-word.sml new file mode 100644 index 0000000..4cc38d8 --- /dev/null +++ b/basis-library/config/choose-word.sml @@ -0,0 +1,29 @@ +(* Copyright (C) 2010 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature CHOOSE_WORDN_ARG = + sig + type 'a t + val fWord8: Word8.word t + val fWord16: Word16.word t + val fWord32: Word32.word t + val fWord64: Word64.word t + end + +functor ChooseWordN_Word8 (A : CHOOSE_WORDN_ARG) : + sig val f : Word8.word A.t end = + struct val f = A.fWord8 val _ = A.fWord16 val _ = A.fWord32 val _ = A.fWord64 end +functor ChooseWordN_Word16 (A : CHOOSE_WORDN_ARG) : + sig val f : Word16.word A.t end = + struct val _ = A.fWord8 val f = A.fWord16 val _ = A.fWord32 val _ = A.fWord64 end +functor ChooseWordN_Word32 (A : CHOOSE_WORDN_ARG) : + sig val f : Word32.word A.t end = + struct val _ = A.fWord8 val _ = A.fWord16 val f = A.fWord32 val _ = A.fWord64 end +functor ChooseWordN_Word64 (A : CHOOSE_WORDN_ARG) : + sig val f : Word64.word A.t end = + struct val _ = A.fWord8 val _ = A.fWord16 val _ = A.fWord32 val f = A.fWord64 end diff --git a/basis-library/config/default/default-char8.sml b/basis-library/config/default/default-char8.sml new file mode 100644 index 0000000..fbb69ff --- /dev/null +++ b/basis-library/config/default/default-char8.sml @@ -0,0 +1,19 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Char = Char8 +type char = Char.char +structure String = String8 +type string = String.string + +functor Char_ChooseChar (A: CHOOSE_CHARN_ARG) : + sig val f : Char.char A.t end = + ChooseCharN_Char8 (A) + +functor String_ChooseString (A: CHOOSE_STRINGN_ARG) : + sig val f : String.string A.t end = + ChooseStringN_String8 (A) diff --git a/basis-library/config/default/default-int32.sml b/basis-library/config/default/default-int32.sml new file mode 100644 index 0000000..349d217 --- /dev/null +++ b/basis-library/config/default/default-int32.sml @@ -0,0 +1,13 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Int = Int32 +type int = Int.int + +functor Int_ChooseInt (A: CHOOSE_INT_ARG) : + sig val f : Int.int A.t end = + ChooseInt_Int32 (A) diff --git a/basis-library/config/default/default-int64.sml b/basis-library/config/default/default-int64.sml new file mode 100644 index 0000000..7fc6a4e --- /dev/null +++ b/basis-library/config/default/default-int64.sml @@ -0,0 +1,13 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Int = Int64 +type int = Int.int + +functor Int_ChooseInt (A: CHOOSE_INT_ARG) : + sig val f : Int.int A.t end = + ChooseInt_Int64 (A) diff --git a/basis-library/config/default/default-intinf.sml b/basis-library/config/default/default-intinf.sml new file mode 100644 index 0000000..67a65fa --- /dev/null +++ b/basis-library/config/default/default-intinf.sml @@ -0,0 +1,13 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Int = IntInf +type int = Int.int + +functor Int_ChooseInt (A: CHOOSE_INT_ARG) : + sig val f : Int.int A.t end = + ChooseInt_IntInf (A) diff --git a/basis-library/config/default/default-real32.sml b/basis-library/config/default/default-real32.sml new file mode 100644 index 0000000..6adf576 --- /dev/null +++ b/basis-library/config/default/default-real32.sml @@ -0,0 +1,13 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Real = Real32 +type real = Real.real + +functor Real_ChooseRealN (A: CHOOSE_REALN_ARG) : + sig val f : Real.real A.t end = + ChooseRealN_Real32 (A) diff --git a/basis-library/config/default/default-real64.sml b/basis-library/config/default/default-real64.sml new file mode 100644 index 0000000..5c66489 --- /dev/null +++ b/basis-library/config/default/default-real64.sml @@ -0,0 +1,13 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Real = Real64 +type real = Real.real + +functor Real_ChooseRealN (A: CHOOSE_REALN_ARG) : + sig val f : Real.real A.t end = + ChooseRealN_Real64 (A) diff --git a/basis-library/config/default/default-widechar16.sml b/basis-library/config/default/default-widechar16.sml new file mode 100644 index 0000000..c3485f1 --- /dev/null +++ b/basis-library/config/default/default-widechar16.sml @@ -0,0 +1,17 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure WideChar = Char16 +structure WideString = String16 + +functor WideChar_ChooseChar (A: CHOOSE_CHARN_ARG) : + sig val f : WideChar.char A.t end = + ChooseCharN_Char16 (A) + +functor WideString_ChooseString (A: CHOOSE_STRINGN_ARG) : + sig val f : WideString.string A.t end = + ChooseStringN_String16 (A) diff --git a/basis-library/config/default/default-widechar32.sml b/basis-library/config/default/default-widechar32.sml new file mode 100644 index 0000000..c40247b --- /dev/null +++ b/basis-library/config/default/default-widechar32.sml @@ -0,0 +1,17 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure WideChar = Char32 +structure WideString = String32 + +functor WideChar_ChooseChar (A: CHOOSE_CHARN_ARG) : + sig val f : WideChar.char A.t end = + ChooseCharN_Char32 (A) + +functor WideString_ChooseString (A: CHOOSE_STRINGN_ARG) : + sig val f : WideString.string A.t end = + ChooseStringN_String32 (A) diff --git a/basis-library/config/default/default-word32.sml b/basis-library/config/default/default-word32.sml new file mode 100644 index 0000000..c2f1ab3 --- /dev/null +++ b/basis-library/config/default/default-word32.sml @@ -0,0 +1,13 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Word = Word32 +type word = Word.word + +functor Word_ChooseWordN (A: CHOOSE_WORDN_ARG) : + sig val f : Word.word A.t end = + ChooseWordN_Word32 (A) diff --git a/basis-library/config/default/default-word64.sml b/basis-library/config/default/default-word64.sml new file mode 100644 index 0000000..0500ea3 --- /dev/null +++ b/basis-library/config/default/default-word64.sml @@ -0,0 +1,13 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Word = Word64 +type word = Word.word + +functor Word_ChooseWordN (A: CHOOSE_WORDN_ARG) : + sig val f : Word.word A.t end = + ChooseWordN_Word64 (A) diff --git a/basis-library/config/default/fixed-int.sml b/basis-library/config/default/fixed-int.sml new file mode 100644 index 0000000..665dc17 --- /dev/null +++ b/basis-library/config/default/fixed-int.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure FixedInt = Int64 + +functor FixedInt_ChooseIntN (A: CHOOSE_INTN_ARG) : + sig val f : FixedInt.int A.t end = + ChooseIntN_Int64 (A) diff --git a/basis-library/config/default/large-int.sml b/basis-library/config/default/large-int.sml new file mode 100644 index 0000000..742a009 --- /dev/null +++ b/basis-library/config/default/large-int.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure LargeInt = IntInf + +functor LargeInt_ChooseInt (A: CHOOSE_INT_ARG) : + sig val f : LargeInt.int A.t end = + ChooseInt_IntInf (A) diff --git a/basis-library/config/default/large-real.sml b/basis-library/config/default/large-real.sml new file mode 100644 index 0000000..a459583 --- /dev/null +++ b/basis-library/config/default/large-real.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure LargeReal = Real64 + +functor LargeReal_ChooseRealN (A: CHOOSE_REALN_ARG) : + sig val f : LargeReal.real A.t end = + ChooseRealN_Real64 (A) diff --git a/basis-library/config/default/large-word.sml b/basis-library/config/default/large-word.sml new file mode 100644 index 0000000..e1ff361 --- /dev/null +++ b/basis-library/config/default/large-word.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure LargeWord = Word64 + +functor LargeWord_ChooseWordN (A: CHOOSE_WORDN_ARG) : + sig val f : LargeWord.word A.t end = + ChooseWordN_Word64 (A) diff --git a/basis-library/config/metadata/array-metadata-size128.sml b/basis-library/config/metadata/array-metadata-size128.sml new file mode 100644 index 0000000..bd9be1f --- /dev/null +++ b/basis-library/config/metadata/array-metadata-size128.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 2017 Matthew Fluet. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure ArrayMetaDataSize = + struct + val bytes : Int32.int = 16 + end diff --git a/basis-library/config/metadata/array-metadata-size192.sml b/basis-library/config/metadata/array-metadata-size192.sml new file mode 100644 index 0000000..0cb94e8 --- /dev/null +++ b/basis-library/config/metadata/array-metadata-size192.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 2017 Matthew Fluet. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure ArrayMetaDataSize = + struct + val bytes : Int32.int = 24 + end diff --git a/basis-library/config/metadata/array-metadata-size256.sml b/basis-library/config/metadata/array-metadata-size256.sml new file mode 100644 index 0000000..0aae87e --- /dev/null +++ b/basis-library/config/metadata/array-metadata-size256.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 2017 Matthew Fluet. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure ArrayMetaDataSize = + struct + val bytes : Int32.int = 32 + end diff --git a/basis-library/config/metadata/array-metadata-size96.sml b/basis-library/config/metadata/array-metadata-size96.sml new file mode 100644 index 0000000..732ef73 --- /dev/null +++ b/basis-library/config/metadata/array-metadata-size96.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 2017 Matthew Fluet. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure ArrayMetaDataSize = + struct + val bytes : Int32.int = 12 + end diff --git a/basis-library/config/metadata/normal-metadata-size128.sml b/basis-library/config/metadata/normal-metadata-size128.sml new file mode 100644 index 0000000..ce76b27 --- /dev/null +++ b/basis-library/config/metadata/normal-metadata-size128.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 2016-2017 Matthew Fluet. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure NormalMetaDataSize = + struct + val bytes : Int32.int = 16 + end diff --git a/basis-library/config/metadata/normal-metadata-size32.sml b/basis-library/config/metadata/normal-metadata-size32.sml new file mode 100644 index 0000000..a164e93 --- /dev/null +++ b/basis-library/config/metadata/normal-metadata-size32.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 2016-2017 Matthew Fluet. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure NormalMetaDataSize = + struct + val bytes : Int32.int = 4 + end diff --git a/basis-library/config/metadata/normal-metadata-size64.sml b/basis-library/config/metadata/normal-metadata-size64.sml new file mode 100644 index 0000000..39c45f5 --- /dev/null +++ b/basis-library/config/metadata/normal-metadata-size64.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 2016-2017 Matthew Fluet. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure NormalMetaDataSize = + struct + val bytes : Int32.int = 8 + end diff --git a/basis-library/config/objptr/objptr-rep32.sml b/basis-library/config/objptr/objptr-rep32.sml new file mode 100644 index 0000000..bad1286 --- /dev/null +++ b/basis-library/config/objptr/objptr-rep32.sml @@ -0,0 +1,16 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure ObjptrInt = Int32 +structure ObjptrWord = Word32 + +functor ObjptrInt_ChooseIntN (A: CHOOSE_INTN_ARG) : + sig val f : ObjptrInt.int A.t end = + ChooseIntN_Int32 (A) +functor ObjptrWord_ChooseWordN (A: CHOOSE_WORDN_ARG) : + sig val f : ObjptrWord.word A.t end = + ChooseWordN_Word32 (A) diff --git a/basis-library/config/objptr/objptr-rep64.sml b/basis-library/config/objptr/objptr-rep64.sml new file mode 100644 index 0000000..b913778 --- /dev/null +++ b/basis-library/config/objptr/objptr-rep64.sml @@ -0,0 +1,16 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure ObjptrInt = Int64 +structure ObjptrWord = Word64 + +functor ObjptrInt_ChooseIntN (A: CHOOSE_INTN_ARG) : + sig val f : ObjptrInt.int A.t end = + ChooseIntN_Int64 (A) +functor ObjptrWord_ChooseWordN (A: CHOOSE_WORDN_ARG) : + sig val f : ObjptrWord.word A.t end = + ChooseWordN_Word64 (A) diff --git a/basis-library/config/seqindex/seqindex-int32.sml b/basis-library/config/seqindex/seqindex-int32.sml new file mode 100644 index 0000000..d3515d9 --- /dev/null +++ b/basis-library/config/seqindex/seqindex-int32.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure SeqIndex = Int32 + +functor SeqIndex_ChooseIntN (A: CHOOSE_INTN_ARG) : + sig val f : SeqIndex.int A.t end = + ChooseIntN_Int32 (A) diff --git a/basis-library/config/seqindex/seqindex-int64.sml b/basis-library/config/seqindex/seqindex-int64.sml new file mode 100644 index 0000000..6343e36 --- /dev/null +++ b/basis-library/config/seqindex/seqindex-int64.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure SeqIndex = Int64 + +functor SeqIndex_ChooseIntN (A: CHOOSE_INTN_ARG) : + sig val f : SeqIndex.int A.t end = + ChooseIntN_Int64 (A) diff --git a/basis-library/default.mlb b/basis-library/default.mlb new file mode 100644 index 0000000..5ad15a6 --- /dev/null +++ b/basis-library/default.mlb @@ -0,0 +1,17 @@ +(* Copyright (C) 2005-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Order here matters for choice of type names. In particular, we want + * basis.mlb to come last so that basis type names are preferred to MLton type + * names. + *) +unsafe.mlb +sml-nj.mlb +mlton.mlb +basis.mlb + + diff --git a/basis-library/equal.mlb b/basis-library/equal.mlb new file mode 100644 index 0000000..4a5e493 --- /dev/null +++ b/basis-library/equal.mlb @@ -0,0 +1,25 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + libs/basis-2002/basis-2002.mlb + basis-2002.mlb + ann "allowSpecifySpecialIds true" in + libs/basis-2002/top-level/basis-equal.sig + end + in + libs/basis-2002/top-level/pervasive-equal.sml + end +end diff --git a/basis-library/general/bool.sig b/basis-library/general/bool.sig new file mode 100644 index 0000000..f07a8b3 --- /dev/null +++ b/basis-library/general/bool.sig @@ -0,0 +1,15 @@ +signature BOOL_GLOBAL = + sig + datatype bool = datatype bool + + val not: bool -> bool + end + +signature BOOL = + sig + include BOOL_GLOBAL + + val fromString: string -> bool option + val scan: (char, 'a) StringCvt.reader -> (bool, 'a) StringCvt.reader + val toString: bool -> string + end diff --git a/basis-library/general/bool.sml b/basis-library/general/bool.sml new file mode 100644 index 0000000..ca9b26f --- /dev/null +++ b/basis-library/general/bool.sml @@ -0,0 +1,38 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Bool: BOOL = + struct + datatype bool = datatype bool + + val not = not + + fun scan reader state = + case reader state of + NONE => NONE + | SOME(c, state) => + case c of + #"f" => (case Reader.reader4 reader state of + SOME((#"a", #"l", #"s", #"e"), state) => + SOME(false, state) + | _ => NONE) + | #"t" => (case Reader.reader3 reader state of + SOME((#"r", #"u", #"e"), state) => + SOME(true, state) + | _ => NONE) + | _ => NONE + + val fromString = StringCvt.scanString scan + + val toString = + fn true => "true" + | false => "false" + end + +structure BoolGlobal: BOOL_GLOBAL = Bool +open BoolGlobal diff --git a/basis-library/general/general.sig b/basis-library/general/general.sig new file mode 100644 index 0000000..b11ec56 --- /dev/null +++ b/basis-library/general/general.sig @@ -0,0 +1,39 @@ +signature GENERAL_GLOBAL = + sig + eqtype unit + + type exn + exception Bind + exception Match + exception Chr + exception Div + exception Domain + exception Fail of string + exception Overflow + exception Size + exception Span + exception Subscript + + val exnName: exn -> string + val exnMessage: exn -> string + + datatype order = LESS | EQUAL | GREATER + + val ! : 'a ref -> 'a + val := : ('a ref * 'a) -> unit + val o : (('b -> 'c) * ('a -> 'b)) -> 'a -> 'c + val before: ('a * unit) -> 'a + val ignore: 'a -> unit + end + +signature GENERAL = + sig + include GENERAL_GLOBAL + end + +signature GENERAL_EXTRA = + sig + include GENERAL + + val addExnMessager: (exn -> string option) -> unit + end diff --git a/basis-library/general/general.sml b/basis-library/general/general.sml new file mode 100644 index 0000000..bf0e328 --- /dev/null +++ b/basis-library/general/general.sml @@ -0,0 +1,56 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure General: GENERAL_EXTRA = + struct + type unit = Primitive.Unit.unit + + type exn = exn + exception Bind = Bind + exception Match = Match + exception Chr + exception Div = Div + exception Domain = Domain + exception Fail of string + exception Overflow = Overflow + exception Size = Size + exception Span = Span + exception Subscript = Subscript + + datatype order = datatype Primitive.Order.order + + val ! = Primitive.Ref.deref + val op := = Primitive.Ref.assign + fun (f o g) x = f (g x) + fun x before () = x + fun ignore _ = () + val exnName = Primitive.Exn.name + + local + val messagers: (exn -> string option) list ref = ref [] + in + val addExnMessager: (exn -> string option) -> unit = + fn f => messagers := f :: !messagers + + val rec exnMessage: exn -> string = + fn e => + let + val rec find = + fn [] => exnName e + | m :: ms => + case m e of + NONE => find ms + | SOME s => s + in + find (!messagers) + end + end + end + +structure GeneralGlobal: GENERAL_GLOBAL = General +open GeneralGlobal diff --git a/basis-library/general/option.sig b/basis-library/general/option.sig new file mode 100644 index 0000000..58dcd00 --- /dev/null +++ b/basis-library/general/option.sig @@ -0,0 +1,23 @@ +signature OPTION_GLOBAL = + sig + datatype 'a option = NONE | SOME of 'a + + exception Option + + val getOpt: 'a option * 'a -> 'a + val isSome: 'a option -> bool + val valOf: 'a option -> 'a + end + +signature OPTION = + sig + include OPTION_GLOBAL + + val app: ('a -> unit) -> 'a option -> unit + val compose: ('a -> 'b) * ('c -> 'a option) -> 'c -> 'b option + val composePartial: ('a -> 'b option) * ('c -> 'a option) -> 'c -> 'b option + val filter: ('a -> bool) -> 'a -> 'a option + val join: 'a option option -> 'a option + val map: ('a -> 'b) -> 'a option -> 'b option + val mapPartial: ('a -> 'b option) -> 'a option -> 'b option + end diff --git a/basis-library/general/option.sml b/basis-library/general/option.sml new file mode 100644 index 0000000..2402faf --- /dev/null +++ b/basis-library/general/option.sml @@ -0,0 +1,50 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Option: OPTION = +struct + +datatype option = datatype option + +exception Option + +fun map f = + fn NONE => NONE + | SOME a => SOME (f a) + +fun app f z = (ignore (map f z); ()) + +fun compose (f, g) c = map f (g c) + +val join = + fn NONE => NONE + | SOME v => v + +fun mapPartial f = join o (map f) + +fun composePartial (f, g) = (mapPartial f) o g + +fun filter f a = if f a then SOME a else NONE + +fun getOpt (z, a) = + case z of + NONE => a + | SOME v => v + +val isSome = + fn NONE => false + | SOME _ => true + +val valOf = + fn NONE => raise Option + | SOME v => v + +end + +structure OptionGlobal: OPTION_GLOBAL = Option +open OptionGlobal diff --git a/basis-library/general/sml90.sig b/basis-library/general/sml90.sig new file mode 100644 index 0000000..6fff5f3 --- /dev/null +++ b/basis-library/general/sml90.sig @@ -0,0 +1,39 @@ +signature SML90 = + sig + type instream + type outstream + exception Abs + exception Diff + exception Exp + exception Floor + exception Interrupt + exception Io of string + exception Ln + exception Mod + exception Neg + exception Ord + exception Prod + exception Quot + exception Sqrt + exception Sum + val arctan: real -> real + val chr: int -> string + val close_in: instream -> unit + val close_out: outstream -> unit + val cos: real -> real + val end_of_stream: instream -> bool + val exp: real -> real + val explode: string -> string list + val implode: string list -> string + val input: instream * int -> string + val ln: real -> real + val lookahead: instream -> string + val open_in: string -> instream + val open_out: string -> outstream + val ord: string -> int + val output: outstream * string -> unit + val sin: real -> real + val sqrt: real -> real + val std_in: instream + val std_out: outstream + end diff --git a/basis-library/general/sml90.sml b/basis-library/general/sml90.sml new file mode 100644 index 0000000..e5e232a --- /dev/null +++ b/basis-library/general/sml90.sml @@ -0,0 +1,70 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure SML90:> SML90 = + struct + type instream = TextIO.instream + type outstream = TextIO.outstream + exception Abs = Overflow + exception Quot = Overflow + exception Prod = Overflow + exception Neg = Overflow + exception Sum = Overflow + exception Diff = Overflow + exception Floor = Overflow + exception Exp = Overflow + exception Sqrt + exception Ln + exception Ord + exception Mod = Div + exception Io of string + exception Interrupt + + local open Real.Math + in + val sqrt = fn x => if Real.< (x, 0.0) then raise Sqrt else sqrt x + val exp = fn x => let val y = exp x + in if Real.isFinite y + then y + else raise Exp + end + val ln = fn x => if Real.> (x, 0.0) then ln x else raise Ln + val sin = sin + val cos = cos + val arctan = atan + end + + fun ord s = + if String.size s = 0 + then raise Ord + else Char.ord(String.sub(s, 0)) + + val chr = String.str o Char.chr + fun explode s = List.map String.str (String.explode s) + val implode = String.concat + fun lookahead ins = + case TextIO.lookahead ins of + NONE => "" + | SOME c => str c + + val std_in = TextIO.stdIn + fun open_in f = + TextIO.openIn f handle IO.Io _ => raise Io (concat ["Cannot open ", f]) + fun input ins = + TextIO.inputN ins handle IO.Io _ => raise Io "Input stream is closed" + val close_in = TextIO.closeIn + fun end_of_stream ins = TextIO.endOfStream ins handle _ => true + val std_out = TextIO.stdOut + fun open_out f = + TextIO.openOut f + handle IO.Io _ => raise Io (concat ["Cannot open ", f]) + fun output (out, s) = + TextIO.output (out, s) + handle IO.Io _ => raise Io "Output stream is closed" + val close_out = TextIO.closeOut + end diff --git a/basis-library/infixes.mlb b/basis-library/infixes.mlb new file mode 100644 index 0000000..c6e5a16 --- /dev/null +++ b/basis-library/infixes.mlb @@ -0,0 +1,16 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + libs/basis-2002/top-level/infixes.sml +end diff --git a/basis-library/integer/embed-int.sml b/basis-library/integer/embed-int.sml new file mode 100644 index 0000000..184ab17 --- /dev/null +++ b/basis-library/integer/embed-int.sml @@ -0,0 +1,160 @@ +(* Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature EMBED_INT = + sig + eqtype int + type big + + val fromBigUnsafe: big -> int + val sizeInBits: Int32.int + val toBig: int -> big + end + +functor EmbedInt (structure Big: INTEGER_EXTRA + structure Small: EMBED_INT where type big = Big.int): INTEGER = + struct + structure Small = + struct + open Small + val precision': Int.int = Int32.toInt sizeInBits + end + + val () = if Int.< (Small.precision', Big.precision') then () + else raise Fail "EmbedWord" + + open Small + + val shift = Word.fromInt (Int.- (Big.precision', precision')) + + val extend: Big.int -> Big.int = + fn i => Big.~>> (Big.<< (i, shift), shift) + + val toBig: Small.int -> Big.int = extend o Small.toBig + + val precision = SOME precision' + + val maxIntBig = Big.>> (Big.fromInt ~1, Word.+ (shift, 0w1)) + + val minIntBig = Big.- (Big.~ maxIntBig, Big.fromInt 1) + + val mask = Big.>> (Big.fromInt ~1, shift) + + fun fromBig (i: Big.int): int = + let + val i' = Big.andb (i, mask) + in + if i = extend i' + then fromBigUnsafe i' + else raise Overflow + end + + val maxInt = SOME (fromBig maxIntBig) + + val minInt = SOME (fromBig minIntBig) + + local + val make: (Big.int * Big.int -> Big.int) -> (int * int -> int) = + fn f => fn (x, y) => fromBig (f (toBig x, toBig y)) + in + val op * = make Big.* + val op + = make Big.+ + val op - = make Big.- + val op div = make Big.div + val op mod = make Big.mod + val quot = make Big.quot + val rem = make Big.rem + end + + local + val make: (Big.int * Big.int -> 'a) -> (int * int -> 'a) = + fn f => fn (x, y) => f (toBig x, toBig y) + in + val op < = make Big.< + val op <= = make Big.<= + val op > = make Big.> + val op >= = make Big.>= + val compare = make Big.compare + end + + val fromInt = fromBig o Big.fromInt + + val toInt = Big.toInt o toBig + + local + val make: (Big.int -> Big.int) -> (int -> int) = + fn f => fn x => fromBig (f (toBig x)) + in + val ~ = make Big.~ + val abs = make Big.abs + end + + fun fmt r i = Big.fmt r (toBig i) + + val fromLarge = fromBig o Big.fromLarge + + fun fromString s = Option.map fromBig (Big.fromString s) + + fun max (i, j) = if i >= j then i else j + + fun min (i, j) = if i <= j then i else j + + fun scan r reader state = + Option.map + (fn (i, state) => (fromBig i, state)) + (Big.scan r reader state) + + val sign = Big.sign o toBig + + fun sameSign (x, y) = sign x = sign y + + val toLarge = Big.toLarge o toBig + + val toString = Big.toString o toBig + end + +functor Embed8 (Small: EMBED_INT where type big = Int8.int): INTEGER = + EmbedInt (structure Big = Int8 + structure Small = Small) + +functor Embed16 (Small: EMBED_INT where type big = Int16.int): INTEGER = + EmbedInt (structure Big = Int16 + structure Small = Small) + +functor Embed32 (Small: EMBED_INT where type big = Int32.int): INTEGER = + EmbedInt (structure Big = Int32 + structure Small = Small) + +structure Int1 = Embed8 (Primitive.Int1) +structure Int2 = Embed8 (Primitive.Int2) +structure Int3 = Embed8 (Primitive.Int3) +structure Int4 = Embed8 (Primitive.Int4) +structure Int5 = Embed8 (Primitive.Int5) +structure Int6 = Embed8 (Primitive.Int6) +structure Int7 = Embed8 (Primitive.Int7) +structure Int9 = Embed16 (Primitive.Int9) +structure Int10 = Embed16 (Primitive.Int10) +structure Int11 = Embed16 (Primitive.Int11) +structure Int12 = Embed16 (Primitive.Int12) +structure Int13 = Embed16 (Primitive.Int13) +structure Int14 = Embed16 (Primitive.Int14) +structure Int15 = Embed16 (Primitive.Int15) +structure Int17 = Embed32 (Primitive.Int17) +structure Int18 = Embed32 (Primitive.Int18) +structure Int19 = Embed32 (Primitive.Int19) +structure Int20 = Embed32 (Primitive.Int20) +structure Int21 = Embed32 (Primitive.Int21) +structure Int22 = Embed32 (Primitive.Int22) +structure Int23 = Embed32 (Primitive.Int23) +structure Int24 = Embed32 (Primitive.Int24) +structure Int25 = Embed32 (Primitive.Int25) +structure Int26 = Embed32 (Primitive.Int26) +structure Int27 = Embed32 (Primitive.Int27) +structure Int28 = Embed32 (Primitive.Int28) +structure Int29 = Embed32 (Primitive.Int29) +structure Int30 = Embed32 (Primitive.Int30) +structure Int31 = Embed32 (Primitive.Int31) diff --git a/basis-library/integer/embed-word.sml b/basis-library/integer/embed-word.sml new file mode 100644 index 0000000..a1ac167 --- /dev/null +++ b/basis-library/integer/embed-word.sml @@ -0,0 +1,191 @@ +(* Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature EMBED_WORD = + sig + eqtype word + type big + + val fromBigUnsafe: big -> word + val sizeInBits: Int32.int + val toBig: word -> big + end + +functor EmbedWord (structure Big: WORD + structure Small: EMBED_WORD where type big = Big.word): WORD = + struct + structure Small = + struct + open Small + val wordSize: Int.int = Int32.toInt sizeInBits + end + + val () = if Int.< (Small.wordSize, Big.wordSize) then () + else raise Fail "EmbedWord" + + open Small + + fun ones size = + Big.- (Big.<< (Big.fromLarge 0w1, Word.fromInt size), + Big.fromLarge 0w1) + + val maxWord = ones wordSize + + fun fromBig (w: Big.word): word = + fromBigUnsafe (Big.andb (w, maxWord)) + + fun fromBigOverflow (w: Big.word): word = + if Big.<= (w, maxWord) + then fromBigUnsafe w + else raise Overflow + + fun highBitIsSet (w: Big.word): bool = + Big.> (w, ones (Int.- (wordSize, 1))) + + fun toBigX (w: word): Big.word = + let + val w = toBig w + in + if highBitIsSet w + then Big.orb (w, Big.notb maxWord) + else w + end + + local + val make: (Big.word * Big.word -> Big.word) -> (word * word -> word) = + fn f => fn (x, y) => fromBig (f (toBig x, toBig y)) + in + val op * = make Big.* + val op + = make Big.+ + val op - = make Big.- + val andb = make Big.andb + val op div = make Big.div + val op mod = make Big.mod + val orb = make Big.orb + val xorb = make Big.xorb + end + + local + val make: ((Big.word * Word.word -> Big.word) + -> word * Word.word -> word) = + fn f => fn (w, w') => fromBig (f (toBig w, w')) + in + val >> = make Big.>> + val << = make Big.<< + end + + fun ~>> (w, w') = fromBig (Big.~>> (toBigX w, w')) + + local + val make: (Big.word * Big.word -> 'a) -> (word * word -> 'a) = + fn f => fn (x, y) => f (toBig x, toBig y) + in + val op < = make Big.< + val op <= = make Big.<= + val op > = make Big.> + val op >= = make Big.>= + val compare = make Big.compare + end + + local + val make: (Big.word -> Big.word) -> word -> word = + fn f => fn w => fromBig (f (toBig w)) + in + val notb = make Big.notb + end + + local + val make: ('a -> Big.word) -> 'a -> word = + fn f => fn a => fromBig (f a) + in + val fromInt = make Big.fromInt + val fromLarge = make Big.fromLarge + val fromLargeInt = make Big.fromLargeInt + end + + local + val make: (Big.word -> 'a) -> word -> 'a = + fn f => fn w => f (toBig w) + in + val toInt = make Big.toInt + val toLarge = make Big.toLarge + val toLargeInt = make Big.toLargeInt + val toString = make Big.toString + end + + local + val make: (Big.word -> 'a) -> word -> 'a = + fn f => fn w => f (toBigX w) + in + val toIntX = make Big.toIntX + val toLargeIntX = make Big.toLargeIntX + val toLargeX = make Big.toLargeX + end + + fun fmt r i = Big.fmt r (toBig i) + + val fromLargeWord = fromLarge + + fun fromString s = Option.map fromBigOverflow (Big.fromString s) + + fun max (w, w') = if w >= w' then w else w' + + fun min (w, w') = if w <= w' then w else w' + + fun scan r reader state = + Option.map + (fn (w, state) => (fromBigOverflow w, state)) + (Big.scan r reader state) + + val toLargeWord = toLarge + + val toLargeWordX = toLargeX + + fun ~ w = fromLarge 0w0 - w + end + +functor EmbedWord8 (Small: EMBED_WORD where type big = Word8.word): WORD = + EmbedWord (structure Big = Word8 + structure Small = Small) + +functor EmbedWord16 (Small: EMBED_WORD where type big = Word16.word): WORD = + EmbedWord (structure Big = Word16 + structure Small = Small) + +functor EmbedWord32 (Small: EMBED_WORD where type big = Word32.word): WORD = + EmbedWord (structure Big = Word32 + structure Small = Small) + +structure Word1 = EmbedWord8 (Primitive.Word1) +structure Word2 = EmbedWord8 (Primitive.Word2) +structure Word3 = EmbedWord8 (Primitive.Word3) +structure Word4 = EmbedWord8 (Primitive.Word4) +structure Word5 = EmbedWord8 (Primitive.Word5) +structure Word6 = EmbedWord8 (Primitive.Word6) +structure Word7 = EmbedWord8 (Primitive.Word7) +structure Word9 = EmbedWord16 (Primitive.Word9) +structure Word10 = EmbedWord16 (Primitive.Word10) +structure Word11 = EmbedWord16 (Primitive.Word11) +structure Word12 = EmbedWord16 (Primitive.Word12) +structure Word13 = EmbedWord16 (Primitive.Word13) +structure Word14 = EmbedWord16 (Primitive.Word14) +structure Word15 = EmbedWord16 (Primitive.Word15) +structure Word17 = EmbedWord32 (Primitive.Word17) +structure Word18 = EmbedWord32 (Primitive.Word18) +structure Word19 = EmbedWord32 (Primitive.Word19) +structure Word20 = EmbedWord32 (Primitive.Word20) +structure Word21 = EmbedWord32 (Primitive.Word21) +structure Word22 = EmbedWord32 (Primitive.Word22) +structure Word23 = EmbedWord32 (Primitive.Word23) +structure Word24 = EmbedWord32 (Primitive.Word24) +structure Word25 = EmbedWord32 (Primitive.Word25) +structure Word26 = EmbedWord32 (Primitive.Word26) +structure Word27 = EmbedWord32 (Primitive.Word27) +structure Word28 = EmbedWord32 (Primitive.Word28) +structure Word29 = EmbedWord32 (Primitive.Word29) +structure Word30 = EmbedWord32 (Primitive.Word30) +structure Word31 = EmbedWord32 (Primitive.Word31) diff --git a/basis-library/integer/int-global.sml b/basis-library/integer/int-global.sml new file mode 100644 index 0000000..9011c12 --- /dev/null +++ b/basis-library/integer/int-global.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure IntGlobal: INTEGER_GLOBAL = Int +open IntGlobal diff --git a/basis-library/integer/int-inf.sig b/basis-library/integer/int-inf.sig new file mode 100644 index 0000000..6574491 --- /dev/null +++ b/basis-library/integer/int-inf.sig @@ -0,0 +1,46 @@ +signature INT_INF = + sig + include INTEGER + + val divMod: int * int -> int * int + val quotRem: int * int -> int * int + val pow: int * Int.int -> int + val log2: int -> Int.int + val orb: int * int -> int + val xorb: int * int -> int + val andb: int * int -> int + val notb: int -> int + val << : int * Word.word -> int + val ~>> : int * Word.word -> int + end + +signature INT_INF_EXTRA = + sig + include INT_INF + type t = int + + structure BigWord : WORD + structure SmallInt : INTEGER + + val areSmall: int * int -> bool + val gcd: int * int -> int + val isSmall: int -> bool + datatype rep = + Big of BigWord.word Vector.vector + | Small of SmallInt.int + val rep: int -> rep + val fromRep: rep -> int option + + val zero: int + val one: int + + val +? : int * int -> int + val *? : int * int -> int + val -? : int * int -> int + val ~? : int -> int + + val ltu: int * int -> bool + val leu: int * int -> bool + val gtu: int * int -> bool + val geu: int * int -> bool + end diff --git a/basis-library/integer/int-inf.sml b/basis-library/integer/int-inf.sml new file mode 100644 index 0000000..50e0d43 --- /dev/null +++ b/basis-library/integer/int-inf.sml @@ -0,0 +1,336 @@ +(* Copyright (C) 2013-2014 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure IntInf: INT_INF_EXTRA = + struct + open Primitive.IntInf + type t = int + + structure BigWord = C_MPLimb + structure SmallInt = ObjptrInt + + structure W = ObjptrWord + structure I = ObjptrInt + structure MPLimb = C_MPLimb + + val precision: Int.int option = NONE + + fun sign (arg: int): Int.int = + case compare (arg, zero) of + LESS => ~1 + | EQUAL => 0 + | GREATER => 1 + + fun sameSign (x, y) = sign x = sign y + + local + val maxShift32 = Word32.<< (0wx1, 0w30) + val maxShift = Word32.toWord maxShift32 + fun make f (arg, shift) = + let + fun body loop (arg, shift) = + if Word.<= (shift, maxShift) + then f (arg, Word32.fromWord shift) + else loop (f (arg, maxShift32), + Word.- (shift, maxShift)) + fun loop (arg, shift) = body loop (arg, shift) + in + body loop (arg, shift) + end + in + val << = make << + val ~>> = make ~>> + end + + val fromInt = schckFromInt + val toInt = schckToInt + val fromLarge = schckFromLargeInt + val toLarge = schckToLargeInt + + local + open StringCvt + + val binCvt = mkCvt {base = 2, smallCvt = I.fmt BIN} + val octCvt = mkCvt {base = 8, smallCvt = I.fmt OCT} + val decCvt = mkCvt {base = 10, smallCvt = I.fmt DEC} + val hexCvt = mkCvt {base = 16, smallCvt = I.fmt HEX} + in + fun fmt radix = + case radix of + BIN => binCvt + | OCT => octCvt + | DEC => decCvt + | HEX => hexCvt + val toString = fmt DEC + end + + local + open StringCvt + + (* + * Given a char, if it is a digit in the appropriate base, + * convert it to a word. Otherwise, return NONE. + * Note, both a-f and A-F are accepted as hexadecimal digits. + *) + fun binDig (ch: char): W.word option = + case ch of + #"0" => SOME 0w0 + | #"1" => SOME 0w1 + | _ => NONE + + local + val op <= = Char.<= + in + fun octDig (ch: char): W.word option = + if #"0" <= ch andalso ch <= #"7" + then SOME (W.fromInt (Int.- (Char.ord ch, + Char.ord #"0"))) + else NONE + + fun decDig (ch: char): W.word option = + if #"0" <= ch andalso ch <= #"9" + then SOME (W.fromInt (Int.- (Char.ord ch, + Char.ord #"0"))) + else NONE + + fun hexDig (ch: char): W.word option = + if #"0" <= ch andalso ch <= #"9" + then SOME (W.fromInt (Int.- (Char.ord ch, + Char.ord #"0"))) + else if #"a" <= ch andalso ch <= #"f" + then SOME (W.fromInt (Int.- (Char.ord ch, + Int.- (Char.ord #"a", 0xa)))) + else if #"A" <= ch andalso ch <= #"F" + then SOME (W.fromInt (Int.- (Char.ord ch, + Int.- (Char.ord #"A", 0xA)))) + else NONE + end + + (* + * Given a digit converter and a char reader, return a digit + * reader. + *) + fun toDigR (charToDig: char -> W.word option, + cread: (char, 'a) reader) + (s: 'a) + : (W.word * 'a) option = + case cread s of + NONE => NONE + | SOME (ch, s') => + case charToDig ch of + NONE => NONE + | SOME dig => SOME (dig, s') + + (* + * A chunk represents the result of processing some digits. + * more is a bool indicating if there might be more digits. + * shift is base raised to the number-of-digits-seen power. + * chunk is the value of the digits seen. + *) + type chunk = {more: bool, + shift: W.word, + chunk: W.word} + (* + * Given the base and a digit reader, + * return a chunk reader. + *) + fun toChunkR (base: W.word, + dread: (W.word, 'a) reader) + : (chunk, 'a) reader = + let + fun loop {left: Int32.int, + shift: W.word, + chunk: W.word, + s: 'a} + : chunk * 'a = + if Int32.<= (left, 0) + then ({more = true, + shift = shift, + chunk = chunk}, + s) + else + case dread s of + NONE => ({more = false, + shift = shift, + chunk = chunk}, + s) + | SOME (dig, s') => + loop {left = Int32.- (left, 1), + shift = W.* (base, shift), + chunk = W.+ (W.* (base, chunk), dig), + s = s'} + (* digitsPerChunk = floor((W.wordSize - 3) / (log2 base)) *) + val digitsPerChunk : Int32.t = + case (W.wordSize, base) of + (64, 0w16) => 15 + | (64, 0w10) => 18 + | (64, 0w8) => 20 + | (64, 0w2) => 61 + | (32, 0w16) => 7 + | (32, 0w10) => 8 + | (32, 0w8) => 9 + | (32, 0w2) => 29 + | _ => raise (Fail "IntInf.scan:digitsPerChunk") + fun reader (s: 'a): (chunk * 'a) option = + case dread s of + NONE => NONE + | SOME (dig, next) => + SOME (loop {left = Int32.- (digitsPerChunk, 1), + shift = base, + chunk = dig, + s = next}) + in + reader + end + + (* + * Given a chunk reader, return an unsigned reader. + *) + fun toUnsR (ckread: (chunk, 'a) reader): (int, 'a) reader = + let + fun loop (more: bool, acc: int, s: 'a) = + if more + then case ckread s of + NONE => (acc, s) + | SOME ({more, shift, chunk}, s') => + loop (more, + ((W.toLargeInt shift) * acc) + + (W.toLargeInt chunk), + s') + else (acc, s) + fun reader (s: 'a): (int * 'a) option = + case ckread s of + NONE => NONE + | SOME ({more, chunk, ...}, s') => + SOME (loop (more, + W.toLargeInt chunk, + s')) + in + reader + end + + (* + * Given a char reader and an unsigned reader, return an unsigned + * reader that includes skipping the option hex '0x'. + *) + fun toHexR (cread: (char, 'a) reader, uread: (int, 'a) reader) s = + case cread s of + NONE => NONE + | SOME (c1, s1) => + if c1 = #"0" then + case cread s1 of + NONE => SOME (zero, s1) + | SOME (c2, s2) => + if c2 = #"x" orelse c2 = #"X" then + case uread s2 of + NONE => SOME (zero, s1) + | SOME x => SOME x + else uread s + else uread s + + (* + * Given a char reader and an unsigned reader, return a signed + * reader. This includes skipping any initial white space. + *) + fun toSign (cread: (char, 'a) reader, uread: (int, 'a) reader) + : (int, 'a) reader = + let + fun reader (s: 'a): (int * 'a) option = + let val s = StringCvt.skipWS cread s in + case cread s of + NONE => NONE + | SOME (ch, s') => + let + val (isNeg, s'') = + case ch of + #"+" => (false, s') + | #"-" => (true, s') + | #"~" => (true, s') + | _ => (false, s) + in + if isNeg + then case uread s'' of + NONE => NONE + | SOME (abs, s''') => SOME (~ abs, s''') + else uread s'' + end + end + in + reader + end + + (* + * Base-specific conversions from char readers to + * int readers. + *) + local + fun reader (base, dig) + (cread: (char, 'a) reader) + : (int, 'a) reader = + let + val dread = toDigR (dig, cread) + val ckread = toChunkR (base, dread) + val uread = toUnsR ckread + val hread = if base = 0w16 then toHexR (cread, uread) else uread + val reader = toSign (cread, hread) + in + reader + end + in + fun binReader z = reader (0w2, binDig) z + fun octReader z = reader (0w8, octDig) z + fun decReader z = reader (0w10, decDig) z + fun hexReader z = reader (0w16, hexDig) z + end + in + fun scan radix = + case radix of + BIN => binReader + | OCT => octReader + | DEC => decReader + | HEX => hexReader + end + + val fromString = StringCvt.scanString (scan StringCvt.DEC) + + local + fun isEven (n: Int.int) = Int.andb (n, 0x1) = 0 + in + fun pow (i: int, j: Int.int): int = + if Int.< (j, 0) then + if i = zero then + raise Div + else + if i = one then one + else if i = negOne then if isEven j then one else negOne + else zero + else + if j = 0 then one + else + let + fun square (n: int): int = n * n + (* pow (j) returns (i ^ j) *) + fun pow (j: Int.int): int = + if Int.<= (j, 0) then one + else if isEven j then evenPow j + else i * evenPow (Int.- (j, 1)) + (* evenPow (j) returns (i ^ j), assuming j is even *) + and evenPow (j: Int.int): int = + square (pow (Int.div (j, 2))) + in + pow j + end + end + + val log2 = + mkLog2 {fromSmall = fn {smallLog2} => Int32.toInt smallLog2, + fromLarge = fn {numLimbsMinusOne, mostSigLimbLog2} => + Int.+ (Int.* (MPLimb.wordSize, SeqIndex.toInt numLimbsMinusOne), + Int32.toInt mostSigLimbLog2)} + end diff --git a/basis-library/integer/int-inf0.sml b/basis-library/integer/int-inf0.sml new file mode 100644 index 0000000..386d797 --- /dev/null +++ b/basis-library/integer/int-inf0.sml @@ -0,0 +1,1634 @@ +(* Copyright (C) 2013-2014,2016-2017 Matthew Fluet. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature PRIM_INT_INF = + sig + eqtype int + type t = int + + val precision: Primitive.Int32.int option + + val maxInt: int option + val minInt: int option + + val zero: int + val one: int + val negOne: int + + datatype rep = + Big of C_MPLimb.word vector + | Small of ObjptrInt.int + val rep: int -> rep + val fromRep: rep -> int option + + val isSmall: int -> bool + val areSmall: int * int -> bool + + val abs: int -> int + val +! : int * int -> int + val +? : int * int -> int + val + : int * int -> int + val divMod: int * int -> int * int + val div: int * int -> int + val gcd: int * int -> int + val mod: int * int -> int + val *! : int * int -> int + val *? : int * int -> int + val * : int * int -> int + val ~! : int -> int + val ~? : int -> int + val ~ : int -> int + val quotRem: int * int -> int * int + val quot: int * int -> int + val rem: int * int -> int + val -! : int * int -> int + val -? : int * int -> int + val - : int * int -> int + + val < : int * int -> bool + val <= : int * int -> bool + val > : int * int -> bool + val >= : int * int -> bool + val compare: int * int -> Primitive.Order.order + val min: int * int -> int + val max: int * int -> int + val ltu: int * int -> bool + val leu: int * int -> bool + val gtu: int * int -> bool + val geu: int * int -> bool + + val andb: int * int -> int + val < int + val << : int * Primitive.Word32.word -> int + val notb: int -> int + val orb: int * int -> int + val ~>>? : int * Primitive.Word32.word -> int + val ~>> : int * Primitive.Word32.word -> int + val xorb: int * int -> int + + val mkCvt: ({base: Primitive.Int32.int, + smallCvt: ObjptrInt.int -> Primitive.String8.string} + -> int -> Primitive.String8.string) + val mkLog2: ({fromSmall: {smallLog2: Primitive.Int32.int} -> 'a, + fromLarge: {mostSigLimbLog2: Primitive.Int32.int, + numLimbsMinusOne: SeqIndex.int} -> 'a} + -> int -> 'a) + + val zextdFromInt8: Primitive.Int8.int -> int + val zextdFromInt16: Primitive.Int16.int -> int + val zextdFromInt32: Primitive.Int32.int -> int + val zextdFromInt64: Primitive.Int64.int -> int + val zextdFromIntInf: Primitive.IntInf.int -> int + val zextdFromWord8: Primitive.Word8.word -> int + val zextdFromWord16: Primitive.Word16.word -> int + val zextdFromWord32: Primitive.Word32.word -> int + val zextdFromWord64: Primitive.Word64.word -> int + val zextdToInt8: int -> Primitive.Int8.int + val zextdToInt16: int -> Primitive.Int16.int + val zextdToInt32: int -> Primitive.Int32.int + val zextdToInt64: int -> Primitive.Int64.int + val zextdToIntInf: int -> Primitive.IntInf.int + val zextdToWord8: int -> Primitive.Word8.word + val zextdToWord16: int -> Primitive.Word16.word + val zextdToWord32: int -> Primitive.Word32.word + val zextdToWord64: int -> Primitive.Word64.word + + val sextdFromInt8: Primitive.Int8.int -> int + val sextdFromInt16: Primitive.Int16.int -> int + val sextdFromInt32: Primitive.Int32.int -> int + val sextdFromInt64: Primitive.Int64.int -> int + val sextdFromIntInf: Primitive.IntInf.int -> int + val sextdFromWord8: Primitive.Word8.word -> int + val sextdFromWord16: Primitive.Word16.word -> int + val sextdFromWord32: Primitive.Word32.word -> int + val sextdFromWord64: Primitive.Word64.word -> int + val sextdToInt8: int -> Primitive.Int8.int + val sextdToInt16: int -> Primitive.Int16.int + val sextdToInt32: int -> Primitive.Int32.int + val sextdToInt64: int -> Primitive.Int64.int + val sextdToIntInf: int -> Primitive.IntInf.int + val sextdToWord8: int -> Primitive.Word8.word + val sextdToWord16: int -> Primitive.Word16.word + val sextdToWord32: int -> Primitive.Word32.word + val sextdToWord64: int -> Primitive.Word64.word + + val castFromInt8: Primitive.Int8.int -> int + val castFromInt16: Primitive.Int16.int -> int + val castFromInt32: Primitive.Int32.int -> int + val castFromInt64: Primitive.Int64.int -> int + val castFromIntInf: Primitive.IntInf.int -> int + val castFromWord8: Primitive.Word8.word -> int + val castFromWord16: Primitive.Word16.word -> int + val castFromWord32: Primitive.Word32.word -> int + val castFromWord64: Primitive.Word64.word -> int + val castToInt8: int -> Primitive.Int8.int + val castToInt16: int -> Primitive.Int16.int + val castToInt32: int -> Primitive.Int32.int + val castToInt64: int -> Primitive.Int64.int + val castToIntInf: int -> Primitive.IntInf.int + val castToWord8: int -> Primitive.Word8.word + val castToWord16: int -> Primitive.Word16.word + val castToWord32: int -> Primitive.Word32.word + val castToWord64: int -> Primitive.Word64.word + + val zchckFromInt8: Primitive.Int8.int -> int + val zchckFromInt16: Primitive.Int16.int -> int + val zchckFromInt32: Primitive.Int32.int -> int + val zchckFromInt64: Primitive.Int64.int -> int + val zchckFromIntInf: Primitive.IntInf.int -> int + val zchckFromWord8: Primitive.Word8.word -> int + val zchckFromWord16: Primitive.Word16.word -> int + val zchckFromWord32: Primitive.Word32.word -> int + val zchckFromWord64: Primitive.Word64.word -> int + val zchckToInt8: int -> Primitive.Int8.int + val zchckToInt16: int -> Primitive.Int16.int + val zchckToInt32: int -> Primitive.Int32.int + val zchckToInt64: int -> Primitive.Int64.int + val zchckToIntInf: int -> Primitive.IntInf.int + val zchckToWord8: int -> Primitive.Word8.word + val zchckToWord16: int -> Primitive.Word16.word + val zchckToWord32: int -> Primitive.Word32.word + val zchckToWord64: int -> Primitive.Word64.word + + val schckFromInt8: Primitive.Int8.int -> int + val schckFromInt16: Primitive.Int16.int -> int + val schckFromInt32: Primitive.Int32.int -> int + val schckFromInt64: Primitive.Int64.int -> int + val schckFromIntInf: Primitive.IntInf.int -> int + val schckFromWord8: Primitive.Word8.word -> int + val schckFromWord16: Primitive.Word16.word -> int + val schckFromWord32: Primitive.Word32.word -> int + val schckFromWord64: Primitive.Word64.word -> int + val schckToInt8: int -> Primitive.Int8.int + val schckToInt16: int -> Primitive.Int16.int + val schckToInt32: int -> Primitive.Int32.int + val schckToInt64: int -> Primitive.Int64.int + val schckToIntInf: int -> Primitive.IntInf.int + val schckToWord8: int -> Primitive.Word8.word + val schckToWord16: int -> Primitive.Word16.word + val schckToWord32: int -> Primitive.Word32.word + val schckToWord64: int -> Primitive.Word64.word + end + +signature PRIM_INTWORD_CONV = + sig + include PRIM_INTWORD_CONV + + val idFromIntInfToIntInf: Primitive.IntInf.int -> Primitive.IntInf.int + + val zextdFromInt8ToIntInf: Primitive.Int8.int -> Primitive.IntInf.int + val zextdFromInt16ToIntInf: Primitive.Int16.int -> Primitive.IntInf.int + val zextdFromInt32ToIntInf: Primitive.Int32.int -> Primitive.IntInf.int + val zextdFromInt64ToIntInf: Primitive.Int64.int -> Primitive.IntInf.int + val zextdFromWord8ToIntInf: Primitive.Word8.word -> Primitive.IntInf.int + val zextdFromWord16ToIntInf: Primitive.Word16.word -> Primitive.IntInf.int + val zextdFromWord32ToIntInf: Primitive.Word32.word -> Primitive.IntInf.int + val zextdFromWord64ToIntInf: Primitive.Word64.word -> Primitive.IntInf.int + + val zextdFromIntInfToInt8: Primitive.IntInf.int -> Primitive.Int8.int + val zextdFromIntInfToInt16: Primitive.IntInf.int -> Primitive.Int16.int + val zextdFromIntInfToInt32: Primitive.IntInf.int -> Primitive.Int32.int + val zextdFromIntInfToInt64: Primitive.IntInf.int -> Primitive.Int64.int + val zextdFromIntInfToIntInf: Primitive.IntInf.int -> Primitive.IntInf.int + val zextdFromIntInfToWord8: Primitive.IntInf.int -> Primitive.Word8.word + val zextdFromIntInfToWord16: Primitive.IntInf.int -> Primitive.Word16.word + val zextdFromIntInfToWord32: Primitive.IntInf.int -> Primitive.Word32.word + val zextdFromIntInfToWord64: Primitive.IntInf.int -> Primitive.Word64.word + + + val sextdFromInt8ToIntInf: Primitive.Int8.int -> Primitive.IntInf.int + val sextdFromInt16ToIntInf: Primitive.Int16.int -> Primitive.IntInf.int + val sextdFromInt32ToIntInf: Primitive.Int32.int -> Primitive.IntInf.int + val sextdFromInt64ToIntInf: Primitive.Int64.int -> Primitive.IntInf.int + val sextdFromWord8ToIntInf: Primitive.Word8.word -> Primitive.IntInf.int + val sextdFromWord16ToIntInf: Primitive.Word16.word -> Primitive.IntInf.int + val sextdFromWord32ToIntInf: Primitive.Word32.word -> Primitive.IntInf.int + val sextdFromWord64ToIntInf: Primitive.Word64.word -> Primitive.IntInf.int + + val sextdFromIntInfToInt8: Primitive.IntInf.int -> Primitive.Int8.int + val sextdFromIntInfToInt16: Primitive.IntInf.int -> Primitive.Int16.int + val sextdFromIntInfToInt32: Primitive.IntInf.int -> Primitive.Int32.int + val sextdFromIntInfToInt64: Primitive.IntInf.int -> Primitive.Int64.int + val sextdFromIntInfToIntInf: Primitive.IntInf.int -> Primitive.IntInf.int + val sextdFromIntInfToWord8: Primitive.IntInf.int -> Primitive.Word8.word + val sextdFromIntInfToWord16: Primitive.IntInf.int -> Primitive.Word16.word + val sextdFromIntInfToWord32: Primitive.IntInf.int -> Primitive.Word32.word + val sextdFromIntInfToWord64: Primitive.IntInf.int -> Primitive.Word64.word + + + val castFromInt8ToIntInf: Primitive.Int8.int -> Primitive.IntInf.int + val castFromInt16ToIntInf: Primitive.Int16.int -> Primitive.IntInf.int + val castFromInt32ToIntInf: Primitive.Int32.int -> Primitive.IntInf.int + val castFromInt64ToIntInf: Primitive.Int64.int -> Primitive.IntInf.int + val castFromWord8ToIntInf: Primitive.Word8.word -> Primitive.IntInf.int + val castFromWord16ToIntInf: Primitive.Word16.word -> Primitive.IntInf.int + val castFromWord32ToIntInf: Primitive.Word32.word -> Primitive.IntInf.int + val castFromWord64ToIntInf: Primitive.Word64.word -> Primitive.IntInf.int + + val castFromIntInfToInt8: Primitive.IntInf.int -> Primitive.Int8.int + val castFromIntInfToInt16: Primitive.IntInf.int -> Primitive.Int16.int + val castFromIntInfToInt32: Primitive.IntInf.int -> Primitive.Int32.int + val castFromIntInfToInt64: Primitive.IntInf.int -> Primitive.Int64.int + val castFromIntInfToIntInf: Primitive.IntInf.int -> Primitive.IntInf.int + val castFromIntInfToWord8: Primitive.IntInf.int -> Primitive.Word8.word + val castFromIntInfToWord16: Primitive.IntInf.int -> Primitive.Word16.word + val castFromIntInfToWord32: Primitive.IntInf.int -> Primitive.Word32.word + val castFromIntInfToWord64: Primitive.IntInf.int -> Primitive.Word64.word + + + val zchckFromInt8ToIntInf: Primitive.Int8.int -> Primitive.IntInf.int + val zchckFromInt16ToIntInf: Primitive.Int16.int -> Primitive.IntInf.int + val zchckFromInt32ToIntInf: Primitive.Int32.int -> Primitive.IntInf.int + val zchckFromInt64ToIntInf: Primitive.Int64.int -> Primitive.IntInf.int + val zchckFromWord8ToIntInf: Primitive.Word8.word -> Primitive.IntInf.int + val zchckFromWord16ToIntInf: Primitive.Word16.word -> Primitive.IntInf.int + val zchckFromWord32ToIntInf: Primitive.Word32.word -> Primitive.IntInf.int + val zchckFromWord64ToIntInf: Primitive.Word64.word -> Primitive.IntInf.int + + val zchckFromIntInfToInt8: Primitive.IntInf.int -> Primitive.Int8.int + val zchckFromIntInfToInt16: Primitive.IntInf.int -> Primitive.Int16.int + val zchckFromIntInfToInt32: Primitive.IntInf.int -> Primitive.Int32.int + val zchckFromIntInfToInt64: Primitive.IntInf.int -> Primitive.Int64.int + val zchckFromIntInfToIntInf: Primitive.IntInf.int -> Primitive.IntInf.int + val zchckFromIntInfToWord8: Primitive.IntInf.int -> Primitive.Word8.word + val zchckFromIntInfToWord16: Primitive.IntInf.int -> Primitive.Word16.word + val zchckFromIntInfToWord32: Primitive.IntInf.int -> Primitive.Word32.word + val zchckFromIntInfToWord64: Primitive.IntInf.int -> Primitive.Word64.word + + + val schckFromInt8ToIntInf: Primitive.Int8.int -> Primitive.IntInf.int + val schckFromInt16ToIntInf: Primitive.Int16.int -> Primitive.IntInf.int + val schckFromInt32ToIntInf: Primitive.Int32.int -> Primitive.IntInf.int + val schckFromInt64ToIntInf: Primitive.Int64.int -> Primitive.IntInf.int + val schckFromWord8ToIntInf: Primitive.Word8.word -> Primitive.IntInf.int + val schckFromWord16ToIntInf: Primitive.Word16.word -> Primitive.IntInf.int + val schckFromWord32ToIntInf: Primitive.Word32.word -> Primitive.IntInf.int + val schckFromWord64ToIntInf: Primitive.Word64.word -> Primitive.IntInf.int + + val schckFromIntInfToInt8: Primitive.IntInf.int -> Primitive.Int8.int + val schckFromIntInfToInt16: Primitive.IntInf.int -> Primitive.Int16.int + val schckFromIntInfToInt32: Primitive.IntInf.int -> Primitive.Int32.int + val schckFromIntInfToInt64: Primitive.IntInf.int -> Primitive.Int64.int + val schckFromIntInfToIntInf: Primitive.IntInf.int -> Primitive.IntInf.int + val schckFromIntInfToWord8: Primitive.IntInf.int -> Primitive.Word8.word + val schckFromIntInfToWord16: Primitive.IntInf.int -> Primitive.Word16.word + val schckFromIntInfToWord32: Primitive.IntInf.int -> Primitive.Word32.word + val schckFromIntInfToWord64: Primitive.IntInf.int -> Primitive.Word64.word + end +signature PRIM_INTEGER = + sig + include PRIM_INTEGER + + val zextdFromIntInf: Primitive.IntInf.int -> int + val zextdToIntInf: int -> Primitive.IntInf.int + + val sextdFromIntInf: Primitive.IntInf.int -> int + val sextdToIntInf: int -> Primitive.IntInf.int + + val castFromIntInf: Primitive.IntInf.int -> int + val castToIntInf: int -> Primitive.IntInf.int + + val zchckFromIntInf: Primitive.IntInf.int -> int + val zchckToIntInf: int -> Primitive.IntInf.int + + val schckFromIntInf: Primitive.IntInf.int -> int + val schckToIntInf: int -> Primitive.IntInf.int + end +signature PRIM_WORD = + sig + include PRIM_WORD + + val zextdFromIntInf: Primitive.IntInf.int -> word + val zextdToIntInf: word -> Primitive.IntInf.int + + val sextdFromIntInf: Primitive.IntInf.int -> word + val sextdToIntInf: word -> Primitive.IntInf.int + + val castFromIntInf: Primitive.IntInf.int -> word + val castToIntInf: word -> Primitive.IntInf.int + + val zchckFromIntInf: Primitive.IntInf.int -> word + val zchckToIntInf: word -> Primitive.IntInf.int + + val schckFromIntInf: Primitive.IntInf.int -> word + val schckToIntInf: word -> Primitive.IntInf.int + end + +structure Primitive = struct + +open Primitive + +structure IntInf = + struct + structure Prim = Primitive.IntInf + structure MLton = Primitive.MLton + + structure A = Primitive.Array + structure V = Primitive.Vector + structure S = SeqIndex + structure ObjptrWord = struct + open ObjptrWord + local + structure S = + ObjptrInt_ChooseIntN + (type 'a t = 'a -> ObjptrWord.word + val fInt8 = ObjptrWord.zextdFromInt8 + val fInt16 = ObjptrWord.zextdFromInt16 + val fInt32 = ObjptrWord.zextdFromInt32 + val fInt64 = ObjptrWord.zextdFromInt64) + in + val idFromObjptrInt = S.f + end + local + structure S = + ObjptrInt_ChooseIntN + (type 'a t = ObjptrWord.word -> 'a + val fInt8 = ObjptrWord.zextdToInt8 + val fInt16 = ObjptrWord.zextdToInt16 + val fInt32 = ObjptrWord.zextdToInt32 + val fInt64 = ObjptrWord.zextdToInt64) + in + val idToObjptrInt = S.f + end + local + structure S = + C_MPLimb_ChooseWordN + (type 'a t = 'a -> ObjptrWord.word + val fWord8 = ObjptrWord.castFromWord8 + val fWord16 = ObjptrWord.castFromWord16 + val fWord32 = ObjptrWord.castFromWord32 + val fWord64 = ObjptrWord.castFromWord64) + in + val castFromMPLimb = S.f + end + local + structure S = + C_MPLimb_ChooseWordN + (type 'a t = ObjptrWord.word -> 'a + val fWord8 = ObjptrWord.castToWord8 + val fWord16 = ObjptrWord.castToWord16 + val fWord32 = ObjptrWord.castToWord32 + val fWord64 = ObjptrWord.castToWord64) + in + val castToMPLimb = S.f + end + end + structure W = ObjptrWord + structure I = ObjptrInt + structure MPLimb = C_MPLimb + structure Sz = struct + open C_Size + local + structure S = + SeqIndex_ChooseIntN + (type 'a t = 'a -> C_Size.word + val fInt8 = C_Size.zextdFromInt8 + val fInt16 = C_Size.zextdFromInt16 + val fInt32 = C_Size.zextdFromInt32 + val fInt64 = C_Size.zextdFromInt64) + in + val zextdFromSeqIndex = S.f + end + end + + type bigInt = Prim.int + + val zero: bigInt = 0 + val one: bigInt = 1 + val negOne: bigInt = ~1 + + (* Check if an IntInf.int is small (i.e., a fixnum). *) + fun isSmall (i: bigInt): bool = + 0w0 <> W.andb (Prim.toWord i, 0w1) + + (* Check if two IntInf.int's are both small (i.e., fixnums). *) + fun areSmall (i: bigInt, i': bigInt): bool = + 0w0 <> W.andb (W.andb (Prim.toWord i, Prim.toWord i'), 0w1) + + (* Return the number of `limbs' in a bigInt. *) + fun bigNumLimbs i = S.- (V.length (Prim.toVector i), 1) + fun numLimbs i = + if isSmall i + then 1 + else bigNumLimbs i + + fun dropTag (w: W.word): W.word = W.~>>? (w, 0w1) + fun dropTagCoerce (i: bigInt): W.word = dropTag (Prim.toWord i) + fun dropTagCoerceInt (i: bigInt): I.int = W.idToObjptrInt (dropTagCoerce i) + fun addTag (w: W.word): W.word = W.orb (W.< + let + val limbsPerObjptr = + if Int32.>= (MPLimb.sizeInBits, ObjptrWord.sizeInBits) + then 1 + else S.sextdFromInt32 (Int32.quot (ObjptrWord.sizeInBits, MPLimb.sizeInBits)) + + val l = V.length v + val ok = + (* sign limb + magnitude limb(s) *) + S.>= (l, 2) andalso + (* sign limb is 0w0 (positive) or 0w1 (negative) *) + MPLimb.<= (V.unsafeSub (v, 0), 0w1) andalso + (* most-significant magnitude limb is non-zero *) + MPLimb.> (V.unsafeSub (v, S.- (l, 1)), 0w0) andalso + (* value exceeds Small representation; + * if positive, then mag in [1, 2^(ObjptrWord.sizeInBits - 2)]. + * if negative, then mag in [0, 2^(ObjptrWord.sizeInBits - 2) - 1]. + *) + (S.> (l, S.+ (1, limbsPerObjptr)) orelse + if Int32.<= (ObjptrWord.sizeInBits, MPLimb.sizeInBits) + then let + val mag = V.unsafeSub (v, 1) + in + MPLimb.>= + (if MPLimb.>= (V.unsafeSub (v, 0), 0w1) then MPLimb.- (mag, 0w1) else mag, + MPLimb.<= + (if MPLimb.>= (V.unsafeSub (v, 0), 0w1) then ObjptrWord.- (mag, 0w1) else mag, + ObjptrWord.< + let + val w = ObjptrWord.idFromObjptrInt i + val wt = addTag w + val ok = w = dropTag wt + in + if ok + then SOME (Prim.fromWord wt) + else NONE + end + + + local + fun 'a make {zextdToMPLimb: 'a -> MPLimb.word, + zextdToObjptrWord: 'a -> ObjptrWord.word, + sextdToObjptrWord: 'a -> ObjptrWord.word, + other : {sizeInBits: Int32.int, + zero: 'a, + eq: 'a * 'a -> bool, + isNeg: 'a -> bool, + neg: 'a -> 'a, + notb: 'a -> 'a, + rashift: 'a * Word32.word -> 'a, + rshift: 'a * Word32.word -> 'a}} + (sextd, w) = + if Int32.> (ObjptrWord.sizeInBits, #sizeInBits other) + orelse let + val shift = Word32.- (ObjptrWord.sizeInBitsWord, 0w2) + val upperBits = (#rashift other) (w, shift) + val zeroBits = #zero other + val oneBits = (#notb other) zeroBits + in + (#eq other) (upperBits, zeroBits) + orelse + (sextd andalso (#eq other) (upperBits, oneBits)) + end + then if sextd + then Prim.fromWord (addTag (sextdToObjptrWord w)) + else Prim.fromWord (addTag (zextdToObjptrWord w)) + else let + fun loop (w, i, acc) = + if (#eq other) (w, (#zero other)) + then (i, acc) + else + let + val limb = zextdToMPLimb w + val w = + (#rshift other) + (w, MPLimb.sizeInBitsWord) + in + loop (w, S.+ (i, 1), (i, limb) :: acc) + end + val (n, acc) = + if sextd andalso (#isNeg other) w + then loop ((#neg other) w, 1, [(0,0w1)]) + else loop (w, 1, [(0,0w0)]) + val a = A.unsafeAlloc n + fun loop acc = + case acc of + [] => () + | (i, v) :: acc => (A.unsafeUpdate (a, i, v) + ; loop acc) + val () = loop acc + in + Prim.fromVector (V.unsafeFromArray a) + end + in + fun extdFromWord8 (sextd, w) = + make {zextdToMPLimb = MPLimb.zextdFromWord8, + zextdToObjptrWord = ObjptrWord.zextdFromWord8, + sextdToObjptrWord = ObjptrWord.sextdFromWord8, + other = {sizeInBits = Word8.sizeInBits, + zero = Word8.zero, + eq = ((op =) : Word8.word * Word8.word -> bool), + isNeg = fn w => Int8.< (IntWordConv.idFromWord8ToInt8 w, 0), + neg = Word8.~, + notb = Word8.notb, + rashift = Word8.~>>?, + rshift = Word8.>>?}} + (sextd, w) + fun zextdFromWord8 w = extdFromWord8 (false, w) + fun zextdFromInt8 i = zextdFromWord8 (IntWordConv.idFromInt8ToWord8 i) + fun sextdFromWord8 w = extdFromWord8 (true, w) + fun sextdFromInt8 i = sextdFromWord8 (IntWordConv.idFromInt8ToWord8 i) + val castFromInt8 = sextdFromInt8 + val castFromWord8 = zextdFromWord8 + val zchckFromInt8 = zextdFromInt8 + val zchckFromWord8 = zextdFromWord8 + val schckFromInt8 = sextdFromInt8 + val schckFromWord8 = sextdFromWord8 + + fun extdFromWord16 (sextd, w) = + make {zextdToMPLimb = MPLimb.zextdFromWord16, + zextdToObjptrWord = ObjptrWord.zextdFromWord16, + sextdToObjptrWord = ObjptrWord.sextdFromWord16, + other = {sizeInBits = Word16.sizeInBits, + zero = Word16.zero, + eq = ((op =) : Word16.word * Word16.word -> bool), + isNeg = fn w => Int16.< (IntWordConv.idFromWord16ToInt16 w, 0), + neg = Word16.~, + notb = Word16.notb, + rashift = Word16.~>>?, + rshift = Word16.>>?}} + (sextd, w) + fun zextdFromWord16 w = extdFromWord16 (false, w) + fun zextdFromInt16 i = zextdFromWord16 (IntWordConv.idFromInt16ToWord16 i) + fun sextdFromWord16 w = extdFromWord16 (true, w) + fun sextdFromInt16 i = sextdFromWord16 (IntWordConv.idFromInt16ToWord16 i) + val castFromInt16 = sextdFromInt16 + val castFromWord16 = zextdFromWord16 + val zchckFromInt16 = zextdFromInt16 + val zchckFromWord16 = zextdFromWord16 + val schckFromInt16 = sextdFromInt16 + val schckFromWord16 = sextdFromWord16 + + fun extdFromWord32 (sextd, w) = + make {zextdToMPLimb = MPLimb.zextdFromWord32, + zextdToObjptrWord = ObjptrWord.zextdFromWord32, + sextdToObjptrWord = ObjptrWord.sextdFromWord32, + other = {sizeInBits = Word32.sizeInBits, + zero = Word32.zero, + eq = ((op =) : Word32.word * Word32.word -> bool), + isNeg = fn w => Int32.< (IntWordConv.idFromWord32ToInt32 w, 0), + neg = Word32.~, + notb = Word32.notb, + rashift = Word32.~>>?, + rshift = Word32.>>?}} + (sextd, w) + fun zextdFromWord32 w = extdFromWord32 (false, w) + fun zextdFromInt32 i = zextdFromWord32 (IntWordConv.idFromInt32ToWord32 i) + fun sextdFromWord32 w = extdFromWord32 (true, w) + fun sextdFromInt32 i = sextdFromWord32 (IntWordConv.idFromInt32ToWord32 i) + val castFromInt32 = sextdFromInt32 + val castFromWord32 = zextdFromWord32 + val zchckFromInt32 = zextdFromInt32 + val zchckFromWord32 = zextdFromWord32 + val schckFromInt32 = sextdFromInt32 + val schckFromWord32 = sextdFromWord32 + + fun extdFromWord64 (sextd, w) = + make {zextdToMPLimb = MPLimb.zextdFromWord64, + zextdToObjptrWord = ObjptrWord.zextdFromWord64, + sextdToObjptrWord = ObjptrWord.sextdFromWord64, + other = {sizeInBits = Word64.sizeInBits, + zero = Word64.zero, + eq = ((op =) : Word64.word * Word64.word -> bool), + isNeg = fn w => Int64.< (IntWordConv.idFromWord64ToInt64 w, 0), + neg = Word64.~, + notb = Word64.notb, + rashift = Word64.~>>?, + rshift = Word64.>>?}} + (sextd, w) + fun zextdFromWord64 w = extdFromWord64 (false, w) + fun zextdFromInt64 i = zextdFromWord64 (IntWordConv.idFromInt64ToWord64 i) + fun sextdFromWord64 w = extdFromWord64 (true, w) + fun sextdFromInt64 i = sextdFromWord64 (IntWordConv.idFromInt64ToWord64 i) + val castFromInt64 = sextdFromInt64 + val castFromWord64 = zextdFromWord64 + val zchckFromInt64 = zextdFromInt64 + val zchckFromWord64 = zextdFromWord64 + val schckFromInt64 = sextdFromInt64 + val schckFromWord64 = sextdFromWord64 + + fun zextdFromIntInf ii = ii + fun sextdFromIntInf ii = ii + fun castFromIntInf ii = ii + fun zchckFromIntInf ii = ii + fun schckFromIntInf ii = ii + end + + local + structure S = + ObjptrInt_ChooseIntN + (type 'a t = 'a -> bigInt + val fInt8 = sextdFromInt8 + val fInt16 = sextdFromInt16 + val fInt32 = sextdFromInt32 + val fInt64 = sextdFromInt64) + in + val sextdFromObjptrInt = S.f + end + + local + datatype 'a ans = + Big of bool * bool * 'a + | Small of ObjptrWord.word + fun 'a make {zextdFromMPLimb: MPLimb.word -> 'a, + other : {sizeInBits: Int32.int, + sizeInBitsWord: Word32.word, + zero: 'a, + lshift: 'a * Word32.word -> 'a, + orb: 'a * 'a -> 'a}} i = + if isSmall i + then Small (dropTagCoerce i) + else let + val v = Prim.toVector i + val n = V.length v + val isneg = V.unsafeSub (v, 0) <> 0w0 + in + if Int32.>= (MPLimb.sizeInBits, #sizeInBits other) + then let + val limbsPer : S.t = 1 + val limb = V.unsafeSub (v, 1) + val extra = + S.> (n, S.+ (limbsPer, 1)) + orelse + (MPLimb.>>? (limb, #sizeInBitsWord other)) <> 0w0 + val ans = zextdFromMPLimb limb + in + Big (isneg, extra, ans) + end + else let + val limbsPer = + S.sextdFromInt32 + (Int32.quot (#sizeInBits other, + MPLimb.sizeInBits)) + val extra = S.> (n, S.+ (limbsPer, 1)) + val ans = + let + fun loop (i, ans) = + if S.> (i, 0) + then let + val limb = V.unsafeSub (v, i) + val ans = + (#orb other) + ((#lshift other) + (ans, MPLimb.sizeInBitsWord), + zextdFromMPLimb limb) + in + loop (S.- (i, 1), ans) + end + else ans + in + loop (S.min (S.- (n, 1), limbsPer), #zero other) + end + in + Big (isneg, extra, ans) + end + end + in + val chckToWord8Aux = + make {zextdFromMPLimb = MPLimb.zextdToWord8, + other = {sizeInBits = Word8.sizeInBits, + sizeInBitsWord = Word8.sizeInBitsWord, + zero = Word8.zero, + lshift = Word8.< ObjptrWord.sextdToWord8 w + | Big (isneg, _, ans) => if isneg then Word8.~ ans else ans + fun sextdToInt8 i = IntWordConv.idFromWord8ToInt8 (sextdToWord8 i) + val zextdToWord8 = sextdToWord8 + fun zextdToInt8 i = IntWordConv.idFromWord8ToInt8 (zextdToWord8 i) + val castToWord8 = sextdToWord8 + val castToInt8 = sextdToInt8 + fun schckToWord8 i = + if not Primitive.Controls.detectOverflow + then sextdToWord8 i + else + case chckToWord8Aux i of + Small w => ObjptrWord.schckToWord8 w + | Big (isneg, extra, ans) => + if extra + then raise Overflow + else if isneg + then let + val ans = Word8.~ ans + val ans' = IntWordConv.idFromWord8ToInt8 ans + in + if Int8.> (ans', 0) + then raise Overflow + else ans + end + else let + val ans' = IntWordConv.idFromWord8ToInt8 ans + in + if Int8.< (ans', 0) + then raise Overflow + else ans + end + fun schckToInt8 i = IntWordConv.idFromWord8ToInt8 (schckToWord8 i) + fun zchckToWord8 i = + if not Primitive.Controls.detectOverflow + then zextdToWord8 i + else + case chckToWord8Aux i of + Small w => ObjptrWord.schckToWord8 w + | Big (isneg, extra, ans) => + if isneg orelse extra + then raise Overflow + else ans + fun zchckToInt8 i = IntWordConv.idFromWord8ToInt8 (zchckToWord8 i) + + val chckToWord16Aux = + make {zextdFromMPLimb = MPLimb.zextdToWord16, + other = {sizeInBits = Word16.sizeInBits, + sizeInBitsWord = Word16.sizeInBitsWord, + zero = Word16.zero, + lshift = Word16.< ObjptrWord.sextdToWord16 w + | Big (isneg, _, ans) => if isneg then Word16.~ ans else ans + fun sextdToInt16 i = IntWordConv.idFromWord16ToInt16 (sextdToWord16 i) + val zextdToWord16 = sextdToWord16 + fun zextdToInt16 i = IntWordConv.idFromWord16ToInt16 (zextdToWord16 i) + val castToWord16 = sextdToWord16 + val castToInt16 = sextdToInt16 + fun schckToWord16 i = + if not Primitive.Controls.detectOverflow + then sextdToWord16 i + else + case chckToWord16Aux i of + Small w => ObjptrWord.schckToWord16 w + | Big (isneg, extra, ans) => + if extra + then raise Overflow + else if isneg + then let + val ans = Word16.~ ans + val ans' = IntWordConv.idFromWord16ToInt16 ans + in + if Int16.> (ans', 0) + then raise Overflow + else ans + end + else let + val ans' = IntWordConv.idFromWord16ToInt16 ans + in + if Int16.< (ans', 0) + then raise Overflow + else ans + end + fun schckToInt16 i = IntWordConv.idFromWord16ToInt16 (schckToWord16 i) + fun zchckToWord16 i = + if not Primitive.Controls.detectOverflow + then zextdToWord16 i + else + case chckToWord16Aux i of + Small w => ObjptrWord.schckToWord16 w + | Big (isneg, extra, ans) => + if isneg orelse extra + then raise Overflow + else ans + fun zchckToInt16 i = IntWordConv.idFromWord16ToInt16 (zchckToWord16 i) + + val chckToWord32Aux = + make {zextdFromMPLimb = MPLimb.zextdToWord32, + other = {sizeInBits = Word32.sizeInBits, + sizeInBitsWord = Word32.sizeInBitsWord, + zero = Word32.zero, + lshift = Word32.< ObjptrWord.sextdToWord32 w + | Big (isneg, _, ans) => if isneg then Word32.~ ans else ans + fun sextdToInt32 i = IntWordConv.idFromWord32ToInt32 (sextdToWord32 i) + val zextdToWord32 = sextdToWord32 + fun zextdToInt32 i = IntWordConv.idFromWord32ToInt32 (zextdToWord32 i) + val castToWord32 = sextdToWord32 + val castToInt32 = sextdToInt32 + fun schckToWord32 i = + if not Primitive.Controls.detectOverflow + then sextdToWord32 i + else + case chckToWord32Aux i of + Small w => ObjptrWord.schckToWord32 w + | Big (isneg, extra, ans) => + if extra + then raise Overflow + else if isneg + then let + val ans = Word32.~ ans + val ans' = IntWordConv.idFromWord32ToInt32 ans + in + if Int32.> (ans', 0) + then raise Overflow + else ans + end + else let + val ans' = IntWordConv.idFromWord32ToInt32 ans + in + if Int32.< (ans', 0) + then raise Overflow + else ans + end + fun schckToInt32 i = IntWordConv.idFromWord32ToInt32 (schckToWord32 i) + fun zchckToWord32 i = + if not Primitive.Controls.detectOverflow + then zextdToWord32 i + else + case chckToWord32Aux i of + Small w => ObjptrWord.schckToWord32 w + | Big (isneg, extra, ans) => + if isneg orelse extra + then raise Overflow + else ans + fun zchckToInt32 i = IntWordConv.idFromWord32ToInt32 (zchckToWord32 i) + + val chckToWord64Aux = + make {zextdFromMPLimb = MPLimb.zextdToWord64, + other = {sizeInBits = Word64.sizeInBits, + sizeInBitsWord = Word64.sizeInBitsWord, + zero = Word64.zero, + lshift = Word64.< ObjptrWord.sextdToWord64 w + | Big (isneg, _, ans) => if isneg then Word64.~ ans else ans + fun sextdToInt64 i = IntWordConv.idFromWord64ToInt64 (sextdToWord64 i) + val zextdToWord64 = sextdToWord64 + fun zextdToInt64 i = IntWordConv.idFromWord64ToInt64 (zextdToWord64 i) + val castToWord64 = sextdToWord64 + val castToInt64 = sextdToInt64 + fun schckToWord64 i = + if not Primitive.Controls.detectOverflow + then sextdToWord64 i + else + case chckToWord64Aux i of + Small w => ObjptrWord.schckToWord64 w + | Big (isneg, extra, ans) => + if extra + then raise Overflow + else if isneg + then let + val ans = Word64.~ ans + val ans' = IntWordConv.idFromWord64ToInt64 ans + in + if Int64.> (ans', 0) + then raise Overflow + else ans + end + else let + val ans' = IntWordConv.idFromWord64ToInt64 ans + in + if Int64.< (ans', 0) + then raise Overflow + else ans + end + fun schckToInt64 i = IntWordConv.idFromWord64ToInt64 (schckToWord64 i) + fun zchckToWord64 i = + if not Primitive.Controls.detectOverflow + then zextdToWord64 i + else + case chckToWord64Aux i of + Small w => ObjptrWord.schckToWord64 w + | Big (isneg, extra, ans) => + if isneg orelse extra + then raise Overflow + else ans + fun zchckToInt64 i = IntWordConv.idFromWord64ToInt64 (zchckToWord64 i) + + fun zextdToIntInf ii = ii + fun sextdToIntInf ii = ii + fun castToIntInf ii = ii + fun zchckToIntInf ii = ii + fun schckToIntInf ii = ii + end + + local + val bytesPerMPLimb = Sz.zextdFromInt32 (Int32.quot (MPLimb.sizeInBits, 8)) + in + val bytesPerArrayMetaData = Sz.zextdFromInt32 ArrayMetaDataSize.bytes + (* Reserve heap space for a large IntInf.int with room for num + extra + * `limbs'. The reason for splitting this up is that extra is intended + * to be a constant, and so can be combined at compile time. + *) + fun reserve (num: S.int, extra: S.int) = + Sz.+ (Sz.* (bytesPerMPLimb, Sz.zextdFromSeqIndex num), + Sz.+ (Sz.* (bytesPerMPLimb, Sz.zextdFromSeqIndex extra), + Sz.+ (bytesPerMPLimb, (* isneg Field *) + Sz.+ (bytesPerArrayMetaData, (* Array MetaData *) + case MLton.Align.align of (* alignment *) + MLton.Align.Align4 => 0w3 + | MLton.Align.Align8 => 0w7 + )))) + end + + (* badObjptr{Int,Word}{,Tagged} is the fixnum IntInf.int whose + * negation and absolute values are not fixnums. + * negBadIntInf is the negation (and absolute value) of that IntInf.int. + *) + val badObjptrInt: I.int = I.~>>? (I.minInt', 0w1) + val badObjptrWord: W.word = W.idFromObjptrInt badObjptrInt + val badObjptrWordTagged: W.word = addTag badObjptrWord + (* val badObjptrIntTagged: I.int = W.idToObjptrInt badObjptrWordTagged *) + val negBadIntInf: bigInt = sextdFromObjptrInt (I.~ badObjptrInt) + + (* Given two ObjptrWord.word's, check if they have the same 'high'/'sign' bit. + *) + fun sameSignBit (lhs: W.word, rhs: W.word): bool = + I.>= (W.idToObjptrInt (W.xorb (lhs, rhs)), 0) + + (* Given a bignum bigint, test if it is (strictly) negative. + *) + fun bigIsNeg (arg: bigInt): bool = + V.unsafeSub (Prim.toVector arg, 0) <> 0w0 + + local + fun make (smallOp, bigOp, limbsFn, extra) + (lhs: bigInt, rhs: bigInt): bigInt = + let + val res = + if areSmall (lhs, rhs) + then let + val lhsw = dropTagCoerce lhs + val lhsi = W.idToObjptrInt lhsw + val rhsw = dropTagCoerce rhs + val rhsi = W.idToObjptrInt rhsw + val ansi = smallOp (lhsi, rhsi) + val answ = W.idFromObjptrInt ansi + val ans = addTag answ + in + if sameSignBit (ans, answ) + then SOME (Prim.fromWord ans) + else NONE + end handle Overflow => NONE + else NONE + in + case res of + NONE => bigOp (lhs, rhs, + reserve (limbsFn (numLimbs lhs, numLimbs rhs), extra)) + | SOME i => i + end + in + val bigAdd = make (I.+!, Prim.+, S.max, 1) + val bigSub = make (I.-!, Prim.-, S.max, 1) + val bigMul = make (I.*!, Prim.*, S.+, 0) + end + + fun bigNeg (arg: bigInt): bigInt = + if isSmall arg + then let + val argw = Prim.toWord arg + in + if argw = badObjptrWordTagged + then negBadIntInf + else Prim.fromWord (W.- (0w2, argw)) + end + else Prim.~ (arg, reserve (numLimbs arg, 1)) + + + fun bigQuot (num: bigInt, den: bigInt): bigInt = + if areSmall (num, den) + then let + val numw = dropTagCoerce num + val numi = W.idToObjptrInt numw + val denw = dropTagCoerce den + val deni = W.idToObjptrInt denw + in + if numw = badObjptrWord + andalso deni = ~1 + then negBadIntInf + else let + val ansi = I.quot (numi, deni) + val answ = W.idFromObjptrInt ansi + val ans = addTag answ + in + Prim.fromWord ans + end + end + else let + val nlimbs = numLimbs num + val dlimbs = numLimbs den + in + if S.< (nlimbs, dlimbs) + then zero + else if den = zero + then raise Div + else Prim.quot (num, den, + reserve (S.- (nlimbs, dlimbs), 2)) + end + + fun bigRem (num: bigInt, den: bigInt): bigInt = + if areSmall (num, den) + then let + val numw = dropTagCoerce num + val numi = W.idToObjptrInt numw + val denw = dropTagCoerce den + val deni = W.idToObjptrInt denw + val ansi = I.rem (numi, deni) + val answ = W.idFromObjptrInt ansi + val ans = addTag answ + in + Prim.fromWord ans + end + else let + val nlimbs = numLimbs num + val dlimbs = numLimbs den + in + if S.< (nlimbs, dlimbs) + then num + else if den = zero + then raise Div + else Prim.rem (num, den, + reserve (dlimbs, 1)) + end + + (* Based on code from PolySpace. *) + local + open I + + fun mod2 x = I.andb (x, 1) + fun div2 x = I.>>? (x, 0w1) + + fun smallGcd (a, b, acc) = + case (a, b) of + (0, _) => b * acc + | (_, 0) => a * acc + | (_, 1) => acc + | (1, _) => acc + | (_ : I.t * I.t) => + if a = b + then a * acc + else + let + val a_2 = div2 a + val a_r2 = mod2 a + val b_2 = div2 b + val b_r2 = mod2 b + in + if 0 = a_r2 + then + if 0 = b_r2 + then smallGcd (a_2, b_2, acc + acc) + else smallGcd (a_2, b, acc) + else + if 0 = b_r2 + then smallGcd (a, b_2, acc) + else + if a >= b + then smallGcd (div2 (a - b), b, acc) + else smallGcd (a, div2 (b - a), acc) + end + in + fun bigGcd (lhs: bigInt, rhs: bigInt): bigInt = + if areSmall (lhs, rhs) + then addTagCoerceInt + (smallGcd (I.abs (dropTagCoerceInt lhs), + I.abs (dropTagCoerceInt rhs), + 1)) + else Prim.gcd + (lhs, rhs, reserve (S.max (numLimbs lhs, numLimbs rhs), 0)) + end + + local + fun make (smallTest: I.int * I.int -> 'a, + int32Test: Int32.int * Int32.int -> 'a) + (lhs: bigInt, rhs: bigInt): 'a = + if areSmall (lhs, rhs) + then smallTest (W.idToObjptrInt (Prim.toWord lhs), + W.idToObjptrInt (Prim.toWord rhs)) + else int32Test (Prim.compare (lhs, rhs), 0) + in + val bigCompare = make (I.compare, Int32.compare) + val bigLT = make (I.<, Int32.<) + val bigLE = make (I.<=, Int32.<=) + val bigGT = make (I.>, Int32.>) + val bigGE = make (I.>=, Int32.>=) + end + + fun bigAbs (arg: bigInt): bigInt = + if isSmall arg + then let + val argw = Prim.toWord arg + in + if argw = badObjptrWordTagged + then negBadIntInf + else if I.< (W.idToObjptrInt argw, 0) + then Prim.fromWord (W.- (0w2, argw)) + else arg + end + else if bigIsNeg arg + then Prim.~ (arg, reserve (numLimbs arg, 1)) + else arg + + fun bigMin (lhs: bigInt, rhs: bigInt): bigInt = + if bigLE (lhs, rhs) then lhs else rhs + + fun bigMax (lhs: bigInt, rhs: bigInt): bigInt = + if bigLE (lhs, rhs) then rhs else lhs + + local + fun bigLTU (lhs, rhs) = + case (bigCompare (lhs, 0), bigCompare (rhs, 0)) of + (LESS, LESS) => bigLT (lhs, rhs) + | (LESS, GREATER) => false + | (_, EQUAL) => false + | (EQUAL, _) => true + | (GREATER, LESS) => true + | (GREATER, GREATER) => bigLT (lhs, rhs) + structure S = IntegralComparisons(type t = bigInt + val op < = bigLTU) + in + val bigLTU = S.< + val bigLEU = S.<= + val bigGTU = S.> + val bigGEU = S.>= + end + + local + val op + = bigAdd + val op - = bigSub + val op > = bigGT + val op >= = bigGE + val op < = bigLT + val quot = bigQuot + val rem = bigRem + in + fun bigDiv (x, y) = + if x >= zero + then if y > zero + then quot (x, y) + else if y < zero + then if x = zero + then zero + else quot (x - one, y) - one + else raise Div + else if y < zero + then quot (x, y) + else if y > zero + then quot (x + one, y) - one + else raise Div + + fun bigMod (x, y) = + if x >= zero + then if y > zero + then rem (x, y) + else if y < zero + then if x = zero + then zero + else rem (x - one, y) + (one + y) + else raise Div + else if y < zero + then rem (x, y) + else if y > zero + then rem (x + one, y) + (y - one) + else raise Div + + fun bigDivMod (x, y) = (bigDiv (x, y), bigMod (x, y)) + fun bigQuotRem (x, y) = (bigQuot (x, y), bigRem (x, y)) + end + + local + fun make (smallOp, bigOp) + (lhs: bigInt, rhs: bigInt) = + if areSmall (lhs, rhs) + then + let + val answ = smallOp (Prim.toWord lhs, Prim.toWord rhs) + val ans = oneTagCoerce answ + in + ans + end + else bigOp (lhs, rhs, + reserve (S.max (numLimbs lhs, numLimbs rhs), 0)) + in + val bigAndb = make (W.andb, Prim.andb) + val bigOrb = make (W.orb, Prim.orb) + val bigXorb = make (W.xorb, Prim.xorb) + end + + fun bigNotb (arg: bigInt): bigInt = + if isSmall arg + then oneTagCoerce (W.notb (Prim.toWord arg)) + else Prim.notb (arg, reserve (numLimbs arg, 0)) + + local + val bitsPerLimb = MPLimb.sizeInBitsWord + fun shiftSize shift = S.sextdFromWord32 (Word32.div (shift, bitsPerLimb)) + in + fun bigLshift (arg: bigInt, shift: Word32.word): bigInt = + if shift = 0wx0 + then arg + else Prim.<< (arg, shift, + reserve (S.+ (numLimbs arg, shiftSize shift), 1)) + fun bigRashift (arg: bigInt, shift: Word32.word): bigInt = + if shift = 0wx0 + then arg + else Prim.~>> (arg, shift, + reserve (S.max (0, S.- (numLimbs arg, shiftSize shift)), 1)) + end + + fun mkBigCvt {base: Int32.int, + smallCvt: I.int -> Primitive.String8.string} + (arg: bigInt) + : Primitive.String8.string = + if isSmall arg + then smallCvt (dropTagCoerceInt arg) + else let + val bpd = Int32.log2 base + val bpl = MPLimb.sizeInBits + val dpl = + Int32.+ (Int32.quot (bpl, bpd), + if Int32.mod (bpl, bpd) = 0 + then 0 else 1) + val bytes = + Sz.+ (Sz.+ (bytesPerArrayMetaData (* Array MetaData *), + Sz.+ (0w1 (* sign *), + case MLton.Align.align of (* alignment *) + MLton.Align.Align4 => 0w3 + | MLton.Align.Align8 => 0w7)), + Sz.* (Sz.zextdFromInt32 dpl, + Sz.zextdFromSeqIndex (numLimbs arg))) + in + Prim.toString (arg, base, bytes) + end + + fun mkBigLog2 {fromSmall: {smallLog2: Primitive.Int32.int} -> 'a, + fromLarge: {numLimbsMinusOne: SeqIndex.int, + mostSigLimbLog2: Primitive.Int32.int} -> 'a} + (arg: bigInt) = + if bigLE (arg, 0) + then raise Domain + else if isSmall arg + then fromSmall {smallLog2 = W.log2 (dropTagCoerce arg)} + else let + val v = Prim.toVector arg + val n = V.length v + val w = MPLimb.log2 (V.unsafeSub (v, S.- (n, 1))) + in + fromLarge {numLimbsMinusOne = S.- (n, 2), + mostSigLimbLog2 = w} + end + + type int = bigInt + type t = int + + val precision = NONE + + val maxInt = NONE + val minInt = NONE + + val abs = bigAbs + val op +! = bigAdd + val op +? = bigAdd + val op + = bigAdd + val divMod = bigDivMod + val op div = bigDiv + val gcd = bigGcd + val op mod = bigMod + val op *! = bigMul + val op *? = bigMul + val op * = bigMul + val op ~! = bigNeg + val op ~? = bigNeg + val op ~ = bigNeg + val quotRem = bigQuotRem + val quot = bigQuot + val rem = bigRem + val op -! = bigSub + val op -? = bigSub + val op - = bigSub + + val op < = bigLT + val op <= = bigLE + val op > = bigGT + val op >= = bigGE + val compare = bigCompare + val min = bigMin + val max = bigMax + val ltu = bigLTU + val leu = bigLEU + val gtu = bigGTU + val geu = bigGEU + + val andb = bigAndb + val <>? = bigRashift + val ~>> = bigRashift + val xorb = bigXorb + + val mkCvt = mkBigCvt + val mkLog2 = mkBigLog2 +end + +structure IntWordConv : PRIM_INTWORD_CONV = + struct + open IntWordConv + + val idFromIntInfToIntInf = fn i => i + + + val zextdFromInt8ToIntInf = IntInf.zextdFromInt8 + val zextdFromInt16ToIntInf = IntInf.zextdFromInt16 + val zextdFromInt32ToIntInf = IntInf.zextdFromInt32 + val zextdFromInt64ToIntInf = IntInf.zextdFromInt64 + val zextdFromWord8ToIntInf = IntInf.zextdFromWord8 + val zextdFromWord16ToIntInf = IntInf.zextdFromWord16 + val zextdFromWord32ToIntInf = IntInf.zextdFromWord32 + val zextdFromWord64ToIntInf = IntInf.zextdFromWord64 + + val zextdFromIntInfToInt8 = IntInf.zextdToInt8 + val zextdFromIntInfToInt16 = IntInf.zextdToInt16 + val zextdFromIntInfToInt32 = IntInf.zextdToInt32 + val zextdFromIntInfToInt64 = IntInf.zextdToInt64 + val zextdFromIntInfToIntInf = IntInf.zextdToIntInf + val zextdFromIntInfToWord8 = IntInf.zextdToWord8 + val zextdFromIntInfToWord16 = IntInf.zextdToWord16 + val zextdFromIntInfToWord32 = IntInf.zextdToWord32 + val zextdFromIntInfToWord64 = IntInf.zextdToWord64 + + + val sextdFromInt8ToIntInf = IntInf.sextdFromInt8 + val sextdFromInt16ToIntInf = IntInf.sextdFromInt16 + val sextdFromInt32ToIntInf = IntInf.sextdFromInt32 + val sextdFromInt64ToIntInf = IntInf.sextdFromInt64 + val sextdFromWord8ToIntInf = IntInf.sextdFromWord8 + val sextdFromWord16ToIntInf = IntInf.sextdFromWord16 + val sextdFromWord32ToIntInf = IntInf.sextdFromWord32 + val sextdFromWord64ToIntInf = IntInf.sextdFromWord64 + + val sextdFromIntInfToInt8 = IntInf.sextdToInt8 + val sextdFromIntInfToInt16 = IntInf.sextdToInt16 + val sextdFromIntInfToInt32 = IntInf.sextdToInt32 + val sextdFromIntInfToInt64 = IntInf.sextdToInt64 + val sextdFromIntInfToIntInf = IntInf.sextdToIntInf + val sextdFromIntInfToWord8 = IntInf.sextdToWord8 + val sextdFromIntInfToWord16 = IntInf.sextdToWord16 + val sextdFromIntInfToWord32 = IntInf.sextdToWord32 + val sextdFromIntInfToWord64 = IntInf.sextdToWord64 + + + val castFromInt8ToIntInf = IntInf.castFromInt8 + val castFromInt16ToIntInf = IntInf.castFromInt16 + val castFromInt32ToIntInf = IntInf.castFromInt32 + val castFromInt64ToIntInf = IntInf.castFromInt64 + val castFromWord8ToIntInf = IntInf.castFromWord8 + val castFromWord16ToIntInf = IntInf.castFromWord16 + val castFromWord32ToIntInf = IntInf.castFromWord32 + val castFromWord64ToIntInf = IntInf.castFromWord64 + + val castFromIntInfToInt8 = IntInf.castToInt8 + val castFromIntInfToInt16 = IntInf.castToInt16 + val castFromIntInfToInt32 = IntInf.castToInt32 + val castFromIntInfToInt64 = IntInf.castToInt64 + val castFromIntInfToIntInf = IntInf.castToIntInf + val castFromIntInfToWord8 = IntInf.castToWord8 + val castFromIntInfToWord16 = IntInf.castToWord16 + val castFromIntInfToWord32 = IntInf.castToWord32 + val castFromIntInfToWord64 = IntInf.castToWord64 + + + val zchckFromInt8ToIntInf = IntInf.zchckFromInt8 + val zchckFromInt16ToIntInf = IntInf.zchckFromInt16 + val zchckFromInt32ToIntInf = IntInf.zchckFromInt32 + val zchckFromInt64ToIntInf = IntInf.zchckFromInt64 + val zchckFromWord8ToIntInf = IntInf.zchckFromWord8 + val zchckFromWord16ToIntInf = IntInf.zchckFromWord16 + val zchckFromWord32ToIntInf = IntInf.zchckFromWord32 + val zchckFromWord64ToIntInf = IntInf.zchckFromWord64 + + val zchckFromIntInfToInt8 = IntInf.zchckToInt8 + val zchckFromIntInfToInt16 = IntInf.zchckToInt16 + val zchckFromIntInfToInt32 = IntInf.zchckToInt32 + val zchckFromIntInfToInt64 = IntInf.zchckToInt64 + val zchckFromIntInfToIntInf = IntInf.zchckToIntInf + val zchckFromIntInfToWord8 = IntInf.zchckToWord8 + val zchckFromIntInfToWord16 = IntInf.zchckToWord16 + val zchckFromIntInfToWord32 = IntInf.zchckToWord32 + val zchckFromIntInfToWord64 = IntInf.zchckToWord64 + + + val schckFromInt8ToIntInf = IntInf.schckFromInt8 + val schckFromInt16ToIntInf = IntInf.schckFromInt16 + val schckFromInt32ToIntInf = IntInf.schckFromInt32 + val schckFromInt64ToIntInf = IntInf.schckFromInt64 + val schckFromWord8ToIntInf = IntInf.schckFromWord8 + val schckFromWord16ToIntInf = IntInf.schckFromWord16 + val schckFromWord32ToIntInf = IntInf.schckFromWord32 + val schckFromWord64ToIntInf = IntInf.schckFromWord64 + + val schckFromIntInfToInt8 = IntInf.schckToInt8 + val schckFromIntInfToInt16 = IntInf.schckToInt16 + val schckFromIntInfToInt32 = IntInf.schckToInt32 + val schckFromIntInfToInt64 = IntInf.schckToInt64 + val schckFromIntInfToIntInf = IntInf.schckToIntInf + val schckFromIntInfToWord8 = IntInf.schckToWord8 + val schckFromIntInfToWord16 = IntInf.schckToWord16 + val schckFromIntInfToWord32 = IntInf.schckToWord32 + val schckFromIntInfToWord64 = IntInf.schckToWord64 + end + +structure Int8 : PRIM_INTEGER = + struct + open Int8 + + val zextdFromIntInf = IntWordConv.zextdFromIntInfToInt8 + val zextdToIntInf = IntWordConv.zextdFromInt8ToIntInf + + val sextdFromIntInf = IntWordConv.sextdFromIntInfToInt8 + val sextdToIntInf = IntWordConv.sextdFromInt8ToIntInf + + val castFromIntInf = IntWordConv.castFromIntInfToInt8 + val castToIntInf = IntWordConv.castFromInt8ToIntInf + + val zchckFromIntInf = IntWordConv.zchckFromIntInfToInt8 + val zchckToIntInf = IntWordConv.zchckFromInt8ToIntInf + + val schckFromIntInf = IntWordConv.schckFromIntInfToInt8 + val schckToIntInf = IntWordConv.schckFromInt8ToIntInf + end +structure Int16 : PRIM_INTEGER = + struct + open Int16 + + val zextdFromIntInf = IntWordConv.zextdFromIntInfToInt16 + val zextdToIntInf = IntWordConv.zextdFromInt16ToIntInf + + val sextdFromIntInf = IntWordConv.sextdFromIntInfToInt16 + val sextdToIntInf = IntWordConv.sextdFromInt16ToIntInf + + val castFromIntInf = IntWordConv.castFromIntInfToInt16 + val castToIntInf = IntWordConv.castFromInt16ToIntInf + + val zchckFromIntInf = IntWordConv.zchckFromIntInfToInt16 + val zchckToIntInf = IntWordConv.zchckFromInt16ToIntInf + + val schckFromIntInf = IntWordConv.schckFromIntInfToInt16 + val schckToIntInf = IntWordConv.schckFromInt16ToIntInf + end +structure Int32 : PRIM_INTEGER = + struct + open Int32 + + val zextdFromIntInf = IntWordConv.zextdFromIntInfToInt32 + val zextdToIntInf = IntWordConv.zextdFromInt32ToIntInf + + val sextdFromIntInf = IntWordConv.sextdFromIntInfToInt32 + val sextdToIntInf = IntWordConv.sextdFromInt32ToIntInf + + val castFromIntInf = IntWordConv.castFromIntInfToInt32 + val castToIntInf = IntWordConv.castFromInt32ToIntInf + + val zchckFromIntInf = IntWordConv.zchckFromIntInfToInt32 + val zchckToIntInf = IntWordConv.zchckFromInt32ToIntInf + + val schckFromIntInf = IntWordConv.schckFromIntInfToInt32 + val schckToIntInf = IntWordConv.schckFromInt32ToIntInf + end +structure Int64 : PRIM_INTEGER = + struct + open Int64 + + val zextdFromIntInf = IntWordConv.zextdFromIntInfToInt64 + val zextdToIntInf = IntWordConv.zextdFromInt64ToIntInf + + val sextdFromIntInf = IntWordConv.sextdFromIntInfToInt64 + val sextdToIntInf = IntWordConv.sextdFromInt64ToIntInf + + val castFromIntInf = IntWordConv.castFromIntInfToInt64 + val castToIntInf = IntWordConv.castFromInt64ToIntInf + + val zchckFromIntInf = IntWordConv.zchckFromIntInfToInt64 + val zchckToIntInf = IntWordConv.zchckFromInt64ToIntInf + + val schckFromIntInf = IntWordConv.schckFromIntInfToInt64 + val schckToIntInf = IntWordConv.schckFromInt64ToIntInf + end +structure Word8 : PRIM_WORD = + struct + open Word8 + + val zextdFromIntInf = IntWordConv.zextdFromIntInfToWord8 + val zextdToIntInf = IntWordConv.zextdFromWord8ToIntInf + + val sextdFromIntInf = IntWordConv.sextdFromIntInfToWord8 + val sextdToIntInf = IntWordConv.sextdFromWord8ToIntInf + + val castFromIntInf = IntWordConv.castFromIntInfToWord8 + val castToIntInf = IntWordConv.castFromWord8ToIntInf + + val zchckFromIntInf = IntWordConv.zchckFromIntInfToWord8 + val zchckToIntInf = IntWordConv.zchckFromWord8ToIntInf + + val schckFromIntInf = IntWordConv.schckFromIntInfToWord8 + val schckToIntInf = IntWordConv.schckFromWord8ToIntInf + end +structure Word16 : PRIM_WORD = + struct + open Word16 + + val zextdFromIntInf = IntWordConv.zextdFromIntInfToWord16 + val zextdToIntInf = IntWordConv.zextdFromWord16ToIntInf + + val sextdFromIntInf = IntWordConv.sextdFromIntInfToWord16 + val sextdToIntInf = IntWordConv.sextdFromWord16ToIntInf + + val castFromIntInf = IntWordConv.castFromIntInfToWord16 + val castToIntInf = IntWordConv.castFromWord16ToIntInf + + val zchckFromIntInf = IntWordConv.zchckFromIntInfToWord16 + val zchckToIntInf = IntWordConv.zchckFromWord16ToIntInf + + val schckFromIntInf = IntWordConv.schckFromIntInfToWord16 + val schckToIntInf = IntWordConv.schckFromWord16ToIntInf + end +structure Word32 : PRIM_WORD = + struct + open Word32 + + val zextdFromIntInf = IntWordConv.zextdFromIntInfToWord32 + val zextdToIntInf = IntWordConv.zextdFromWord32ToIntInf + + val sextdFromIntInf = IntWordConv.sextdFromIntInfToWord32 + val sextdToIntInf = IntWordConv.sextdFromWord32ToIntInf + + val castFromIntInf = IntWordConv.castFromIntInfToWord32 + val castToIntInf = IntWordConv.castFromWord32ToIntInf + + val zchckFromIntInf = IntWordConv.zchckFromIntInfToWord32 + val zchckToIntInf = IntWordConv.zchckFromWord32ToIntInf + + val schckFromIntInf = IntWordConv.schckFromIntInfToWord32 + val schckToIntInf = IntWordConv.schckFromWord32ToIntInf + end +structure Word64 : PRIM_WORD = + struct + open Word64 + + val zextdFromIntInf = IntWordConv.zextdFromIntInfToWord64 + val zextdToIntInf = IntWordConv.zextdFromWord64ToIntInf + + val sextdFromIntInf = IntWordConv.sextdFromIntInfToWord64 + val sextdToIntInf = IntWordConv.sextdFromWord64ToIntInf + + val castFromIntInf = IntWordConv.castFromIntInfToWord64 + val castToIntInf = IntWordConv.castFromWord64ToIntInf + + val zchckFromIntInf = IntWordConv.zchckFromIntInfToWord64 + val zchckToIntInf = IntWordConv.zchckFromWord64ToIntInf + + val schckFromIntInf = IntWordConv.schckFromIntInfToWord64 + val schckToIntInf = IntWordConv.schckFromWord64ToIntInf + end + +structure IntInf : PRIM_INT_INF = IntInf + +end diff --git a/basis-library/integer/int.sml b/basis-library/integer/int.sml new file mode 100644 index 0000000..a219019 --- /dev/null +++ b/basis-library/integer/int.sml @@ -0,0 +1,172 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor Integer (I: PRIM_INTEGER): INTEGER_EXTRA = +struct + +open I +type t = int + +val precision': Int.int = Primitive.Int32.zextdToInt sizeInBits +val precision: Int.int option = SOME precision' +val sizeInBitsWord = Primitive.Word32.zextdToWord sizeInBitsWord + +val maxInt: int option = SOME maxInt' +val minInt: int option = SOME minInt' + +val sign: int -> Int.int = + fn i => if i = zero + then (0: Int.int) + else if i < zero + then (~1: Int.int) + else (1: Int.int) + +fun sameSign (x, y) = sign x = sign y + +fun << (i, n) = + if Word.>= (n, sizeInBitsWord) + then zero + else I.<> (i, n) = + if Word.>= (n, sizeInBitsWord) + then zero + else I.>>? (i, Primitive.Word32.zextdFromWord n) +fun ~>> (i, n) = + if Word.< (n, sizeInBitsWord) + then I.~>>? (i, Primitive.Word32.zextdFromWord n) + else I.~>>? (i, Primitive.Word32.- (I.sizeInBitsWord, 0w1)) +fun rol (i, n) = I.rolUnsafe (i, Primitive.Word32.zextdFromWord n) +fun ror (i, n) = I.rorUnsafe (i, Primitive.Word32.zextdFromWord n) + +val fromInt = I.schckFromInt +val toInt = I.schckToInt + +val fromLargeInt = I.schckFromLargeInt +val toLargeInt = I.schckToLargeInt +val fromLarge = fromLargeInt +val toLarge = toLargeInt + +(* fmt constructs a string to represent the integer by building it into a + * statically allocated buffer. For the most part, this is a textbook + * algorithm: loop starting at the end of the buffer; we use rem to + * extract the next digit to put into the buffer; and we use quot to + * figure out the part of the integer that we haven't yet formatted. + * However, this function uses the negative absolute value of the input + * number, which allows it to take into account minInt without any + * special-casing. This requires the rem function to behave in a very + * specific way, or else things will go terribly wrong. This may be a + * concern when porting to platforms where the division hardware has a + * different interpretation than SML about what happens when doing + * division of negative numbers. + *) +local + (* Allocate a buffer large enough to hold any formatted integer in any radix. + * The most that will be required is for minInt in binary. + *) + val maxNumDigits = Int.+ (precision', 1) + val oneBuf = One.make (fn () => CharArray.array (maxNumDigits, #"\000")) +in + fun fmt radix (n: int): string = + One.use + (oneBuf, fn buf => + let + val radix = fromInt (StringCvt.radixToInt radix) + fun loop (q, i: Int.int) = + let + val _ = + CharArray.update + (buf, i, StringCvt.digitToChar (toInt (~? (rem (q, radix))))) + val q = quot (q, radix) + in + if q = zero + then + let + val start = + if n < zero + then + let + val i = Int.- (i, 1) + val () = CharArray.update (buf, i, #"~") + in + i + end + else i + in + CharArraySlice.vector + (CharArraySlice.slice (buf, start, NONE)) + end + else loop (q, Int.- (i, 1)) + end + in + loop (if n < zero then n else ~? n, Int.- (maxNumDigits, 1)) + end) +end + +val toString = fmt StringCvt.DEC + +fun scan radix reader s = + let + (* Works with the negative of the number so that minInt can be scanned. *) + val s = StringCvt.skipWS reader s + fun charToDigit c = + case StringCvt.charToDigit radix c of + NONE => NONE + | SOME n => SOME (fromInt n) + val radixInt = fromInt (StringCvt.radixToInt radix) + fun finishNum (s, n) = + case reader s of + NONE => SOME (n, s) + | SOME (c, s') => + case charToDigit c of + NONE => SOME (n, s) + | SOME n' => finishNum (s', n * radixInt - n') + fun num s = + case (reader s, radix) of + (NONE, _) => NONE + | (SOME (#"0", s), StringCvt.HEX) => + (case reader s of + NONE => SOME (zero, s) + | SOME (c, s') => + if c = #"x" orelse c = #"X" then + case reader s' of + NONE => SOME (zero, s) + | SOME (c, s') => + case charToDigit c of + NONE => SOME (zero, s) + | SOME n => finishNum (s', ~? n) + else + case charToDigit c of + NONE => SOME (zero, s) + | SOME n => finishNum (s', ~? n)) + | (SOME (c, s), _) => + case charToDigit c of + NONE => NONE + | SOME n => finishNum (s, ~? n) + fun negate s = + case num s of + NONE => NONE + | SOME (n, s) => SOME (~ n, s) + in + case reader s of + NONE => NONE + | SOME (c, s') => + case c of + #"~" => num s' + | #"-" => num s' + | #"+" => negate s' + | _ => negate s + end + +val fromString = StringCvt.scanString (scan StringCvt.DEC) + +end + +structure Int8 = Integer (Primitive.Int8) +structure Int16 = Integer (Primitive.Int16) +structure Int32 = Integer (Primitive.Int32) +structure Int64 = Integer (Primitive.Int64) diff --git a/basis-library/integer/integer.sig b/basis-library/integer/integer.sig new file mode 100644 index 0000000..4fe4c1a --- /dev/null +++ b/basis-library/integer/integer.sig @@ -0,0 +1,87 @@ +signature INTEGER_GLOBAL = + sig + eqtype int + end + +signature INTEGER = + sig + include INTEGER_GLOBAL + + val precision : Int.int option + val minInt : int option + val maxInt : int option + + val toLarge: int -> LargeInt.int + val fromLarge: LargeInt.int -> int + val toInt: int -> Int.int + val fromInt: Int.int -> int + + val + : int * int -> int + val - : int * int -> int + val * : int * int -> int + val div: int * int -> int + val mod: int * int -> int + val quot: int * int -> int + val rem: int * int -> int + + val compare: int * int -> order + val < : int * int -> bool + val <= : int * int -> bool + val > : int * int -> bool + val >= : int * int -> bool + + val ~ : int -> int + val abs: int -> int + val min: int * int -> int + val max: int * int -> int + + val sign: int -> Int.int + val sameSign: int * int -> bool + + val fmt: StringCvt.radix -> int -> string + val toString: int -> string + val scan: (StringCvt.radix + -> (char, 'a) StringCvt.reader + -> (int, 'a) StringCvt.reader) + val fromString: string -> int option + end + +signature INTEGER_EXTRA = + sig + include INTEGER + type t = int + + val zero: int + val one: int + + val precision' : Int.int + val maxInt' : int + val minInt' : int + + val +? : int * int -> int + val *? : int * int -> int + val -? : int * int -> int + val ~? : int -> int + + val andb: int * int -> int + val << : int * Word.word -> int + val notb: int -> int + val orb: int * int -> int + val rol: int * Word.word -> int + val ror: int * Word.word -> int + val ~>> : int * Word.word -> int + val >> : int * Word.word -> int + val xorb: int * int -> int + + val ltu: int * int -> bool + val leu: int * int -> bool + val gtu: int * int -> bool + val geu: int * int -> bool + + val toLargeInt: int -> LargeInt.int + val fromLargeInt: LargeInt.int -> int + val castFromFixedInt: FixedInt.int -> int + val castToFixedInt: int -> FixedInt.int + val castFromSysWord: SysWord.word -> int + val castToSysWord: int -> SysWord.word + end diff --git a/basis-library/integer/iwconv0.sml b/basis-library/integer/iwconv0.sml new file mode 100644 index 0000000..6f7e4d2 --- /dev/null +++ b/basis-library/integer/iwconv0.sml @@ -0,0 +1,1474 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature PRIM_INTWORD_CONV = + sig + include PRIM_INTWORD_CONV + + (* C-like cast: extend according to signedness of from or low-bits *) + val castFromInt8ToInt8: Primitive.Int8.int -> Primitive.Int8.int + val castFromInt8ToInt16: Primitive.Int8.int -> Primitive.Int16.int + val castFromInt8ToInt32: Primitive.Int8.int -> Primitive.Int32.int + val castFromInt8ToInt64: Primitive.Int8.int -> Primitive.Int64.int + val castFromInt8ToWord8: Primitive.Int8.int -> Primitive.Word8.word + val castFromInt8ToWord16: Primitive.Int8.int -> Primitive.Word16.word + val castFromInt8ToWord32: Primitive.Int8.int -> Primitive.Word32.word + val castFromInt8ToWord64: Primitive.Int8.int -> Primitive.Word64.word + + val castFromInt16ToInt8: Primitive.Int16.int -> Primitive.Int8.int + val castFromInt16ToInt16: Primitive.Int16.int -> Primitive.Int16.int + val castFromInt16ToInt32: Primitive.Int16.int -> Primitive.Int32.int + val castFromInt16ToInt64: Primitive.Int16.int -> Primitive.Int64.int + val castFromInt16ToWord8: Primitive.Int16.int -> Primitive.Word8.word + val castFromInt16ToWord16: Primitive.Int16.int -> Primitive.Word16.word + val castFromInt16ToWord32: Primitive.Int16.int -> Primitive.Word32.word + val castFromInt16ToWord64: Primitive.Int16.int -> Primitive.Word64.word + + val castFromInt32ToInt8: Primitive.Int32.int -> Primitive.Int8.int + val castFromInt32ToInt16: Primitive.Int32.int -> Primitive.Int16.int + val castFromInt32ToInt32: Primitive.Int32.int -> Primitive.Int32.int + val castFromInt32ToInt64: Primitive.Int32.int -> Primitive.Int64.int + val castFromInt32ToWord8: Primitive.Int32.int -> Primitive.Word8.word + val castFromInt32ToWord16: Primitive.Int32.int -> Primitive.Word16.word + val castFromInt32ToWord32: Primitive.Int32.int -> Primitive.Word32.word + val castFromInt32ToWord64: Primitive.Int32.int -> Primitive.Word64.word + + val castFromInt64ToInt8: Primitive.Int64.int -> Primitive.Int8.int + val castFromInt64ToInt16: Primitive.Int64.int -> Primitive.Int16.int + val castFromInt64ToInt32: Primitive.Int64.int -> Primitive.Int32.int + val castFromInt64ToInt64: Primitive.Int64.int -> Primitive.Int64.int + val castFromInt64ToWord8: Primitive.Int64.int -> Primitive.Word8.word + val castFromInt64ToWord16: Primitive.Int64.int -> Primitive.Word16.word + val castFromInt64ToWord32: Primitive.Int64.int -> Primitive.Word32.word + val castFromInt64ToWord64: Primitive.Int64.int -> Primitive.Word64.word + + val castFromWord8ToInt8: Primitive.Word8.word -> Primitive.Int8.int + val castFromWord8ToInt16: Primitive.Word8.word -> Primitive.Int16.int + val castFromWord8ToInt32: Primitive.Word8.word -> Primitive.Int32.int + val castFromWord8ToInt64: Primitive.Word8.word -> Primitive.Int64.int + val castFromWord8ToWord8: Primitive.Word8.word -> Primitive.Word8.word + val castFromWord8ToWord16: Primitive.Word8.word -> Primitive.Word16.word + val castFromWord8ToWord32: Primitive.Word8.word -> Primitive.Word32.word + val castFromWord8ToWord64: Primitive.Word8.word -> Primitive.Word64.word + + val castFromWord16ToInt8: Primitive.Word16.word -> Primitive.Int8.int + val castFromWord16ToInt16: Primitive.Word16.word -> Primitive.Int16.int + val castFromWord16ToInt32: Primitive.Word16.word -> Primitive.Int32.int + val castFromWord16ToInt64: Primitive.Word16.word -> Primitive.Int64.int + val castFromWord16ToWord8: Primitive.Word16.word -> Primitive.Word8.word + val castFromWord16ToWord16: Primitive.Word16.word -> Primitive.Word16.word + val castFromWord16ToWord32: Primitive.Word16.word -> Primitive.Word32.word + val castFromWord16ToWord64: Primitive.Word16.word -> Primitive.Word64.word + + val castFromWord32ToInt8: Primitive.Word32.word -> Primitive.Int8.int + val castFromWord32ToInt16: Primitive.Word32.word -> Primitive.Int16.int + val castFromWord32ToInt32: Primitive.Word32.word -> Primitive.Int32.int + val castFromWord32ToInt64: Primitive.Word32.word -> Primitive.Int64.int + val castFromWord32ToWord8: Primitive.Word32.word -> Primitive.Word8.word + val castFromWord32ToWord16: Primitive.Word32.word -> Primitive.Word16.word + val castFromWord32ToWord32: Primitive.Word32.word -> Primitive.Word32.word + val castFromWord32ToWord64: Primitive.Word32.word -> Primitive.Word64.word + + val castFromWord64ToInt8: Primitive.Word64.word -> Primitive.Int8.int + val castFromWord64ToInt16: Primitive.Word64.word -> Primitive.Int16.int + val castFromWord64ToInt32: Primitive.Word64.word -> Primitive.Int32.int + val castFromWord64ToInt64: Primitive.Word64.word -> Primitive.Int64.int + val castFromWord64ToWord8: Primitive.Word64.word -> Primitive.Word8.word + val castFromWord64ToWord16: Primitive.Word64.word -> Primitive.Word16.word + val castFromWord64ToWord32: Primitive.Word64.word -> Primitive.Word32.word + val castFromWord64ToWord64: Primitive.Word64.word -> Primitive.Word64.word + + (* checked zero-extend or low-bits, + * Overflow if composed zero-extend not identity + *) + val zchckFromInt8ToInt8: Primitive.Int8.int -> Primitive.Int8.int + val zchckFromInt8ToInt16: Primitive.Int8.int -> Primitive.Int16.int + val zchckFromInt8ToInt32: Primitive.Int8.int -> Primitive.Int32.int + val zchckFromInt8ToInt64: Primitive.Int8.int -> Primitive.Int64.int + val zchckFromInt8ToWord8: Primitive.Int8.int -> Primitive.Word8.word + val zchckFromInt8ToWord16: Primitive.Int8.int -> Primitive.Word16.word + val zchckFromInt8ToWord32: Primitive.Int8.int -> Primitive.Word32.word + val zchckFromInt8ToWord64: Primitive.Int8.int -> Primitive.Word64.word + + val zchckFromInt16ToInt8: Primitive.Int16.int -> Primitive.Int8.int + val zchckFromInt16ToInt16: Primitive.Int16.int -> Primitive.Int16.int + val zchckFromInt16ToInt32: Primitive.Int16.int -> Primitive.Int32.int + val zchckFromInt16ToInt64: Primitive.Int16.int -> Primitive.Int64.int + val zchckFromInt16ToWord8: Primitive.Int16.int -> Primitive.Word8.word + val zchckFromInt16ToWord16: Primitive.Int16.int -> Primitive.Word16.word + val zchckFromInt16ToWord32: Primitive.Int16.int -> Primitive.Word32.word + val zchckFromInt16ToWord64: Primitive.Int16.int -> Primitive.Word64.word + + val zchckFromInt32ToInt8: Primitive.Int32.int -> Primitive.Int8.int + val zchckFromInt32ToInt16: Primitive.Int32.int -> Primitive.Int16.int + val zchckFromInt32ToInt32: Primitive.Int32.int -> Primitive.Int32.int + val zchckFromInt32ToInt64: Primitive.Int32.int -> Primitive.Int64.int + val zchckFromInt32ToWord8: Primitive.Int32.int -> Primitive.Word8.word + val zchckFromInt32ToWord16: Primitive.Int32.int -> Primitive.Word16.word + val zchckFromInt32ToWord32: Primitive.Int32.int -> Primitive.Word32.word + val zchckFromInt32ToWord64: Primitive.Int32.int -> Primitive.Word64.word + + val zchckFromInt64ToInt8: Primitive.Int64.int -> Primitive.Int8.int + val zchckFromInt64ToInt16: Primitive.Int64.int -> Primitive.Int16.int + val zchckFromInt64ToInt32: Primitive.Int64.int -> Primitive.Int32.int + val zchckFromInt64ToInt64: Primitive.Int64.int -> Primitive.Int64.int + val zchckFromInt64ToWord8: Primitive.Int64.int -> Primitive.Word8.word + val zchckFromInt64ToWord16: Primitive.Int64.int -> Primitive.Word16.word + val zchckFromInt64ToWord32: Primitive.Int64.int -> Primitive.Word32.word + val zchckFromInt64ToWord64: Primitive.Int64.int -> Primitive.Word64.word + + val zchckFromWord8ToInt8: Primitive.Word8.word -> Primitive.Int8.int + val zchckFromWord8ToInt16: Primitive.Word8.word -> Primitive.Int16.int + val zchckFromWord8ToInt32: Primitive.Word8.word -> Primitive.Int32.int + val zchckFromWord8ToInt64: Primitive.Word8.word -> Primitive.Int64.int + val zchckFromWord8ToWord8: Primitive.Word8.word -> Primitive.Word8.word + val zchckFromWord8ToWord16: Primitive.Word8.word -> Primitive.Word16.word + val zchckFromWord8ToWord32: Primitive.Word8.word -> Primitive.Word32.word + val zchckFromWord8ToWord64: Primitive.Word8.word -> Primitive.Word64.word + + val zchckFromWord16ToInt8: Primitive.Word16.word -> Primitive.Int8.int + val zchckFromWord16ToInt16: Primitive.Word16.word -> Primitive.Int16.int + val zchckFromWord16ToInt32: Primitive.Word16.word -> Primitive.Int32.int + val zchckFromWord16ToInt64: Primitive.Word16.word -> Primitive.Int64.int + val zchckFromWord16ToWord8: Primitive.Word16.word -> Primitive.Word8.word + val zchckFromWord16ToWord16: Primitive.Word16.word -> Primitive.Word16.word + val zchckFromWord16ToWord32: Primitive.Word16.word -> Primitive.Word32.word + val zchckFromWord16ToWord64: Primitive.Word16.word -> Primitive.Word64.word + + val zchckFromWord32ToInt8: Primitive.Word32.word -> Primitive.Int8.int + val zchckFromWord32ToInt16: Primitive.Word32.word -> Primitive.Int16.int + val zchckFromWord32ToInt32: Primitive.Word32.word -> Primitive.Int32.int + val zchckFromWord32ToInt64: Primitive.Word32.word -> Primitive.Int64.int + val zchckFromWord32ToWord8: Primitive.Word32.word -> Primitive.Word8.word + val zchckFromWord32ToWord16: Primitive.Word32.word -> Primitive.Word16.word + val zchckFromWord32ToWord32: Primitive.Word32.word -> Primitive.Word32.word + val zchckFromWord32ToWord64: Primitive.Word32.word -> Primitive.Word64.word + + val zchckFromWord64ToInt8: Primitive.Word64.word -> Primitive.Int8.int + val zchckFromWord64ToInt16: Primitive.Word64.word -> Primitive.Int16.int + val zchckFromWord64ToInt32: Primitive.Word64.word -> Primitive.Int32.int + val zchckFromWord64ToInt64: Primitive.Word64.word -> Primitive.Int64.int + val zchckFromWord64ToWord8: Primitive.Word64.word -> Primitive.Word8.word + val zchckFromWord64ToWord16: Primitive.Word64.word -> Primitive.Word16.word + val zchckFromWord64ToWord32: Primitive.Word64.word -> Primitive.Word32.word + val zchckFromWord64ToWord64: Primitive.Word64.word -> Primitive.Word64.word + + (* checked sign-extend or low-bits, + * Overflow if composed sign-extend not identity + *) + val schckFromInt8ToInt8: Primitive.Int8.int -> Primitive.Int8.int + val schckFromInt8ToInt16: Primitive.Int8.int -> Primitive.Int16.int + val schckFromInt8ToInt32: Primitive.Int8.int -> Primitive.Int32.int + val schckFromInt8ToInt64: Primitive.Int8.int -> Primitive.Int64.int + val schckFromInt8ToWord8: Primitive.Int8.int -> Primitive.Word8.word + val schckFromInt8ToWord16: Primitive.Int8.int -> Primitive.Word16.word + val schckFromInt8ToWord32: Primitive.Int8.int -> Primitive.Word32.word + val schckFromInt8ToWord64: Primitive.Int8.int -> Primitive.Word64.word + + val schckFromInt16ToInt8: Primitive.Int16.int -> Primitive.Int8.int + val schckFromInt16ToInt16: Primitive.Int16.int -> Primitive.Int16.int + val schckFromInt16ToInt32: Primitive.Int16.int -> Primitive.Int32.int + val schckFromInt16ToInt64: Primitive.Int16.int -> Primitive.Int64.int + val schckFromInt16ToWord8: Primitive.Int16.int -> Primitive.Word8.word + val schckFromInt16ToWord16: Primitive.Int16.int -> Primitive.Word16.word + val schckFromInt16ToWord32: Primitive.Int16.int -> Primitive.Word32.word + val schckFromInt16ToWord64: Primitive.Int16.int -> Primitive.Word64.word + + val schckFromInt32ToInt8: Primitive.Int32.int -> Primitive.Int8.int + val schckFromInt32ToInt16: Primitive.Int32.int -> Primitive.Int16.int + val schckFromInt32ToInt32: Primitive.Int32.int -> Primitive.Int32.int + val schckFromInt32ToInt64: Primitive.Int32.int -> Primitive.Int64.int + val schckFromInt32ToWord8: Primitive.Int32.int -> Primitive.Word8.word + val schckFromInt32ToWord16: Primitive.Int32.int -> Primitive.Word16.word + val schckFromInt32ToWord32: Primitive.Int32.int -> Primitive.Word32.word + val schckFromInt32ToWord64: Primitive.Int32.int -> Primitive.Word64.word + + val schckFromInt64ToInt8: Primitive.Int64.int -> Primitive.Int8.int + val schckFromInt64ToInt16: Primitive.Int64.int -> Primitive.Int16.int + val schckFromInt64ToInt32: Primitive.Int64.int -> Primitive.Int32.int + val schckFromInt64ToInt64: Primitive.Int64.int -> Primitive.Int64.int + val schckFromInt64ToWord8: Primitive.Int64.int -> Primitive.Word8.word + val schckFromInt64ToWord16: Primitive.Int64.int -> Primitive.Word16.word + val schckFromInt64ToWord32: Primitive.Int64.int -> Primitive.Word32.word + val schckFromInt64ToWord64: Primitive.Int64.int -> Primitive.Word64.word + + val schckFromWord8ToInt8: Primitive.Word8.word -> Primitive.Int8.int + val schckFromWord8ToInt16: Primitive.Word8.word -> Primitive.Int16.int + val schckFromWord8ToInt32: Primitive.Word8.word -> Primitive.Int32.int + val schckFromWord8ToInt64: Primitive.Word8.word -> Primitive.Int64.int + val schckFromWord8ToWord8: Primitive.Word8.word -> Primitive.Word8.word + val schckFromWord8ToWord16: Primitive.Word8.word -> Primitive.Word16.word + val schckFromWord8ToWord32: Primitive.Word8.word -> Primitive.Word32.word + val schckFromWord8ToWord64: Primitive.Word8.word -> Primitive.Word64.word + + val schckFromWord16ToInt8: Primitive.Word16.word -> Primitive.Int8.int + val schckFromWord16ToInt16: Primitive.Word16.word -> Primitive.Int16.int + val schckFromWord16ToInt32: Primitive.Word16.word -> Primitive.Int32.int + val schckFromWord16ToInt64: Primitive.Word16.word -> Primitive.Int64.int + val schckFromWord16ToWord8: Primitive.Word16.word -> Primitive.Word8.word + val schckFromWord16ToWord16: Primitive.Word16.word -> Primitive.Word16.word + val schckFromWord16ToWord32: Primitive.Word16.word -> Primitive.Word32.word + val schckFromWord16ToWord64: Primitive.Word16.word -> Primitive.Word64.word + + val schckFromWord32ToInt8: Primitive.Word32.word -> Primitive.Int8.int + val schckFromWord32ToInt16: Primitive.Word32.word -> Primitive.Int16.int + val schckFromWord32ToInt32: Primitive.Word32.word -> Primitive.Int32.int + val schckFromWord32ToInt64: Primitive.Word32.word -> Primitive.Int64.int + val schckFromWord32ToWord8: Primitive.Word32.word -> Primitive.Word8.word + val schckFromWord32ToWord16: Primitive.Word32.word -> Primitive.Word16.word + val schckFromWord32ToWord32: Primitive.Word32.word -> Primitive.Word32.word + val schckFromWord32ToWord64: Primitive.Word32.word -> Primitive.Word64.word + + val schckFromWord64ToInt8: Primitive.Word64.word -> Primitive.Int8.int + val schckFromWord64ToInt16: Primitive.Word64.word -> Primitive.Int16.int + val schckFromWord64ToInt32: Primitive.Word64.word -> Primitive.Int32.int + val schckFromWord64ToInt64: Primitive.Word64.word -> Primitive.Int64.int + val schckFromWord64ToWord8: Primitive.Word64.word -> Primitive.Word8.word + val schckFromWord64ToWord16: Primitive.Word64.word -> Primitive.Word16.word + val schckFromWord64ToWord32: Primitive.Word64.word -> Primitive.Word32.word + val schckFromWord64ToWord64: Primitive.Word64.word -> Primitive.Word64.word + end +signature PRIM_INTEGER = + sig + include PRIM_INTEGER + + val zextdFromInt8: Primitive.Int8.int -> int + val zextdFromInt16: Primitive.Int16.int -> int + val zextdFromInt32: Primitive.Int32.int -> int + val zextdFromInt64: Primitive.Int64.int -> int + val zextdFromWord8: Primitive.Word8.word -> int + val zextdFromWord16: Primitive.Word16.word -> int + val zextdFromWord32: Primitive.Word32.word -> int + val zextdFromWord64: Primitive.Word64.word -> int + val zextdToInt8: int -> Primitive.Int8.int + val zextdToInt16: int -> Primitive.Int16.int + val zextdToInt32: int -> Primitive.Int32.int + val zextdToInt64: int -> Primitive.Int64.int + val zextdToWord8: int -> Primitive.Word8.word + val zextdToWord16: int -> Primitive.Word16.word + val zextdToWord32: int -> Primitive.Word32.word + val zextdToWord64: int -> Primitive.Word64.word + + val sextdFromInt8: Primitive.Int8.int -> int + val sextdFromInt16: Primitive.Int16.int -> int + val sextdFromInt32: Primitive.Int32.int -> int + val sextdFromInt64: Primitive.Int64.int -> int + val sextdFromWord8: Primitive.Word8.word -> int + val sextdFromWord16: Primitive.Word16.word -> int + val sextdFromWord32: Primitive.Word32.word -> int + val sextdFromWord64: Primitive.Word64.word -> int + val sextdToInt8: int -> Primitive.Int8.int + val sextdToInt16: int -> Primitive.Int16.int + val sextdToInt32: int -> Primitive.Int32.int + val sextdToInt64: int -> Primitive.Int64.int + val sextdToWord8: int -> Primitive.Word8.word + val sextdToWord16: int -> Primitive.Word16.word + val sextdToWord32: int -> Primitive.Word32.word + val sextdToWord64: int -> Primitive.Word64.word + + val castFromInt8: Primitive.Int8.int -> int + val castFromInt16: Primitive.Int16.int -> int + val castFromInt32: Primitive.Int32.int -> int + val castFromInt64: Primitive.Int64.int -> int + val castFromWord8: Primitive.Word8.word -> int + val castFromWord16: Primitive.Word16.word -> int + val castFromWord32: Primitive.Word32.word -> int + val castFromWord64: Primitive.Word64.word -> int + val castToInt8: int -> Primitive.Int8.int + val castToInt16: int -> Primitive.Int16.int + val castToInt32: int -> Primitive.Int32.int + val castToInt64: int -> Primitive.Int64.int + val castToWord8: int -> Primitive.Word8.word + val castToWord16: int -> Primitive.Word16.word + val castToWord32: int -> Primitive.Word32.word + val castToWord64: int -> Primitive.Word64.word + + val zchckFromInt8: Primitive.Int8.int -> int + val zchckFromInt16: Primitive.Int16.int -> int + val zchckFromInt32: Primitive.Int32.int -> int + val zchckFromInt64: Primitive.Int64.int -> int + val zchckFromWord8: Primitive.Word8.word -> int + val zchckFromWord16: Primitive.Word16.word -> int + val zchckFromWord32: Primitive.Word32.word -> int + val zchckFromWord64: Primitive.Word64.word -> int + val zchckToInt8: int -> Primitive.Int8.int + val zchckToInt16: int -> Primitive.Int16.int + val zchckToInt32: int -> Primitive.Int32.int + val zchckToInt64: int -> Primitive.Int64.int + val zchckToWord8: int -> Primitive.Word8.word + val zchckToWord16: int -> Primitive.Word16.word + val zchckToWord32: int -> Primitive.Word32.word + val zchckToWord64: int -> Primitive.Word64.word + + val schckFromInt8: Primitive.Int8.int -> int + val schckFromInt16: Primitive.Int16.int -> int + val schckFromInt32: Primitive.Int32.int -> int + val schckFromInt64: Primitive.Int64.int -> int + val schckFromWord8: Primitive.Word8.word -> int + val schckFromWord16: Primitive.Word16.word -> int + val schckFromWord32: Primitive.Word32.word -> int + val schckFromWord64: Primitive.Word64.word -> int + val schckToInt8: int -> Primitive.Int8.int + val schckToInt16: int -> Primitive.Int16.int + val schckToInt32: int -> Primitive.Int32.int + val schckToInt64: int -> Primitive.Int64.int + val schckToWord8: int -> Primitive.Word8.word + val schckToWord16: int -> Primitive.Word16.word + val schckToWord32: int -> Primitive.Word32.word + val schckToWord64: int -> Primitive.Word64.word + end +signature PRIM_WORD = + sig + include PRIM_WORD + + val zextdFromInt8: Primitive.Int8.int -> word + val zextdFromInt16: Primitive.Int16.int -> word + val zextdFromInt32: Primitive.Int32.int -> word + val zextdFromInt64: Primitive.Int64.int -> word + val zextdFromWord8: Primitive.Word8.word -> word + val zextdFromWord16: Primitive.Word16.word -> word + val zextdFromWord32: Primitive.Word32.word -> word + val zextdFromWord64: Primitive.Word64.word -> word + val zextdToInt8: word -> Primitive.Int8.int + val zextdToInt16: word -> Primitive.Int16.int + val zextdToInt32: word -> Primitive.Int32.int + val zextdToInt64: word -> Primitive.Int64.int + val zextdToWord8: word -> Primitive.Word8.word + val zextdToWord16: word -> Primitive.Word16.word + val zextdToWord32: word -> Primitive.Word32.word + val zextdToWord64: word -> Primitive.Word64.word + + val sextdFromInt8: Primitive.Int8.int -> word + val sextdFromInt16: Primitive.Int16.int -> word + val sextdFromInt32: Primitive.Int32.int -> word + val sextdFromInt64: Primitive.Int64.int -> word + val sextdFromWord8: Primitive.Word8.word -> word + val sextdFromWord16: Primitive.Word16.word -> word + val sextdFromWord32: Primitive.Word32.word -> word + val sextdFromWord64: Primitive.Word64.word -> word + val sextdToInt8: word -> Primitive.Int8.int + val sextdToInt16: word -> Primitive.Int16.int + val sextdToInt32: word -> Primitive.Int32.int + val sextdToInt64: word -> Primitive.Int64.int + val sextdToWord8: word -> Primitive.Word8.word + val sextdToWord16: word -> Primitive.Word16.word + val sextdToWord32: word -> Primitive.Word32.word + val sextdToWord64: word -> Primitive.Word64.word + + val castFromInt8: Primitive.Int8.int -> word + val castFromInt16: Primitive.Int16.int -> word + val castFromInt32: Primitive.Int32.int -> word + val castFromInt64: Primitive.Int64.int -> word + val castFromWord8: Primitive.Word8.word -> word + val castFromWord16: Primitive.Word16.word -> word + val castFromWord32: Primitive.Word32.word -> word + val castFromWord64: Primitive.Word64.word -> word + val castToInt8: word -> Primitive.Int8.int + val castToInt16: word -> Primitive.Int16.int + val castToInt32: word -> Primitive.Int32.int + val castToInt64: word -> Primitive.Int64.int + val castToWord8: word -> Primitive.Word8.word + val castToWord16: word -> Primitive.Word16.word + val castToWord32: word -> Primitive.Word32.word + val castToWord64: word -> Primitive.Word64.word + + val zchckFromInt8: Primitive.Int8.int -> word + val zchckFromInt16: Primitive.Int16.int -> word + val zchckFromInt32: Primitive.Int32.int -> word + val zchckFromInt64: Primitive.Int64.int -> word + val zchckFromWord8: Primitive.Word8.word -> word + val zchckFromWord16: Primitive.Word16.word -> word + val zchckFromWord32: Primitive.Word32.word -> word + val zchckFromWord64: Primitive.Word64.word -> word + val zchckToInt8: word -> Primitive.Int8.int + val zchckToInt16: word -> Primitive.Int16.int + val zchckToInt32: word -> Primitive.Int32.int + val zchckToInt64: word -> Primitive.Int64.int + val zchckToWord8: word -> Primitive.Word8.word + val zchckToWord16: word -> Primitive.Word16.word + val zchckToWord32: word -> Primitive.Word32.word + val zchckToWord64: word -> Primitive.Word64.word + + val schckFromInt8: Primitive.Int8.int -> word + val schckFromInt16: Primitive.Int16.int -> word + val schckFromInt32: Primitive.Int32.int -> word + val schckFromInt64: Primitive.Int64.int -> word + val schckFromWord8: Primitive.Word8.word -> word + val schckFromWord16: Primitive.Word16.word -> word + val schckFromWord32: Primitive.Word32.word -> word + val schckFromWord64: Primitive.Word64.word -> word + val schckToInt8: word -> Primitive.Int8.int + val schckToInt16: word -> Primitive.Int16.int + val schckToInt32: word -> Primitive.Int32.int + val schckToInt64: word -> Primitive.Int64.int + val schckToWord8: word -> Primitive.Word8.word + val schckToWord16: word -> Primitive.Word16.word + val schckToWord32: word -> Primitive.Word32.word + val schckToWord64: word -> Primitive.Word64.word + end + +structure Primitive = struct + +open Primitive + +structure IntWordConv : PRIM_INTWORD_CONV = + struct + open IntWordConv + + (* C-like cast: extend according to signedness of from or low-bits *) + val castFromInt8ToInt8 = sextdFromInt8ToInt8 + val castFromInt8ToInt16 = sextdFromInt8ToInt16 + val castFromInt8ToInt32 = sextdFromInt8ToInt32 + val castFromInt8ToInt64 = sextdFromInt8ToInt64 + val castFromInt8ToWord8 = sextdFromInt8ToWord8 + val castFromInt8ToWord16 = sextdFromInt8ToWord16 + val castFromInt8ToWord32 = sextdFromInt8ToWord32 + val castFromInt8ToWord64 = sextdFromInt8ToWord64 + val castFromInt16ToInt8 = sextdFromInt16ToInt8 + val castFromInt16ToInt16 = sextdFromInt16ToInt16 + val castFromInt16ToInt32 = sextdFromInt16ToInt32 + val castFromInt16ToInt64 = sextdFromInt16ToInt64 + val castFromInt16ToWord8 = sextdFromInt16ToWord8 + val castFromInt16ToWord16 = sextdFromInt16ToWord16 + val castFromInt16ToWord32 = sextdFromInt16ToWord32 + val castFromInt16ToWord64 = sextdFromInt16ToWord64 + val castFromInt32ToInt8 = sextdFromInt32ToInt8 + val castFromInt32ToInt16 = sextdFromInt32ToInt16 + val castFromInt32ToInt32 = sextdFromInt32ToInt32 + val castFromInt32ToInt64 = sextdFromInt32ToInt64 + val castFromInt32ToWord8 = sextdFromInt32ToWord8 + val castFromInt32ToWord16 = sextdFromInt32ToWord16 + val castFromInt32ToWord32 = sextdFromInt32ToWord32 + val castFromInt32ToWord64 = sextdFromInt32ToWord64 + val castFromInt64ToInt8 = sextdFromInt64ToInt8 + val castFromInt64ToInt16 = sextdFromInt64ToInt16 + val castFromInt64ToInt32 = sextdFromInt64ToInt32 + val castFromInt64ToInt64 = sextdFromInt64ToInt64 + val castFromInt64ToWord8 = sextdFromInt64ToWord8 + val castFromInt64ToWord16 = sextdFromInt64ToWord16 + val castFromInt64ToWord32 = sextdFromInt64ToWord32 + val castFromInt64ToWord64 = sextdFromInt64ToWord64 + + val castFromWord8ToInt8 = zextdFromWord8ToInt8 + val castFromWord8ToInt16 = zextdFromWord8ToInt16 + val castFromWord8ToInt32 = zextdFromWord8ToInt32 + val castFromWord8ToInt64 = zextdFromWord8ToInt64 + val castFromWord8ToWord8 = zextdFromWord8ToWord8 + val castFromWord8ToWord16 = zextdFromWord8ToWord16 + val castFromWord8ToWord32 = zextdFromWord8ToWord32 + val castFromWord8ToWord64 = zextdFromWord8ToWord64 + val castFromWord16ToInt8 = zextdFromWord16ToInt8 + val castFromWord16ToInt16 = zextdFromWord16ToInt16 + val castFromWord16ToInt32 = zextdFromWord16ToInt32 + val castFromWord16ToInt64 = zextdFromWord16ToInt64 + val castFromWord16ToWord8 = zextdFromWord16ToWord8 + val castFromWord16ToWord16 = zextdFromWord16ToWord16 + val castFromWord16ToWord32 = zextdFromWord16ToWord32 + val castFromWord16ToWord64 = zextdFromWord16ToWord64 + val castFromWord32ToInt8 = zextdFromWord32ToInt8 + val castFromWord32ToInt16 = zextdFromWord32ToInt16 + val castFromWord32ToInt32 = zextdFromWord32ToInt32 + val castFromWord32ToInt64 = zextdFromWord32ToInt64 + val castFromWord32ToWord8 = zextdFromWord32ToWord8 + val castFromWord32ToWord16 = zextdFromWord32ToWord16 + val castFromWord32ToWord32 = zextdFromWord32ToWord32 + val castFromWord32ToWord64 = zextdFromWord32ToWord64 + val castFromWord64ToInt8 = zextdFromWord64ToInt8 + val castFromWord64ToInt16 = zextdFromWord64ToInt16 + val castFromWord64ToInt32 = zextdFromWord64ToInt32 + val castFromWord64ToInt64 = zextdFromWord64ToInt64 + val castFromWord64ToWord8 = zextdFromWord64ToWord8 + val castFromWord64ToWord16 = zextdFromWord64ToWord16 + val castFromWord64ToWord32 = zextdFromWord64ToWord32 + val castFromWord64ToWord64 = zextdFromWord64ToWord64 + + (* checked zero-extend or low-bits, + * Overflow if composed zero-extend not identity + *) + local + fun (''l, ''s) make {zextdFromLargeToSmall: ''l -> ''s, + zextdFromSmallToLarge: ''s -> ''l} = + if Primitive.Controls.detectOverflow + then fn (x: ''l) => let + val res = zextdFromLargeToSmall x + in + if x = (zextdFromSmallToLarge res) + then res + else raise Overflow + end + else zextdFromLargeToSmall + in + val zchckFromInt8ToInt8 = zextdFromInt8ToInt8 + val zchckFromInt8ToInt16 = zextdFromInt8ToInt16 + val zchckFromInt8ToInt32 = zextdFromInt8ToInt32 + val zchckFromInt8ToInt64 = zextdFromInt8ToInt64 + val zchckFromInt8ToWord8 = zextdFromInt8ToWord8 + val zchckFromInt8ToWord16 = zextdFromInt8ToWord16 + val zchckFromInt8ToWord32 = zextdFromInt8ToWord32 + val zchckFromInt8ToWord64 = zextdFromInt8ToWord64 + val zchckFromInt16ToInt8 = + make {zextdFromLargeToSmall = zextdFromInt16ToInt8, + zextdFromSmallToLarge = zextdFromInt8ToInt16} + val zchckFromInt16ToInt16 = zextdFromInt16ToInt16 + val zchckFromInt16ToInt32 = zextdFromInt16ToInt32 + val zchckFromInt16ToInt64 = zextdFromInt16ToInt64 + val zchckFromInt16ToWord8 = + make {zextdFromLargeToSmall = zextdFromInt16ToWord8, + zextdFromSmallToLarge = zextdFromWord8ToInt16} + val zchckFromInt16ToWord16 = zextdFromInt16ToWord16 + val zchckFromInt16ToWord32 = zextdFromInt16ToWord32 + val zchckFromInt16ToWord64 = zextdFromInt16ToWord64 + val zchckFromInt32ToInt8 = + make {zextdFromLargeToSmall = zextdFromInt32ToInt8, + zextdFromSmallToLarge = zextdFromInt8ToInt32} + val zchckFromInt32ToInt16 = + make {zextdFromLargeToSmall = zextdFromInt32ToInt16, + zextdFromSmallToLarge = zextdFromInt16ToInt32} + val zchckFromInt32ToInt32 = zextdFromInt32ToInt32 + val zchckFromInt32ToInt64 = zextdFromInt32ToInt64 + val zchckFromInt32ToWord8 = + make {zextdFromLargeToSmall = zextdFromInt32ToWord8, + zextdFromSmallToLarge = zextdFromWord8ToInt32} + val zchckFromInt32ToWord16 = + make {zextdFromLargeToSmall = zextdFromInt32ToWord16, + zextdFromSmallToLarge = zextdFromWord16ToInt32} + val zchckFromInt32ToWord32 = zextdFromInt32ToWord32 + val zchckFromInt32ToWord64 = zextdFromInt32ToWord64 + val zchckFromInt64ToInt8 = + make {zextdFromLargeToSmall = zextdFromInt64ToInt8, + zextdFromSmallToLarge = zextdFromInt8ToInt64} + val zchckFromInt64ToInt16 = + make {zextdFromLargeToSmall = zextdFromInt64ToInt16, + zextdFromSmallToLarge = zextdFromInt16ToInt64} + val zchckFromInt64ToInt32 = + make {zextdFromLargeToSmall = zextdFromInt64ToInt32, + zextdFromSmallToLarge = zextdFromInt32ToInt64} + val zchckFromInt64ToInt64 = zextdFromInt64ToInt64 + val zchckFromInt64ToWord8 = + make {zextdFromLargeToSmall = zextdFromInt64ToWord8, + zextdFromSmallToLarge = zextdFromWord8ToInt64} + val zchckFromInt64ToWord16 = + make {zextdFromLargeToSmall = zextdFromInt64ToWord16, + zextdFromSmallToLarge = zextdFromWord16ToInt64} + val zchckFromInt64ToWord32 = + make {zextdFromLargeToSmall = zextdFromInt64ToWord32, + zextdFromSmallToLarge = zextdFromWord32ToInt64} + val zchckFromInt64ToWord64 = zextdFromInt64ToWord64 + + val zchckFromWord8ToInt8 = zextdFromWord8ToInt8 + val zchckFromWord8ToInt16 = zextdFromWord8ToInt16 + val zchckFromWord8ToInt32 = zextdFromWord8ToInt32 + val zchckFromWord8ToInt64 = zextdFromWord8ToInt64 + val zchckFromWord8ToWord8 = zextdFromWord8ToWord8 + val zchckFromWord8ToWord16 = zextdFromWord8ToWord16 + val zchckFromWord8ToWord32 = zextdFromWord8ToWord32 + val zchckFromWord8ToWord64 = zextdFromWord8ToWord64 + val zchckFromWord16ToInt8 = + make {zextdFromLargeToSmall = zextdFromWord16ToInt8, + zextdFromSmallToLarge = zextdFromInt8ToWord16} + val zchckFromWord16ToInt16 = zextdFromWord16ToInt16 + val zchckFromWord16ToInt32 = zextdFromWord16ToInt32 + val zchckFromWord16ToInt64 = zextdFromWord16ToInt64 + val zchckFromWord16ToWord8 = + make {zextdFromLargeToSmall = zextdFromWord16ToWord8, + zextdFromSmallToLarge = zextdFromWord8ToWord16} + val zchckFromWord16ToWord16 = zextdFromWord16ToWord16 + val zchckFromWord16ToWord32 = zextdFromWord16ToWord32 + val zchckFromWord16ToWord64 = zextdFromWord16ToWord64 + val zchckFromWord32ToInt8 = + make {zextdFromLargeToSmall = zextdFromWord32ToInt8, + zextdFromSmallToLarge = zextdFromInt8ToWord32} + val zchckFromWord32ToInt16 = + make {zextdFromLargeToSmall = zextdFromWord32ToInt16, + zextdFromSmallToLarge = zextdFromInt16ToWord32} + val zchckFromWord32ToInt32 = zextdFromWord32ToInt32 + val zchckFromWord32ToInt64 = zextdFromWord32ToInt64 + val zchckFromWord32ToWord8 = + make {zextdFromLargeToSmall = zextdFromWord32ToWord8, + zextdFromSmallToLarge = zextdFromWord8ToWord32} + val zchckFromWord32ToWord16 = + make {zextdFromLargeToSmall = zextdFromWord32ToWord16, + zextdFromSmallToLarge = zextdFromWord16ToWord32} + val zchckFromWord32ToWord32 = zextdFromWord32ToWord32 + val zchckFromWord32ToWord64 = zextdFromWord32ToWord64 + val zchckFromWord64ToInt8 = + make {zextdFromLargeToSmall = zextdFromWord64ToInt8, + zextdFromSmallToLarge = zextdFromInt8ToWord64} + val zchckFromWord64ToInt16 = + make {zextdFromLargeToSmall = zextdFromWord64ToInt16, + zextdFromSmallToLarge = zextdFromInt16ToWord64} + val zchckFromWord64ToInt32 = + make {zextdFromLargeToSmall = zextdFromWord64ToInt32, + zextdFromSmallToLarge = zextdFromInt32ToWord64} + val zchckFromWord64ToInt64 = zextdFromWord64ToInt64 + val zchckFromWord64ToWord8 = + make {zextdFromLargeToSmall = zextdFromWord64ToWord8, + zextdFromSmallToLarge = zextdFromWord8ToWord64} + val zchckFromWord64ToWord16 = + make {zextdFromLargeToSmall = zextdFromWord64ToWord16, + zextdFromSmallToLarge = zextdFromWord16ToWord64} + val zchckFromWord64ToWord32 = + make {zextdFromLargeToSmall = zextdFromWord64ToWord32, + zextdFromSmallToLarge = zextdFromWord32ToWord64} + val zchckFromWord64ToWord64 = zextdFromWord64ToWord64 + end + + (* checked sign-extend or low-bits, + * Overflow if composed sign-extend not identity + *) + local + fun (''l, ''s) make {sextdFromLargeToSmall: ''l -> ''s, + sextdFromSmallToLarge: ''s -> ''l} = + if Primitive.Controls.detectOverflow + then fn (x: ''l) => let + val res = sextdFromLargeToSmall x + in + if x = (sextdFromSmallToLarge res) + then res + else raise Overflow + end + else sextdFromLargeToSmall + in + val schckFromInt8ToInt8 = sextdFromInt8ToInt8 + val schckFromInt8ToInt16 = sextdFromInt8ToInt16 + val schckFromInt8ToInt32 = sextdFromInt8ToInt32 + val schckFromInt8ToInt64 = sextdFromInt8ToInt64 + val schckFromInt8ToWord8 = sextdFromInt8ToWord8 + val schckFromInt8ToWord16 = sextdFromInt8ToWord16 + val schckFromInt8ToWord32 = sextdFromInt8ToWord32 + val schckFromInt8ToWord64 = sextdFromInt8ToWord64 + val schckFromInt16ToInt8 = + make {sextdFromLargeToSmall = sextdFromInt16ToInt8, + sextdFromSmallToLarge = sextdFromInt8ToInt16} + val schckFromInt16ToInt16 = sextdFromInt16ToInt16 + val schckFromInt16ToInt32 = sextdFromInt16ToInt32 + val schckFromInt16ToInt64 = sextdFromInt16ToInt64 + val schckFromInt16ToWord8 = + make {sextdFromLargeToSmall = sextdFromInt16ToWord8, + sextdFromSmallToLarge = sextdFromWord8ToInt16} + val schckFromInt16ToWord16 = sextdFromInt16ToWord16 + val schckFromInt16ToWord32 = sextdFromInt16ToWord32 + val schckFromInt16ToWord64 = sextdFromInt16ToWord64 + val schckFromInt32ToInt8 = + make {sextdFromLargeToSmall = sextdFromInt32ToInt8, + sextdFromSmallToLarge = sextdFromInt8ToInt32} + val schckFromInt32ToInt16 = + make {sextdFromLargeToSmall = sextdFromInt32ToInt16, + sextdFromSmallToLarge = sextdFromInt16ToInt32} + val schckFromInt32ToInt32 = sextdFromInt32ToInt32 + val schckFromInt32ToInt64 = sextdFromInt32ToInt64 + val schckFromInt32ToWord8 = + make {sextdFromLargeToSmall = sextdFromInt32ToWord8, + sextdFromSmallToLarge = sextdFromWord8ToInt32} + val schckFromInt32ToWord16 = + make {sextdFromLargeToSmall = sextdFromInt32ToWord16, + sextdFromSmallToLarge = sextdFromWord16ToInt32} + val schckFromInt32ToWord32 = sextdFromInt32ToWord32 + val schckFromInt32ToWord64 = sextdFromInt32ToWord64 + val schckFromInt64ToInt8 = + make {sextdFromLargeToSmall = sextdFromInt64ToInt8, + sextdFromSmallToLarge = sextdFromInt8ToInt64} + val schckFromInt64ToInt16 = + make {sextdFromLargeToSmall = sextdFromInt64ToInt16, + sextdFromSmallToLarge = sextdFromInt16ToInt64} + val schckFromInt64ToInt32 = + make {sextdFromLargeToSmall = sextdFromInt64ToInt32, + sextdFromSmallToLarge = sextdFromInt32ToInt64} + val schckFromInt64ToInt64 = sextdFromInt64ToInt64 + val schckFromInt64ToWord8 = + make {sextdFromLargeToSmall = sextdFromInt64ToWord8, + sextdFromSmallToLarge = sextdFromWord8ToInt64} + val schckFromInt64ToWord16 = + make {sextdFromLargeToSmall = sextdFromInt64ToWord16, + sextdFromSmallToLarge = sextdFromWord16ToInt64} + val schckFromInt64ToWord32 = + make {sextdFromLargeToSmall = sextdFromInt64ToWord32, + sextdFromSmallToLarge = sextdFromWord32ToInt64} + val schckFromInt64ToWord64 = sextdFromInt64ToWord64 + + val schckFromWord8ToInt8 = sextdFromWord8ToInt8 + val schckFromWord8ToInt16 = sextdFromWord8ToInt16 + val schckFromWord8ToInt32 = sextdFromWord8ToInt32 + val schckFromWord8ToInt64 = sextdFromWord8ToInt64 + val schckFromWord8ToWord8 = sextdFromWord8ToWord8 + val schckFromWord8ToWord16 = sextdFromWord8ToWord16 + val schckFromWord8ToWord32 = sextdFromWord8ToWord32 + val schckFromWord8ToWord64 = sextdFromWord8ToWord64 + val schckFromWord16ToInt8 = + make {sextdFromLargeToSmall = sextdFromWord16ToInt8, + sextdFromSmallToLarge = sextdFromInt8ToWord16} + val schckFromWord16ToInt16 = sextdFromWord16ToInt16 + val schckFromWord16ToInt32 = sextdFromWord16ToInt32 + val schckFromWord16ToInt64 = sextdFromWord16ToInt64 + val schckFromWord16ToWord8 = + make {sextdFromLargeToSmall = sextdFromWord16ToWord8, + sextdFromSmallToLarge = sextdFromWord8ToWord16} + val schckFromWord16ToWord16 = sextdFromWord16ToWord16 + val schckFromWord16ToWord32 = sextdFromWord16ToWord32 + val schckFromWord16ToWord64 = sextdFromWord16ToWord64 + val schckFromWord32ToInt8 = + make {sextdFromLargeToSmall = sextdFromWord32ToInt8, + sextdFromSmallToLarge = sextdFromInt8ToWord32} + val schckFromWord32ToInt16 = + make {sextdFromLargeToSmall = sextdFromWord32ToInt16, + sextdFromSmallToLarge = sextdFromInt16ToWord32} + val schckFromWord32ToInt32 = sextdFromWord32ToInt32 + val schckFromWord32ToInt64 = sextdFromWord32ToInt64 + val schckFromWord32ToWord8 = + make {sextdFromLargeToSmall = sextdFromWord32ToWord8, + sextdFromSmallToLarge = sextdFromWord8ToWord32} + val schckFromWord32ToWord16 = + make {sextdFromLargeToSmall = sextdFromWord32ToWord16, + sextdFromSmallToLarge = sextdFromWord16ToWord32} + val schckFromWord32ToWord32 = sextdFromWord32ToWord32 + val schckFromWord32ToWord64 = sextdFromWord32ToWord64 + val schckFromWord64ToInt8 = + make {sextdFromLargeToSmall = sextdFromWord64ToInt8, + sextdFromSmallToLarge = sextdFromInt8ToWord64} + val schckFromWord64ToInt16 = + make {sextdFromLargeToSmall = sextdFromWord64ToInt16, + sextdFromSmallToLarge = sextdFromInt16ToWord64} + val schckFromWord64ToInt32 = + make {sextdFromLargeToSmall = sextdFromWord64ToInt32, + sextdFromSmallToLarge = sextdFromInt32ToWord64} + val schckFromWord64ToInt64 = sextdFromWord64ToInt64 + val schckFromWord64ToWord8 = + make {sextdFromLargeToSmall = sextdFromWord64ToWord8, + sextdFromSmallToLarge = sextdFromWord8ToWord64} + val schckFromWord64ToWord16 = + make {sextdFromLargeToSmall = sextdFromWord64ToWord16, + sextdFromSmallToLarge = sextdFromWord16ToWord64} + val schckFromWord64ToWord32 = + make {sextdFromLargeToSmall = sextdFromWord64ToWord32, + sextdFromSmallToLarge = sextdFromWord32ToWord64} + val schckFromWord64ToWord64 = sextdFromWord64ToWord64 + end + + end + +structure Int8 : PRIM_INTEGER = + struct + open Int8 + + val zextdFromInt8 = IntWordConv.zextdFromInt8ToInt8 + val zextdFromInt16 = IntWordConv.zextdFromInt16ToInt8 + val zextdFromInt32 = IntWordConv.zextdFromInt32ToInt8 + val zextdFromInt64 = IntWordConv.zextdFromInt64ToInt8 + val zextdFromWord8 = IntWordConv.zextdFromWord8ToInt8 + val zextdFromWord16 = IntWordConv.zextdFromWord16ToInt8 + val zextdFromWord32 = IntWordConv.zextdFromWord32ToInt8 + val zextdFromWord64 = IntWordConv.zextdFromWord64ToInt8 + val zextdToInt8 = IntWordConv.zextdFromInt8ToInt8 + val zextdToInt16 = IntWordConv.zextdFromInt8ToInt16 + val zextdToInt32 = IntWordConv.zextdFromInt8ToInt32 + val zextdToInt64 = IntWordConv.zextdFromInt8ToInt64 + val zextdToWord8 = IntWordConv.zextdFromInt8ToWord8 + val zextdToWord16 = IntWordConv.zextdFromInt8ToWord16 + val zextdToWord32 = IntWordConv.zextdFromInt8ToWord32 + val zextdToWord64 = IntWordConv.zextdFromInt8ToWord64 + + val sextdFromInt8 = IntWordConv.sextdFromInt8ToInt8 + val sextdFromInt16 = IntWordConv.sextdFromInt16ToInt8 + val sextdFromInt32 = IntWordConv.sextdFromInt32ToInt8 + val sextdFromInt64 = IntWordConv.sextdFromInt64ToInt8 + val sextdFromWord8 = IntWordConv.sextdFromWord8ToInt8 + val sextdFromWord16 = IntWordConv.sextdFromWord16ToInt8 + val sextdFromWord32 = IntWordConv.sextdFromWord32ToInt8 + val sextdFromWord64 = IntWordConv.sextdFromWord64ToInt8 + val sextdToInt8 = IntWordConv.sextdFromInt8ToInt8 + val sextdToInt16 = IntWordConv.sextdFromInt8ToInt16 + val sextdToInt32 = IntWordConv.sextdFromInt8ToInt32 + val sextdToInt64 = IntWordConv.sextdFromInt8ToInt64 + val sextdToWord8 = IntWordConv.sextdFromInt8ToWord8 + val sextdToWord16 = IntWordConv.sextdFromInt8ToWord16 + val sextdToWord32 = IntWordConv.sextdFromInt8ToWord32 + val sextdToWord64 = IntWordConv.sextdFromInt8ToWord64 + + val castFromInt8 = IntWordConv.castFromInt8ToInt8 + val castFromInt16 = IntWordConv.castFromInt16ToInt8 + val castFromInt32 = IntWordConv.castFromInt32ToInt8 + val castFromInt64 = IntWordConv.castFromInt64ToInt8 + val castFromWord8 = IntWordConv.castFromWord8ToInt8 + val castFromWord16 = IntWordConv.castFromWord16ToInt8 + val castFromWord32 = IntWordConv.castFromWord32ToInt8 + val castFromWord64 = IntWordConv.castFromWord64ToInt8 + val castToInt8 = IntWordConv.castFromInt8ToInt8 + val castToInt16 = IntWordConv.castFromInt8ToInt16 + val castToInt32 = IntWordConv.castFromInt8ToInt32 + val castToInt64 = IntWordConv.castFromInt8ToInt64 + val castToWord8 = IntWordConv.castFromInt8ToWord8 + val castToWord16 = IntWordConv.castFromInt8ToWord16 + val castToWord32 = IntWordConv.castFromInt8ToWord32 + val castToWord64 = IntWordConv.castFromInt8ToWord64 + + val zchckFromInt8 = IntWordConv.zchckFromInt8ToInt8 + val zchckFromInt16 = IntWordConv.zchckFromInt16ToInt8 + val zchckFromInt32 = IntWordConv.zchckFromInt32ToInt8 + val zchckFromInt64 = IntWordConv.zchckFromInt64ToInt8 + val zchckFromWord8 = IntWordConv.zchckFromWord8ToInt8 + val zchckFromWord16 = IntWordConv.zchckFromWord16ToInt8 + val zchckFromWord32 = IntWordConv.zchckFromWord32ToInt8 + val zchckFromWord64 = IntWordConv.zchckFromWord64ToInt8 + val zchckToInt8 = IntWordConv.zchckFromInt8ToInt8 + val zchckToInt16 = IntWordConv.zchckFromInt8ToInt16 + val zchckToInt32 = IntWordConv.zchckFromInt8ToInt32 + val zchckToInt64 = IntWordConv.zchckFromInt8ToInt64 + val zchckToWord8 = IntWordConv.zchckFromInt8ToWord8 + val zchckToWord16 = IntWordConv.zchckFromInt8ToWord16 + val zchckToWord32 = IntWordConv.zchckFromInt8ToWord32 + val zchckToWord64 = IntWordConv.zchckFromInt8ToWord64 + + val schckFromInt8 = IntWordConv.schckFromInt8ToInt8 + val schckFromInt16 = IntWordConv.schckFromInt16ToInt8 + val schckFromInt32 = IntWordConv.schckFromInt32ToInt8 + val schckFromInt64 = IntWordConv.schckFromInt64ToInt8 + val schckFromWord8 = IntWordConv.schckFromWord8ToInt8 + val schckFromWord16 = IntWordConv.schckFromWord16ToInt8 + val schckFromWord32 = IntWordConv.schckFromWord32ToInt8 + val schckFromWord64 = IntWordConv.schckFromWord64ToInt8 + val schckToInt8 = IntWordConv.schckFromInt8ToInt8 + val schckToInt16 = IntWordConv.schckFromInt8ToInt16 + val schckToInt32 = IntWordConv.schckFromInt8ToInt32 + val schckToInt64 = IntWordConv.schckFromInt8ToInt64 + val schckToWord8 = IntWordConv.schckFromInt8ToWord8 + val schckToWord16 = IntWordConv.schckFromInt8ToWord16 + val schckToWord32 = IntWordConv.schckFromInt8ToWord32 + val schckToWord64 = IntWordConv.schckFromInt8ToWord64 + end + +structure Int16 : PRIM_INTEGER = + struct + open Int16 + + val zextdFromInt8 = IntWordConv.zextdFromInt8ToInt16 + val zextdFromInt16 = IntWordConv.zextdFromInt16ToInt16 + val zextdFromInt32 = IntWordConv.zextdFromInt32ToInt16 + val zextdFromInt64 = IntWordConv.zextdFromInt64ToInt16 + val zextdFromWord8 = IntWordConv.zextdFromWord8ToInt16 + val zextdFromWord16 = IntWordConv.zextdFromWord16ToInt16 + val zextdFromWord32 = IntWordConv.zextdFromWord32ToInt16 + val zextdFromWord64 = IntWordConv.zextdFromWord64ToInt16 + val zextdToInt8 = IntWordConv.zextdFromInt16ToInt8 + val zextdToInt16 = IntWordConv.zextdFromInt16ToInt16 + val zextdToInt32 = IntWordConv.zextdFromInt16ToInt32 + val zextdToInt64 = IntWordConv.zextdFromInt16ToInt64 + val zextdToWord8 = IntWordConv.zextdFromInt16ToWord8 + val zextdToWord16 = IntWordConv.zextdFromInt16ToWord16 + val zextdToWord32 = IntWordConv.zextdFromInt16ToWord32 + val zextdToWord64 = IntWordConv.zextdFromInt16ToWord64 + + val sextdFromInt8 = IntWordConv.sextdFromInt8ToInt16 + val sextdFromInt16 = IntWordConv.sextdFromInt16ToInt16 + val sextdFromInt32 = IntWordConv.sextdFromInt32ToInt16 + val sextdFromInt64 = IntWordConv.sextdFromInt64ToInt16 + val sextdFromWord8 = IntWordConv.sextdFromWord8ToInt16 + val sextdFromWord16 = IntWordConv.sextdFromWord16ToInt16 + val sextdFromWord32 = IntWordConv.sextdFromWord32ToInt16 + val sextdFromWord64 = IntWordConv.sextdFromWord64ToInt16 + val sextdToInt8 = IntWordConv.sextdFromInt16ToInt8 + val sextdToInt16 = IntWordConv.sextdFromInt16ToInt16 + val sextdToInt32 = IntWordConv.sextdFromInt16ToInt32 + val sextdToInt64 = IntWordConv.sextdFromInt16ToInt64 + val sextdToWord8 = IntWordConv.sextdFromInt16ToWord8 + val sextdToWord16 = IntWordConv.sextdFromInt16ToWord16 + val sextdToWord32 = IntWordConv.sextdFromInt16ToWord32 + val sextdToWord64 = IntWordConv.sextdFromInt16ToWord64 + + val castFromInt8 = IntWordConv.castFromInt8ToInt16 + val castFromInt16 = IntWordConv.castFromInt16ToInt16 + val castFromInt32 = IntWordConv.castFromInt32ToInt16 + val castFromInt64 = IntWordConv.castFromInt64ToInt16 + val castFromWord8 = IntWordConv.castFromWord8ToInt16 + val castFromWord16 = IntWordConv.castFromWord16ToInt16 + val castFromWord32 = IntWordConv.castFromWord32ToInt16 + val castFromWord64 = IntWordConv.castFromWord64ToInt16 + val castToInt8 = IntWordConv.castFromInt16ToInt8 + val castToInt16 = IntWordConv.castFromInt16ToInt16 + val castToInt32 = IntWordConv.castFromInt16ToInt32 + val castToInt64 = IntWordConv.castFromInt16ToInt64 + val castToWord8 = IntWordConv.castFromInt16ToWord8 + val castToWord16 = IntWordConv.castFromInt16ToWord16 + val castToWord32 = IntWordConv.castFromInt16ToWord32 + val castToWord64 = IntWordConv.castFromInt16ToWord64 + + val zchckFromInt8 = IntWordConv.zchckFromInt8ToInt16 + val zchckFromInt16 = IntWordConv.zchckFromInt16ToInt16 + val zchckFromInt32 = IntWordConv.zchckFromInt32ToInt16 + val zchckFromInt64 = IntWordConv.zchckFromInt64ToInt16 + val zchckFromWord8 = IntWordConv.zchckFromWord8ToInt16 + val zchckFromWord16 = IntWordConv.zchckFromWord16ToInt16 + val zchckFromWord32 = IntWordConv.zchckFromWord32ToInt16 + val zchckFromWord64 = IntWordConv.zchckFromWord64ToInt16 + val zchckToInt8 = IntWordConv.zchckFromInt16ToInt8 + val zchckToInt16 = IntWordConv.zchckFromInt16ToInt16 + val zchckToInt32 = IntWordConv.zchckFromInt16ToInt32 + val zchckToInt64 = IntWordConv.zchckFromInt16ToInt64 + val zchckToWord8 = IntWordConv.zchckFromInt16ToWord8 + val zchckToWord16 = IntWordConv.zchckFromInt16ToWord16 + val zchckToWord32 = IntWordConv.zchckFromInt16ToWord32 + val zchckToWord64 = IntWordConv.zchckFromInt16ToWord64 + + val schckFromInt8 = IntWordConv.schckFromInt8ToInt16 + val schckFromInt16 = IntWordConv.schckFromInt16ToInt16 + val schckFromInt32 = IntWordConv.schckFromInt32ToInt16 + val schckFromInt64 = IntWordConv.schckFromInt64ToInt16 + val schckFromWord8 = IntWordConv.schckFromWord8ToInt16 + val schckFromWord16 = IntWordConv.schckFromWord16ToInt16 + val schckFromWord32 = IntWordConv.schckFromWord32ToInt16 + val schckFromWord64 = IntWordConv.schckFromWord64ToInt16 + val schckToInt8 = IntWordConv.schckFromInt16ToInt8 + val schckToInt16 = IntWordConv.schckFromInt16ToInt16 + val schckToInt32 = IntWordConv.schckFromInt16ToInt32 + val schckToInt64 = IntWordConv.schckFromInt16ToInt64 + val schckToWord8 = IntWordConv.schckFromInt16ToWord8 + val schckToWord16 = IntWordConv.schckFromInt16ToWord16 + val schckToWord32 = IntWordConv.schckFromInt16ToWord32 + val schckToWord64 = IntWordConv.schckFromInt16ToWord64 + end + +structure Int32 : PRIM_INTEGER = + struct + open Int32 + + val zextdFromInt8 = IntWordConv.zextdFromInt8ToInt32 + val zextdFromInt16 = IntWordConv.zextdFromInt16ToInt32 + val zextdFromInt32 = IntWordConv.zextdFromInt32ToInt32 + val zextdFromInt64 = IntWordConv.zextdFromInt64ToInt32 + val zextdFromWord8 = IntWordConv.zextdFromWord8ToInt32 + val zextdFromWord16 = IntWordConv.zextdFromWord16ToInt32 + val zextdFromWord32 = IntWordConv.zextdFromWord32ToInt32 + val zextdFromWord64 = IntWordConv.zextdFromWord64ToInt32 + val zextdToInt8 = IntWordConv.zextdFromInt32ToInt8 + val zextdToInt16 = IntWordConv.zextdFromInt32ToInt16 + val zextdToInt32 = IntWordConv.zextdFromInt32ToInt32 + val zextdToInt64 = IntWordConv.zextdFromInt32ToInt64 + val zextdToWord8 = IntWordConv.zextdFromInt32ToWord8 + val zextdToWord16 = IntWordConv.zextdFromInt32ToWord16 + val zextdToWord32 = IntWordConv.zextdFromInt32ToWord32 + val zextdToWord64 = IntWordConv.zextdFromInt32ToWord64 + + val sextdFromInt8 = IntWordConv.sextdFromInt8ToInt32 + val sextdFromInt16 = IntWordConv.sextdFromInt16ToInt32 + val sextdFromInt32 = IntWordConv.sextdFromInt32ToInt32 + val sextdFromInt64 = IntWordConv.sextdFromInt64ToInt32 + val sextdFromWord8 = IntWordConv.sextdFromWord8ToInt32 + val sextdFromWord16 = IntWordConv.sextdFromWord16ToInt32 + val sextdFromWord32 = IntWordConv.sextdFromWord32ToInt32 + val sextdFromWord64 = IntWordConv.sextdFromWord64ToInt32 + val sextdToInt8 = IntWordConv.sextdFromInt32ToInt8 + val sextdToInt16 = IntWordConv.sextdFromInt32ToInt16 + val sextdToInt32 = IntWordConv.sextdFromInt32ToInt32 + val sextdToInt64 = IntWordConv.sextdFromInt32ToInt64 + val sextdToWord8 = IntWordConv.sextdFromInt32ToWord8 + val sextdToWord16 = IntWordConv.sextdFromInt32ToWord16 + val sextdToWord32 = IntWordConv.sextdFromInt32ToWord32 + val sextdToWord64 = IntWordConv.sextdFromInt32ToWord64 + + val castFromInt8 = IntWordConv.castFromInt8ToInt32 + val castFromInt16 = IntWordConv.castFromInt16ToInt32 + val castFromInt32 = IntWordConv.castFromInt32ToInt32 + val castFromInt64 = IntWordConv.castFromInt64ToInt32 + val castFromWord8 = IntWordConv.castFromWord8ToInt32 + val castFromWord16 = IntWordConv.castFromWord16ToInt32 + val castFromWord32 = IntWordConv.castFromWord32ToInt32 + val castFromWord64 = IntWordConv.castFromWord64ToInt32 + val castToInt8 = IntWordConv.castFromInt32ToInt8 + val castToInt16 = IntWordConv.castFromInt32ToInt16 + val castToInt32 = IntWordConv.castFromInt32ToInt32 + val castToInt64 = IntWordConv.castFromInt32ToInt64 + val castToWord8 = IntWordConv.castFromInt32ToWord8 + val castToWord16 = IntWordConv.castFromInt32ToWord16 + val castToWord32 = IntWordConv.castFromInt32ToWord32 + val castToWord64 = IntWordConv.castFromInt32ToWord64 + + val zchckFromInt8 = IntWordConv.zchckFromInt8ToInt32 + val zchckFromInt16 = IntWordConv.zchckFromInt16ToInt32 + val zchckFromInt32 = IntWordConv.zchckFromInt32ToInt32 + val zchckFromInt64 = IntWordConv.zchckFromInt64ToInt32 + val zchckFromWord8 = IntWordConv.zchckFromWord8ToInt32 + val zchckFromWord16 = IntWordConv.zchckFromWord16ToInt32 + val zchckFromWord32 = IntWordConv.zchckFromWord32ToInt32 + val zchckFromWord64 = IntWordConv.zchckFromWord64ToInt32 + val zchckToInt8 = IntWordConv.zchckFromInt32ToInt8 + val zchckToInt16 = IntWordConv.zchckFromInt32ToInt16 + val zchckToInt32 = IntWordConv.zchckFromInt32ToInt32 + val zchckToInt64 = IntWordConv.zchckFromInt32ToInt64 + val zchckToWord8 = IntWordConv.zchckFromInt32ToWord8 + val zchckToWord16 = IntWordConv.zchckFromInt32ToWord16 + val zchckToWord32 = IntWordConv.zchckFromInt32ToWord32 + val zchckToWord64 = IntWordConv.zchckFromInt32ToWord64 + + val schckFromInt8 = IntWordConv.schckFromInt8ToInt32 + val schckFromInt16 = IntWordConv.schckFromInt16ToInt32 + val schckFromInt32 = IntWordConv.schckFromInt32ToInt32 + val schckFromInt64 = IntWordConv.schckFromInt64ToInt32 + val schckFromWord8 = IntWordConv.schckFromWord8ToInt32 + val schckFromWord16 = IntWordConv.schckFromWord16ToInt32 + val schckFromWord32 = IntWordConv.schckFromWord32ToInt32 + val schckFromWord64 = IntWordConv.schckFromWord64ToInt32 + val schckToInt8 = IntWordConv.schckFromInt32ToInt8 + val schckToInt16 = IntWordConv.schckFromInt32ToInt16 + val schckToInt32 = IntWordConv.schckFromInt32ToInt32 + val schckToInt64 = IntWordConv.schckFromInt32ToInt64 + val schckToWord8 = IntWordConv.schckFromInt32ToWord8 + val schckToWord16 = IntWordConv.schckFromInt32ToWord16 + val schckToWord32 = IntWordConv.schckFromInt32ToWord32 + val schckToWord64 = IntWordConv.schckFromInt32ToWord64 + end + +structure Int64 : PRIM_INTEGER = + struct + open Int64 + + val zextdFromInt8 = IntWordConv.zextdFromInt8ToInt64 + val zextdFromInt16 = IntWordConv.zextdFromInt16ToInt64 + val zextdFromInt32 = IntWordConv.zextdFromInt32ToInt64 + val zextdFromInt64 = IntWordConv.zextdFromInt64ToInt64 + val zextdFromWord8 = IntWordConv.zextdFromWord8ToInt64 + val zextdFromWord16 = IntWordConv.zextdFromWord16ToInt64 + val zextdFromWord32 = IntWordConv.zextdFromWord32ToInt64 + val zextdFromWord64 = IntWordConv.zextdFromWord64ToInt64 + val zextdToInt8 = IntWordConv.zextdFromInt64ToInt8 + val zextdToInt16 = IntWordConv.zextdFromInt64ToInt16 + val zextdToInt32 = IntWordConv.zextdFromInt64ToInt32 + val zextdToInt64 = IntWordConv.zextdFromInt64ToInt64 + val zextdToWord8 = IntWordConv.zextdFromInt64ToWord8 + val zextdToWord16 = IntWordConv.zextdFromInt64ToWord16 + val zextdToWord32 = IntWordConv.zextdFromInt64ToWord32 + val zextdToWord64 = IntWordConv.zextdFromInt64ToWord64 + + val sextdFromInt8 = IntWordConv.sextdFromInt8ToInt64 + val sextdFromInt16 = IntWordConv.sextdFromInt16ToInt64 + val sextdFromInt32 = IntWordConv.sextdFromInt32ToInt64 + val sextdFromInt64 = IntWordConv.sextdFromInt64ToInt64 + val sextdFromWord8 = IntWordConv.sextdFromWord8ToInt64 + val sextdFromWord16 = IntWordConv.sextdFromWord16ToInt64 + val sextdFromWord32 = IntWordConv.sextdFromWord32ToInt64 + val sextdFromWord64 = IntWordConv.sextdFromWord64ToInt64 + val sextdToInt8 = IntWordConv.sextdFromInt64ToInt8 + val sextdToInt16 = IntWordConv.sextdFromInt64ToInt16 + val sextdToInt32 = IntWordConv.sextdFromInt64ToInt32 + val sextdToInt64 = IntWordConv.sextdFromInt64ToInt64 + val sextdToWord8 = IntWordConv.sextdFromInt64ToWord8 + val sextdToWord16 = IntWordConv.sextdFromInt64ToWord16 + val sextdToWord32 = IntWordConv.sextdFromInt64ToWord32 + val sextdToWord64 = IntWordConv.sextdFromInt64ToWord64 + + val castFromInt8 = IntWordConv.castFromInt8ToInt64 + val castFromInt16 = IntWordConv.castFromInt16ToInt64 + val castFromInt32 = IntWordConv.castFromInt32ToInt64 + val castFromInt64 = IntWordConv.castFromInt64ToInt64 + val castFromWord8 = IntWordConv.castFromWord8ToInt64 + val castFromWord16 = IntWordConv.castFromWord16ToInt64 + val castFromWord32 = IntWordConv.castFromWord32ToInt64 + val castFromWord64 = IntWordConv.castFromWord64ToInt64 + val castToInt8 = IntWordConv.castFromInt64ToInt8 + val castToInt16 = IntWordConv.castFromInt64ToInt16 + val castToInt32 = IntWordConv.castFromInt64ToInt32 + val castToInt64 = IntWordConv.castFromInt64ToInt64 + val castToWord8 = IntWordConv.castFromInt64ToWord8 + val castToWord16 = IntWordConv.castFromInt64ToWord16 + val castToWord32 = IntWordConv.castFromInt64ToWord32 + val castToWord64 = IntWordConv.castFromInt64ToWord64 + + val zchckFromInt8 = IntWordConv.zchckFromInt8ToInt64 + val zchckFromInt16 = IntWordConv.zchckFromInt16ToInt64 + val zchckFromInt32 = IntWordConv.zchckFromInt32ToInt64 + val zchckFromInt64 = IntWordConv.zchckFromInt64ToInt64 + val zchckFromWord8 = IntWordConv.zchckFromWord8ToInt64 + val zchckFromWord16 = IntWordConv.zchckFromWord16ToInt64 + val zchckFromWord32 = IntWordConv.zchckFromWord32ToInt64 + val zchckFromWord64 = IntWordConv.zchckFromWord64ToInt64 + val zchckToInt8 = IntWordConv.zchckFromInt64ToInt8 + val zchckToInt16 = IntWordConv.zchckFromInt64ToInt16 + val zchckToInt32 = IntWordConv.zchckFromInt64ToInt32 + val zchckToInt64 = IntWordConv.zchckFromInt64ToInt64 + val zchckToWord8 = IntWordConv.zchckFromInt64ToWord8 + val zchckToWord16 = IntWordConv.zchckFromInt64ToWord16 + val zchckToWord32 = IntWordConv.zchckFromInt64ToWord32 + val zchckToWord64 = IntWordConv.zchckFromInt64ToWord64 + + val schckFromInt8 = IntWordConv.schckFromInt8ToInt64 + val schckFromInt16 = IntWordConv.schckFromInt16ToInt64 + val schckFromInt32 = IntWordConv.schckFromInt32ToInt64 + val schckFromInt64 = IntWordConv.schckFromInt64ToInt64 + val schckFromWord8 = IntWordConv.schckFromWord8ToInt64 + val schckFromWord16 = IntWordConv.schckFromWord16ToInt64 + val schckFromWord32 = IntWordConv.schckFromWord32ToInt64 + val schckFromWord64 = IntWordConv.schckFromWord64ToInt64 + val schckToInt8 = IntWordConv.schckFromInt64ToInt8 + val schckToInt16 = IntWordConv.schckFromInt64ToInt16 + val schckToInt32 = IntWordConv.schckFromInt64ToInt32 + val schckToInt64 = IntWordConv.schckFromInt64ToInt64 + val schckToWord8 = IntWordConv.schckFromInt64ToWord8 + val schckToWord16 = IntWordConv.schckFromInt64ToWord16 + val schckToWord32 = IntWordConv.schckFromInt64ToWord32 + val schckToWord64 = IntWordConv.schckFromInt64ToWord64 + end + +structure Word8 : PRIM_WORD = + struct + open Word8 + + val zextdFromInt8 = IntWordConv.zextdFromInt8ToWord8 + val zextdFromInt16 = IntWordConv.zextdFromInt16ToWord8 + val zextdFromInt32 = IntWordConv.zextdFromInt32ToWord8 + val zextdFromInt64 = IntWordConv.zextdFromInt64ToWord8 + val zextdFromWord8 = IntWordConv.zextdFromWord8ToWord8 + val zextdFromWord16 = IntWordConv.zextdFromWord16ToWord8 + val zextdFromWord32 = IntWordConv.zextdFromWord32ToWord8 + val zextdFromWord64 = IntWordConv.zextdFromWord64ToWord8 + val zextdToInt8 = IntWordConv.zextdFromWord8ToInt8 + val zextdToInt16 = IntWordConv.zextdFromWord8ToInt16 + val zextdToInt32 = IntWordConv.zextdFromWord8ToInt32 + val zextdToInt64 = IntWordConv.zextdFromWord8ToInt64 + val zextdToWord8 = IntWordConv.zextdFromWord8ToWord8 + val zextdToWord16 = IntWordConv.zextdFromWord8ToWord16 + val zextdToWord32 = IntWordConv.zextdFromWord8ToWord32 + val zextdToWord64 = IntWordConv.zextdFromWord8ToWord64 + + val sextdFromInt8 = IntWordConv.sextdFromInt8ToWord8 + val sextdFromInt16 = IntWordConv.sextdFromInt16ToWord8 + val sextdFromInt32 = IntWordConv.sextdFromInt32ToWord8 + val sextdFromInt64 = IntWordConv.sextdFromInt64ToWord8 + val sextdFromWord8 = IntWordConv.sextdFromWord8ToWord8 + val sextdFromWord16 = IntWordConv.sextdFromWord16ToWord8 + val sextdFromWord32 = IntWordConv.sextdFromWord32ToWord8 + val sextdFromWord64 = IntWordConv.sextdFromWord64ToWord8 + val sextdToInt8 = IntWordConv.sextdFromWord8ToInt8 + val sextdToInt16 = IntWordConv.sextdFromWord8ToInt16 + val sextdToInt32 = IntWordConv.sextdFromWord8ToInt32 + val sextdToInt64 = IntWordConv.sextdFromWord8ToInt64 + val sextdToWord8 = IntWordConv.sextdFromWord8ToWord8 + val sextdToWord16 = IntWordConv.sextdFromWord8ToWord16 + val sextdToWord32 = IntWordConv.sextdFromWord8ToWord32 + val sextdToWord64 = IntWordConv.sextdFromWord8ToWord64 + + val castFromInt8 = IntWordConv.castFromInt8ToWord8 + val castFromInt16 = IntWordConv.castFromInt16ToWord8 + val castFromInt32 = IntWordConv.castFromInt32ToWord8 + val castFromInt64 = IntWordConv.castFromInt64ToWord8 + val castFromWord8 = IntWordConv.castFromWord8ToWord8 + val castFromWord16 = IntWordConv.castFromWord16ToWord8 + val castFromWord32 = IntWordConv.castFromWord32ToWord8 + val castFromWord64 = IntWordConv.castFromWord64ToWord8 + val castToInt8 = IntWordConv.castFromWord8ToInt8 + val castToInt16 = IntWordConv.castFromWord8ToInt16 + val castToInt32 = IntWordConv.castFromWord8ToInt32 + val castToInt64 = IntWordConv.castFromWord8ToInt64 + val castToWord8 = IntWordConv.castFromWord8ToWord8 + val castToWord16 = IntWordConv.castFromWord8ToWord16 + val castToWord32 = IntWordConv.castFromWord8ToWord32 + val castToWord64 = IntWordConv.castFromWord8ToWord64 + + val zchckFromInt8 = IntWordConv.zchckFromInt8ToWord8 + val zchckFromInt16 = IntWordConv.zchckFromInt16ToWord8 + val zchckFromInt32 = IntWordConv.zchckFromInt32ToWord8 + val zchckFromInt64 = IntWordConv.zchckFromInt64ToWord8 + val zchckFromWord8 = IntWordConv.zchckFromWord8ToWord8 + val zchckFromWord16 = IntWordConv.zchckFromWord16ToWord8 + val zchckFromWord32 = IntWordConv.zchckFromWord32ToWord8 + val zchckFromWord64 = IntWordConv.zchckFromWord64ToWord8 + val zchckToInt8 = IntWordConv.zchckFromWord8ToInt8 + val zchckToInt16 = IntWordConv.zchckFromWord8ToInt16 + val zchckToInt32 = IntWordConv.zchckFromWord8ToInt32 + val zchckToInt64 = IntWordConv.zchckFromWord8ToInt64 + val zchckToWord8 = IntWordConv.zchckFromWord8ToWord8 + val zchckToWord16 = IntWordConv.zchckFromWord8ToWord16 + val zchckToWord32 = IntWordConv.zchckFromWord8ToWord32 + val zchckToWord64 = IntWordConv.zchckFromWord8ToWord64 + + val schckFromInt8 = IntWordConv.schckFromInt8ToWord8 + val schckFromInt16 = IntWordConv.schckFromInt16ToWord8 + val schckFromInt32 = IntWordConv.schckFromInt32ToWord8 + val schckFromInt64 = IntWordConv.schckFromInt64ToWord8 + val schckFromWord8 = IntWordConv.schckFromWord8ToWord8 + val schckFromWord16 = IntWordConv.schckFromWord16ToWord8 + val schckFromWord32 = IntWordConv.schckFromWord32ToWord8 + val schckFromWord64 = IntWordConv.schckFromWord64ToWord8 + val schckToInt8 = IntWordConv.schckFromWord8ToInt8 + val schckToInt16 = IntWordConv.schckFromWord8ToInt16 + val schckToInt32 = IntWordConv.schckFromWord8ToInt32 + val schckToInt64 = IntWordConv.schckFromWord8ToInt64 + val schckToWord8 = IntWordConv.schckFromWord8ToWord8 + val schckToWord16 = IntWordConv.schckFromWord8ToWord16 + val schckToWord32 = IntWordConv.schckFromWord8ToWord32 + val schckToWord64 = IntWordConv.schckFromWord8ToWord64 + end + +structure Word16 : PRIM_WORD = + struct + open Word16 + + val zextdFromInt8 = IntWordConv.zextdFromInt8ToWord16 + val zextdFromInt16 = IntWordConv.zextdFromInt16ToWord16 + val zextdFromInt32 = IntWordConv.zextdFromInt32ToWord16 + val zextdFromInt64 = IntWordConv.zextdFromInt64ToWord16 + val zextdFromWord8 = IntWordConv.zextdFromWord8ToWord16 + val zextdFromWord16 = IntWordConv.zextdFromWord16ToWord16 + val zextdFromWord32 = IntWordConv.zextdFromWord32ToWord16 + val zextdFromWord64 = IntWordConv.zextdFromWord64ToWord16 + val zextdToInt8 = IntWordConv.zextdFromWord16ToInt8 + val zextdToInt16 = IntWordConv.zextdFromWord16ToInt16 + val zextdToInt32 = IntWordConv.zextdFromWord16ToInt32 + val zextdToInt64 = IntWordConv.zextdFromWord16ToInt64 + val zextdToWord8 = IntWordConv.zextdFromWord16ToWord8 + val zextdToWord16 = IntWordConv.zextdFromWord16ToWord16 + val zextdToWord32 = IntWordConv.zextdFromWord16ToWord32 + val zextdToWord64 = IntWordConv.zextdFromWord16ToWord64 + + val sextdFromInt8 = IntWordConv.sextdFromInt8ToWord16 + val sextdFromInt16 = IntWordConv.sextdFromInt16ToWord16 + val sextdFromInt32 = IntWordConv.sextdFromInt32ToWord16 + val sextdFromInt64 = IntWordConv.sextdFromInt64ToWord16 + val sextdFromWord8 = IntWordConv.sextdFromWord8ToWord16 + val sextdFromWord16 = IntWordConv.sextdFromWord16ToWord16 + val sextdFromWord32 = IntWordConv.sextdFromWord32ToWord16 + val sextdFromWord64 = IntWordConv.sextdFromWord64ToWord16 + val sextdToInt8 = IntWordConv.sextdFromWord16ToInt8 + val sextdToInt16 = IntWordConv.sextdFromWord16ToInt16 + val sextdToInt32 = IntWordConv.sextdFromWord16ToInt32 + val sextdToInt64 = IntWordConv.sextdFromWord16ToInt64 + val sextdToWord8 = IntWordConv.sextdFromWord16ToWord8 + val sextdToWord16 = IntWordConv.sextdFromWord16ToWord16 + val sextdToWord32 = IntWordConv.sextdFromWord16ToWord32 + val sextdToWord64 = IntWordConv.sextdFromWord16ToWord64 + + val castFromInt8 = IntWordConv.castFromInt8ToWord16 + val castFromInt16 = IntWordConv.castFromInt16ToWord16 + val castFromInt32 = IntWordConv.castFromInt32ToWord16 + val castFromInt64 = IntWordConv.castFromInt64ToWord16 + val castFromWord8 = IntWordConv.castFromWord8ToWord16 + val castFromWord16 = IntWordConv.castFromWord16ToWord16 + val castFromWord32 = IntWordConv.castFromWord32ToWord16 + val castFromWord64 = IntWordConv.castFromWord64ToWord16 + val castToInt8 = IntWordConv.castFromWord16ToInt8 + val castToInt16 = IntWordConv.castFromWord16ToInt16 + val castToInt32 = IntWordConv.castFromWord16ToInt32 + val castToInt64 = IntWordConv.castFromWord16ToInt64 + val castToWord8 = IntWordConv.castFromWord16ToWord8 + val castToWord16 = IntWordConv.castFromWord16ToWord16 + val castToWord32 = IntWordConv.castFromWord16ToWord32 + val castToWord64 = IntWordConv.castFromWord16ToWord64 + + val zchckFromInt8 = IntWordConv.zchckFromInt8ToWord16 + val zchckFromInt16 = IntWordConv.zchckFromInt16ToWord16 + val zchckFromInt32 = IntWordConv.zchckFromInt32ToWord16 + val zchckFromInt64 = IntWordConv.zchckFromInt64ToWord16 + val zchckFromWord8 = IntWordConv.zchckFromWord8ToWord16 + val zchckFromWord16 = IntWordConv.zchckFromWord16ToWord16 + val zchckFromWord32 = IntWordConv.zchckFromWord32ToWord16 + val zchckFromWord64 = IntWordConv.zchckFromWord64ToWord16 + val zchckToInt8 = IntWordConv.zchckFromWord16ToInt8 + val zchckToInt16 = IntWordConv.zchckFromWord16ToInt16 + val zchckToInt32 = IntWordConv.zchckFromWord16ToInt32 + val zchckToInt64 = IntWordConv.zchckFromWord16ToInt64 + val zchckToWord8 = IntWordConv.zchckFromWord16ToWord8 + val zchckToWord16 = IntWordConv.zchckFromWord16ToWord16 + val zchckToWord32 = IntWordConv.zchckFromWord16ToWord32 + val zchckToWord64 = IntWordConv.zchckFromWord16ToWord64 + + val schckFromInt8 = IntWordConv.schckFromInt8ToWord16 + val schckFromInt16 = IntWordConv.schckFromInt16ToWord16 + val schckFromInt32 = IntWordConv.schckFromInt32ToWord16 + val schckFromInt64 = IntWordConv.schckFromInt64ToWord16 + val schckFromWord8 = IntWordConv.schckFromWord8ToWord16 + val schckFromWord16 = IntWordConv.schckFromWord16ToWord16 + val schckFromWord32 = IntWordConv.schckFromWord32ToWord16 + val schckFromWord64 = IntWordConv.schckFromWord64ToWord16 + val schckToInt8 = IntWordConv.schckFromWord16ToInt8 + val schckToInt16 = IntWordConv.schckFromWord16ToInt16 + val schckToInt32 = IntWordConv.schckFromWord16ToInt32 + val schckToInt64 = IntWordConv.schckFromWord16ToInt64 + val schckToWord8 = IntWordConv.schckFromWord16ToWord8 + val schckToWord16 = IntWordConv.schckFromWord16ToWord16 + val schckToWord32 = IntWordConv.schckFromWord16ToWord32 + val schckToWord64 = IntWordConv.schckFromWord16ToWord64 + end + +structure Word32 : PRIM_WORD = + struct + open Word32 + + val zextdFromInt8 = IntWordConv.zextdFromInt8ToWord32 + val zextdFromInt16 = IntWordConv.zextdFromInt16ToWord32 + val zextdFromInt32 = IntWordConv.zextdFromInt32ToWord32 + val zextdFromInt64 = IntWordConv.zextdFromInt64ToWord32 + val zextdFromWord8 = IntWordConv.zextdFromWord8ToWord32 + val zextdFromWord16 = IntWordConv.zextdFromWord16ToWord32 + val zextdFromWord32 = IntWordConv.zextdFromWord32ToWord32 + val zextdFromWord64 = IntWordConv.zextdFromWord64ToWord32 + val zextdToInt8 = IntWordConv.zextdFromWord32ToInt8 + val zextdToInt16 = IntWordConv.zextdFromWord32ToInt16 + val zextdToInt32 = IntWordConv.zextdFromWord32ToInt32 + val zextdToInt64 = IntWordConv.zextdFromWord32ToInt64 + val zextdToWord8 = IntWordConv.zextdFromWord32ToWord8 + val zextdToWord16 = IntWordConv.zextdFromWord32ToWord16 + val zextdToWord32 = IntWordConv.zextdFromWord32ToWord32 + val zextdToWord64 = IntWordConv.zextdFromWord32ToWord64 + + val sextdFromInt8 = IntWordConv.sextdFromInt8ToWord32 + val sextdFromInt16 = IntWordConv.sextdFromInt16ToWord32 + val sextdFromInt32 = IntWordConv.sextdFromInt32ToWord32 + val sextdFromInt64 = IntWordConv.sextdFromInt64ToWord32 + val sextdFromWord8 = IntWordConv.sextdFromWord8ToWord32 + val sextdFromWord16 = IntWordConv.sextdFromWord16ToWord32 + val sextdFromWord32 = IntWordConv.sextdFromWord32ToWord32 + val sextdFromWord64 = IntWordConv.sextdFromWord64ToWord32 + val sextdToInt8 = IntWordConv.sextdFromWord32ToInt8 + val sextdToInt16 = IntWordConv.sextdFromWord32ToInt16 + val sextdToInt32 = IntWordConv.sextdFromWord32ToInt32 + val sextdToInt64 = IntWordConv.sextdFromWord32ToInt64 + val sextdToWord8 = IntWordConv.sextdFromWord32ToWord8 + val sextdToWord16 = IntWordConv.sextdFromWord32ToWord16 + val sextdToWord32 = IntWordConv.sextdFromWord32ToWord32 + val sextdToWord64 = IntWordConv.sextdFromWord32ToWord64 + + val castFromInt8 = IntWordConv.castFromInt8ToWord32 + val castFromInt16 = IntWordConv.castFromInt16ToWord32 + val castFromInt32 = IntWordConv.castFromInt32ToWord32 + val castFromInt64 = IntWordConv.castFromInt64ToWord32 + val castFromWord8 = IntWordConv.castFromWord8ToWord32 + val castFromWord16 = IntWordConv.castFromWord16ToWord32 + val castFromWord32 = IntWordConv.castFromWord32ToWord32 + val castFromWord64 = IntWordConv.castFromWord64ToWord32 + val castToInt8 = IntWordConv.castFromWord32ToInt8 + val castToInt16 = IntWordConv.castFromWord32ToInt16 + val castToInt32 = IntWordConv.castFromWord32ToInt32 + val castToInt64 = IntWordConv.castFromWord32ToInt64 + val castToWord8 = IntWordConv.castFromWord32ToWord8 + val castToWord16 = IntWordConv.castFromWord32ToWord16 + val castToWord32 = IntWordConv.castFromWord32ToWord32 + val castToWord64 = IntWordConv.castFromWord32ToWord64 + + val zchckFromInt8 = IntWordConv.zchckFromInt8ToWord32 + val zchckFromInt16 = IntWordConv.zchckFromInt16ToWord32 + val zchckFromInt32 = IntWordConv.zchckFromInt32ToWord32 + val zchckFromInt64 = IntWordConv.zchckFromInt64ToWord32 + val zchckFromWord8 = IntWordConv.zchckFromWord8ToWord32 + val zchckFromWord16 = IntWordConv.zchckFromWord16ToWord32 + val zchckFromWord32 = IntWordConv.zchckFromWord32ToWord32 + val zchckFromWord64 = IntWordConv.zchckFromWord64ToWord32 + val zchckToInt8 = IntWordConv.zchckFromWord32ToInt8 + val zchckToInt16 = IntWordConv.zchckFromWord32ToInt16 + val zchckToInt32 = IntWordConv.zchckFromWord32ToInt32 + val zchckToInt64 = IntWordConv.zchckFromWord32ToInt64 + val zchckToWord8 = IntWordConv.zchckFromWord32ToWord8 + val zchckToWord16 = IntWordConv.zchckFromWord32ToWord16 + val zchckToWord32 = IntWordConv.zchckFromWord32ToWord32 + val zchckToWord64 = IntWordConv.zchckFromWord32ToWord64 + + val schckFromInt8 = IntWordConv.schckFromInt8ToWord32 + val schckFromInt16 = IntWordConv.schckFromInt16ToWord32 + val schckFromInt32 = IntWordConv.schckFromInt32ToWord32 + val schckFromInt64 = IntWordConv.schckFromInt64ToWord32 + val schckFromWord8 = IntWordConv.schckFromWord8ToWord32 + val schckFromWord16 = IntWordConv.schckFromWord16ToWord32 + val schckFromWord32 = IntWordConv.schckFromWord32ToWord32 + val schckFromWord64 = IntWordConv.schckFromWord64ToWord32 + val schckToInt8 = IntWordConv.schckFromWord32ToInt8 + val schckToInt16 = IntWordConv.schckFromWord32ToInt16 + val schckToInt32 = IntWordConv.schckFromWord32ToInt32 + val schckToInt64 = IntWordConv.schckFromWord32ToInt64 + val schckToWord8 = IntWordConv.schckFromWord32ToWord8 + val schckToWord16 = IntWordConv.schckFromWord32ToWord16 + val schckToWord32 = IntWordConv.schckFromWord32ToWord32 + val schckToWord64 = IntWordConv.schckFromWord32ToWord64 + end + +structure Word64 : PRIM_WORD = + struct + open Word64 + + val zextdFromInt8 = IntWordConv.zextdFromInt8ToWord64 + val zextdFromInt16 = IntWordConv.zextdFromInt16ToWord64 + val zextdFromInt32 = IntWordConv.zextdFromInt32ToWord64 + val zextdFromInt64 = IntWordConv.zextdFromInt64ToWord64 + val zextdFromWord8 = IntWordConv.zextdFromWord8ToWord64 + val zextdFromWord16 = IntWordConv.zextdFromWord16ToWord64 + val zextdFromWord32 = IntWordConv.zextdFromWord32ToWord64 + val zextdFromWord64 = IntWordConv.zextdFromWord64ToWord64 + val zextdToInt8 = IntWordConv.zextdFromWord64ToInt8 + val zextdToInt16 = IntWordConv.zextdFromWord64ToInt16 + val zextdToInt32 = IntWordConv.zextdFromWord64ToInt32 + val zextdToInt64 = IntWordConv.zextdFromWord64ToInt64 + val zextdToWord8 = IntWordConv.zextdFromWord64ToWord8 + val zextdToWord16 = IntWordConv.zextdFromWord64ToWord16 + val zextdToWord32 = IntWordConv.zextdFromWord64ToWord32 + val zextdToWord64 = IntWordConv.zextdFromWord64ToWord64 + + val sextdFromInt8 = IntWordConv.sextdFromInt8ToWord64 + val sextdFromInt16 = IntWordConv.sextdFromInt16ToWord64 + val sextdFromInt32 = IntWordConv.sextdFromInt32ToWord64 + val sextdFromInt64 = IntWordConv.sextdFromInt64ToWord64 + val sextdFromWord8 = IntWordConv.sextdFromWord8ToWord64 + val sextdFromWord16 = IntWordConv.sextdFromWord16ToWord64 + val sextdFromWord32 = IntWordConv.sextdFromWord32ToWord64 + val sextdFromWord64 = IntWordConv.sextdFromWord64ToWord64 + val sextdToInt8 = IntWordConv.sextdFromWord64ToInt8 + val sextdToInt16 = IntWordConv.sextdFromWord64ToInt16 + val sextdToInt32 = IntWordConv.sextdFromWord64ToInt32 + val sextdToInt64 = IntWordConv.sextdFromWord64ToInt64 + val sextdToWord8 = IntWordConv.sextdFromWord64ToWord8 + val sextdToWord16 = IntWordConv.sextdFromWord64ToWord16 + val sextdToWord32 = IntWordConv.sextdFromWord64ToWord32 + val sextdToWord64 = IntWordConv.sextdFromWord64ToWord64 + + val castFromInt8 = IntWordConv.castFromInt8ToWord64 + val castFromInt16 = IntWordConv.castFromInt16ToWord64 + val castFromInt32 = IntWordConv.castFromInt32ToWord64 + val castFromInt64 = IntWordConv.castFromInt64ToWord64 + val castFromWord8 = IntWordConv.castFromWord8ToWord64 + val castFromWord16 = IntWordConv.castFromWord16ToWord64 + val castFromWord32 = IntWordConv.castFromWord32ToWord64 + val castFromWord64 = IntWordConv.castFromWord64ToWord64 + val castToInt8 = IntWordConv.castFromWord64ToInt8 + val castToInt16 = IntWordConv.castFromWord64ToInt16 + val castToInt32 = IntWordConv.castFromWord64ToInt32 + val castToInt64 = IntWordConv.castFromWord64ToInt64 + val castToWord8 = IntWordConv.castFromWord64ToWord8 + val castToWord16 = IntWordConv.castFromWord64ToWord16 + val castToWord32 = IntWordConv.castFromWord64ToWord32 + val castToWord64 = IntWordConv.castFromWord64ToWord64 + + val zchckFromInt8 = IntWordConv.zchckFromInt8ToWord64 + val zchckFromInt16 = IntWordConv.zchckFromInt16ToWord64 + val zchckFromInt32 = IntWordConv.zchckFromInt32ToWord64 + val zchckFromInt64 = IntWordConv.zchckFromInt64ToWord64 + val zchckFromWord8 = IntWordConv.zchckFromWord8ToWord64 + val zchckFromWord16 = IntWordConv.zchckFromWord16ToWord64 + val zchckFromWord32 = IntWordConv.zchckFromWord32ToWord64 + val zchckFromWord64 = IntWordConv.zchckFromWord64ToWord64 + val zchckToInt8 = IntWordConv.zchckFromWord64ToInt8 + val zchckToInt16 = IntWordConv.zchckFromWord64ToInt16 + val zchckToInt32 = IntWordConv.zchckFromWord64ToInt32 + val zchckToInt64 = IntWordConv.zchckFromWord64ToInt64 + val zchckToWord8 = IntWordConv.zchckFromWord64ToWord8 + val zchckToWord16 = IntWordConv.zchckFromWord64ToWord16 + val zchckToWord32 = IntWordConv.zchckFromWord64ToWord32 + val zchckToWord64 = IntWordConv.zchckFromWord64ToWord64 + + val schckFromInt8 = IntWordConv.schckFromInt8ToWord64 + val schckFromInt16 = IntWordConv.schckFromInt16ToWord64 + val schckFromInt32 = IntWordConv.schckFromInt32ToWord64 + val schckFromInt64 = IntWordConv.schckFromInt64ToWord64 + val schckFromWord8 = IntWordConv.schckFromWord8ToWord64 + val schckFromWord16 = IntWordConv.schckFromWord16ToWord64 + val schckFromWord32 = IntWordConv.schckFromWord32ToWord64 + val schckFromWord64 = IntWordConv.schckFromWord64ToWord64 + val schckToInt8 = IntWordConv.schckFromWord64ToInt8 + val schckToInt16 = IntWordConv.schckFromWord64ToInt16 + val schckToInt32 = IntWordConv.schckFromWord64ToInt32 + val schckToInt64 = IntWordConv.schckFromWord64ToInt64 + val schckToWord8 = IntWordConv.schckFromWord64ToWord8 + val schckToWord16 = IntWordConv.schckFromWord64ToWord16 + val schckToWord32 = IntWordConv.schckFromWord64ToWord32 + val schckToWord64 = IntWordConv.schckFromWord64ToWord64 + end + +end diff --git a/basis-library/integer/num0.sml b/basis-library/integer/num0.sml new file mode 100644 index 0000000..ff36c1d --- /dev/null +++ b/basis-library/integer/num0.sml @@ -0,0 +1,291 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MKNUM0_ARG = + sig + structure Int: PRIM_INTEGER + structure Word: PRIM_WORD + val idFromIntToWord: Int.int -> Word.word + val idFromWordToInt: Word.word -> Int.int + end +signature PRIM_INTEGER = + sig + include PRIM_INTEGER + + val maxInt': int + val minInt': int + val maxInt: int option + val minInt: int option + + val zero: int + val one: int + + val abs: int -> int + val div: int * int -> int + val mod: int * int -> int + val quot: int * int -> int + val rem: int * int -> int + + val ltu: int * int -> bool + val leu: int * int -> bool + val gtu: int * int -> bool + val geu: int * int -> bool + + val andb : int * int -> int + val < int + val notb : int -> int + val orb : int * int -> int + val rolUnsafe : int * Primitive.Word32.word -> int + val rorUnsafe : int * Primitive.Word32.word -> int + val ~>>? : int * Primitive.Word32.word -> int + val >>? : int * Primitive.Word32.word -> int + val xorb : int * int -> int + + val power: {base:int, exp: int} -> int + val log2: int -> Primitive.Int32.int + val log2Word: int -> Primitive.Word32.word + end +signature PRIM_WORD = + sig + include PRIM_WORD + + val zero: word + val one: word + + val maxWord': word + + val div: word * word -> word + val mod: word * word -> word + + val log2: word -> Primitive.Int32.int + val log2Word: word -> Primitive.Word32.word + end + +functor MkNum0 (S: MKNUM0_ARG): sig + structure Int: PRIM_INTEGER + structure Word: PRIM_WORD + end = + struct + open S + + val _ = + if Int.sizeInBits <> Word.sizeInBits + orelse Int.sizeInBitsWord <> Word.sizeInBitsWord + then raise Primitive.Exn.Fail8 "MkNum0: Int.sizeInBits <> Word.sizeInBits" + else () + + structure Word = + struct + open Word + + val zero = zextdFromWord32 0w0 + val one = zextdFromWord32 0w1 + + val maxWord' = notb zero + + local + fun make f (w, w') = + if Primitive.Controls.safe andalso w' = zero + then raise Div + else f (w, w') + in + val op div = make (op quotUnsafe) + val op mod = make (op remUnsafe) + end + + fun log2Word w = + let + fun loop (n, s, acc) = + if n = one + then acc + else let + val (n, acc) = + if n >= <>? (n, s), Primitive.Word32.+ (acc, s)) + else (n, acc) + in + loop (n, Primitive.Word32.>>? (s, 0w1), acc) + end + in + if Primitive.Controls.safe andalso w = zero + then raise Domain + else loop (w, Primitive.Word32.>>? (sizeInBitsWord, 0w1), 0w0) + end + fun log2 w = Primitive.IntWordConv.zextdFromWord32ToInt32 (log2Word w) + end + + structure Int = + struct + open Int + + val zero = zextdFromInt32 0 + val one = zextdFromInt32 1 + + local + fun makeBinop f = + fn (x: int, y: int) => + idFromWordToInt + (f (idFromIntToWord x, idFromIntToWord y)) + fun makeUnop f = + fn (x: int) => + idFromWordToInt + (f (idFromIntToWord x)) + fun makeShop f = + fn (x: int, w: Primitive.Word32.word) => + idFromWordToInt + (f (idFromIntToWord x, w)) + in + val andb = makeBinop Word.andb + val <>? = makeShop Word.~>>? + val >>? = makeShop Word.>>? + val xorb = makeBinop Word.xorb + end + fun log2 i = Word.log2 (idFromIntToWord i) + fun log2Word i = Word.log2Word (idFromIntToWord i) + + val minInt' = <>? (notb zero, 0w1) + val minInt = SOME minInt' + val maxInt = SOME maxInt' + + fun abs (x: int) = if x < zero then ~ x else x + + fun quot (x, y) = + if Primitive.Controls.safe + andalso y = zero + then raise Div + else if (Primitive.Controls.detectOverflow + orelse Primitive.Controls.safe) + andalso x = minInt' andalso y = ~one + then if Primitive.Controls.detectOverflow + then raise Overflow + else minInt' + else quotUnsafe (x, y) + + fun rem (x, y) = + if Primitive.Controls.safe + andalso y = zero + then raise Div + else if x = minInt' andalso y = ~one + then zero + else remUnsafe (x, y) + + fun x div y = + if x >= zero + then if y > zero + then quotUnsafe (x, y) + else if y < zero + then if x = zero + then zero + else quotUnsafe (x -? one, y) -? one + else raise Div + else if y < zero + then if (Primitive.Controls.detectOverflow + orelse Primitive.Controls.safe) + andalso x = minInt' andalso y = ~one + then if Primitive.Controls.detectOverflow + then raise Overflow + else minInt' + else quotUnsafe (x, y) + else if y > zero + then quotUnsafe (x +? one, y) -? one + else raise Div + + fun x mod y = + if x >= zero + then if y > zero + then remUnsafe (x, y) + else if y < zero + then if x = zero + then zero + else remUnsafe (x -? one, y) +? (y + one) + else raise Div + else if y < zero + then if x = minInt' andalso y = ~one + then zero + else remUnsafe (x, y) + else if y > zero + then remUnsafe (x +? one, y) +? (y -? one) + else raise Div + + local + structure S = + UnsignedIntegralComparisons + (type int = int + type word = Word.word + val idFromIntToWord = idFromIntToWord + val op < = Word.<) + in + open S + end + + fun power {base, exp} = + if Primitive.Controls.safe + andalso exp < zero + then raise Primitive.Exn.Fail8 "Int.power" + else let + fun loop (exp, accum) = + if exp <= zero + then accum + else loop (exp - one, base * accum) + in loop (exp, one) + end + end + + end + +structure Primitive = struct +open Primitive + +local + structure S = + MkNum0 (structure Int = Int8 + structure Word = Word8 + val idFromIntToWord = IntWordConv.idFromInt8ToWord8 + val idFromWordToInt = IntWordConv.idFromWord8ToInt8) +in + structure Int8 : PRIM_INTEGER = S.Int + structure Word8 : PRIM_WORD = S.Word +end +local + structure S = + MkNum0 (structure Int = Int16 + structure Word = Word16 + val idFromIntToWord = IntWordConv.idFromInt16ToWord16 + val idFromWordToInt = IntWordConv.idFromWord16ToInt16) +in + structure Int16 : PRIM_INTEGER = S.Int + structure Word16 : PRIM_WORD = S.Word +end +local + structure S = + MkNum0 (structure Int = Int32 + structure Word = Word32 + val idFromIntToWord = IntWordConv.idFromInt32ToWord32 + val idFromWordToInt = IntWordConv.idFromWord32ToInt32) +in + structure Int32 : PRIM_INTEGER = S.Int + structure Word32 : PRIM_WORD = S.Word +end +local + structure S = + MkNum0 (structure Int = Int64 + structure Word = Word64 + val idFromIntToWord = IntWordConv.idFromInt64ToWord64 + val idFromWordToInt = IntWordConv.idFromWord64ToInt64) +in + structure Int64 : PRIM_INTEGER = S.Int + structure Word64 : PRIM_WORD = S.Word +end + +end diff --git a/basis-library/integer/num1.sml b/basis-library/integer/num1.sml new file mode 100644 index 0000000..5a5ef46 --- /dev/null +++ b/basis-library/integer/num1.sml @@ -0,0 +1,999 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MKNUM1_ARG = + sig + type num + + val zextdFromInt8: Primitive.Int8.int -> num + val zextdFromInt16: Primitive.Int16.int -> num + val zextdFromInt32: Primitive.Int32.int -> num + val zextdFromInt64: Primitive.Int64.int -> num + val zextdFromIntInf: Primitive.IntInf.int -> num + val zextdFromWord8: Primitive.Word8.word -> num + val zextdFromWord16: Primitive.Word16.word -> num + val zextdFromWord32: Primitive.Word32.word -> num + val zextdFromWord64: Primitive.Word64.word -> num + val zextdToInt8: num -> Primitive.Int8.int + val zextdToInt16: num -> Primitive.Int16.int + val zextdToInt32: num -> Primitive.Int32.int + val zextdToInt64: num -> Primitive.Int64.int + val zextdToIntInf: num -> Primitive.IntInf.int + val zextdToWord8: num -> Primitive.Word8.word + val zextdToWord16: num -> Primitive.Word16.word + val zextdToWord32: num -> Primitive.Word32.word + val zextdToWord64: num -> Primitive.Word64.word + + val sextdFromInt8: Primitive.Int8.int -> num + val sextdFromInt16: Primitive.Int16.int -> num + val sextdFromInt32: Primitive.Int32.int -> num + val sextdFromInt64: Primitive.Int64.int -> num + val sextdFromIntInf: Primitive.IntInf.int -> num + val sextdFromWord8: Primitive.Word8.word -> num + val sextdFromWord16: Primitive.Word16.word -> num + val sextdFromWord32: Primitive.Word32.word -> num + val sextdFromWord64: Primitive.Word64.word -> num + val sextdToInt8: num -> Primitive.Int8.int + val sextdToInt16: num -> Primitive.Int16.int + val sextdToInt32: num -> Primitive.Int32.int + val sextdToInt64: num -> Primitive.Int64.int + val sextdToIntInf: num -> Primitive.IntInf.int + val sextdToWord8: num -> Primitive.Word8.word + val sextdToWord16: num -> Primitive.Word16.word + val sextdToWord32: num -> Primitive.Word32.word + val sextdToWord64: num -> Primitive.Word64.word + + val castFromInt8: Primitive.Int8.int -> num + val castFromInt16: Primitive.Int16.int -> num + val castFromInt32: Primitive.Int32.int -> num + val castFromInt64: Primitive.Int64.int -> num + val castFromIntInf: Primitive.IntInf.int -> num + val castFromWord8: Primitive.Word8.word -> num + val castFromWord16: Primitive.Word16.word -> num + val castFromWord32: Primitive.Word32.word -> num + val castFromWord64: Primitive.Word64.word -> num + val castToInt8: num -> Primitive.Int8.int + val castToInt16: num -> Primitive.Int16.int + val castToInt32: num -> Primitive.Int32.int + val castToInt64: num -> Primitive.Int64.int + val castToIntInf: num -> Primitive.IntInf.int + val castToWord8: num -> Primitive.Word8.word + val castToWord16: num -> Primitive.Word16.word + val castToWord32: num -> Primitive.Word32.word + val castToWord64: num -> Primitive.Word64.word + + val zchckFromInt8: Primitive.Int8.int -> num + val zchckFromInt16: Primitive.Int16.int -> num + val zchckFromInt32: Primitive.Int32.int -> num + val zchckFromInt64: Primitive.Int64.int -> num + val zchckFromIntInf: Primitive.IntInf.int -> num + val zchckFromWord8: Primitive.Word8.word -> num + val zchckFromWord16: Primitive.Word16.word -> num + val zchckFromWord32: Primitive.Word32.word -> num + val zchckFromWord64: Primitive.Word64.word -> num + val zchckToInt8: num -> Primitive.Int8.int + val zchckToInt16: num -> Primitive.Int16.int + val zchckToInt32: num -> Primitive.Int32.int + val zchckToInt64: num -> Primitive.Int64.int + val zchckToIntInf: num -> Primitive.IntInf.int + val zchckToWord8: num -> Primitive.Word8.word + val zchckToWord16: num -> Primitive.Word16.word + val zchckToWord32: num -> Primitive.Word32.word + val zchckToWord64: num -> Primitive.Word64.word + + val schckFromInt8: Primitive.Int8.int -> num + val schckFromInt16: Primitive.Int16.int -> num + val schckFromInt32: Primitive.Int32.int -> num + val schckFromInt64: Primitive.Int64.int -> num + val schckFromIntInf: Primitive.IntInf.int -> num + val schckFromWord8: Primitive.Word8.word -> num + val schckFromWord16: Primitive.Word16.word -> num + val schckFromWord32: Primitive.Word32.word -> num + val schckFromWord64: Primitive.Word64.word -> num + val schckToInt8: num -> Primitive.Int8.int + val schckToInt16: num -> Primitive.Int16.int + val schckToInt32: num -> Primitive.Int32.int + val schckToInt64: num -> Primitive.Int64.int + val schckToIntInf: num -> Primitive.IntInf.int + val schckToWord8: num -> Primitive.Word8.word + val schckToWord16: num -> Primitive.Word16.word + val schckToWord32: num -> Primitive.Word32.word + val schckToWord64: num -> Primitive.Word64.word + end +signature MKNUM1_RES = + sig + type num + + val zextdFromInt: Int.int -> num + val zextdToInt: num -> Int.int + val sextdFromInt: Int.int -> num + val sextdToInt: num -> Int.int + val castFromInt: Int.int -> num + val castToInt: num -> Int.int + val zchckFromInt: Int.int -> num + val zchckToInt: num -> Int.int + val schckFromInt: Int.int -> num + val schckToInt: num -> Int.int + + val zextdFromFixedInt: FixedInt.int -> num + val zextdToFixedInt: num -> FixedInt.int + val sextdFromFixedInt: FixedInt.int -> num + val sextdToFixedInt: num -> FixedInt.int + val castFromFixedInt: FixedInt.int -> num + val castToFixedInt: num -> FixedInt.int + val zchckFromFixedInt: FixedInt.int -> num + val zchckToFixedInt: num -> FixedInt.int + val schckFromFixedInt: FixedInt.int -> num + val schckToFixedInt: num -> FixedInt.int + + val zextdFromLargeInt: LargeInt.int -> num + val zextdToLargeInt: num -> LargeInt.int + val sextdFromLargeInt: LargeInt.int -> num + val sextdToLargeInt: num -> LargeInt.int + val castFromLargeInt: LargeInt.int -> num + val castToLargeInt: num -> LargeInt.int + val zchckFromLargeInt: LargeInt.int -> num + val zchckToLargeInt: num -> LargeInt.int + val schckFromLargeInt: LargeInt.int -> num + val schckToLargeInt: num -> LargeInt.int + + val zextdFromWord: Word.word -> num + val zextdToWord: num -> Word.word + val sextdFromWord: Word.word -> num + val sextdToWord: num -> Word.word + val castFromWord: Word.word -> num + val castToWord: num -> Word.word + val zchckFromWord: Word.word -> num + val zchckToWord: num -> Word.word + val schckFromWord: Word.word -> num + val schckToWord: num -> Word.word + + val zextdFromLargeWord: LargeWord.word -> num + val zextdToLargeWord: num -> LargeWord.word + val sextdFromLargeWord: LargeWord.word -> num + val sextdToLargeWord: num -> LargeWord.word + val castFromLargeWord: LargeWord.word -> num + val castToLargeWord: num -> LargeWord.word + val zchckFromLargeWord: LargeWord.word -> num + val zchckToLargeWord: num -> LargeWord.word + val schckFromLargeWord: LargeWord.word -> num + val schckToLargeWord: num -> LargeWord.word + + val zextdFromSysWord: SysWord.word -> num + val zextdToSysWord: num -> SysWord.word + val sextdFromSysWord: SysWord.word -> num + val sextdToSysWord: num -> SysWord.word + val castFromSysWord: SysWord.word -> num + val castToSysWord: num -> SysWord.word + val zchckFromSysWord: SysWord.word -> num + val zchckToSysWord: num -> SysWord.word + val schckFromSysWord: SysWord.word -> num + val schckToSysWord: num -> SysWord.word + end +signature PRIM_INTEGER = + sig + include PRIM_INTEGER + include MKNUM1_RES where type num = int + end +signature PRIM_WORD = + sig + include PRIM_WORD + include MKNUM1_RES where type num = word + end + +functor MkNum1 (I: MKNUM1_ARG) : MKNUM1_RES = + struct + open I + + local + structure S = + Int_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.zextdFromInt8 + val fInt16 = I.zextdFromInt16 + val fInt32 = I.zextdFromInt32 + val fInt64 = I.zextdFromInt64 + val fIntInf = I.zextdFromIntInf) + in + val zextdFromInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.zextdToInt8 + val fInt16 = I.zextdToInt16 + val fInt32 = I.zextdToInt32 + val fInt64 = I.zextdToInt64 + val fIntInf = I.zextdToIntInf) + in + val zextdToInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.sextdFromInt8 + val fInt16 = I.sextdFromInt16 + val fInt32 = I.sextdFromInt32 + val fInt64 = I.sextdFromInt64 + val fIntInf = I.sextdFromIntInf) + in + val sextdFromInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.sextdToInt8 + val fInt16 = I.sextdToInt16 + val fInt32 = I.sextdToInt32 + val fInt64 = I.sextdToInt64 + val fIntInf = I.sextdToIntInf) + in + val sextdToInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.castFromInt8 + val fInt16 = I.castFromInt16 + val fInt32 = I.castFromInt32 + val fInt64 = I.castFromInt64 + val fIntInf = I.castFromIntInf) + in + val castFromInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.castToInt8 + val fInt16 = I.castToInt16 + val fInt32 = I.castToInt32 + val fInt64 = I.castToInt64 + val fIntInf = I.castToIntInf) + in + val castToInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.zchckFromInt8 + val fInt16 = I.zchckFromInt16 + val fInt32 = I.zchckFromInt32 + val fInt64 = I.zchckFromInt64 + val fIntInf = I.zchckFromIntInf) + in + val zchckFromInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.zchckToInt8 + val fInt16 = I.zchckToInt16 + val fInt32 = I.zchckToInt32 + val fInt64 = I.zchckToInt64 + val fIntInf = I.zchckToIntInf) + in + val zchckToInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.schckFromInt8 + val fInt16 = I.schckFromInt16 + val fInt32 = I.schckFromInt32 + val fInt64 = I.schckFromInt64 + val fIntInf = I.schckFromIntInf) + in + val schckFromInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.schckToInt8 + val fInt16 = I.schckToInt16 + val fInt32 = I.schckToInt32 + val fInt64 = I.schckToInt64 + val fIntInf = I.schckToIntInf) + in + val schckToInt = S.f + end + + + local + structure S = + FixedInt_ChooseIntN + (type 'a t = 'a -> num + val fInt8 = I.zextdFromInt8 + val fInt16 = I.zextdFromInt16 + val fInt32 = I.zextdFromInt32 + val fInt64 = I.zextdFromInt64) + in + val zextdFromFixedInt = S.f + end + local + structure S = + FixedInt_ChooseIntN + (type 'a t = num -> 'a + val fInt8 = I.zextdToInt8 + val fInt16 = I.zextdToInt16 + val fInt32 = I.zextdToInt32 + val fInt64 = I.zextdToInt64) + in + val zextdToFixedInt = S.f + end + local + structure S = + FixedInt_ChooseIntN + (type 'a t = 'a -> num + val fInt8 = I.sextdFromInt8 + val fInt16 = I.sextdFromInt16 + val fInt32 = I.sextdFromInt32 + val fInt64 = I.sextdFromInt64) + in + val sextdFromFixedInt = S.f + end + local + structure S = + FixedInt_ChooseIntN + (type 'a t = num -> 'a + val fInt8 = I.sextdToInt8 + val fInt16 = I.sextdToInt16 + val fInt32 = I.sextdToInt32 + val fInt64 = I.sextdToInt64) + in + val sextdToFixedInt = S.f + end + local + structure S = + FixedInt_ChooseIntN + (type 'a t = 'a -> num + val fInt8 = I.castFromInt8 + val fInt16 = I.castFromInt16 + val fInt32 = I.castFromInt32 + val fInt64 = I.castFromInt64) + in + val castFromFixedInt = S.f + end + local + structure S = + FixedInt_ChooseIntN + (type 'a t = num -> 'a + val fInt8 = I.castToInt8 + val fInt16 = I.castToInt16 + val fInt32 = I.castToInt32 + val fInt64 = I.castToInt64) + in + val castToFixedInt = S.f + end + local + structure S = + FixedInt_ChooseIntN + (type 'a t = 'a -> num + val fInt8 = I.zchckFromInt8 + val fInt16 = I.zchckFromInt16 + val fInt32 = I.zchckFromInt32 + val fInt64 = I.zchckFromInt64) + in + val zchckFromFixedInt = S.f + end + local + structure S = + FixedInt_ChooseIntN + (type 'a t = num -> 'a + val fInt8 = I.zchckToInt8 + val fInt16 = I.zchckToInt16 + val fInt32 = I.zchckToInt32 + val fInt64 = I.zchckToInt64) + in + val zchckToFixedInt = S.f + end + local + structure S = + FixedInt_ChooseIntN + (type 'a t = 'a -> num + val fInt8 = I.schckFromInt8 + val fInt16 = I.schckFromInt16 + val fInt32 = I.schckFromInt32 + val fInt64 = I.schckFromInt64) + in + val schckFromFixedInt = S.f + end + local + structure S = + FixedInt_ChooseIntN + (type 'a t = num -> 'a + val fInt8 = I.schckToInt8 + val fInt16 = I.schckToInt16 + val fInt32 = I.schckToInt32 + val fInt64 = I.schckToInt64) + in + val schckToFixedInt = S.f + end + + + local + structure S = + LargeInt_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.zextdFromInt8 + val fInt16 = I.zextdFromInt16 + val fInt32 = I.zextdFromInt32 + val fInt64 = I.zextdFromInt64 + val fIntInf = I.zextdFromIntInf) + in + val zextdFromLargeInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.zextdToInt8 + val fInt16 = I.zextdToInt16 + val fInt32 = I.zextdToInt32 + val fInt64 = I.zextdToInt64 + val fIntInf = I.zextdToIntInf) + in + val zextdToLargeInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.sextdFromInt8 + val fInt16 = I.sextdFromInt16 + val fInt32 = I.sextdFromInt32 + val fInt64 = I.sextdFromInt64 + val fIntInf = I.sextdFromIntInf) + in + val sextdFromLargeInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.sextdToInt8 + val fInt16 = I.sextdToInt16 + val fInt32 = I.sextdToInt32 + val fInt64 = I.sextdToInt64 + val fIntInf = I.sextdToIntInf) + in + val sextdToLargeInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.castFromInt8 + val fInt16 = I.castFromInt16 + val fInt32 = I.castFromInt32 + val fInt64 = I.castFromInt64 + val fIntInf = I.castFromIntInf) + in + val castFromLargeInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.castToInt8 + val fInt16 = I.castToInt16 + val fInt32 = I.castToInt32 + val fInt64 = I.castToInt64 + val fIntInf = I.castToIntInf) + in + val castToLargeInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.zchckFromInt8 + val fInt16 = I.zchckFromInt16 + val fInt32 = I.zchckFromInt32 + val fInt64 = I.zchckFromInt64 + val fIntInf = I.zchckFromIntInf) + in + val zchckFromLargeInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.zchckToInt8 + val fInt16 = I.zchckToInt16 + val fInt32 = I.zchckToInt32 + val fInt64 = I.zchckToInt64 + val fIntInf = I.zchckToIntInf) + in + val zchckToLargeInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = 'a -> num + val fInt8 = I.schckFromInt8 + val fInt16 = I.schckFromInt16 + val fInt32 = I.schckFromInt32 + val fInt64 = I.schckFromInt64 + val fIntInf = I.schckFromIntInf) + in + val schckFromLargeInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = num -> 'a + val fInt8 = I.schckToInt8 + val fInt16 = I.schckToInt16 + val fInt32 = I.schckToInt32 + val fInt64 = I.schckToInt64 + val fIntInf = I.schckToIntInf) + in + val schckToLargeInt = S.f + end + + + local + structure S = + Word_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.zextdFromWord8 + val fWord16 = I.zextdFromWord16 + val fWord32 = I.zextdFromWord32 + val fWord64 = I.zextdFromWord64) + in + val zextdFromWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.zextdToWord8 + val fWord16 = I.zextdToWord16 + val fWord32 = I.zextdToWord32 + val fWord64 = I.zextdToWord64) + in + val zextdToWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.sextdFromWord8 + val fWord16 = I.sextdFromWord16 + val fWord32 = I.sextdFromWord32 + val fWord64 = I.sextdFromWord64) + in + val sextdFromWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.sextdToWord8 + val fWord16 = I.sextdToWord16 + val fWord32 = I.sextdToWord32 + val fWord64 = I.sextdToWord64) + in + val sextdToWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.castFromWord8 + val fWord16 = I.castFromWord16 + val fWord32 = I.castFromWord32 + val fWord64 = I.castFromWord64) + in + val castFromWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.castToWord8 + val fWord16 = I.castToWord16 + val fWord32 = I.castToWord32 + val fWord64 = I.castToWord64) + in + val castToWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.zchckFromWord8 + val fWord16 = I.zchckFromWord16 + val fWord32 = I.zchckFromWord32 + val fWord64 = I.zchckFromWord64) + in + val zchckFromWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.zchckToWord8 + val fWord16 = I.zchckToWord16 + val fWord32 = I.zchckToWord32 + val fWord64 = I.zchckToWord64) + in + val zchckToWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.schckFromWord8 + val fWord16 = I.schckFromWord16 + val fWord32 = I.schckFromWord32 + val fWord64 = I.schckFromWord64) + in + val schckFromWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.schckToWord8 + val fWord16 = I.schckToWord16 + val fWord32 = I.schckToWord32 + val fWord64 = I.schckToWord64) + in + val schckToWord = S.f + end + + + local + structure S = + LargeWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.zextdFromWord8 + val fWord16 = I.zextdFromWord16 + val fWord32 = I.zextdFromWord32 + val fWord64 = I.zextdFromWord64) + in + val zextdFromLargeWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.zextdToWord8 + val fWord16 = I.zextdToWord16 + val fWord32 = I.zextdToWord32 + val fWord64 = I.zextdToWord64) + in + val zextdToLargeWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.sextdFromWord8 + val fWord16 = I.sextdFromWord16 + val fWord32 = I.sextdFromWord32 + val fWord64 = I.sextdFromWord64) + in + val sextdFromLargeWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.sextdToWord8 + val fWord16 = I.sextdToWord16 + val fWord32 = I.sextdToWord32 + val fWord64 = I.sextdToWord64) + in + val sextdToLargeWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.castFromWord8 + val fWord16 = I.castFromWord16 + val fWord32 = I.castFromWord32 + val fWord64 = I.castFromWord64) + in + val castFromLargeWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.castToWord8 + val fWord16 = I.castToWord16 + val fWord32 = I.castToWord32 + val fWord64 = I.castToWord64) + in + val castToLargeWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.zchckFromWord8 + val fWord16 = I.zchckFromWord16 + val fWord32 = I.zchckFromWord32 + val fWord64 = I.zchckFromWord64) + in + val zchckFromLargeWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.zchckToWord8 + val fWord16 = I.zchckToWord16 + val fWord32 = I.zchckToWord32 + val fWord64 = I.zchckToWord64) + in + val zchckToLargeWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.schckFromWord8 + val fWord16 = I.schckFromWord16 + val fWord32 = I.schckFromWord32 + val fWord64 = I.schckFromWord64) + in + val schckFromLargeWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.schckToWord8 + val fWord16 = I.schckToWord16 + val fWord32 = I.schckToWord32 + val fWord64 = I.schckToWord64) + in + val schckToLargeWord = S.f + end + + + local + structure S = + SysWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.zextdFromWord8 + val fWord16 = I.zextdFromWord16 + val fWord32 = I.zextdFromWord32 + val fWord64 = I.zextdFromWord64) + in + val zextdFromSysWord = S.f + end + local + structure S = + SysWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.zextdToWord8 + val fWord16 = I.zextdToWord16 + val fWord32 = I.zextdToWord32 + val fWord64 = I.zextdToWord64) + in + val zextdToSysWord = S.f + end + local + structure S = + SysWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.sextdFromWord8 + val fWord16 = I.sextdFromWord16 + val fWord32 = I.sextdFromWord32 + val fWord64 = I.sextdFromWord64) + in + val sextdFromSysWord = S.f + end + local + structure S = + SysWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.sextdToWord8 + val fWord16 = I.sextdToWord16 + val fWord32 = I.sextdToWord32 + val fWord64 = I.sextdToWord64) + in + val sextdToSysWord = S.f + end + local + structure S = + SysWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.castFromWord8 + val fWord16 = I.castFromWord16 + val fWord32 = I.castFromWord32 + val fWord64 = I.castFromWord64) + in + val castFromSysWord = S.f + end + local + structure S = + SysWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.castToWord8 + val fWord16 = I.castToWord16 + val fWord32 = I.castToWord32 + val fWord64 = I.castToWord64) + in + val castToSysWord = S.f + end + local + structure S = + SysWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.zchckFromWord8 + val fWord16 = I.zchckFromWord16 + val fWord32 = I.zchckFromWord32 + val fWord64 = I.zchckFromWord64) + in + val zchckFromSysWord = S.f + end + local + structure S = + SysWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.zchckToWord8 + val fWord16 = I.zchckToWord16 + val fWord32 = I.zchckToWord32 + val fWord64 = I.zchckToWord64) + in + val zchckToSysWord = S.f + end + local + structure S = + SysWord_ChooseWordN + (type 'a t = 'a -> num + val fWord8 = I.schckFromWord8 + val fWord16 = I.schckFromWord16 + val fWord32 = I.schckFromWord32 + val fWord64 = I.schckFromWord64) + in + val schckFromSysWord = S.f + end + local + structure S = + SysWord_ChooseWordN + (type 'a t = num -> 'a + val fWord8 = I.schckToWord8 + val fWord16 = I.schckToWord16 + val fWord32 = I.schckToWord32 + val fWord64 = I.schckToWord64) + in + val schckToSysWord = S.f + end + end + +structure Primitive = +struct +open Primitive + +structure Int8 = + struct + open Int8 + local + structure S = MkNum1(struct + open Int8 + type num = int + end) + in + open S + end + end +structure Int16 = + struct + open Int16 + local + structure S = MkNum1(struct + open Int16 + type num = int + end) + in + open S + end + end +structure Int32 = + struct + open Int32 + local + structure S = MkNum1(struct + open Int32 + type num = int + end) + in + open S + end + end +structure Int64 = + struct + open Int64 + local + structure S = MkNum1(struct + open Int64 + type num = int + end) + in + open S + end + end +structure IntInf = + struct + open IntInf + local + structure S = MkNum1(struct + open IntInf + type num = int + end) + in + open S + end + end + +structure Word8 = + struct + open Word8 + local + structure S = MkNum1(struct + open Word8 + type num = word + end) + in + open S + end + end +structure Word16 = + struct + open Word16 + local + structure S = MkNum1(struct + open Word16 + type num = word + end) + in + open S + end + end +structure Word32 = + struct + open Word32 + local + structure S = MkNum1(struct + open Word32 + type num = word + end) + in + open S + end + end +structure Word64 : PRIM_WORD = + struct + open Word64 + local + structure S = MkNum1(struct + open Word64 + type num = word + end) + in + open S + end + end + +end diff --git a/basis-library/integer/pack-word.sig b/basis-library/integer/pack-word.sig new file mode 100644 index 0000000..f0fdc2f --- /dev/null +++ b/basis-library/integer/pack-word.sig @@ -0,0 +1,20 @@ +signature PACK_WORD = + sig + val bytesPerElem: int + val isBigEndian: bool + val subArr: Word8Array.array * int -> LargeWord.word + val subArrX: Word8Array.array * int -> LargeWord.word + val subVec: Word8Vector.vector * int -> LargeWord.word + val subVecX: Word8Vector.vector * int -> LargeWord.word + val update: Word8Array.array * int * LargeWord.word -> unit + end + +signature PACK_WORD_EXTRA = + sig + include PACK_WORD + val unsafeSubArr: Word8Array.array * int -> LargeWord.word + val unsafeSubArrX: Word8Array.array * int -> LargeWord.word + val unsafeSubVec: Word8Vector.vector * int -> LargeWord.word + val unsafeSubVecX: Word8Vector.vector * int -> LargeWord.word + val unsafeUpdate: Word8Array.array * int * LargeWord.word -> unit + end diff --git a/basis-library/integer/pack-word.sml b/basis-library/integer/pack-word.sml new file mode 100644 index 0000000..08e7e33 --- /dev/null +++ b/basis-library/integer/pack-word.sml @@ -0,0 +1,244 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor PackWord (S: sig + type word + val wordSize: int + val isBigEndian: bool + val subArr: Word8.word array * SeqIndex.int -> word + val subVec: Word8.word vector * SeqIndex.int -> word + val update: Word8.word array * SeqIndex.int * word -> unit + val bswap: word -> word + val toLarge: word -> LargeWord.word + val toLargeX: word -> LargeWord.word + val fromLarge: LargeWord.word -> word + end): PACK_WORD_EXTRA = +struct + +open S + +val bytesPerElem = Int.div (wordSize, 8) + +fun offset (i, n) = + let + val () = + if Primitive.Controls.safe + andalso (Int.geu (Int.+ (Int.* (bytesPerElem, i), + Int.- (bytesPerElem, 1)), n)) + then raise Subscript + else () + in + SeqIndex.fromInt i + end + handle Overflow => raise Subscript + +val subArrRev = bswap o subArr +val subVecRev = bswap o subVec +fun updateRev (a, i, w) = update (a, i, bswap w) + +val (subA, subV, updA) = + if isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian + then (subArr, subVec, update) + else (subArrRev, subVecRev, updateRev) + +fun unsafeUpdate (a, i, w) = + let + val i = SeqIndex.fromInt i + val a = Word8Array.toPoly a + in + updA (a, i, fromLarge w) + end + +fun update (a, i, w) = + let + val i = offset (i, Word8Array.length a) + val a = Word8Array.toPoly a + in + updA (a, i, fromLarge w) + end + +local + fun make (sub, length, toPoly) (av, i) = + let + val i = offset (i, length av) + in + sub (toPoly av, i) + end +in + val subArr = toLarge o (make (subA, Word8Array.length, Word8Array.toPoly)) + val subArrX = toLargeX o (make (subA, Word8Array.length, Word8Array.toPoly)) + val subVec = toLarge o (make (subV, Word8Vector.length, Word8Vector.toPoly)) + val subVecX = toLargeX o (make (subV, Word8Vector.length, Word8Vector.toPoly)) +end + +local + fun make (sub, length, toPoly) (av, i) = + let + val i = SeqIndex.fromInt i + in + sub (toPoly av, i) + end +in + val unsafeSubArr = toLarge o (make (subA, Word8Array.length, Word8Array.toPoly)) + val unsafeSubArrX = toLargeX o (make (subA, Word8Array.length, Word8Array.toPoly)) + val unsafeSubVec = toLarge o (make (subV, Word8Vector.length, Word8Vector.toPoly)) + val unsafeSubVecX = toLargeX o (make (subV, Word8Vector.length, Word8Vector.toPoly)) +end + +end + +structure PackWord8Big: PACK_WORD_EXTRA = + PackWord (val isBigEndian = true + open Primitive.PackWord8 + open Word8) +structure PackWord8Little: PACK_WORD_EXTRA = + PackWord (val isBigEndian = false + open Primitive.PackWord8 + open Word8) +structure PackWord8Host: PACK_WORD_EXTRA = + PackWord (val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian + open Primitive.PackWord8 + open Word8) +structure PackWord16Big: PACK_WORD_EXTRA = + PackWord (val isBigEndian = true + open Primitive.PackWord16 + open Word16) +structure PackWord16Little: PACK_WORD_EXTRA = + PackWord (val isBigEndian = false + open Primitive.PackWord16 + open Word16) +structure PackWord16Host: PACK_WORD_EXTRA = + PackWord (val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian + open Primitive.PackWord16 + open Word16) +structure PackWord32Big: PACK_WORD_EXTRA = + PackWord (val isBigEndian = true + open Primitive.PackWord32 + open Word32) +structure PackWord32Little: PACK_WORD_EXTRA = + PackWord (val isBigEndian = false + open Primitive.PackWord32 + open Word32) +structure PackWord32Host: PACK_WORD_EXTRA = + PackWord (val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian + open Primitive.PackWord32 + open Word32) +structure PackWord64Big: PACK_WORD_EXTRA = + PackWord (val isBigEndian = true + open Primitive.PackWord64 + open Word64) +structure PackWord64Little: PACK_WORD_EXTRA = + PackWord (val isBigEndian = false + open Primitive.PackWord64 + open Word64) +structure PackWord64Host: PACK_WORD_EXTRA = + PackWord (val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian + open Primitive.PackWord64 + open Word64) +local + structure PackWord = + struct + local + structure S = + Word_ChooseWordN + (type 'a t = Word8.word array * SeqIndex.t -> 'a + val fWord8 = Primitive.PackWord8.subArr + val fWord16 = Primitive.PackWord16.subArr + val fWord32 = Primitive.PackWord32.subArr + val fWord64 = Primitive.PackWord64.subArr) + in + val subArr = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = Word8.word vector * SeqIndex.t -> 'a + val fWord8 = Primitive.PackWord8.subVec + val fWord16 = Primitive.PackWord16.subVec + val fWord32 = Primitive.PackWord32.subVec + val fWord64 = Primitive.PackWord64.subVec) + in + val subVec = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = Word8.word array * SeqIndex.t * 'a -> unit + val fWord8 = Primitive.PackWord8.update + val fWord16 = Primitive.PackWord16.update + val fWord32 = Primitive.PackWord32.update + val fWord64 = Primitive.PackWord64.update) + in + val update = S.f + end + end +in +structure PackWordBig: PACK_WORD_EXTRA = + PackWord (val isBigEndian = true + open PackWord + open Word) +structure PackWordLittle: PACK_WORD_EXTRA = + PackWord (val isBigEndian = false + open PackWord + open Word) +structure PackWordHost: PACK_WORD_EXTRA = + PackWord (val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian + open PackWord + open Word) +end +local + structure PackLargeWord = + struct + local + structure S = + LargeWord_ChooseWordN + (type 'a t = Word8.word array * SeqIndex.t -> 'a + val fWord8 = Primitive.PackWord8.subArr + val fWord16 = Primitive.PackWord16.subArr + val fWord32 = Primitive.PackWord32.subArr + val fWord64 = Primitive.PackWord64.subArr) + in + val subArr = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = Word8.word vector * SeqIndex.t -> 'a + val fWord8 = Primitive.PackWord8.subVec + val fWord16 = Primitive.PackWord16.subVec + val fWord32 = Primitive.PackWord32.subVec + val fWord64 = Primitive.PackWord64.subVec) + in + val subVec = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = Word8.word array * SeqIndex.t * 'a -> unit + val fWord8 = Primitive.PackWord8.update + val fWord16 = Primitive.PackWord16.update + val fWord32 = Primitive.PackWord32.update + val fWord64 = Primitive.PackWord64.update) + in + val update = S.f + end + end +in +structure PackLargeWordBig: PACK_WORD_EXTRA = + PackWord (val isBigEndian = true + open PackLargeWord + open LargeWord) +structure PackLargeWordLittle: PACK_WORD_EXTRA = + PackWord (val isBigEndian = false + open PackLargeWord + open LargeWord) +structure PackLargeWordHost: PACK_WORD_EXTRA = + PackWord (val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian + open PackLargeWord + open LargeWord) +end diff --git a/basis-library/integer/word-global.sml b/basis-library/integer/word-global.sml new file mode 100644 index 0000000..0ee324d --- /dev/null +++ b/basis-library/integer/word-global.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure WordGlobal: WORD_GLOBAL = Word +open WordGlobal diff --git a/basis-library/integer/word.sig b/basis-library/integer/word.sig new file mode 100644 index 0000000..4e1a688 --- /dev/null +++ b/basis-library/integer/word.sig @@ -0,0 +1,80 @@ +signature WORD_GLOBAL = + sig + eqtype word + end + +signature WORD = + sig + include WORD_GLOBAL + + val wordSize: Int.int + + val toLarge: word -> LargeWord.word + val toLargeX: word -> LargeWord.word + val toLargeWord: word -> LargeWord.word + val toLargeWordX: word -> LargeWord.word + val fromLarge: LargeWord.word -> word + val fromLargeWord: LargeWord.word -> word + val toLargeInt: word -> LargeInt.int + val toLargeIntX: word -> LargeInt.int + val fromLargeInt: LargeInt.int -> word + val toInt: word -> int + val toIntX: word -> int + val fromInt: int -> word + + val + : word * word -> word + val - : word * word -> word + val * : word * word -> word + val div: word * word -> word + val mod: word * word -> word + + val andb: word * word -> word + val << : word * Word.word -> word + val notb: word -> word + val orb: word * word -> word + val ~>> : word * Word.word -> word + val >> : word * Word.word -> word + val xorb: word * word -> word + + val compare: word * word -> order + val < : word * word -> bool + val <= : word * word -> bool + val > : word * word -> bool + val >= : word * word -> bool + + val ~ : word -> word + val min: word * word -> word + val max: word * word -> word + + val fmt: StringCvt.radix -> word -> string + val toString: word -> string + val scan: (StringCvt.radix + -> (char, 'a) StringCvt.reader + -> (word, 'a) StringCvt.reader) + val fromString: string -> word option + end + +signature WORD_EXTRA = + sig + include WORD + type t = word + + val zero: word + val one: word + + val maxWord' : word + + val toWord: word -> Word.word + val toWordX: word -> Word.word + val fromWord: Word.word -> word + + val bswap: word -> word + val rol: word * Word.word -> word + val ror: word * Word.word -> word + val log2 : word -> Primitive.Int32.int + + val castFromFixedInt: FixedInt.int -> word + val castToFixedInt: word -> FixedInt.int + val castFromSysWord: SysWord.word -> word + val castToSysWord: word -> SysWord.word + end diff --git a/basis-library/integer/word.sml b/basis-library/integer/word.sml new file mode 100644 index 0000000..8ea23e5 --- /dev/null +++ b/basis-library/integer/word.sml @@ -0,0 +1,216 @@ +(* Copyright (C) 2013 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor Word (W: PRIM_WORD) : WORD_EXTRA = +struct + +open W +type t = word + +val wordSize: Int.int = Primitive.Int32.zextdToInt sizeInBits +val sizeInBitsWord = Primitive.Word32.zextdToWord sizeInBitsWord + +fun << (i, n) = + if Word.>= (n, sizeInBitsWord) + then zero + else W.<> (i, n) = + if Word.>= (n, sizeInBitsWord) + then zero + else W.>>? (i, Primitive.Word32.zextdFromWord n) +fun ~>> (i, n) = + if Word.< (n, sizeInBitsWord) + then W.~>>? (i, Primitive.Word32.zextdFromWord n) + else W.~>>? (i, Primitive.Word32.- (W.sizeInBitsWord, 0w1)) +fun rol (i, n) = W.rolUnsafe (i, Primitive.Word32.zextdFromWord n) +fun ror (i, n) = W.rorUnsafe (i, Primitive.Word32.zextdFromWord n) + +local + fun st (w, msk, sft) = + let + val odd = andb (w, msk) + val evn = xorb (w, odd) + in + (xorb (W.<>? (evn, sft)), + xorb (msk, W.<>? (sft, 0w1))), + Primitive.Word32.>>? (sft, 0w1)) + end + val (f, sft : Primitive.Word32.t) = + case W.sizeInBitsWord of + 0w8 => (fn x => x, 0w4) + | 0w16 => (st, 0w8) + | 0w32 => (st o st, 0w16) + | 0w64 => (st o st o st, 0w32) + | _ => raise (Fail "Word.bswap") +in + fun bswap w = #1 (f (w, W.< false + | SOME precision => + Int32.<= (precision, W.sizeInBits)) + andalso Int.< (i, 0) + then raise Overflow + else i + end +val fromLargeInt = W.sextdFromLargeInt +val toLargeIntX = W.schckToLargeInt +fun toLargeInt w = + let + val i = W.zchckToLargeInt w + in + if Primitive.Controls.detectOverflow + andalso (case LargeInt.precision of + NONE => false + | SOME precision => + Int32.<= (precision, W.sizeInBits)) + andalso LargeInt.< (i, 0) + then raise Overflow + else i + end + +val fromLargeWord = W.zextdFromLargeWord +val fromLarge = fromLargeWord +val toLargeWordX = W.sextdToLargeWord +val toLargeX = toLargeWordX +val toLargeWord = W.zextdToLargeWord +val toLarge = toLargeWord + +val fromWord = W.zextdFromWord +val toWordX = W.sextdToWord +val toWord = W.zextdToWord + +local + (* Allocate a buffer large enough to hold any formatted word in any radix. + * The most that will be required is for maxWord in binary. + *) + val maxNumDigits = wordSize + val oneBuf = One.make (fn () => CharArray.array (maxNumDigits, #"\000")) +in + fun fmt radix (w: word): string = + One.use + (oneBuf, fn buf => + let + val radix = fromInt (StringCvt.radixToInt radix) + fun loop (q, i: Int.int) = + let + val _ = + CharArray.update + (buf, i, StringCvt.digitToChar (toInt (q mod radix))) + val q = q div radix + in + if q = zero + then CharArraySlice.vector + (CharArraySlice.slice (buf, i, NONE)) + else loop (q, Int.- (i, 1)) + end + in + loop (w, Int.- (maxNumDigits, 1)) + end) +end + +(* +fun fmt radix (w: word): string = + let + val radix = fromInt (StringCvt.radixToInt radix) + fun loop (q, chars) = + let + val chars = StringCvt.digitToChar (toInt (q mod radix)) :: chars + val q = q div radix + in + if q = zero + then String.implode chars + else loop (q, chars) + end + in + loop (w, []) + end +*) + +val toString = fmt StringCvt.HEX + +fun scan radix reader state = + let + val state = StringCvt.skipWS reader state + val charToDigit = StringCvt.charToDigit radix + val radixWord = fromInt (StringCvt.radixToInt radix) + fun finishNum (state, n) = + case reader state of + NONE => SOME (n, state) + | SOME (c, state') => + case charToDigit c of + NONE => SOME (n, state) + | SOME n' => + let val n'' = n * radixWord + in if n'' div radixWord = n + then let val n' = fromInt n' + val n''' = n'' + n' + in if n''' >= n'' + then finishNum (state', n''') + else raise Overflow + end + else raise Overflow + end + fun num state = finishNum (state, zero) + in + case reader state of + NONE => NONE + | SOME (c, state) => + case c of + #"0" => + (case reader state of + NONE => SOME (zero, state) + | SOME (c, state') => + case c of + #"w" => (case radix of + StringCvt.HEX => + (case reader state' of + NONE => + (* the #"w" was not followed by + * an #"X" or #"x", therefore we + * return 0 *) + SOME (zero, state) + | SOME (c, state) => + (case c of + #"x" => num state + | #"X" => num state + | _ => + (* the #"w" was not followed by + * an #"X" or #"x", therefore we + * return 0 *) + SOME (zero, state))) + | _ => num state') + | #"x" => (case radix of + StringCvt.HEX => num state' + | _ => NONE) + | #"X" => (case radix of + StringCvt.HEX => num state' + | _ => NONE) + | _ => num state) + | _ => (case charToDigit c of + NONE => NONE + | SOME n => finishNum (state, fromInt n)) + end + +val fromString = StringCvt.scanString (scan StringCvt.HEX) + +end + +structure Word8 = Word (Primitive.Word8) +structure Word16 = Word (Primitive.Word16) +structure Word32 = Word (Primitive.Word32) +structure Word64 = Word (Primitive.Word64) diff --git a/basis-library/io/bin-io.sig b/basis-library/io/bin-io.sig new file mode 100644 index 0000000..451ea6d --- /dev/null +++ b/basis-library/io/bin-io.sig @@ -0,0 +1,47 @@ +signature BIN_IO = + sig + structure StreamIO: BIN_STREAM_IO + + type elem = StreamIO.elem + type instream + type outstream + type vector = StreamIO.vector + + val canInput: instream * int -> int option + val closeIn: instream -> unit + val closeOut: outstream -> unit + val endOfStream: instream -> bool + val flushOut: outstream -> unit + val getInstream: instream -> StreamIO.instream + val getOutstream: outstream -> StreamIO.outstream + val getPosOut: outstream -> StreamIO.out_pos + val input1: instream -> elem option + val input: instream -> vector + val inputAll: instream -> vector + val inputN: instream * int -> vector + val lookahead: instream -> elem option + val mkInstream: StreamIO.instream -> instream + val mkOutstream: StreamIO.outstream -> outstream + val openAppend: string -> outstream + val openIn: string -> instream + val openOut: string -> outstream + val output1: outstream * elem -> unit + val output: outstream * vector -> unit + val setInstream: (instream * StreamIO.instream) -> unit + val setOutstream: outstream * StreamIO.outstream -> unit + val setPosOut: outstream * StreamIO.out_pos -> unit + end + +signature BIN_IO_EXTRA = + sig + include BIN_IO + + val equalsIn: instream * instream -> bool + val inFd: instream -> Posix.IO.file_desc + val newIn: Posix.IO.file_desc * string -> instream + val newOut: Posix.IO.file_desc * string -> outstream + val outFd: outstream -> Posix.IO.file_desc + val stdErr: outstream + val stdIn: instream + val stdOut: outstream + end diff --git a/basis-library/io/bin-io.sml b/basis-library/io/bin-io.sml new file mode 100644 index 0000000..dc9061e --- /dev/null +++ b/basis-library/io/bin-io.sml @@ -0,0 +1,22 @@ +(* Copyright (C) 2002-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure BinIO: BIN_IO_EXTRA = + ImperativeIOExtra + (structure Array = Word8Array + structure ArraySlice = Word8ArraySlice + structure PrimIO = BinPrimIO + structure Vector = Word8Vector + structure VectorSlice = Word8VectorSlice + val chunkSize = Int32.toInt (Primitive.Controls.bufSize) + val fileTypeFlags = [PrimitiveFFI.Posix.FileSys.O.BINARY] + val line = NONE + val mkReader = Posix.IO.mkBinReader + val mkWriter = Posix.IO.mkBinWriter + val someElem = 0wx0: Word8.word + val xlatePos = SOME {fromInt = fn i => i, + toInt = fn i => i}) diff --git a/basis-library/io/bin-prim-io.sml b/basis-library/io/bin-prim-io.sml new file mode 100644 index 0000000..1a3fd72 --- /dev/null +++ b/basis-library/io/bin-prim-io.sml @@ -0,0 +1,19 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure BinPrimIO : PRIM_IO + where type array = Word8Array.array + where type vector = Word8Vector.vector + where type elem = Word8.word + where type pos = Position.int = + PrimIO (structure Vector = Word8Vector + structure VectorSlice = Word8VectorSlice + structure Array = Word8Array + structure ArraySlice = Word8ArraySlice + type pos = Position.int + val compare = Position.compare + val someElem = 0wx0: Word8.word) diff --git a/basis-library/io/bin-stream-io.sig b/basis-library/io/bin-stream-io.sig new file mode 100644 index 0000000..9e54fa1 --- /dev/null +++ b/basis-library/io/bin-stream-io.sig @@ -0,0 +1,4 @@ +signature BIN_STREAM_IO = + STREAM_IO + where type elem = Word8Vector.elem + where type vector = Word8Vector.vector diff --git a/basis-library/io/imperative-io.fun b/basis-library/io/imperative-io.fun new file mode 100644 index 0000000..d0e4c33 --- /dev/null +++ b/basis-library/io/imperative-io.fun @@ -0,0 +1,823 @@ +(* Copyright (C) 2013,2017 Matthew Fluet. + * Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature IMPERATIVE_IO_EXTRA_ARG = + sig + structure Array: sig + include MONO_ARRAY + val alloc: int -> array + val unsafeSub: array * int -> elem + end + structure ArraySlice: MONO_ARRAY_SLICE + structure PrimIO: PRIM_IO + structure Vector: sig + include MONO_VECTOR + val unsafeFromArray: Array.array -> vector + end + structure VectorSlice: MONO_VECTOR_SLICE + sharing type Array.array + = ArraySlice.array + = PrimIO.array + sharing type Array.elem + = ArraySlice.elem + = PrimIO.elem + = Vector.elem + = VectorSlice.elem + sharing type Array.vector + = ArraySlice.vector + = PrimIO.vector + = Vector.vector + = VectorSlice.vector + sharing type ArraySlice.slice + = PrimIO.array_slice + sharing type ArraySlice.vector_slice + = PrimIO.vector_slice + = VectorSlice.slice + + val chunkSize: int + val fileTypeFlags: Posix.FileSys.O.flags list + val line : {isLine: Vector.elem -> bool, + lineElem: Vector.elem} option + val mkReader: {fd: Posix.FileSys.file_desc, + name: string, + initBlkMode: bool} -> PrimIO.reader + val mkWriter: {fd: Posix.FileSys.file_desc, + name: string, + appendMode: bool, + initBlkMode: bool, + chunkSize: int} -> PrimIO.writer + val someElem: PrimIO.elem + val xlatePos : {toInt : PrimIO.pos -> Position.int, + fromInt : Position.int -> PrimIO.pos} option + end + +functor ImperativeIOExtra (S: IMPERATIVE_IO_EXTRA_ARG): IMPERATIVE_IO_EXTRA = +struct + +open S + +structure StreamIO = StreamIOExtraFile (S) + +structure PIO = PrimIO +structure SIO = StreamIO +structure A = Array +structure AS = ArraySlice +structure V = Vector +structure VS = VectorSlice + +type elem = PrimIO.elem +type vector = PrimIO.vector +type vector_slice = VS.slice + +(* ------------------------------------------------- *) +(* outstream *) +(* ------------------------------------------------- *) + +(* The following :> hides the fact that Outstream.t is an eqtype. Doing it + * here is much easier than putting :> on the functor result. + *) +structure Outstream:> + sig + type t + + val get: t -> SIO.outstream + val make: SIO.outstream -> t + val set: t * SIO.outstream -> unit + end = + struct + datatype t = T of SIO.outstream ref + + fun get (T r) = !r + fun set (T r, s) = r := s + fun make s = T (ref s) + end + +type outstream = Outstream.t +fun output (os, v) = SIO.output (Outstream.get os, v) +fun output1 (os, v) = SIO.output1 (Outstream.get os, v) +fun outputSlice (os, v) = SIO.outputSlice (Outstream.get os, v) +fun flushOut os = SIO.flushOut (Outstream.get os) +fun closeOut os = SIO.closeOut (Outstream.get os) +val mkOutstream = Outstream.make +val getOutstream = Outstream.get +val setOutstream = Outstream.set +val getPosOut = SIO.getPosOut o Outstream.get +fun setPosOut (os, outPos) = Outstream.set (os, SIO.setPosOut outPos) + +fun newOut {appendMode, bufferMode, closeAtExit, fd, name} = + let + val writer = mkWriter {appendMode = appendMode, + chunkSize = chunkSize, + fd = fd, + initBlkMode = true, + name = name} + val outstream = SIO.mkOutstream'' {bufferMode = bufferMode, + closeAtExit = closeAtExit, + closed = false, + writer = writer} + in + mkOutstream outstream + end + +structure PFS = Posix.FileSys + +val stdErr = newOut {appendMode = true, + bufferMode = IO.NO_BUF, + closeAtExit = false, + fd = PFS.stderr, + name = ""} + +val newOut = fn {appendMode, closeAtExit, fd, name} => + newOut {appendMode = appendMode, + bufferMode = if Posix.ProcEnv.isatty fd + then IO.LINE_BUF + else IO.BLOCK_BUF, + closeAtExit = closeAtExit, + fd = fd, + name = name} + +val stdOut = newOut {appendMode = true, + closeAtExit = false, + fd = PFS.stdout, + name = ""} + +val newOut = fn {appendMode, fd, name} => + newOut {appendMode = appendMode, + closeAtExit = true, + fd = fd, + name = name} + +fun 'a protect' (function: string, name: string, f: unit -> 'a): 'a = + f () handle e => raise IO.Io {cause = e, + function = function, + name = name} + +local + val readWrite = + let + open PFS.S + in + flags [irusr, iwusr, irgrp, iwgrp, iroth, iwoth] + end +in + fun openOut file = + protect' + ("openOut", file, fn () => + let + val fd = PFS.createf (file, Posix.IO.O_WRONLY, + PFS.O.flags (PFS.O.trunc::fileTypeFlags), + readWrite) + in + newOut {fd = fd, + name = file, + appendMode = false} + end) + + fun openAppend file = + protect' + ("openAppend", file, fn () => + let + val fd = PFS.createf (file, Posix.IO.O_WRONLY, + PFS.O.flags (PFS.O.append::fileTypeFlags), + readWrite) + in + newOut {fd = fd, + name = file, + appendMode = true} + end) +end + +val newOut = fn (fd, name) => newOut {fd = fd, + name = name, + appendMode = false} +val outFd = SIO.outFd o getOutstream + +(* ------------------------------------------------- *) +(* instream *) +(* ------------------------------------------------- *) + +datatype state = + Closed + | Open of {eos: bool} + | Stream of SIO.instream +(* Inv: if !first < !last then !state = Open {eos = false} + * if !state = Closed then !first = !last + * if !state = Open {eos = true} then !first = !last + *) + +datatype instream = In of {augmentedReader: PIO.reader, + buf: A.array, + first: int ref, (* index of first character *) + last: int ref, (* one past the index of the last char *) + reader: PIO.reader, + state: state ref} + +local + val augmentedReader = PIO.nullRd () + val buf = A.alloc 0 + val first = ref 0 + val last = ref 0 + val reader = PIO.nullRd () +in + fun mkInstream s = In {augmentedReader = augmentedReader, + buf = buf, + first = first, + last = last, + reader = reader, + state = ref (Stream s)} +end + +fun setInstream (In {first, last, state, ...}, s) = + (first := 0 + ; last := 0 + ; state := Stream s) + +fun equalsIn (In {first = f, ...}, In {first = f', ...}) = f = f' + +fun augmentedReaderSel (In {augmentedReader = PIO.RD v, ...}, sel) = sel v + +fun readerSel (In {reader = PIO.RD v, ...}, sel) = sel v + +fun inbufferName ib = readerSel (ib, #name) + +fun inFd ib = + case readerSel (ib, #ioDesc) of + NONE => raise IO.Io {cause = Fail "", + function = "inFd", + name = inbufferName ib} + | SOME ioDesc => valOf (Posix.FileSys.iodToFD ioDesc) + +val empty = V.tabulate (0, fn _ => someElem) + +local + fun make (sel, e: exn) ib = + case augmentedReaderSel (ib, sel) of + NONE => raise e + | SOME x => x +in + val readArr = make (#readArr, IO.BlockingNotSupported) + val readArrNB = make (#readArrNB, IO.NonblockingNotSupported) + val readVec = make (#readVec, IO.BlockingNotSupported) +end + +fun 'a protect (ib, function: string, f: unit -> 'a): 'a = + f () handle e => raise IO.Io {cause = e, + function = function, + name = inbufferName ib} + +fun update (ib as In {buf, first, last, state, ...}) = + let + val i = readArr ib (AS.full buf) + in + if i = 0 + then (state := Open {eos = true} + ; false) + else (first := 0 + ; last := i + ; true) + end + +fun input (ib as In {buf, first, last, ...}) = + let + val f = !first + val l = !last + in + if f < l + then (first := l + ; AS.vector (AS.slice (buf, f, SOME (l - f)))) + else + let + val In {state, ...} = ib + in + case !state of + Closed => empty + | Open {eos} => + if eos + then (state := Open {eos = false} + ; empty) + else protect (ib, "input", fn () => + readVec ib (augmentedReaderSel (ib, #chunkSize))) + | Stream s => + let + val (v, s') = SIO.input s + val _ = state := Stream s' + in + v + end + end + end + +(* input1 will move past a temporary end of stream *) +fun input1 (ib as In {buf, first, last, ...}) = + let + val f = !first + in + if f < !last + then (first := f + 1 + ; SOME (A.unsafeSub (buf, f))) + else + let + val In {state, ...} = ib + in + case !state of + Closed => NONE + | Open {eos} => + if eos + then + (state := Open {eos = false} + ; NONE) + else + if protect (ib, "input1", fn () => update ib) + then + (first := 1 + ; SOME (A.sub (buf, 0))) + else NONE + | Stream s => + let + val (c, s') = SIO.input1' s + val _ = state := Stream s' + in + c + end + end + end + +fun inputN (ib as In {buf, first, last, ...}, n) = + if n < 0 orelse n > V.maxLen + then raise Size + else + let + val f = !first + val l = !last + val size = l - f + in + if size >= n + then (first := f + n + ; AS.vector (AS.slice (buf, f, SOME n))) + else + let + val In {state, ...} = ib + in + case !state of + Closed => empty + | Open {eos} => + if eos + then (state := Open {eos = false} + ; empty) + else + protect + (ib, "inputN", fn () => + let + val readArr = readArr ib + val inp = A.alloc n + fun fill k = + if k >= size + then () + else (A.update (inp, k, A.sub (buf, f + k)) + ; fill (k + 1)) + val _ = fill 0 + val _ = first := l + fun loop i = + if i = n + then i + else let + val j = + readArr + (AS.slice (inp, i, SOME (n - i))) + in + if j = 0 + then (state := Open {eos = true}; i) + else loop (i + j) + end + val i = loop size + in + if i = n + then V.unsafeFromArray inp + else AS.vector (AS.slice (inp, 0, SOME i)) + end) + | Stream s => + let + val (v, s') = SIO.inputN (s, n) + val _ = state := Stream s' + in + v + end + end + end + +fun inputAll (ib as In {state, ...}) = + case !state of + Closed => empty + | Open {eos} => + if eos + then (state := Open {eos = false} + ; empty) + else + protect + (ib, "inputAll", fn () => + let + val In {buf, first, last, ...} = ib + val readVec = readVec ib + val f = !first + val l = !last + val inp = AS.vector (AS.slice (buf, f, SOME (l - f))) + val inps = [inp] + fun loop inps = + let + val inp = + readVec (augmentedReaderSel (ib, #chunkSize)) + in + if V.length inp = 0 + then V.concat (List.rev inps) + else loop (inp :: inps) + end + in + loop inps + end) + | Stream s => + let + val (v, s') = SIO.inputAll s + val _ = state := Stream s' + in + v + end + +val inputLine = + case line of + NONE => (fn ib => SOME (input ib)) + | SOME {isLine, lineElem} => + let + val lineVec = V.tabulate (1, fn _ => lineElem) + in + fn (ib as In {state, ...}) => + case !state of + Closed => NONE + | Open {eos} => + if eos + then NONE + else + protect + (ib, "inputLine", fn () => + let + val In {buf, first, last, ...} = ib + fun finish (inps, trail) = + let + val inps = if trail + then lineVec :: inps + else inps + val inp = V.concat (List.rev inps) + in + SOME inp + end + fun loop inps = + if !first < !last orelse update ib + then + let + val f = !first + val l = !last + (* !first < !last *) + fun loop' i = (* pre: !first <= i <= !last *) + let + fun done j = (* pre: !first < j <= !last *) + let + val inp = AS.vector (AS.slice (buf, f, SOME (j - f))) + in + first := j; + inp::inps + end + in + if i >= l + then loop (done i) + else if isLine (A.sub (buf, i)) + then finish (done (i + 1), false) + else loop' (i + 1) + end + in + loop' f + end + else (case inps of + [] => NONE + | _ => finish (inps, true)) + in + loop [] + end) + | Stream s => + Option.map + (fn (v, s') => (state := Stream s'; v)) + (SIO.inputLine s) + end + +fun canInput (ib as In {state, ...}, n) = + if n < 0 orelse n > V.maxLen + then raise Size + else + case !state of + Closed => SOME 0 + | Open {eos} => + if eos + then SOME 0 + else + protect + (ib, "canInput", fn () => + let + val readArrNB = readArrNB ib + val In {buf, first, last, ...} = ib + val f = !first + val l = !last + val read = l - f + val _ = + if f > 0 + then + (AS.copy {di = 0, + dst = buf, + src = AS.slice (buf, f, SOME read)} + ; first := 0) + else () + val size = A.length buf + (* 0 = !first *) + fun loop read = + if read = size + then {read = read, eos = false} + else + let + val slice = AS.slice (buf, read, NONE) + val i = readArrNB slice + in + case i of + NONE => {read = read, eos = false} + | SOME i => + if 0 = i + then {read = read, eos = true} + else loop (read + i) + end + val {read, eos} = loop read + val _ = last := read + in + if read > 0 + then SOME (Int.min (n, read)) + else if eos + then (state := Open {eos = true}; SOME 0) + else NONE + end) + | Stream s => SIO.canInput (s, n) + +fun lookahead (ib as In {buf, first, last, ...}) = + let + val f = !first + val l = !last + in + if f < l + then SOME (A.unsafeSub (buf, f)) + else + let + val In {state, ...} = ib + in + case !state of + Closed => NONE + | Open {eos, ...} => + if eos + then NONE + else if protect (ib, "lookahead", fn () => update ib) + then SOME (A.sub (buf, 0)) + else NONE + | Stream s => Option.map #1 (SIO.input1 s) + end + end + +fun closeIn (ib as In {first, last, state, ...}) = + case !state of + Closed => () + | Open _ => + (first := !last + ; state := Closed + ; protect (ib, "closeIn", fn () => readerSel (ib, #close) ())) + | Stream s => SIO.closeIn s + +fun endOfStream (ib as In {first, last, state, ...}) = + !first = !last + andalso + (case !state of + Closed => true + | Open {eos, ...} => + eos orelse not (protect (ib, "endOfStream", fn () => update ib)) + | Stream s => SIO.endOfStream s) + +fun mkInbuffer' {reader, closed, bufferContents} = + let + val (state, first, last, buf) = + if closed + then (ref Closed, ref 0, ref 0, Array.array (0, someElem)) + else let + val PIO.RD {chunkSize, ...} = reader + val buf = Array.array (chunkSize, someElem) + val first = ref 0 + val (state, last) = + case bufferContents of + NONE => (ref (Open {eos = false}), ref 0) + | SOME v => + if V.length v = 0 + then (ref (Open {eos = true}), ref 0) + else (V.appi (fn (i, c) => A.update (buf, i, c)) v + ; (ref (Open {eos = false}), ref (V.length v))) + in + (state, first, last, buf) + end + in + In {augmentedReader = PIO.augmentReader reader, + buf = buf, + first = first, + last = last, + reader = reader, + state = state} + end + +fun openVector v = + mkInbuffer' {bufferContents = NONE, + closed = false, + reader = PIO.openVector v} + +val openInbuffers : (instream * {close: bool}) list ref = ref [] + +fun getInstream (ib as In {state, ...}) = + let + fun doit (closed: bool, bufferContents) = + let + val In {reader, ...} = ib + val (ibs, openInbuffers') = + List.partition (fn (ib', _) => equalsIn (ib, ib')) + (!openInbuffers) + val _ = openInbuffers := openInbuffers' + val closeAtExit = + List.foldr (fn ((_, {close = close'}), close) => + close orelse close') + false ibs + in + SIO.mkInstream'' {bufferContents = bufferContents, + closeAtExit = closeAtExit, + closed = closed, + reader = reader} + end + in + case !state of + Closed => doit (true, NONE) + | Open {eos} => + if eos + then doit (false, SOME (true, empty)) + else + let + val In {buf, first, last, ...} = ib + val f = !first + val l = !last + val s = + if f < l + then + doit (false, + SOME (true, + AS.vector (AS.slice (buf, f, + SOME (l - f))))) + else doit (false, NONE) + val () = state := Stream s + in + s + end + | Stream s => s + end + +val mkInbuffer'' = + let + val _ = + Cleaner.addNew + (Cleaner.atExit, fn () => + List.app (fn (ib, {close}) => if close then closeIn ib else ()) + (!openInbuffers)) + in + fn {bufferContents, closeAtExit, closed, reader} => + let + val ib = mkInbuffer' {bufferContents = bufferContents, + closed = closed, + reader = reader} + val _ = if closed + then () + else openInbuffers := ((ib, {close = closeAtExit}) + :: (!openInbuffers)) + in + ib + end + end + +fun scanStream f is = + case f SIO.input1 (getInstream is) of + NONE => NONE + | SOME (v, s') => (setInstream (is, s'); SOME v) + +val closeIn = fn ib => + let + val _ = openInbuffers := List.filter (fn (ib',_) => + not (equalsIn (ib, ib'))) + (!openInbuffers) + in + closeIn ib + end + +fun newIn {bufferContents, closeAtExit, fd, name} = + let + val reader = mkReader {fd = fd, initBlkMode = true, name = name} + in + mkInbuffer'' {bufferContents = bufferContents, + closeAtExit = closeAtExit, + closed = false, + reader = reader} + end + +val newIn = fn (fd, name) => + newIn {bufferContents = NONE, + closeAtExit = true, + fd = fd, + name = name} + +val stdIn = newIn (PFS.stdin, "") + +fun openIn file = + protect' + ("openIn", file, fn () => + let + val fd = PFS.openf (file, Posix.IO.O_RDONLY, PFS.O.flags fileTypeFlags) + in + newIn (fd, file) + end) + +end + +signature IMPERATIVE_IO_ARG = + sig + structure Array: MONO_ARRAY +(* structure ArraySlice: MONO_ARRAY_SLICE *) + structure StreamIO: STREAM_IO + structure Vector: MONO_VECTOR +(* structure VectorSlice: MONO_VECTOR_SLICE *) +(* sharing type Array.array = ArraySlice.array *) + sharing type + Array.elem +(* = ArraySlice.elem *) + = StreamIO.elem + = Vector.elem +(* = VectorSlice.elem *) + sharing type + Array.vector +(* = ArraySlice.vector *) + = Vector.vector +(* = VectorSlice.vector *) +(* sharing type ArraySlice.vector_slice = VectorSlice.slice *) + end + +functor ImperativeIO (S: IMPERATIVE_IO_ARG): IMPERATIVE_IO = + struct + open S + + structure SIO = StreamIO + + type elem = SIO.elem + type vector = SIO.vector + + datatype outstream = Out of SIO.outstream ref + + fun output (Out os, v) = SIO.output (!os, v) + fun output1 (Out os, v) = SIO.output1 (!os, v) + fun flushOut (Out os) = SIO.flushOut (!os) + fun closeOut (Out os) = SIO.closeOut (!os) + fun mkOutstream os = Out (ref os) + fun getOutstream (Out os) = !os + fun setOutstream (Out os, os') = os := os' + fun getPosOut (Out os) = SIO.getPosOut (!os) + fun setPosOut (Out os, out_pos) = os := SIO.setPosOut out_pos + + datatype instream = In of SIO.instream ref + + fun canInput (In is, n) = SIO.canInput (!is, n) + fun closeIn (In is) = SIO.closeIn (!is) + fun endOfStream (In is) = SIO.endOfStream (!is) + fun getInstream (In is) = !is + fun input (In is) = let val (v, is') = SIO.input (!is) + in is := is'; v + end + (* input1 will never move past a temporary end of stream *) + fun input1 (In is) = + case SIO.input1 (!is) of + SOME (c,is') => (is := is'; SOME c) + | NONE => NONE + fun inputAll (In is) = let val (v, is') = SIO.inputAll (!is) + in is := is'; v + end + fun inputN (In is, n) = let val (v, is') = SIO.inputN (!is, n) + in is := is'; v + end + fun lookahead (In is) = + Option.map #1 (SIO.input1 (!is)) + fun mkInstream is = In (ref is) + fun setInstream (In is, is') = is := is' + end diff --git a/basis-library/io/imperative-io.sig b/basis-library/io/imperative-io.sig new file mode 100644 index 0000000..412da3e --- /dev/null +++ b/basis-library/io/imperative-io.sig @@ -0,0 +1,80 @@ +signature IMPERATIVE_IO = + sig + structure StreamIO: STREAM_IO + + type elem = StreamIO.elem + type vector = StreamIO.vector + type instream + type outstream + + val canInput: instream * int -> int option + val closeIn: instream -> unit + val closeOut: outstream -> unit + val endOfStream: instream -> bool + val flushOut: outstream -> unit + val getInstream: instream -> StreamIO.instream + val getOutstream: outstream -> StreamIO.outstream + val getPosOut: outstream -> StreamIO.out_pos + val input1: instream -> elem option + val input: instream -> vector + val inputAll: instream -> vector + val inputN: instream * int -> vector + val lookahead: instream -> elem option + val mkInstream: StreamIO.instream -> instream + val mkOutstream: StreamIO.outstream -> outstream + val output1: outstream * elem -> unit + val output: outstream * vector -> unit + val setInstream: instream * StreamIO.instream -> unit + val setOutstream: outstream * StreamIO.outstream -> unit + val setPosOut: outstream * StreamIO.out_pos -> unit + end + +signature IMPERATIVE_IO_EXTRA = + sig + structure StreamIO: STREAM_IO_EXTRA + + type elem = StreamIO.elem + type instream + type outstream + type vector = StreamIO.vector + type vector_slice = StreamIO.vector_slice + + val canInput: instream * int -> int option + val closeIn: instream -> unit + val closeOut: outstream -> unit + val endOfStream: instream -> bool + val equalsIn: instream * instream -> bool + val flushOut: outstream -> unit + val getInstream: instream -> StreamIO.instream + val getOutstream: outstream -> StreamIO.outstream + val getPosOut: outstream -> StreamIO.out_pos + val inFd: instream -> Posix.IO.file_desc + val input1: instream -> elem option + val input: instream -> vector + val inputAll: instream -> vector + val inputLine: instream -> vector option + val inputN: instream * int -> vector + val lookahead: instream -> elem option + val mkInstream: StreamIO.instream -> instream + val mkOutstream: StreamIO.outstream -> outstream + val newIn: Posix.IO.file_desc * string -> instream + val newOut: Posix.IO.file_desc * string -> outstream + val openAppend: string -> outstream + val openIn: string -> instream + val openOut: string -> outstream + val openVector: vector -> instream + val outFd: outstream -> Posix.IO.file_desc + val output1: outstream * elem -> unit + val output: outstream * vector -> unit + val outputSlice: outstream * vector_slice -> unit + val scanStream: + ((elem, StreamIO.instream) StringCvt.reader + -> ('a, StreamIO.instream) StringCvt.reader) + -> instream -> 'a option + val setInstream: instream * StreamIO.instream -> unit + val setOutstream: outstream * StreamIO.outstream -> unit + val setPosOut: outstream * StreamIO.out_pos -> unit + val stdErr: outstream + val stdIn: instream + val stdOut: outstream + end diff --git a/basis-library/io/io.sig b/basis-library/io/io.sig new file mode 100644 index 0000000..c06fa5e --- /dev/null +++ b/basis-library/io/io.sig @@ -0,0 +1,19 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature IO = + sig + exception Io of {name : string, + function : string, + cause : exn} + exception BlockingNotSupported + exception NonblockingNotSupported + exception RandomAccessNotSupported + exception ClosedStream + datatype buffer_mode = NO_BUF | LINE_BUF | BLOCK_BUF + end diff --git a/basis-library/io/io.sml b/basis-library/io/io.sml new file mode 100644 index 0000000..3d9e77d --- /dev/null +++ b/basis-library/io/io.sml @@ -0,0 +1,33 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure IO: IO = + struct + exception BlockingNotSupported + + exception ClosedStream + + exception Io of {cause : exn, + function : string, + name : string} + + val _ = + General.addExnMessager + (fn e => + case e of + Io {cause, function, name, ...} => + SOME (concat ["Io: ", function, " \"", name, "\" failed with ", + exnMessage cause]) + | _ => NONE) + + exception NonblockingNotSupported + + exception RandomAccessNotSupported + + datatype buffer_mode = NO_BUF | LINE_BUF | BLOCK_BUF + end diff --git a/basis-library/io/prim-io.fun b/basis-library/io/prim-io.fun new file mode 100644 index 0000000..edcdcb4 --- /dev/null +++ b/basis-library/io/prim-io.fun @@ -0,0 +1,323 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature PRIM_IO_ARG = + sig + structure Vector: MONO_VECTOR + structure VectorSlice: MONO_VECTOR_SLICE + structure Array: MONO_ARRAY + structure ArraySlice: MONO_ARRAY_SLICE + sharing type Vector.elem = VectorSlice.elem + = Array.elem = ArraySlice.elem + sharing type Vector.vector = VectorSlice.vector + = Array.vector = ArraySlice.vector + sharing type VectorSlice.slice = ArraySlice.vector_slice + sharing type Array.array = ArraySlice.array + + val someElem: Vector.elem + + eqtype pos + val compare: pos * pos -> order + end + +functor PrimIO (S: PRIM_IO_ARG): PRIM_IO = + struct + open S + + structure V = Vector + structure VS = VectorSlice + structure A = Array + structure AS = ArraySlice + + type elem = A.elem + type vector = V.vector + type vector_slice = VS.slice + type array = A.array + type array_slice = AS.slice + type pos = pos + val compare = compare + + datatype reader = + RD of {avail: unit -> int option, + block: (unit -> unit) option, + canInput: (unit -> bool) option, + chunkSize: int, + close: unit -> unit, + endPos: (unit -> pos) option, + getPos: (unit -> pos) option, + ioDesc: OS.IO.iodesc option, + name: string, + readArr: (array_slice -> int) option, + readArrNB: (array_slice -> int option) option, + readVec: (int -> vector) option, + readVecNB: (int -> vector option) option, + setPos: (pos -> unit) option, + verifyPos: (unit -> pos) option} + + datatype writer = + WR of {block: (unit -> unit) option, + canOutput: (unit -> bool) option, + chunkSize: int, + close: unit -> unit, + endPos: (unit -> pos) option, + getPos: (unit -> pos) option, + ioDesc: OS.IO.iodesc option, + name: string, + setPos: (pos -> unit) option, + verifyPos: (unit -> pos) option, + writeArr: (array_slice -> int) option, + writeArrNB: (array_slice -> int option) option, + writeVec: (vector_slice -> int) option, + writeVecNB: (vector_slice -> int option) option} + + + fun liftExn name function cause = raise IO.Io {name = name, + function = function, + cause = cause} + + fun openVector v = + let + val name = "openVector" + val closed = ref false + val pos = ref 0 + val eofPos = V.length v + fun check f = if !closed + then liftExn name f IO.ClosedStream + else () + fun const f c = fn _ => (check f; c) + fun readVec f i = + let + val _ = check f + val n = Int.min (i, eofPos - !pos) + in + VS.vector (VS.slice (v, !pos, SOME n)) before (pos := !pos + n) + end + fun readArr f sl = + let + val _ = check f + val (buf, i, sz) = AS.base sl + val n = Int.min (sz, eofPos - !pos) + in + AS.copyVec {src = VS.slice (v, !pos, SOME n), + dst = buf, + di = i}; + pos := !pos + n; + n + end + in + RD {avail = const "avail" NONE, + block = SOME (const "block" ()), + canInput = SOME (const "canInput" true), + chunkSize = 32, + close = fn () => (closed := true), + endPos = NONE, + getPos = NONE, + ioDesc = NONE, + name = name, + readArr = SOME (readArr "readArr"), + readArrNB = SOME (SOME o (readArr "readVecNB")), + readVec = SOME (readVec "readVec"), + readVecNB = SOME (SOME o (readVec "readVecNB")), + setPos = NONE, + verifyPos = NONE} + end + + fun nullRd () = + let + val name = "nullRd" + val closed = ref false + fun check f = if !closed + then liftExn name f IO.ClosedStream + else () + fun const f c = fn _ => (check f; c) + val empty = V.fromList [] + in + RD {avail = const "avail" NONE, + block = SOME (const "block" ()), + canInput = SOME (const "canInput" true), + chunkSize = 1, + close = fn () => (closed := true), + endPos = NONE, + getPos = NONE, + ioDesc = NONE, + name = name, + readArr = SOME (const "readArr" 0), + readArrNB = SOME (const "readArrNB" (SOME 0)), + readVec = SOME (const "readVec" empty), + readVecNB = SOME (const "readVecNB" (SOME empty)), + setPos = NONE, + verifyPos = NONE} + end + + fun nullWr () = + let + val name = "nullWr" + val closed = ref false + fun check f = if !closed + then liftExn name f IO.ClosedStream + else () + fun const f c = fn _ => (check f; c) + fun function f g = fn x => (check f; g x) + in + WR {block = SOME (const "block" ()), + canOutput = SOME (const "canOutput" true), + chunkSize = 1, + close = fn () => (closed := true), + endPos = NONE, + getPos = NONE, + ioDesc = NONE, + name = name, + setPos = NONE, + verifyPos = NONE, + writeArr = SOME (function "writeArr" AS.length), + writeArrNB = SOME (function "writeArrNB" (SOME o AS.length)), + writeVec = SOME (function "writeVec" VS.length), + writeVecNB = SOME (function "writeVecNB" (SOME o VS.length))} + end + + fun doBlock (f, block: unit -> unit) x = (block (); valOf (f x)) + fun doCanInput (f, canInput) x = if canInput () + then SOME (f x) + else NONE + + fun augmentReader (RD {name, chunkSize, + readVec, readArr, readVecNB, readArrNB, + block, canInput, avail, + getPos, setPos, endPos, verifyPos, + close, ioDesc}) = + let + fun augmentRead (readVec, readArr) = + case (readVec, readArr) of + (SOME readVec, SOME readArr) => (SOME readVec, SOME readArr) + | (NONE, SOME readArr) => + (SOME (fn i => + let + val buf = A.array (i, someElem) + fun first j = AS.slice (buf, 0, SOME j) + in + (AS.vector o first) (readArr (first i)) + end), + SOME readArr) + | (SOME readVec, NONE) => + (SOME readVec, + SOME (fn sl => + let + val (buf, i, sz) = AS.base sl + val v = readVec sz + val _ = A.copyVec {src = v, dst = buf, di = i} + in + V.length v + end)) + | (NONE, NONE) => (NONE, NONE) + fun augmentReadNB (readVecNB, readArrNB) = + case (readVecNB, readArrNB) of + (SOME readVecNB, SOME readArrNB) => (SOME readVecNB, SOME readArrNB) + | (NONE, SOME readArrNB) => + (SOME (fn i => + let + val buf = A.array (i, someElem) + fun first j = AS.slice (buf, 0, SOME j) + in + Option.map (AS.vector o first) (readArrNB (first i)) + end), + SOME readArrNB) + | (SOME readVecNB, NONE) => + (SOME readVecNB, + SOME (fn sl => + let + val (buf, i, sz) = AS.base sl + in + case readVecNB sz of + NONE => NONE + | SOME v => (A.copyVec {src = v, dst = buf, di = i} + ; SOME (V.length v)) + end)) + | (NONE, NONE) => (NONE, NONE) + fun augmentSeq (readSeq, readSeqNB) = + case (readSeq, readSeqNB) of + (SOME readSeq, SOME readSeqNB) => (SOME readSeq, SOME readSeqNB) + | (NONE, SOME readSeqNB) => + (case block of + NONE => NONE + | SOME block => SOME (doBlock (readSeqNB, block)), + SOME readSeqNB) + | (SOME readSeq, NONE) => + (SOME readSeq, + case canInput of + NONE => NONE + | SOME canInput => SOME (doCanInput (readSeq, canInput))) + | (NONE, NONE) => (NONE, NONE) + + val ((readVec,readArr),(readVecNB,readArrNB)) = + (augmentRead (readVec, readArr), + augmentReadNB (readVecNB, readArrNB)) + val ((readVec,readVecNB),(readArr,readArrNB)) = + (augmentSeq (readVec, readVecNB), + augmentSeq (readArr, readArrNB)) + in + RD {name = name, chunkSize = chunkSize, + readVec = readVec, readArr = readArr, + readVecNB = readVecNB, readArrNB = readArrNB, + block = block, canInput = canInput, avail = avail, + getPos = getPos, setPos = setPos, + endPos = endPos, verifyPos = verifyPos, + close = close, ioDesc = ioDesc} + end + + fun augmentWriter (WR {name, chunkSize, + writeVec, writeArr, writeVecNB, writeArrNB, + block, canOutput, + getPos, setPos, endPos, verifyPos, + close, ioDesc}) = + let + fun augmentWrite (writeVec, writeArr) = + case (writeVec, writeArr) of + (SOME writeVec, SOME writeArr) => (SOME writeVec, SOME writeArr) + | (NONE, SOME writeArr) => + (SOME (fn sl => + writeArr + (AS.full + (A.tabulate (VS.length sl, fn i => VS.sub (sl, i))))), + SOME writeArr) + | (SOME writeVec, NONE) => + (SOME writeVec, + SOME (fn sl => writeVec (VS.full (AS.vector sl)))) + | (NONE, NONE) => (NONE, NONE) + fun augmentSeq (writeSeq, writeSeqNB) = + case (writeSeq, writeSeqNB) of + (SOME writeSeq, SOME writeSeqNB) => (SOME writeSeq, SOME writeSeqNB) + | (NONE, SOME writeSeqNB) => + (case block of + NONE => NONE + | SOME block => SOME (fn x => (block (); + valOf (writeSeqNB x))), + SOME writeSeqNB) + | (SOME writeSeq, NONE) => + (SOME writeSeq, + case canOutput of + NONE => NONE + | SOME canOutput => SOME (fn x => (if canOutput () + then SOME (writeSeq x) + else NONE))) + | (NONE, NONE) => (NONE, NONE) + + val ((writeVec,writeArr),(writeVecNB,writeArrNB)) = + (augmentWrite (writeVec, writeArr), + augmentWrite (writeVecNB, writeArrNB)) + val ((writeVec,writeVecNB),(writeArr,writeArrNB)) = + (augmentSeq (writeVec, writeVecNB), + augmentSeq (writeArr, writeArrNB)) + in + WR {name = name, chunkSize = chunkSize, + writeVec = writeVec, writeArr = writeArr, + writeVecNB = writeVecNB, writeArrNB = writeArrNB, + block = block, canOutput = canOutput, + getPos = getPos, setPos = setPos, + endPos = endPos, verifyPos = verifyPos, + close = close, ioDesc = ioDesc} + end + end diff --git a/basis-library/io/prim-io.sig b/basis-library/io/prim-io.sig new file mode 100644 index 0000000..41e0435 --- /dev/null +++ b/basis-library/io/prim-io.sig @@ -0,0 +1,58 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature PRIM_IO = + sig + type elem + type vector + type vector_slice + type array + type array_slice + + eqtype pos + val compare: pos * pos -> order + + datatype reader = + RD of {avail: unit -> int option, + block: (unit -> unit) option, + canInput: (unit -> bool) option, + chunkSize: int, + close: unit -> unit, + endPos: (unit -> pos) option, + getPos: (unit -> pos) option, + ioDesc: OS.IO.iodesc option, + name: string, + readArr: (array_slice -> int) option, + readArrNB: (array_slice -> int option) option, + readVec: (int -> vector) option, + readVecNB: (int -> vector option) option, + setPos: (pos -> unit) option, + verifyPos: (unit -> pos) option} + + datatype writer = + WR of {block: (unit -> unit) option, + canOutput: (unit -> bool) option, + chunkSize: int, + close: unit -> unit, + endPos: (unit -> pos) option, + getPos: (unit -> pos) option, + ioDesc: OS.IO.iodesc option, + name: string, + setPos: (pos -> unit) option, + verifyPos: (unit -> pos) option, + writeArr: (array_slice -> int) option, + writeArrNB: (array_slice -> int option) option, + writeVec: (vector_slice -> int) option, + writeVecNB: (vector_slice -> int option) option} + + val openVector: vector -> reader + val nullRd: unit -> reader + val nullWr: unit -> writer + + val augmentReader: reader -> reader + val augmentWriter: writer -> writer + end diff --git a/basis-library/io/stream-io.fun b/basis-library/io/stream-io.fun new file mode 100644 index 0000000..d2172b9 --- /dev/null +++ b/basis-library/io/stream-io.fun @@ -0,0 +1,961 @@ +(* Copyright (C) 2013 Matthew Fluet. + * Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature STREAM_IO_EXTRA_ARG = + sig + structure Array: MONO_ARRAY + structure ArraySlice: MONO_ARRAY_SLICE + structure PrimIO: PRIM_IO + structure Vector: MONO_VECTOR + structure VectorSlice: MONO_VECTOR_SLICE + sharing type PrimIO.elem + = Vector.elem = VectorSlice.elem + = Array.elem = ArraySlice.elem + sharing type PrimIO.vector + = Vector.vector = VectorSlice.vector + = Array.vector = ArraySlice.vector + sharing type PrimIO.vector_slice + = VectorSlice.slice + = ArraySlice.vector_slice + sharing type PrimIO.array + = Array.array = ArraySlice.array + sharing type PrimIO.array_slice + = ArraySlice.slice + + val line: {isLine: PrimIO.elem -> bool, + lineElem: PrimIO.elem} option + val someElem: PrimIO.elem + val xlatePos : {toInt : PrimIO.pos -> Position.int, + fromInt : Position.int -> PrimIO.pos} option + end + +functor StreamIOExtra (S: STREAM_IO_EXTRA_ARG): STREAM_IO_EXTRA = + struct + open S + + structure PIO = PrimIO + structure A = Array + structure AS = ArraySlice + structure V = struct + open Vector + val extract : vector * int * int option -> vector + = VectorSlice.vector o VectorSlice.slice + end + structure VS = VectorSlice + + type elem = PIO.elem + type vector = PIO.vector + type vector_slice = PIO.vector_slice + type reader = PIO.reader + type writer = PIO.writer + type pos = PIO.pos + + fun liftExn name function cause = raise IO.Io {name = name, + function = function, + cause = cause} + + (*---------------*) + (* outstream *) + (*---------------*) + + datatype buf = Buf of {array: A.array, + size: int ref} + datatype bufferMode = NO_BUF + | LINE_BUF of buf + | BLOCK_BUF of buf + fun newLineBuf bufSize = + LINE_BUF (Buf {size = ref 0, + array = A.array (bufSize, someElem)}) + fun newBlockBuf bufSize = + BLOCK_BUF (Buf {size = ref 0, + array = A.array (bufSize, someElem)}) + + datatype state = Active | Terminated | Closed + fun active state = case state of Active => true | _ => false + fun terminated state = not (active state) + fun closed state = case state of Closed => true | _ => false + + datatype outstream = Out of {writer: writer, + augmented_writer: writer, + state: state ref, + bufferMode: bufferMode ref} + + fun equalsOut (Out {state = state1, ...}, Out {state = state2, ...}) = + state1 = state2 + + fun outstreamSel (Out v, sel) = sel v + fun outstreamWriter os = outstreamSel (os, #writer) + fun writerSel (PIO.WR v, sel) = sel v + fun outstreamName os = writerSel (outstreamWriter os, #name) + + local + fun flushGen (write: 'a -> int, + base: 'a -> ('b * int * int), + slice: ('b * int * int option) -> 'a, + a: 'a) = + let + val (b, i, sz) = base a + val max = i + sz + fun loop i = + if i = max + then () + else let + val j = write (slice (b, i, SOME (max - i))) + in + if j = 0 + then raise (Fail "partial write") + else loop (i + j) + end + in + loop i + end + in + fun flushVec (writer, x) = + case writerSel (writer, #writeVec) of + NONE => raise IO.BlockingNotSupported + | SOME writeVec => flushGen (writeVec, VS.base, VS.slice, x) + + fun flushArr (writer, x) = + case writerSel (writer, #writeArr) of + NONE => raise IO.BlockingNotSupported + | SOME writeArr => flushGen (writeArr, AS.base, AS.slice, x) + end + + fun flushBuf' (writer, size, array) = + let + val size' = !size + in + size := 0 + ; flushArr (writer, AS.slice (array, 0, SOME size')) + end + + fun flushBuf (writer, Buf {size, array}) = flushBuf' (writer, size, array) + + fun output (os as Out {augmented_writer, + state, + bufferMode, ...}, v) = + if terminated (!state) + then liftExn (outstreamName os) "output" IO.ClosedStream + else let + fun put () = flushVec (augmented_writer, VS.full v) + fun doit (buf as Buf {size, array}, maybe) = + let + val curSize = !size + val newSize = curSize + V.length v + in + if newSize >= A.length array orelse maybe () + then (flushBuf (augmented_writer, buf); put ()) + else (A.copyVec {src = v, dst = array, di = curSize}; + size := newSize) + end + in + case !bufferMode of + NO_BUF => put () + | LINE_BUF buf => doit (buf, fn () => (case line of + NONE => false + | SOME {isLine, lineElem} => V.exists isLine v)) + | BLOCK_BUF buf => doit (buf, fn () => false) + end + handle exn => liftExn (outstreamName os) "output" exn + + fun ensureActive (os as Out {state, ...}) = + if active (!state) + then () + else liftExn (outstreamName os) "output" IO.ClosedStream + + local + val buf1 = A.array (1, someElem) + fun flush (os, size, array) = + let + val Out {augmented_writer, ...} = os + in + flushBuf' (augmented_writer, size, array) + handle exn => liftExn (outstreamName os) "output1" exn + end + in + (* output1 is implemented very carefully to make it fast. Think hard + * before modifying it, and test after you do, to make sure that it + * hasn't been slowed down. + *) + fun output1 (os as Out {bufferMode, ...}, c): unit = + case !bufferMode of + BLOCK_BUF (Buf {array, size}) => + let + val n = !size + in + (* Use the bounds check for the update to make sure there + * is space to put the character in the array. + *) + (A.update (array, n, c) + ; size := 1 + n) + handle Subscript => + let + val _ = ensureActive os + val _ = flush (os, size, array) + val _ = A.update (array, 0, c) + val _ = size := 1 + in + () + end + end + | LINE_BUF (Buf {array, size}) => + let + val n = !size + val _ = + (* Use the bounds check for the update to make sure there + * is space to put the character in the array. + *) + (A.update (array, n, c) + ; size := 1 + n) + handle Subscript => + let + val _ = ensureActive os + val _ = flush (os, size, array) + val _ = A.update (array, 0, c) + val _ = size := 1 + in + () + end + in + case line of + NONE => () + | SOME {isLine, lineElem} => + if isLine c then flush (os, size, array) else () + end + | NO_BUF => + let + val _ = ensureActive os + val _ = A.update (buf1, 0, c) + val Out {augmented_writer, ...} = os + in + flushArr (augmented_writer, AS.slice (buf1, 0, SOME 1)) + end + end + + fun outputSlice (os as Out {augmented_writer, + state, + bufferMode, ...}, v) = + if terminated (!state) + then liftExn (outstreamName os) "output" IO.ClosedStream + else let + fun put () = flushVec (augmented_writer, v) + fun doit (buf as Buf {size, array}, maybe) = + let + val curSize = !size + val newSize = curSize + VS.length v + in + if newSize >= A.length array orelse maybe () + then (flushBuf (augmented_writer, buf); put ()) + else (AS.copyVec {src = v, dst = array, di = curSize}; + size := newSize) + end + in + case !bufferMode of + NO_BUF => put () + | LINE_BUF buf => doit (buf, fn () => (case line of + NONE => false + | SOME {isLine, lineElem} => VS.exists isLine v)) + | BLOCK_BUF buf => doit (buf, fn () => false) + end + handle exn => liftExn (outstreamName os) "output" exn + + fun flushOut (os as Out {augmented_writer, + state, + bufferMode, ...}) = + if terminated (!state) + then () + else case !bufferMode of + NO_BUF => () + | LINE_BUF buf => flushBuf (augmented_writer, buf) + | BLOCK_BUF buf => flushBuf (augmented_writer, buf) + handle exn => liftExn (outstreamName os) "flushOut" exn + + fun makeTerminated (Out {bufferMode, ...}) = + let + fun doit (Buf {array, size}) = size := A.length array + in + case !bufferMode of + BLOCK_BUF b => doit b + | LINE_BUF b => doit b + | NO_BUF => () + end + + fun closeOut (os as Out {state, ...}) = + if closed (!state) + then () + else (flushOut os; + if terminated (!state) + then () + else (writerSel (outstreamWriter os, #close)) (); + state := Closed + ; makeTerminated os) + handle exn => liftExn (outstreamName os) "closeOut" exn + + fun getBufferMode (Out {bufferMode, ...}) = + case !bufferMode of + NO_BUF => IO.NO_BUF + | LINE_BUF _ => IO.LINE_BUF + | BLOCK_BUF _ => IO.BLOCK_BUF + + fun setBufferMode (os as Out {bufferMode, ...}, mode) = + case mode of + IO.NO_BUF => (flushOut os; + bufferMode := NO_BUF) + | IO.LINE_BUF => let + fun doit () = + bufferMode := + newLineBuf (writerSel (outstreamWriter os, #chunkSize)) + in + case !bufferMode of + NO_BUF => doit () + | LINE_BUF _ => () + | BLOCK_BUF _ => doit () + end + | IO.BLOCK_BUF => let + fun doit () = + bufferMode := + newBlockBuf (writerSel (outstreamWriter os, #chunkSize)) + in + case !bufferMode of + NO_BUF => doit () + | LINE_BUF _ => doit () + | BLOCK_BUF _ => () + end + + fun mkOutstream' {writer, closed, bufferMode} = + let + val bufSize = writerSel (writer, #chunkSize) + in + Out {writer = writer, + augmented_writer = PIO.augmentWriter writer, + state = ref (if closed then Closed else Active), + bufferMode = ref (case bufferMode of + IO.NO_BUF => NO_BUF + | IO.LINE_BUF => newLineBuf bufSize + | IO.BLOCK_BUF => newBlockBuf bufSize)} + end + fun mkOutstream (writer, bufferMode) = + mkOutstream' {writer = writer, closed = false, bufferMode = bufferMode} + + fun getWriter (os as Out {writer, state, bufferMode, ...}) = + if closed (!state) + then liftExn (outstreamName os) "getWriter" IO.ClosedStream + else (flushOut os + ; state := Terminated + ; makeTerminated os + ; (writer, + case !bufferMode of + NO_BUF => IO.NO_BUF + | LINE_BUF _ => IO.LINE_BUF + | BLOCK_BUF _ => IO.BLOCK_BUF)) + + datatype out_pos = OutPos of {pos: pos, + outstream: outstream} + + fun getPosOut (os as Out {...}) = + (flushOut os; + case writerSel (outstreamSel (os, #writer), #getPos) of + NONE => liftExn (outstreamName os) "getPosOut" IO.RandomAccessNotSupported + | SOME getPos => OutPos {pos = getPos (), + outstream = os}) + + fun setPosOut (OutPos {pos, outstream = os}) = + (flushOut os; + case writerSel (outstreamSel (os, #writer), #setPos) of + NONE => liftExn (outstreamName os) "setPosOut" IO.RandomAccessNotSupported + | SOME setPos => setPos pos; + os) + + fun filePosOut (OutPos {pos, ...}) = pos + + (*---------------*) + (* instream *) + (*---------------*) + + datatype state = Link of {buf: buf} + | Eos of {buf: buf} (* V.length inp = 0 *) + | End + | Truncated + | Closed + and buf = Buf of {inp: V.vector, + base: pos option, + next: state ref} + + datatype instream = In of {common: {reader: reader, + augmented_reader: reader, + tail: state ref ref}, + pos: int, + buf: buf} + (* @ s = Eos, End, Truncated, Closed ==> + * pos = V.length inp, !next = s + *) + + fun equalsIn (In {common = {tail = tail1, ...}, ...}, + In {common = {tail = tail2, ...}, ...}) = + tail1 = tail2 + + fun update (In {common, ...}, pos, buf) = + In {common = common, + pos = pos, + buf = buf} + fun updatePos (is as In {buf, ...}, pos) = update (is, pos, buf) + fun updateBufBeg (is, buf) = update (is, 0, buf) + fun updateBufEnd (is, buf as Buf {inp, ...}) = update (is, V.length inp, buf) + + fun instreamSel (In v, sel) = sel v + fun instreamCommon is = instreamSel (is, #common) + fun instreamCommonSel (is, sel) = sel (instreamCommon is) + fun instreamReader is = instreamCommonSel (is, #reader) + fun instreamTail is = instreamCommonSel (is, #tail) + fun readerSel (PIO.RD v, sel) = sel v + fun instreamName is = readerSel (instreamReader is, #name) + + val empty = V.tabulate (0, fn _ => someElem) + + fun extend function + (is as In {common = {augmented_reader, tail, ...}, ...}) + blocking = + case !(!tail) of + End => + let + fun link (base, inp) = let + val next = ref End + val buf = Buf {inp = inp, + base = base, + next = next} + val this = if V.length inp = 0 + then Eos {buf = buf} + else Link {buf = buf} + val _ = !tail := this + val _ = tail := next + in + SOME this + end + fun doit readVec = + let + val base = + case readerSel (augmented_reader, #getPos) of + NONE => NONE + | SOME getPos => SOME (getPos ()) + val inp = readVec (readerSel (augmented_reader, #chunkSize)) + handle exn => + liftExn (instreamName is) function exn + in + case inp of + NONE => NONE + | SOME inp => link (base, inp) + end + in + if blocking + then case readerSel (augmented_reader, #readVec) of + NONE => liftExn (instreamName is) + function + IO.BlockingNotSupported + | SOME readVec => doit (SOME o readVec) + else case readerSel (augmented_reader, #readVecNB) of + NONE => liftExn (instreamName is) + function + IO.NonblockingNotSupported + | SOME readVecNB => doit readVecNB + end + | _ => liftExn (instreamName is) function Match + + fun extendB function is = valOf (extend function is true) + fun extendNB function is = extend function is false + + fun input (is as In {pos, buf as Buf {inp, next, ...}, ...}) = + if pos < V.length inp + then (V.extract(inp, pos, NONE), + updateBufEnd (is, buf)) + else let + fun doit next = + case next of + Link {buf as Buf {inp, ...}} => (inp, updateBufEnd (is, buf)) + | Eos {buf} => (empty, updateBufBeg (is, buf)) + | End => doit (extendB "input" is) + | _ => (empty, is) + in + doit (!next) + end + + fun inputN (is, n) = + if n < 0 orelse n > V.maxLen + then raise Size + else let + fun first (is as In {pos, buf as Buf {inp, ...}, ...}, n) = + if pos + n <= V.length inp + then let + val inp' = V.extract(inp, pos, SOME n) + in + (inp', updatePos (is, pos + n)) + end + else let + val inp' = VS.slice(inp, pos, NONE) + in + loop (buf, [inp'], n - (V.length inp - pos)) + end + and loop (buf' as Buf {next, ...}, inps, n) = + let + fun doit next = + case next of + Link {buf as Buf {inp, ...}} => + if n <= V.length inp + then let + val inp' = VS.slice(inp, 0, SOME n) + val inps = inp'::inps + in + finish (inps, update (is, n, buf)) + end + else loop (buf, (VS.full inp)::inps, n - V.length inp) + | Eos {buf} => + finish (inps, if n > 0 + then updateBufBeg (is, buf) + else updateBufEnd (is, buf')) + | End => doit (extendB "inputN" is) + | _ => finish (inps, updateBufEnd (is, buf')) + in + doit (!next) + end + and finish (inps, is) = + let val inp = VS.concat (List.rev inps) + in (inp, is) + end + in + first (is, n) + end + + (* input1' will move past a temporary end of stream *) + fun input1' (is as In {pos, buf = Buf {inp, next, ...}, ...}) = + case SOME (V.sub (inp, pos)) handle Subscript => NONE of + NONE => + let + fun doit next = + case next of + Link {buf} => input1' (updateBufBeg (is, buf)) + | Eos {buf} => (NONE, updateBufBeg (is, buf)) + | End => doit (extendB "input1" is) + | _ => (NONE, is) + in + doit (!next) + end + | SOME e => + let + val is' = updatePos (is, pos + 1) + in + (SOME e, is') + end + + (* input1 will never move past a temporary end of stream *) + fun input1 is = + case input1' is of + (SOME c, is') => SOME (c, is') + | _ => NONE + + fun inputAll is = + let + fun loop (is, ac) = + let val (inp, is') = input is + in + if V.length inp = 0 + then (V.concat (List.rev ac), is') + else loop (is', inp::ac) + end + in + loop (is, []) + end + + val inputLine = + case line of + NONE => (fn is => SOME (input is)) + | SOME {isLine, lineElem} => + let + val lineVecSl = VS.full (V.tabulate (1, fn _ => lineElem)) + in + fn is => + let + fun findLine (v, i) = + let + fun loop i = + case SOME (V.sub (v, i)) handle Subscript => NONE of + NONE => NONE + | SOME c => + if isLine c + then SOME (i + 1) + else loop (i + 1) + in + loop i + end + fun first (is as In {pos, buf as Buf {inp, next, ...}, ...}) = + (case findLine (inp, pos) of + SOME i => let + val inp' = V.extract(inp, pos, SOME (i - pos)) + in + SOME (inp', updatePos (is, i)) + end + | NONE => if pos < V.length inp + then let + val inp' = VS.slice(inp, pos, NONE) + in + loop (buf, [inp']) + end + else let + fun doit next = + case next of + Link {buf} => first (updateBufBeg (is, buf)) + | Eos _ => NONE + | End => doit (extendB "inputLine" is) + | _ => NONE + in + doit (!next) + end) + and loop (buf' as Buf {next, ...}, inps) = + (* List.length inps > 0 *) + let + fun doit next = + case next of + Link {buf as Buf {inp, ...}} => + (case findLine (inp, 0) of + SOME i => let + val inp' = VS.slice(inp, 0, SOME i) + val inps = inp'::inps + in + finish (inps, update (is, i, buf), false) + end + | NONE => loop (buf, (VS.full inp)::inps)) + | End => doit (extendB "inputLine" is) + | _ => finish (inps, updateBufEnd (is, buf'), true) + in + doit (!next) + end + and finish (inps, is, trail) = + let + val inps = if trail + then lineVecSl::inps + else inps + val inp = VS.concat (List.rev inps) + in + SOME (inp, is) + end + in + first is + end + end + + fun canInput (is as In {pos, buf = Buf {inp, next, ...}, ...}, n) = + if n < 0 orelse n > V.maxLen + then raise Size + else if n = 0 + then SOME 0 + else let + fun start inp = + add ([], inp, 0) + and add (inps, inp, k) = + let + val l = V.length inp + val inps = inp::inps + in + if k + l > n + then finish (inps, n) + else loop (inps, k + l) + end + and loop (inps, k) = + case extendNB "canInput" is of + NONE => finish (inps, k) + | SOME (Link {buf = Buf {inp, ...}}) => + add (inps, inp, k) + | SOME (Eos _) => finish (inps, k) + | _ => raise Fail "extendNB bug" + and finish (inps, k) = + let + val inp = V.concat (List.rev inps) + in + (inp, k) + end + in + if pos < V.length inp + then SOME (Int.min (V.length inp - pos, n)) + else case !next of + End => + (case extendNB "canInput" is of + NONE => NONE + | SOME (Link {buf = Buf {inp, base, ...}}) => + let + val (inp, k) = start inp + val buf = Buf {inp = inp, + base = base, + next = ref End} + in + next := Link {buf = buf}; + SOME k + end + | SOME (Eos _) => SOME 0 + | _ => raise Fail "extendNB bug") + | _ => SOME 0 + end + + structure Close = + struct + datatype t = T of {close: unit -> unit, + name: string, + tail: state ref ref} + + fun close (T {close, name, tail}) = + case !(!tail) of + End => + (!tail := Closed + ; close () handle exn => liftExn name "closeIn" exn) + | _ => () + + fun equalsInstream (T {tail, ...}, is) = tail = instreamTail is + + fun make (In {common = {reader = PIO.RD {close, name, ...}, + tail, ...}, + ...}): t = + T {close = close, name = name, tail = tail} + end + + val closeIn = Close.close o Close.make + + fun endOfStream is = + let val (inp, _) = input is + in V.length inp = 0 + end + + fun mkInstream' {bufferContents, closed, reader} = + let + val next = ref (if closed then Closed else End) + val base = + case readerSel (reader, #getPos) of + NONE => NONE + | SOME getPos => SOME (getPos ()) + val buf = + case bufferContents of + NONE => Buf {inp = empty, + base = base, + next = next} + | SOME (lastRead, v) => + if V.length v = 0 + then Buf {inp = empty, + base = base, + next = ref (Eos {buf = Buf {inp = empty, + base = base, + next = next}})} + else case (lastRead, base, xlatePos) of + (true, SOME b, SOME {fromInt, toInt}) => + let + val b = + fromInt (Position.- (toInt b, Position.fromInt (V.length v))) + in + Buf {inp = v, + base = SOME b, + next = next} + end + | _ => Buf {inp = v, + base = NONE, + next = next} + in + In {common = {reader = reader, + augmented_reader = PIO.augmentReader reader, + tail = ref next}, + pos = 0, + buf = buf} + end + + fun mkInstream (reader, bufferContents) = + mkInstream' {bufferContents = if 0 = V.length bufferContents + then NONE + else SOME (false, bufferContents), + closed = false, + reader = reader} + + fun getReader (is as In {common = {reader, tail, ...}, ...}) = + case !(!tail) of + End => (!tail := Truncated; + let val (inp, _) = inputAll is + in (reader, inp) + end) + | _ => liftExn (instreamName is) "getReader" IO.ClosedStream + + fun filePosIn (is as In {common = {augmented_reader, ...}, + pos, + buf = Buf {base, ...}, ...}) = + case base of + SOME b => (case xlatePos of + SOME {fromInt, toInt} => + (fromInt (Position.+ (Position.fromInt pos, toInt b))) + | NONE => (case (readerSel (augmented_reader, #readVec), + readerSel (augmented_reader, #getPos), + readerSel (augmented_reader, #setPos)) of + (SOME readVec, SOME getPos, SOME setPos) => + let + val curPos = getPos () + in + setPos b + ; ignore (readVec pos) + ; getPos () before setPos curPos + end + | _ => + liftExn (instreamName is) "filePosIn" IO.RandomAccessNotSupported)) + | NONE => liftExn (instreamName is) "filePosIn" IO.RandomAccessNotSupported + end + +signature STREAM_IO_ARG = + sig + structure Array: MONO_ARRAY + structure ArraySlice: MONO_ARRAY_SLICE + structure PrimIO: PRIM_IO + structure Vector: MONO_VECTOR + structure VectorSlice: MONO_VECTOR_SLICE + sharing type PrimIO.elem = Vector.elem = VectorSlice.elem = Array.elem + = ArraySlice.elem + sharing type PrimIO.vector = Vector.vector = VectorSlice.vector + = Array.vector = ArraySlice.vector + sharing type PrimIO.vector_slice = VectorSlice.slice + = ArraySlice.vector_slice + sharing type PrimIO.array = Array.array = ArraySlice.array + sharing type PrimIO.array_slice = ArraySlice.slice + + val someElem: PrimIO.elem + end + +functor StreamIO (S: STREAM_IO_ARG): STREAM_IO = + StreamIOExtra (open S + val line = NONE + val xlatePos = NONE) + +signature STREAM_IO_EXTRA_FILE_ARG = STREAM_IO_EXTRA_ARG + +functor StreamIOExtraFile (S: STREAM_IO_EXTRA_FILE_ARG): STREAM_IO_EXTRA_FILE = + struct + open S + + structure PIO = PrimIO + structure V = Vector + + structure StreamIO = StreamIOExtra (S) + open StreamIO + + fun liftExn name function cause = raise IO.Io {name = name, + function = function, + cause = cause} + + (*---------------*) + (* outstream *) + (*---------------*) + + fun writerSel (PIO.WR v, sel) = sel v + fun outstreamName os = writerSel (outstreamWriter os, #name) + + fun outFd os = + case writerSel (outstreamWriter os, #ioDesc) of + SOME ioDesc => valOf (Posix.FileSys.iodToFD ioDesc) + | NONE => liftExn (outstreamName os) "outFd" (Fail "") + + val openOutstreams : (outstream * {close: bool}) list ref = ref [] + + val mkOutstream'' = + let + val _ = Cleaner.addNew + (Cleaner.atExit, fn () => + List.app (fn (os, {close}) => + if close + then closeOut os + else flushOut os) (!openOutstreams)) + in + fn {bufferMode, closeAtExit, closed, writer} => + let + val os = mkOutstream' {bufferMode = bufferMode, + closed = closed, + writer = writer} + val _ = + if closed + then () + else openOutstreams := ((os, {close = closeAtExit}) + :: (!openOutstreams)) + in + os + end + end + + fun mkOutstream' {bufferMode, closed, writer} = + mkOutstream'' {bufferMode = bufferMode, + closeAtExit = true, + closed = closed, + writer = writer} + + fun mkOutstream (writer, bufferMode) = + mkOutstream' {bufferMode = bufferMode, + closed = false, + writer = writer} + + val closeOut = fn os => + let + val _ = openOutstreams := List.filter (fn (os', _) => + not (equalsOut (os, os'))) + (!openOutstreams) + in + closeOut os + end + + (*---------------*) + (* instream *) + (*---------------*) + + fun readerSel (PIO.RD v, sel) = sel v + + fun instreamName is = readerSel (instreamReader is, #name) + + fun inFd is = + case readerSel (instreamReader is, #ioDesc) of + SOME ioDesc => valOf (Posix.FileSys.iodToFD ioDesc) + | NONE => liftExn (instreamName is) "inFd" (Fail "") + + val closeAtExits: Close.t list ref = ref [] + + val mkInstream'' = + let + val _ = Cleaner.addNew (Cleaner.atExit, fn () => + List.app Close.close (!closeAtExits)) + in + fn {bufferContents, closeAtExit, closed, reader} => + let + val is = + mkInstream' {bufferContents = bufferContents, + closed = closed, + reader = reader} + val _ = + if closed orelse not closeAtExit + then () + else closeAtExits := Close.make is :: (!closeAtExits) + in + is + end + end + + fun mkInstream' {bufferContents, closed, reader} = + mkInstream'' {bufferContents = bufferContents, + closeAtExit = true, + closed = closed, + reader = reader} + + + fun mkInstream (reader, bufferContents) = + mkInstream' {bufferContents = (if V.length bufferContents = 0 then NONE + else SOME (false, bufferContents)), + closed = false, + reader = reader} + + val closeIn = fn is => + let + val _ = + closeAtExits := + List.filter (fn c => Close.equalsInstream (c, is)) (!closeAtExits) + in + closeIn is + end + end diff --git a/basis-library/io/stream-io.sig b/basis-library/io/stream-io.sig new file mode 100644 index 0000000..28bd517 --- /dev/null +++ b/basis-library/io/stream-io.sig @@ -0,0 +1,78 @@ +signature STREAM_IO = + sig + type elem + type instream + type out_pos + type outstream + type pos + type reader + type vector + type writer + + val canInput: instream * int -> int option + val closeIn: instream -> unit + val closeOut: outstream -> unit + val endOfStream: instream -> bool + val filePosIn: instream -> pos + val filePosOut: out_pos -> pos + val flushOut: outstream -> unit + val getBufferMode: outstream -> IO.buffer_mode + val getPosOut: outstream -> out_pos + val getReader: instream -> reader * vector + val getWriter: outstream -> writer * IO.buffer_mode + val input1: instream -> (elem * instream) option + val input: instream -> vector * instream + val inputAll: instream -> vector * instream + val inputN: instream * int -> vector * instream + val mkInstream: reader * vector -> instream + val mkOutstream: writer * IO.buffer_mode -> outstream + val output1: outstream * elem -> unit + val output: outstream * vector -> unit + val setBufferMode: outstream * IO.buffer_mode -> unit + val setPosOut: out_pos -> outstream + end + +signature STREAM_IO_EXTRA = + sig + include STREAM_IO + type vector_slice + + structure Close: + sig + type t + + val close: t -> unit + val equalsInstream: t * instream -> bool + val make: instream -> t + end + + val equalsIn: instream * instream -> bool + val equalsOut: outstream * outstream -> bool + val input1': instream -> elem option * instream + val inputLine: instream -> (vector * instream) option + val instreamReader: instream -> reader + val mkInstream': {bufferContents: (bool * vector) option, + closed: bool, + reader: reader} -> instream + val mkOutstream': {bufferMode: IO.buffer_mode, + closed: bool, + writer: writer} -> outstream + val outputSlice: outstream * vector_slice -> unit + val outstreamWriter: outstream -> writer + end + +signature STREAM_IO_EXTRA_FILE = + sig + include STREAM_IO_EXTRA + + val inFd: instream -> Posix.IO.file_desc + val mkInstream'': {bufferContents: (bool * vector) option, + closeAtExit: bool, + closed: bool, + reader: reader} -> instream + val outFd: outstream -> Posix.IO.file_desc + val mkOutstream'': {bufferMode: IO.buffer_mode, + closeAtExit: bool, + closed: bool, + writer: writer} -> outstream + end diff --git a/basis-library/io/text-io.sig b/basis-library/io/text-io.sig new file mode 100644 index 0000000..ea1c657 --- /dev/null +++ b/basis-library/io/text-io.sig @@ -0,0 +1,66 @@ +signature TEXT_IO_GLOBAL = + sig + val print: string -> unit + end + +signature TEXT_IO = + sig + include TEXT_IO_GLOBAL + + structure StreamIO: TEXT_STREAM_IO +(* where type elem = Char.char *) (* redundant *) + where type pos = TextPrimIO.pos + where type reader = TextPrimIO.reader +(* where type vector = CharVector.vector *) (* redundant *) + where type writer = TextPrimIO.writer + + type elem = StreamIO.elem + type instream + type outstream + type vector = StreamIO.vector + + val canInput: instream * int -> int option + val closeIn: instream -> unit + val closeOut: outstream -> unit + val endOfStream: instream -> bool + val flushOut: outstream -> unit + val getInstream: instream -> StreamIO.instream + val getOutstream: outstream -> StreamIO.outstream + val getPosOut: outstream -> StreamIO.out_pos + val input1: instream -> elem option + val input: instream -> vector + val inputAll: instream -> vector + val inputLine: instream -> string option + val inputN: instream * int -> vector + val lookahead: instream -> elem option + val mkInstream: StreamIO.instream -> instream + val mkOutstream: StreamIO.outstream -> outstream + val openAppend: string -> outstream + val openIn: string -> instream + val openOut: string -> outstream + val openString: string -> instream + val output1: outstream * elem -> unit + val output: outstream * vector -> unit + val outputSubstr: outstream * substring -> unit + val scanStream: + ((Char.char, StreamIO.instream) StringCvt.reader + -> ('a, StreamIO.instream) StringCvt.reader) + -> instream -> 'a option + val setInstream: (instream * StreamIO.instream) -> unit + val setOutstream: outstream * StreamIO.outstream -> unit + val setPosOut: outstream * StreamIO.out_pos -> unit + val stdErr: outstream + val stdIn: instream + val stdOut: outstream + end + +signature TEXT_IO_EXTRA = + sig + include TEXT_IO + + val equalsIn: instream * instream -> bool + val inFd: instream -> Posix.IO.file_desc + val newIn: Posix.IO.file_desc * string -> instream + val newOut: Posix.IO.file_desc * string -> outstream + val outFd: outstream -> Posix.IO.file_desc + end diff --git a/basis-library/io/text-io.sml b/basis-library/io/text-io.sml new file mode 100644 index 0000000..e731a59 --- /dev/null +++ b/basis-library/io/text-io.sml @@ -0,0 +1,44 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure TextIO: TEXT_IO_EXTRA = + struct + structure IO = + ImperativeIOExtra + (structure Array = CharArray + structure ArraySlice = CharArraySlice + structure PrimIO = TextPrimIO + structure Vector = CharVector + structure VectorSlice = CharVectorSlice + val chunkSize = Int32.toInt (Primitive.Controls.bufSize) + val fileTypeFlags = [PrimitiveFFI.Posix.FileSys.O.TEXT] + val line = SOME {isLine = fn c => c = #"\n", + lineElem = #"\n"} + val mkReader = Posix.IO.mkTextReader + val mkWriter = Posix.IO.mkTextWriter + val someElem = (#"\000": Char.char) + val xlatePos = SOME {fromInt = fn i => i, + toInt = fn i => i}) + open IO + + structure StreamIO = + struct + open StreamIO + + fun outputSubstr (s, ss) = outputSlice (s, ss) + end + + val outputSubstr = outputSlice + + val openString = openVector + + fun print (s: string) = (output (stdOut, s); flushOut stdOut) + end + +structure TextIOGlobal: TEXT_IO_GLOBAL = TextIO +open TextIOGlobal diff --git a/basis-library/io/text-prim-io.sml b/basis-library/io/text-prim-io.sml new file mode 100644 index 0000000..60b47ad --- /dev/null +++ b/basis-library/io/text-prim-io.sml @@ -0,0 +1,18 @@ +(* Copyright (C) 2002-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure TextPrimIO : PRIM_IO + where type array = CharArray.array + where type vector = CharVector.vector + where type elem = Char.char = + PrimIO (structure Vector = CharVector + structure VectorSlice = CharVectorSlice + structure Array = CharArray + structure ArraySlice = CharArraySlice + type pos = Position.int + val compare = Position.compare + val someElem = #"\000": Char.char) diff --git a/basis-library/io/text-stream-io.sig b/basis-library/io/text-stream-io.sig new file mode 100644 index 0000000..9d9f22c --- /dev/null +++ b/basis-library/io/text-stream-io.sig @@ -0,0 +1,9 @@ +signature TEXT_STREAM_IO = + sig + include STREAM_IO + where type elem = Char.char + where type vector = CharVector.vector + + val inputLine: instream -> (string * instream) option + val outputSubstr: outstream * substring -> unit + end diff --git a/basis-library/libs/all.mlb b/basis-library/libs/all.mlb new file mode 100644 index 0000000..e3c60ed --- /dev/null +++ b/basis-library/libs/all.mlb @@ -0,0 +1,19 @@ +(* Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + ../basis.mlb + ../pervasive.mlb + ../basis-2002.mlb + ../basis-1997.mlb + ../basis-none.mlb + ../mlton.mlb + ../sml-nj.mlb + ../unsafe.mlb + ../c-types.mlb +in +end diff --git a/basis-library/libs/basis-1997/arrays-and-vectors/array.sig b/basis-library/libs/basis-1997/arrays-and-vectors/array.sig new file mode 100644 index 0000000..7643493 --- /dev/null +++ b/basis-library/libs/basis-1997/arrays-and-vectors/array.sig @@ -0,0 +1,26 @@ +signature ARRAY_1997 = + sig + eqtype 'a array + type 'a vector + + val app: ('a -> unit) -> 'a array -> unit + val appi: (int * 'a -> unit) -> 'a array * int * int option -> unit + val array: int * 'a -> 'a array + val copy: {src: 'a array, si: int, len: int option, + dst: 'a array, di: int} -> unit + val copyVec: {src: 'a vector, si: int, len: int option, + dst: 'a array, di: int} -> unit + val extract: 'a array * int * int option -> 'a vector + val foldl: ('a * 'b -> 'b) -> 'b -> 'a array -> 'b + val foldli: (int * 'a * 'b -> 'b) -> 'b -> 'a array * int * int option -> 'b + val foldr: ('a * 'b -> 'b) -> 'b -> 'a array -> 'b + val foldri: (int * 'a * 'b -> 'b) -> 'b -> 'a array * int * int option -> 'b + val fromList: 'a list -> 'a array + val length: 'a array -> int + val maxLen: int + val modify: ('a -> 'a) -> 'a array -> unit + val modifyi: (int * 'a -> 'a) -> 'a array * int * int option -> unit + val sub: 'a array * int -> 'a + val tabulate: int * (int -> 'a) -> 'a array + val update: 'a array * int * 'a -> unit + end diff --git a/basis-library/libs/basis-1997/arrays-and-vectors/mono-array.sig b/basis-library/libs/basis-1997/arrays-and-vectors/mono-array.sig new file mode 100644 index 0000000..5bb042c --- /dev/null +++ b/basis-library/libs/basis-1997/arrays-and-vectors/mono-array.sig @@ -0,0 +1,26 @@ +signature MONO_ARRAY_1997 = + sig + eqtype array + type elem + structure Vector: MONO_VECTOR_1997 + val maxLen: int + val array: (int * elem) -> array + val fromList: elem list -> array + val tabulate: (int * (int -> elem)) -> array + val length: array -> int + val sub: (array * int) -> elem + val update: (array * int * elem) -> unit + val extract: (array * int * int option) -> Vector.vector + val copy: {src: array, si: int, len: int option, + dst: array, di: int} -> unit + val copyVec: {src: Vector.vector, si: int, len: int option, + dst: array, di: int} -> unit + val appi: ((int * elem) -> unit) -> (array * int * int option) -> unit + val app: (elem -> unit) -> array -> unit + val foldli: ((int * elem * 'b) -> 'b) -> 'b -> (array * int * int option) -> 'b + val foldri: ((int * elem * 'b) -> 'b) -> 'b -> (array * int * int option) -> 'b + val foldl: ((elem * 'b) -> 'b) -> 'b -> array -> 'b + val foldr: ((elem * 'b) -> 'b) -> 'b -> array -> 'b + val modifyi: ((int * elem) -> elem) -> (array * int * int option) -> unit + val modify: (elem -> elem) -> array -> unit + end diff --git a/basis-library/libs/basis-1997/arrays-and-vectors/mono-array2.sig b/basis-library/libs/basis-1997/arrays-and-vectors/mono-array2.sig new file mode 100644 index 0000000..e406a8d --- /dev/null +++ b/basis-library/libs/basis-1997/arrays-and-vectors/mono-array2.sig @@ -0,0 +1,27 @@ +signature MONO_ARRAY2_1997 = + sig + eqtype array + type elem + type region = {base: array, + row: int, col: int, + nrows: int option, ncols: int option} + datatype traversal = datatype Array2.traversal + structure Vector: MONO_VECTOR_1997 + val array: (int * int * elem) -> array + val fromList: elem list list -> array + val tabulate: traversal -> (int * int * ((int * int) -> elem)) -> array + val sub: (array * int * int) -> elem + val update: (array * int * int * elem) -> unit + val dimensions: array -> (int * int) + val nCols: array -> int + val nRows: array -> int + val row: (array * int) -> Vector.vector + val column: (array * int) -> Vector.vector + val copy: {src: region, dst: array, dst_row: int, dst_col: int} -> unit + val appi: Array2.traversal -> ((int * int * elem) -> unit) -> region -> unit + val app: Array2.traversal -> (elem -> unit) -> array -> unit + val modifyi: Array2.traversal -> ((int * int * elem) -> elem) -> region -> unit + val modify: Array2.traversal -> (elem -> elem) -> array -> unit + val foldi: Array2.traversal -> ((int * int * elem * 'b) -> 'b) -> 'b -> region -> 'b + val fold: Array2.traversal -> ((elem * 'b) -> 'b) -> 'b -> array -> 'b + end diff --git a/basis-library/libs/basis-1997/arrays-and-vectors/mono-vector-array-array2-convert.fun b/basis-library/libs/basis-1997/arrays-and-vectors/mono-vector-array-array2-convert.fun new file mode 100644 index 0000000..758e842 --- /dev/null +++ b/basis-library/libs/basis-1997/arrays-and-vectors/mono-vector-array-array2-convert.fun @@ -0,0 +1,67 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + + +functor MonoVectorArrayArray2Convert + (structure Vector: MONO_VECTOR + structure VectorSlice: MONO_VECTOR_SLICE + structure Array: MONO_ARRAY + structure ArraySlice: MONO_ARRAY_SLICE + structure Array2: MONO_ARRAY2 + sharing type Vector.elem = VectorSlice.elem = + Array.elem = ArraySlice.elem = + Array2.elem + sharing type Vector.vector = VectorSlice.vector = + Array.vector = ArraySlice.vector = + Array2.vector + sharing type VectorSlice.slice = ArraySlice.vector_slice + sharing type Array.array = ArraySlice.array) : + sig + structure Vector: MONO_VECTOR_1997 + structure Array: MONO_ARRAY_1997 + structure Array2: MONO_ARRAY2_1997 + sharing type Vector.elem = Array.elem = Array2.elem + sharing type Vector.vector = Array.Vector.vector = Array2.Vector.vector + end = + struct + fun shift1 f (_, s, _) = fn (i:int, x) => f (i + s, x) + fun shift2 f (_, s, _) = fn (i:int, x, y) => f (i + s, x, y) + + structure V = + struct + open Vector + fun extract sl = VectorSlice.vector (VectorSlice.slice sl) + fun mapi f sl = VectorSlice.mapi (shift1 f sl) (VectorSlice.slice sl) + fun appi f sl = VectorSlice.appi (shift1 f sl) (VectorSlice.slice sl) + fun foldli f b sl = VectorSlice.foldli (shift2 f sl) b (VectorSlice.slice sl) + fun foldri f b sl = VectorSlice.foldri (shift2 f sl) b (VectorSlice.slice sl) + end + structure A = + struct + open Array + structure Vector = V + fun appi f sl = ArraySlice.appi (shift1 f sl) (ArraySlice.slice sl) + fun copy {src, si, len, dst, di} = + ArraySlice.copy {src = ArraySlice.slice (src, si, len), + dst = dst, di = di} + fun copyVec {src, si, len, dst, di} = + ArraySlice.copyVec {src = VectorSlice.slice (src, si, len), + dst = dst, di = di} + fun extract sl = ArraySlice.vector (ArraySlice.slice sl) + fun foldli f b sl = ArraySlice.foldli (shift2 f sl) b (ArraySlice.slice sl) + fun foldri f b sl = ArraySlice.foldri (shift2 f sl) b (ArraySlice.slice sl) + fun modifyi f sl = ArraySlice.modifyi (shift1 f sl) (ArraySlice.slice sl) + end + structure A2 = + struct + open Array2 + structure Vector = V + end + structure Array = A + structure Vector = V + structure Array2 = A2 + end diff --git a/basis-library/libs/basis-1997/arrays-and-vectors/mono-vector.sig b/basis-library/libs/basis-1997/arrays-and-vectors/mono-vector.sig new file mode 100644 index 0000000..bd595fa --- /dev/null +++ b/basis-library/libs/basis-1997/arrays-and-vectors/mono-vector.sig @@ -0,0 +1,20 @@ +signature MONO_VECTOR_1997 = + sig + type vector + type elem + val maxLen: int + val fromList: elem list -> vector + val tabulate: (int * (int -> elem)) -> vector + val length: vector -> int + val sub: (vector * int) -> elem + val extract: (vector * int * int option) -> vector + val concat: vector list -> vector + val mapi: ((int * elem) -> elem) -> (vector * int * int option) -> vector + val map: (elem -> elem) -> vector -> vector + val appi: ((int * elem) -> unit) -> (vector * int * int option) -> unit + val app: (elem -> unit) -> vector -> unit + val foldli: ((int * elem * 'a) -> 'a) -> 'a -> (vector * int * int option) -> 'a + val foldri: ((int * elem * 'a) -> 'a) -> 'a -> (vector * int * int option) -> 'a + val foldl: ((elem * 'a) -> 'a) -> 'a -> vector -> 'a + val foldr: ((elem * 'a) -> 'a) -> 'a -> vector -> 'a + end diff --git a/basis-library/libs/basis-1997/arrays-and-vectors/vector-array-convert.fun b/basis-library/libs/basis-1997/arrays-and-vectors/vector-array-convert.fun new file mode 100644 index 0000000..949f077 --- /dev/null +++ b/basis-library/libs/basis-1997/arrays-and-vectors/vector-array-convert.fun @@ -0,0 +1,50 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + + +functor VectorArrayConvert + (structure Vector: VECTOR + structure VectorSlice: VECTOR_SLICE + where type 'a slice = 'a VectorSlice.slice + structure Array: ARRAY + structure ArraySlice: ARRAY_SLICE + where type 'a slice = 'a ArraySlice.slice) : + sig + structure Vector: VECTOR_1997 + structure Array: ARRAY_1997 + end = + struct + fun shift1 f (_, s, _) = fn (i:int, x) => f (i + s, x) + fun shift2 f (_, s, _) = fn (i:int, x, y) => f (i + s, x, y) + + structure V = + struct + open Vector + fun extract sl = VectorSlice.vector (VectorSlice.slice sl) + fun mapi f sl = VectorSlice.mapi (shift1 f sl) (VectorSlice.slice sl) + fun appi f sl = VectorSlice.appi (shift1 f sl) (VectorSlice.slice sl) + fun foldli f b sl = VectorSlice.foldli (shift2 f sl) b (VectorSlice.slice sl) + fun foldri f b sl = VectorSlice.foldri (shift2 f sl) b (VectorSlice.slice sl) + end + structure A = + struct + open Array + fun appi f sl = ArraySlice.appi (shift1 f sl) (ArraySlice.slice sl) + fun copy {src, si, len, dst, di} = + ArraySlice.copy {src = ArraySlice.slice (src, si, len), + dst = dst, di = di} + fun copyVec {src, si, len, dst, di} = + ArraySlice.copyVec {src = VectorSlice.slice (src, si, len), + dst = dst, di = di} + fun extract sl = ArraySlice.vector (ArraySlice.slice sl) + fun foldli f b sl = ArraySlice.foldli (shift2 f sl) b (ArraySlice.slice sl) + fun foldri f b sl = ArraySlice.foldri (shift2 f sl) b (ArraySlice.slice sl) + fun modifyi f sl = ArraySlice.modifyi (shift1 f sl) (ArraySlice.slice sl) + end + structure Vector = V + structure Array = A + end diff --git a/basis-library/libs/basis-1997/arrays-and-vectors/vector.sig b/basis-library/libs/basis-1997/arrays-and-vectors/vector.sig new file mode 100644 index 0000000..55ec2e8 --- /dev/null +++ b/basis-library/libs/basis-1997/arrays-and-vectors/vector.sig @@ -0,0 +1,19 @@ +signature VECTOR_1997 = + sig + eqtype 'a vector + val maxLen: int + val fromList: 'a list -> 'a vector + val tabulate: (int * (int -> 'a)) -> 'a vector + val length: 'a vector -> int + val sub: ('a vector * int) -> 'a + val extract: ('a vector * int * int option) -> 'a vector + val concat: 'a vector list -> 'a vector + val mapi: ((int * 'a) -> 'b) -> ('a vector * int * int option) -> 'b vector + val map: ('a -> 'b) -> 'a vector -> 'b vector + val appi: ((int * 'a) -> unit) -> ('a vector * int * int option) -> unit + val app: ('a -> unit) -> 'a vector -> unit + val foldli: ((int * 'a * 'b) -> 'b) -> 'b -> ('a vector * int * int option) -> 'b + val foldri: ((int * 'a * 'b) -> 'b) -> 'b -> ('a vector * int * int option) -> 'b + val foldl: (('a * 'b) -> 'b) -> 'b -> 'a vector -> 'b + val foldr: (('a * 'b) -> 'b) -> 'b -> 'a vector -> 'b + end diff --git a/basis-library/libs/basis-1997/basis-1997.mlb b/basis-library/libs/basis-1997/basis-1997.mlb new file mode 100644 index 0000000..3008ea9 --- /dev/null +++ b/basis-library/libs/basis-1997/basis-1997.mlb @@ -0,0 +1,105 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + ../basis-2002/basis-2002.mlb + ../../basis-2002.mlb + local + ../basis-extra/basis-extra.mlb + in + signature SML90 + structure SML90 + end + arrays-and-vectors/vector.sig + arrays-and-vectors/array.sig + arrays-and-vectors/vector-array-convert.fun + arrays-and-vectors/mono-vector.sig + arrays-and-vectors/mono-array.sig + arrays-and-vectors/mono-array2.sig + arrays-and-vectors/mono-vector-array-array2-convert.fun + integer/word.sig + text/string.sig + text/substring.sig + text/text-convert.fun + real/IEEE-real.sig + real/IEEE-real-convert.fun + real/real.sig + real/real-convert.fun + posix/flags.sig + posix/flags-convert.fun + posix/process.sig + posix/process-convert.fun + posix/file-sys.sig + posix/file-sys-convert.fun + posix/io.sig + posix/io-convert.fun + posix/tty.sig + posix/tty-convert.fun + posix/posix.sig + posix/posix-convert.fun + system/timer.sig + system/timer-convert.fun + system/file-sys.sig + system/file-sys-convert.fun + system/path.sig + system/path-convert.fun + system/process.sig + system/process-convert.fun + system/os.sig + system/os-convert.fun + system/unix.sig + system/unix-convert.fun + io/io.sig + io/io-convert.fun + io/stream-io.sig + io/text-stream-io.sig + io/text-io.sig + io/text-io-convert.fun + io/bin-stream-io.sig + io/bin-io.sig + io/bin-io-convert.fun + ann "allowSpecifySpecialIds true" in + top-level/basis.sig + end + top-level/basis.sml + in + signature MONO_ARRAY_1997 + signature MONO_VECTOR_1997 + signature REAL_1997 + signature STRING_1997 + signature SUBSTRING_1997 + signature WORD_1997 + signature ARRAY_1997 + signature IEEE_REAL_1997 + signature IO_1997 + signature OS_1997 + signature OS_FILE_SYS_1997 + signature OS_PATH_1997 + signature OS_PROCESS_1997 + signature SML90 + signature TIMER_1997 + signature VECTOR_1997 + signature MONO_ARRAY2_1997 + signature POSIX_FLAGS_1997 + signature POSIX_1997 + signature POSIX_PROCESS_1997 + signature POSIX_FILE_SYS_1997 + signature POSIX_IO_1997 + signature POSIX_TTY_1997 + signature UNIX_1997 + + structure Basis1997 + end +end diff --git a/basis-library/libs/basis-1997/integer/word.sig b/basis-library/libs/basis-1997/integer/word.sig new file mode 100644 index 0000000..d54c937 --- /dev/null +++ b/basis-library/libs/basis-1997/integer/word.sig @@ -0,0 +1,39 @@ +signature WORD_1997 = + sig + eqtype word + val wordSize: int + val toLargeWord: word -> LargeWord.word + val toLargeWordX: word -> LargeWord.word + val fromLargeWord: LargeWord.word -> word + val toLargeInt: word -> LargeInt.int + val toLargeIntX: word -> LargeInt.int + val fromLargeInt: LargeInt.int -> word + val toInt: word -> Int.int + val toIntX: word -> Int.int + val fromInt: Int.int -> word + val orb: (word * word) -> word + val xorb: (word * word) -> word + val andb: (word * word) -> word + val notb: word -> word + val << : (word * Word.word) -> word + val >> : (word * Word.word) -> word + val ~>> : (word * Word.word) -> word + val + : (word * word) -> word + val - : (word * word) -> word + val * : (word * word) -> word + val div: (word * word) -> word + val mod: (word * word) -> word + val compare: (word * word) -> order + val > : (word * word) -> bool + val < : (word * word) -> bool + val >= : (word * word) -> bool + val <= : (word * word) -> bool + val min: (word * word) -> word + val max: (word * word) -> word + val fmt: StringCvt.radix -> word -> string + val toString: word -> string + val fromString: string -> word option + val scan: StringCvt.radix -> + (char, 'a) StringCvt.reader -> + (word, 'a) StringCvt.reader + end diff --git a/basis-library/libs/basis-1997/io/bin-io-convert.fun b/basis-library/libs/basis-1997/io/bin-io-convert.fun new file mode 100644 index 0000000..7a8ea74 --- /dev/null +++ b/basis-library/libs/basis-1997/io/bin-io-convert.fun @@ -0,0 +1,19 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor BinIOConvert + (structure BinIO: BIN_IO) : + BIN_IO_1997 = + struct + open BinIO + + structure StreamIO = + struct + open StreamIO + val inputAll = #1 o inputAll + end + end diff --git a/basis-library/libs/basis-1997/io/bin-io.sig b/basis-library/libs/basis-1997/io/bin-io.sig new file mode 100644 index 0000000..f3af743 --- /dev/null +++ b/basis-library/libs/basis-1997/io/bin-io.sig @@ -0,0 +1,46 @@ +signature BIN_IO_1997 = + sig + structure StreamIO: BIN_STREAM_IO_1997 + + type vector = StreamIO.vector + type elem = StreamIO.elem + type instream + + val canInput: instream * int -> int option + val closeIn: instream -> unit + val endOfStream: instream -> bool + val getInstream: instream -> StreamIO.instream + val input1: instream -> elem option + val input: instream -> vector + val inputAll: instream -> vector + val inputN: instream * int -> vector + val lookahead: instream -> elem option + val mkInstream: StreamIO.instream -> instream + val openIn: string -> instream +(* + val scanStream: + ((Char.char, StreamIO.instream) StringCvt.reader + -> ('a, StreamIO.instream) StringCvt.reader) + -> instream -> 'a option +*) + val setInstream: (instream * StreamIO.instream) -> unit +(* + val getPosIn: instream -> StreamIO.in_pos + val setPosIn: (instream * StreamIO.in_pos) -> unit +*) + + type outstream + val closeOut: outstream -> unit + val flushOut: outstream -> unit + val getOutstream: outstream -> StreamIO.outstream + val getPosOut: outstream -> StreamIO.out_pos + val mkOutstream: StreamIO.outstream -> outstream + val openAppend: string -> outstream + val openOut: string -> outstream + val output1: outstream * elem -> unit + val output: outstream * vector -> unit + val setOutstream: outstream * StreamIO.outstream -> unit +(* + val setPosOut: outstream * StreamIO.out_pos -> unit +*) + end diff --git a/basis-library/libs/basis-1997/io/bin-stream-io.sig b/basis-library/libs/basis-1997/io/bin-stream-io.sig new file mode 100644 index 0000000..57837ef --- /dev/null +++ b/basis-library/libs/basis-1997/io/bin-stream-io.sig @@ -0,0 +1,6 @@ +signature BIN_STREAM_IO_1997 = + sig + include STREAM_IO_1997 + where type vector = Word8Vector.vector + where type elem = Word8Vector.elem + end diff --git a/basis-library/libs/basis-1997/io/io-convert.fun b/basis-library/libs/basis-1997/io/io-convert.fun new file mode 100644 index 0000000..839a92d --- /dev/null +++ b/basis-library/libs/basis-1997/io/io-convert.fun @@ -0,0 +1,14 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor IOConvert + (structure IO: IO) : + IO_1997 = + struct + open IO + exception TerminatedStream + end diff --git a/basis-library/libs/basis-1997/io/io.sig b/basis-library/libs/basis-1997/io/io.sig new file mode 100644 index 0000000..d7cbbc6 --- /dev/null +++ b/basis-library/libs/basis-1997/io/io.sig @@ -0,0 +1,12 @@ +signature IO_1997 = + sig + exception Io of {cause: exn, + function: string, + name: string} + exception BlockingNotSupported + exception NonblockingNotSupported + exception RandomAccessNotSupported + exception TerminatedStream + exception ClosedStream + datatype buffer_mode = NO_BUF | LINE_BUF | BLOCK_BUF + end diff --git a/basis-library/libs/basis-1997/io/stream-io.sig b/basis-library/libs/basis-1997/io/stream-io.sig new file mode 100644 index 0000000..081a631 --- /dev/null +++ b/basis-library/libs/basis-1997/io/stream-io.sig @@ -0,0 +1,38 @@ +signature STREAM_IO_1997 = + sig + type elem + type vector +(* + type reader + type writer +*) + + type instream + type outstream + + type out_pos + type pos (* = int *) + + val canInput: instream * int -> int option + val closeIn: instream -> unit + val endOfStream: instream -> bool + val filePosOut: out_pos -> pos + val input1: instream -> (elem * instream) option + val input: instream -> vector * instream + val inputAll: instream -> vector + val inputN: instream * int -> vector * instream +(* + val mkInstream: reader * vector -> instream (* need to update this *) + val getReader: instream -> reader * vector + val output: outstream * vector -> unit + val output1: outstream * elem -> unit + val flushOut: outstream -> unit + val closeOut: outstream -> unit + val setBufferMode: outstream * IO.buffer_mode -> unit + val getBufferMode: outstream -> IO.buffer_mode + val mkOutstream: writer * IO.buffer_mode -> outstream + val getWriter: outstream -> writer * IO.buffer_mode + val getPosOut: outstream -> out_pos + val setPosOut: out_pos -> outstream +*) + end diff --git a/basis-library/libs/basis-1997/io/text-io-convert.fun b/basis-library/libs/basis-1997/io/text-io-convert.fun new file mode 100644 index 0000000..67a0ca3 --- /dev/null +++ b/basis-library/libs/basis-1997/io/text-io-convert.fun @@ -0,0 +1,30 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor TextIOConvert + (structure TextIO: TEXT_IO) : + TEXT_IO_1997 = + struct + open TextIO + + fun inputLine ins = + case TextIO.inputLine ins of + NONE => "" + | SOME s => s + + structure StreamIO = + struct + open StreamIO + + val inputAll = #1 o inputAll + + fun inputLine ins = + case StreamIO.inputLine ins of + NONE => ("", ins) + | SOME (s, ins) => (s, ins) + end + end diff --git a/basis-library/libs/basis-1997/io/text-io.sig b/basis-library/libs/basis-1997/io/text-io.sig new file mode 100644 index 0000000..32b3e55 --- /dev/null +++ b/basis-library/libs/basis-1997/io/text-io.sig @@ -0,0 +1,51 @@ +signature TEXT_IO_1997 = + sig + structure StreamIO: TEXT_STREAM_IO_1997 + + type vector = StreamIO.vector + type elem = StreamIO.elem + type instream + + val canInput: instream * int -> int option + val closeIn: instream -> unit + val endOfStream: instream -> bool + val getInstream: instream -> StreamIO.instream + val input1: instream -> elem option + val input: instream -> vector + val inputAll: instream -> vector + val inputLine: instream -> string + val inputN: instream * int -> vector + val lookahead: instream -> elem option + val mkInstream: StreamIO.instream -> instream + val openIn: string -> instream + val print: string -> unit + val scanStream: + ((Char.char, StreamIO.instream) StringCvt.reader + -> ('a, StreamIO.instream) StringCvt.reader) + -> instream -> 'a option + val setInstream: (instream * StreamIO.instream) -> unit + val stdIn: instream +(* + val openString: string -> instream + val getPosIn: instream -> StreamIO.in_pos + val setPosIn: (instream * StreamIO.in_pos) -> unit +*) + + type outstream + val closeOut: outstream -> unit + val flushOut: outstream -> unit + val getOutstream: outstream -> StreamIO.outstream + val getPosOut: outstream -> StreamIO.out_pos + val mkOutstream: StreamIO.outstream -> outstream + val openAppend: string -> outstream + val openOut: string -> outstream + val output1: outstream * elem -> unit + val output: outstream * vector -> unit + val outputSubstr: outstream * substring -> unit + val setOutstream: outstream * StreamIO.outstream -> unit + val stdErr: outstream + val stdOut: outstream +(* + val setPosOut: outstream * StreamIO.out_pos -> unit +*) + end diff --git a/basis-library/libs/basis-1997/io/text-stream-io.sig b/basis-library/libs/basis-1997/io/text-stream-io.sig new file mode 100644 index 0000000..c44ad62 --- /dev/null +++ b/basis-library/libs/basis-1997/io/text-stream-io.sig @@ -0,0 +1,11 @@ +signature TEXT_STREAM_IO_1997 = + sig + include STREAM_IO_1997 + where type vector = CharVector.vector + where type elem = Char.char + + val inputLine: instream -> string * instream +(* + val outputSubstr: outstream * substring -> unit +*) + end diff --git a/basis-library/libs/basis-1997/posix/file-sys-convert.fun b/basis-library/libs/basis-1997/posix/file-sys-convert.fun new file mode 100644 index 0000000..162627a --- /dev/null +++ b/basis-library/libs/basis-1997/posix/file-sys-convert.fun @@ -0,0 +1,29 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor PosixFileSysConvert + (structure FileSys: POSIX_FILE_SYS) : + POSIX_FILE_SYS_1997 = + struct + open FileSys + val readdir = fn d => + case readdir d of + NONE => "" + | SOME s => s + structure S = + struct + open S + structure Flags = FlagsConvert(structure Flags = S) + open Flags + end + structure O = + struct + open O + structure Flags = FlagsConvert(structure Flags = O) + open Flags + end + end diff --git a/basis-library/libs/basis-1997/posix/file-sys.sig b/basis-library/libs/basis-1997/posix/file-sys.sig new file mode 100644 index 0000000..66fe904 --- /dev/null +++ b/basis-library/libs/basis-1997/posix/file-sys.sig @@ -0,0 +1,124 @@ +signature POSIX_FILE_SYS_1997 = + sig + eqtype uid + eqtype gid + eqtype file_desc + + val fdToWord: file_desc -> SysWord.word + val wordToFD: SysWord.word -> file_desc + + (* identity functions *) + val fdToIOD: file_desc -> OS.IO.iodesc + val iodToFD: OS.IO.iodesc -> file_desc option + + type dirstream + val opendir: string -> dirstream + val readdir: dirstream -> string + val rewinddir: dirstream -> unit + val closedir: dirstream -> unit + + val chdir: string -> unit + val getcwd: unit -> string + + val stdin: file_desc + val stdout: file_desc + val stderr: file_desc + + structure S: + sig + eqtype mode + include POSIX_FLAGS_1997 where type flags = mode + + val irwxu: mode + val irusr: mode + val iwusr: mode + val ixusr: mode + val irwxg: mode + val irgrp: mode + val iwgrp: mode + val ixgrp: mode + val irwxo: mode + val iroth: mode + val iwoth: mode + val ixoth: mode + val isuid: mode + val isgid: mode + end + + structure O: + sig + include POSIX_FLAGS_1997 + + val append: flags + val excl: flags + val noctty: flags + val nonblock: flags + val sync: flags + val trunc: flags + end + + datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR + + val openf: string * open_mode * O.flags -> file_desc + val createf: string * open_mode * O.flags * S.mode -> file_desc + val creat: string * S.mode -> file_desc + val umask: S.mode -> S.mode + val link: {old: string, new: string} -> unit + val mkdir: string * S.mode -> unit + val mkfifo: string * S.mode -> unit + val unlink: string -> unit + val rmdir: string -> unit + val rename: {old: string, new: string} -> unit + val symlink: {old: string, new: string} -> unit + val readlink: string -> string + + eqtype dev + val wordToDev: SysWord.word -> dev + val devToWord: dev -> SysWord.word + + eqtype ino + val wordToIno: SysWord.word -> ino + val inoToWord: ino -> SysWord.word + + structure ST: + sig + type stat + + val isDir: stat -> bool + val isChr: stat -> bool + val isBlk: stat -> bool + val isReg: stat -> bool + val isFIFO: stat -> bool + val isLink: stat -> bool + val isSock: stat -> bool + val mode: stat -> S.mode + val ino: stat -> ino + val dev: stat -> dev + val nlink: stat -> int + val uid: stat -> uid + val gid: stat -> gid + val size: stat -> Position.int + val atime: stat -> Time.time + val mtime: stat -> Time.time + val ctime: stat -> Time.time + end + + val stat: string -> ST.stat + val lstat: string -> ST.stat + val fstat: file_desc -> ST.stat + + datatype access_mode = + A_READ + | A_WRITE + | A_EXEC + + val access: string * access_mode list -> bool + val chmod: string * S.mode -> unit + val fchmod: file_desc * S.mode -> unit + val chown: string * uid * gid -> unit + val fchown: file_desc * uid * gid -> unit + val utime: string * {actime: Time.time, modtime: Time.time} option -> unit + val ftruncate: file_desc * Position.int -> unit + val pathconf: string * string -> SysWord.word option + val fpathconf: file_desc * string -> SysWord.word option + end diff --git a/basis-library/libs/basis-1997/posix/flags-convert.fun b/basis-library/libs/basis-1997/posix/flags-convert.fun new file mode 100644 index 0000000..88aab3f --- /dev/null +++ b/basis-library/libs/basis-1997/posix/flags-convert.fun @@ -0,0 +1,14 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor FlagsConvert + (structure Flags: BIT_FLAGS) : + POSIX_FLAGS_1997 where type flags = Flags.flags = + struct + open Flags + val wordTo = fromWord + end diff --git a/basis-library/libs/basis-1997/posix/flags.sig b/basis-library/libs/basis-1997/posix/flags.sig new file mode 100644 index 0000000..8cc15c1 --- /dev/null +++ b/basis-library/libs/basis-1997/posix/flags.sig @@ -0,0 +1,10 @@ +signature POSIX_FLAGS_1997 = + sig + eqtype flags + + val toWord: flags -> SysWord.word + val wordTo: SysWord.word -> flags + val flags: flags list -> flags + val allSet: flags * flags -> bool + val anySet: flags * flags -> bool + end diff --git a/basis-library/libs/basis-1997/posix/io-convert.fun b/basis-library/libs/basis-1997/posix/io-convert.fun new file mode 100644 index 0000000..a5c61bf --- /dev/null +++ b/basis-library/libs/basis-1997/posix/io-convert.fun @@ -0,0 +1,34 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor PosixIOConvert (structure IO: POSIX_IO): POSIX_IO_1997 = + struct + open IO + + structure FD = + struct + open FD + structure Flags = FlagsConvert (structure Flags = FD) + open Flags + end + + structure O = + struct + open O + structure Flags = FlagsConvert (structure Flags = O) + open Flags + end + + fun readArr (fd, {buf, i, sz}) = + IO.readArr (fd, Word8ArraySlice.slice (buf, i, sz)) + + fun writeArr (fd, {buf, i, sz}) = + IO.writeArr (fd, Word8ArraySlice.slice (buf, i, sz)) + + fun writeVec (fd, {buf, i, sz}) = + IO.writeVec (fd, Word8VectorSlice.slice (buf, i, sz)) + end diff --git a/basis-library/libs/basis-1997/posix/io.sig b/basis-library/libs/basis-1997/posix/io.sig new file mode 100644 index 0000000..d4af376 --- /dev/null +++ b/basis-library/libs/basis-1997/posix/io.sig @@ -0,0 +1,75 @@ +signature POSIX_IO_1997 = + sig + eqtype file_desc + eqtype pid + + val pipe: unit -> {infd: file_desc, outfd: file_desc} + val dup: file_desc -> file_desc + val dup2: {old: file_desc, new: file_desc} -> unit + + val close: file_desc -> unit + val readVec: file_desc * int -> Word8Vector.vector + val readArr: file_desc * {buf: Word8Array.array, + i: int, + sz: int option} -> int + val writeVec: file_desc * {buf: Word8Vector.vector, + i: int, + sz: int option} -> int + val writeArr: file_desc * {buf: Word8Array.array, + i: int, + sz: int option} -> int + + datatype whence = SEEK_SET | SEEK_CUR | SEEK_END + + structure FD: + sig + include POSIX_FLAGS_1997 + + val cloexec: flags + end + + structure O: + sig + include POSIX_FLAGS_1997 + + val append: flags + val nonblock: flags + val sync: flags + end + + datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR + + val dupfd: {old: file_desc, base: file_desc} -> file_desc + val getfd: file_desc -> FD.flags + val setfd: file_desc * FD.flags -> unit + val getfl: file_desc -> O.flags * open_mode + val setfl: file_desc * O.flags -> unit + val lseek: file_desc * Position.int * whence -> Position.int + val fsync: file_desc -> unit + + datatype lock_type = + F_RDLCK + | F_WRLCK + | F_UNLCK + + structure FLock: + sig + type flock + val flock: { + ltype: lock_type, + whence: whence, + start: Position.int, + len: Position.int, + pid: pid option + } -> flock + val ltype: flock -> lock_type + val whence: flock -> whence + val start: flock -> Position.int + val len: flock -> Position.int + val pid: flock -> pid option + end + + val getlk: file_desc * FLock.flock -> FLock.flock + val setlk: file_desc * FLock.flock -> FLock.flock + val setlkw: file_desc * FLock.flock -> FLock.flock + end diff --git a/basis-library/libs/basis-1997/posix/posix-convert.fun b/basis-library/libs/basis-1997/posix/posix-convert.fun new file mode 100644 index 0000000..483876f --- /dev/null +++ b/basis-library/libs/basis-1997/posix/posix-convert.fun @@ -0,0 +1,17 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor PosixConvert + (structure Posix : POSIX) : + POSIX_1997 = + struct + open Posix + structure Process = PosixProcessConvert(structure Process = Process) + structure FileSys = PosixFileSysConvert(structure FileSys = FileSys) + structure IO = PosixIOConvert(structure IO = IO) + structure TTY = PosixTTYConvert(structure TTY = TTY) + end diff --git a/basis-library/libs/basis-1997/posix/posix.sig b/basis-library/libs/basis-1997/posix/posix.sig new file mode 100644 index 0000000..75c49ba --- /dev/null +++ b/basis-library/libs/basis-1997/posix/posix.sig @@ -0,0 +1,11 @@ +signature POSIX_1997 = + sig + structure Error: POSIX_ERROR + structure Signal: POSIX_SIGNAL + structure Process: POSIX_PROCESS_1997 + structure ProcEnv: POSIX_PROC_ENV + structure FileSys: POSIX_FILE_SYS_1997 + structure IO: POSIX_IO_1997 + structure SysDB: POSIX_SYS_DB + structure TTY: POSIX_TTY_1997 + end diff --git a/basis-library/libs/basis-1997/posix/process-convert.fun b/basis-library/libs/basis-1997/posix/process-convert.fun new file mode 100644 index 0000000..981a79b --- /dev/null +++ b/basis-library/libs/basis-1997/posix/process-convert.fun @@ -0,0 +1,19 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor PosixProcessConvert + (structure Process: POSIX_PROCESS) : + POSIX_PROCESS_1997 = + struct + open Process + structure W = + struct + open W + structure Flags = FlagsConvert(structure Flags = W) + open Flags + end + end diff --git a/basis-library/libs/basis-1997/posix/process.sig b/basis-library/libs/basis-1997/posix/process.sig new file mode 100644 index 0000000..bd10645 --- /dev/null +++ b/basis-library/libs/basis-1997/posix/process.sig @@ -0,0 +1,45 @@ +signature POSIX_PROCESS_1997 = + sig + eqtype signal + eqtype pid + + val wordToPid: SysWord.word -> pid + val pidToWord: pid -> SysWord.word + val fork: unit -> pid option + val exec: string * string list -> 'a + val exece: string * string list * string list -> 'a + val execp: string * string list -> 'a + + datatype waitpid_arg = + W_ANY_CHILD + | W_CHILD of pid + | W_SAME_GROUP + | W_GROUP of pid + + datatype exit_status = + W_EXITED + | W_EXITSTATUS of Word8.word + | W_SIGNALED of signal + | W_STOPPED of signal + + structure W : + sig + include POSIX_FLAGS_1997 + val untraced: flags + end + + val wait: unit -> pid * exit_status + val waitpid: waitpid_arg * W.flags list -> pid * exit_status + val waitpid_nh: waitpid_arg * W.flags list -> (pid * exit_status) option + val exit: Word8.word -> 'a + + datatype killpid_arg = + K_PROC of pid + | K_SAME_GROUP + | K_GROUP of pid + + val kill: killpid_arg * signal -> unit + val alarm: Time.time -> Time.time + val pause: unit -> unit + val sleep: Time.time -> Time.time + end diff --git a/basis-library/libs/basis-1997/posix/tty-convert.fun b/basis-library/libs/basis-1997/posix/tty-convert.fun new file mode 100644 index 0000000..a10b748 --- /dev/null +++ b/basis-library/libs/basis-1997/posix/tty-convert.fun @@ -0,0 +1,38 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor PosixTTYConvert + (structure TTY: POSIX_TTY) : + POSIX_TTY_1997 = + struct + open TTY + structure I = + struct + open I + structure Flags = FlagsConvert(structure Flags = I) + open Flags + end + structure O = + struct + open O + structure Flags = FlagsConvert(structure Flags = O) + open Flags + end + structure C = + struct + open C + structure Flags = FlagsConvert(structure Flags = C) + open Flags + end + structure L = + struct + open L + structure Flags = FlagsConvert(structure Flags = L) + open Flags + end + open TC + end diff --git a/basis-library/libs/basis-1997/posix/tty.sig b/basis-library/libs/basis-1997/posix/tty.sig new file mode 100644 index 0000000..2d3044c --- /dev/null +++ b/basis-library/libs/basis-1997/posix/tty.sig @@ -0,0 +1,165 @@ +signature POSIX_TTY_1997 = + sig + eqtype pid + eqtype file_desc + + structure V: + sig + val eof: int + val eol: int + val erase: int + val intr: int + val kill: int + val min: int + val quit: int + val susp: int + val time: int + val start: int + val stop: int + val nccs: int + + type cc + val cc: (int * char) list -> cc + val update: cc * (int * char) list -> cc + val sub: cc * int -> char + end + + structure I: + sig + include POSIX_FLAGS_1997 + val brkint: flags + val icrnl: flags + val ignbrk: flags + val igncr: flags + val ignpar: flags + val inlcr: flags + val inpck: flags + val istrip: flags + val ixoff: flags + val ixon: flags + val parmrk: flags + end + + structure O: + sig + include POSIX_FLAGS_1997 + val opost: flags + end + + structure C: + sig + include POSIX_FLAGS_1997 + val clocal: flags + val cread: flags + val cs5: flags + val cs6: flags + val cs7: flags + val cs8: flags + val csize: flags + val cstopb: flags + val hupcl: flags + val parenb: flags + val parodd: flags + end + + structure L: + sig + include POSIX_FLAGS_1997 + val echo: flags + val echoe: flags + val echok: flags + val echonl: flags + val icanon: flags + val iexten: flags + val isig: flags + val noflsh: flags + val tostop: flags + end + + eqtype speed + + val compareSpeed: speed * speed -> order + val speedToWord: speed -> SysWord.word + val wordToSpeed: SysWord.word -> speed + + val b0: speed + val b50: speed + val b75: speed + val b110: speed + val b134: speed + val b150: speed + val b200: speed + val b300: speed + val b600: speed + val b1200: speed + val b1800: speed + val b2400: speed + val b4800: speed + val b9600: speed + val b19200: speed + val b38400: speed + + type termios + + val termios: {iflag: I.flags, + oflag: O.flags, + cflag: C.flags, + lflag: L.flags, + cc: V.cc, + ispeed: speed, + ospeed: speed} -> termios + + val fieldsOf: termios -> {iflag: I.flags, + oflag: O.flags, + cflag: C.flags, + lflag: L.flags, + cc: V.cc, + ispeed: speed, + ospeed: speed} + val getiflag: termios -> I.flags + val getoflag: termios -> O.flags + val getcflag: termios -> C.flags + val getlflag: termios -> L.flags + val getcc: termios -> V.cc + + structure CF: + sig + val getospeed: termios -> speed + val setospeed: termios * speed -> termios + val getispeed: termios -> speed + val setispeed: termios * speed -> termios + end + + structure TC: + sig + eqtype set_action + + val sanow: set_action + val sadrain: set_action + val saflush: set_action + + eqtype flow_action + + val ooff: flow_action + val oon: flow_action + val ioff: flow_action + val ion: flow_action + + eqtype queue_sel + + val iflush: queue_sel + val oflush: queue_sel + val ioflush: queue_sel + end + + val getattr: file_desc -> termios + val setattr: file_desc * TC.set_action * termios -> unit + + val sendbreak: file_desc * int -> unit + val drain: file_desc -> unit + val flush: file_desc * TC.queue_sel -> unit + val flow: file_desc * TC.flow_action -> unit + + val getpgrp: file_desc -> pid + val setpgrp: file_desc * pid -> unit + end diff --git a/basis-library/libs/basis-1997/real/IEEE-real-convert.fun b/basis-library/libs/basis-1997/real/IEEE-real-convert.fun new file mode 100644 index 0000000..87db138 --- /dev/null +++ b/basis-library/libs/basis-1997/real/IEEE-real-convert.fun @@ -0,0 +1,55 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor IEEERealConvert + (structure IEEEReal: IEEE_REAL): + sig + include IEEE_REAL_1997 + val >> : IEEEReal.float_class -> float_class + val << : float_class -> IEEEReal.float_class + val >>> : IEEEReal.decimal_approx -> decimal_approx + val <<< : decimal_approx -> IEEEReal.decimal_approx + end = + struct + open IEEEReal + + datatype nan_mode = QUIET | SIGNALLING + datatype float_class = + NAN of nan_mode + | INF + | ZERO + | NORMAL + | SUBNORMAL + val >> = + fn IEEEReal.NAN => NAN QUIET + | IEEEReal.INF => INF + | IEEEReal.ZERO => ZERO + | IEEEReal.NORMAL => NORMAL + | IEEEReal.SUBNORMAL => SUBNORMAL + val << = + fn NAN _ => IEEEReal.NAN + | INF => IEEEReal.INF + | ZERO => IEEEReal.ZERO + | NORMAL => IEEEReal.NORMAL + | SUBNORMAL => IEEEReal.SUBNORMAL + + type decimal_approx = {kind: float_class, sign: bool, + digits: int list, exp: int} + + val <<< = fn {kind, sign, digits, exp} => + {class = << kind, sign = sign, + digits = digits, exp = exp} + val >>> = fn {class, sign, digits, exp} => + {kind = >> class, sign = sign, + digits = digits, exp = exp} + + val toString = toString o <<< + val fromString = fn s => + Option.map (>>>) (fromString s) + end + +structure IEEEReal1997 = IEEERealConvert(structure IEEEReal = IEEEReal) diff --git a/basis-library/libs/basis-1997/real/IEEE-real.sig b/basis-library/libs/basis-1997/real/IEEE-real.sig new file mode 100644 index 0000000..57bbac2 --- /dev/null +++ b/basis-library/libs/basis-1997/real/IEEE-real.sig @@ -0,0 +1,23 @@ +signature IEEE_REAL_1997 = + sig + exception Unordered + datatype real_order = LESS | EQUAL | GREATER | UNORDERED + datatype nan_mode = QUIET | SIGNALLING + datatype float_class = + NAN of nan_mode + | INF + | ZERO + | NORMAL + | SUBNORMAL + datatype rounding_mode = + TO_NEAREST + | TO_NEGINF + | TO_POSINF + | TO_ZERO + val setRoundingMode: rounding_mode -> unit + val getRoundingMode: unit -> rounding_mode + type decimal_approx = {kind: float_class, sign: bool, + digits: int list, exp: int} + val toString: decimal_approx -> string + val fromString: string -> decimal_approx option + end diff --git a/basis-library/libs/basis-1997/real/real-convert.fun b/basis-library/libs/basis-1997/real/real-convert.fun new file mode 100644 index 0000000..00f5ea5 --- /dev/null +++ b/basis-library/libs/basis-1997/real/real-convert.fun @@ -0,0 +1,17 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor RealConvert + (structure Real: REAL) : + REAL_1997 = + struct + open Real + + val class = IEEEReal1997.>> o class + val toDecimal = IEEEReal1997.>>> o toDecimal + val fromDecimal = fromDecimal o IEEEReal1997.<<< + end diff --git a/basis-library/libs/basis-1997/real/real.sig b/basis-library/libs/basis-1997/real/real.sig new file mode 100644 index 0000000..94dd8fb --- /dev/null +++ b/basis-library/libs/basis-1997/real/real.sig @@ -0,0 +1,68 @@ +signature REAL_1997 = + sig + type real + structure Math: MATH where type real = real + + val ceil: real -> Int.int + val floor: real -> Int.int + val round: real -> Int.int + val trunc: real -> Int.int + + val radix: int + val precision: int + val maxFinite: real + val minPos: real + val minNormalPos: real + val posInf: real + val negInf: real + val + : real * real -> real + val - : real * real -> real + val * : real * real -> real + val / : real * real -> real + val rem: real * real -> real + val *+ : real * real * real -> real + val *- : real * real * real -> real + val ~ : real -> real + val abs: real -> real + val min: real * real -> real + val max: real * real -> real + val sign: real -> int + val signBit: real -> bool + val sameSign: real * real -> bool + val copySign: real * real -> real + val compare: real * real -> order + val compareReal: real * real -> IEEEReal1997.real_order + val < : real * real -> bool + val <= : real * real -> bool + val > : real * real -> bool + val >= : real * real -> bool + val == : real * real -> bool + val != : real * real -> bool + val ?= : real * real -> bool + val unordered: real * real -> bool + val isFinite: real -> bool + val isNan: real -> bool + val isNormal: real -> bool + val class: real -> IEEEReal1997.float_class + val fmt: StringCvt.realfmt -> real -> string + val toString: real -> string + val scan: (char, 'a) StringCvt.reader -> (real, 'a) StringCvt.reader + val fromString: string -> real option + val toManExp: real -> {man: real, exp: int} + val fromManExp: {man: real, exp: int} -> real + val split: real -> {whole: real, frac: real} + val realMod: real -> real + val nextAfter: real * real -> real + val checkFloat: real -> real + val realFloor: real -> real + val realCeil: real -> real + val realTrunc: real -> real + val toInt: IEEEReal1997.rounding_mode -> real -> int + val toLargeInt: IEEEReal1997.rounding_mode -> real -> LargeInt.int + val fromInt: int -> real + val fromLargeInt: LargeInt.int -> real + val toLarge: real -> LargeReal.real + val fromLarge: IEEEReal1997.rounding_mode -> LargeReal.real -> real + val toDecimal: real -> IEEEReal1997.decimal_approx + val fromDecimal: IEEEReal1997.decimal_approx -> real option + end diff --git a/basis-library/libs/basis-1997/system/file-sys-convert.fun b/basis-library/libs/basis-1997/system/file-sys-convert.fun new file mode 100644 index 0000000..3db0041 --- /dev/null +++ b/basis-library/libs/basis-1997/system/file-sys-convert.fun @@ -0,0 +1,17 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor OSFileSysConvert + (structure FileSys : OS_FILE_SYS) : + OS_FILE_SYS_1997 = + struct + open FileSys + val readDir = fn d => + case readDir d of + NONE => "" + | SOME s => s + end diff --git a/basis-library/libs/basis-1997/system/file-sys.sig b/basis-library/libs/basis-1997/system/file-sys.sig new file mode 100644 index 0000000..d8fbc26 --- /dev/null +++ b/basis-library/libs/basis-1997/system/file-sys.sig @@ -0,0 +1,37 @@ +signature OS_FILE_SYS_1997 = + sig + type dirstream + + val openDir: string -> dirstream + val readDir: dirstream -> string + val rewindDir: dirstream -> unit + val closeDir: dirstream -> unit + val chDir: string -> unit + + val getDir: unit -> string + val mkDir: string -> unit + val rmDir: string -> unit + val isDir: string -> bool + val isLink: string -> bool + val readLink: string -> string + val fullPath: string -> string + val realPath: string -> string + val modTime: string -> Time.time + val fileSize: string -> Position.int + val setTime: string * Time.time option -> unit + val remove: string -> unit + val rename: {old: string, new: string} -> unit + + datatype access_mode = + A_READ + | A_WRITE + | A_EXEC + + val access: string * access_mode list -> bool + val tmpName: unit -> string + + eqtype file_id + val fileId: string -> file_id + val hash: file_id -> word + val compare: file_id * file_id -> order + end diff --git a/basis-library/libs/basis-1997/system/os-convert.fun b/basis-library/libs/basis-1997/system/os-convert.fun new file mode 100644 index 0000000..7575cb4 --- /dev/null +++ b/basis-library/libs/basis-1997/system/os-convert.fun @@ -0,0 +1,16 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor OSConvert + (structure OS: OS) : + OS_1997 = + struct + open OS + structure FileSys = OSFileSysConvert(structure FileSys = FileSys) + structure Path = OSPathConvert(structure Path = Path) + structure Process = OSProcessConvert(structure Process = Process) + end diff --git a/basis-library/libs/basis-1997/system/os.sig b/basis-library/libs/basis-1997/system/os.sig new file mode 100644 index 0000000..13961f3 --- /dev/null +++ b/basis-library/libs/basis-1997/system/os.sig @@ -0,0 +1,15 @@ +signature OS_1997 = + sig + eqtype syserror + + exception SysErr of string * syserror option + + val errorMsg: syserror -> string + val errorName: syserror -> string + val syserror: string -> syserror option + + structure FileSys: OS_FILE_SYS_1997 + structure Path: OS_PATH_1997 + structure Process: OS_PROCESS_1997 + structure IO: OS_IO + end diff --git a/basis-library/libs/basis-1997/system/path-convert.fun b/basis-library/libs/basis-1997/system/path-convert.fun new file mode 100644 index 0000000..ef6dabc --- /dev/null +++ b/basis-library/libs/basis-1997/system/path-convert.fun @@ -0,0 +1,18 @@ +(* Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor OSPathConvert + (structure Path : OS_PATH) : + OS_PATH_1997 = + struct + open Path + + val mkAbsolute = fn (path, relativeTo) => + mkAbsolute {path = path, relativeTo = relativeTo} + val mkRelative = fn (path, relativeTo) => + mkRelative {path = path, relativeTo = relativeTo} + end diff --git a/basis-library/libs/basis-1997/system/path.sig b/basis-library/libs/basis-1997/system/path.sig new file mode 100644 index 0000000..60ff8fa --- /dev/null +++ b/basis-library/libs/basis-1997/system/path.sig @@ -0,0 +1,30 @@ +signature OS_PATH_1997 = + sig + exception Path + exception InvalidArc + val parentArc : string + val currentArc : string + val validVolume : {isAbs : bool, vol : string} -> bool + val fromString : string -> {isAbs : bool, vol : string, arcs : string list} + val toString : {isAbs : bool, vol : string, arcs : string list} -> string + val getVolume : string -> string + val getParent : string -> string + val splitDirFile : string -> {dir : string, file : string} + val joinDirFile : {dir : string, file : string} -> string + val dir : string -> string + val file : string -> string + val splitBaseExt : string -> {base : string, ext : string option} + val joinBaseExt : {base : string, ext : string option} -> string + val base : string -> string + val ext : string -> string option + val mkCanonical : string -> string + val isCanonical : string -> bool + val mkAbsolute : (string * string) -> string + val mkRelative : (string * string) -> string + val isAbsolute : string -> bool + val isRelative : string -> bool + val isRoot : string -> bool + val concat : (string * string) -> string + val toUnixPath : string -> string + val fromUnixPath : string -> string + end diff --git a/basis-library/libs/basis-1997/system/process-convert.fun b/basis-library/libs/basis-1997/system/process-convert.fun new file mode 100644 index 0000000..c815ac2 --- /dev/null +++ b/basis-library/libs/basis-1997/system/process-convert.fun @@ -0,0 +1,13 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor OSProcessConvert + (structure Process : OS_PROCESS) : + OS_PROCESS_1997 = + struct + open Process + end diff --git a/basis-library/libs/basis-1997/system/process.sig b/basis-library/libs/basis-1997/system/process.sig new file mode 100644 index 0000000..670d158 --- /dev/null +++ b/basis-library/libs/basis-1997/system/process.sig @@ -0,0 +1,16 @@ +signature OS_PROCESS_1997 = + sig + (* VIOLATION *) +(* + eqtype status +*) + type status + + val atExit: (unit -> unit) -> unit + val exit: status -> 'a + val failure: status + val getEnv: string -> string option + val success: status + val system: string -> status + val terminate: status -> 'a + end diff --git a/basis-library/libs/basis-1997/system/timer-convert.fun b/basis-library/libs/basis-1997/system/timer-convert.fun new file mode 100644 index 0000000..3d3b2d0 --- /dev/null +++ b/basis-library/libs/basis-1997/system/timer-convert.fun @@ -0,0 +1,21 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor TimerConvert + (structure Timer: TIMER) : + TIMER_1997 = + struct + open Timer + + val checkCPUTimer = fn cput => + let + val {usr, sys} = checkCPUTimer cput + val gc = checkGCTime cput + in + {usr = usr, sys = sys, gc = gc} + end + end diff --git a/basis-library/libs/basis-1997/system/timer.sig b/basis-library/libs/basis-1997/system/timer.sig new file mode 100644 index 0000000..6c363c9 --- /dev/null +++ b/basis-library/libs/basis-1997/system/timer.sig @@ -0,0 +1,11 @@ +signature TIMER_1997 = + sig + type cpu_timer + type real_timer + val startCPUTimer: unit -> cpu_timer + val checkCPUTimer: cpu_timer -> {usr: Time.time, sys: Time.time, gc: Time.time} + val totalCPUTimer: unit -> cpu_timer + val startRealTimer: unit -> real_timer + val checkRealTimer: real_timer -> Time.time + val totalRealTimer: unit -> real_timer + end diff --git a/basis-library/libs/basis-1997/system/unix-convert.fun b/basis-library/libs/basis-1997/system/unix-convert.fun new file mode 100644 index 0000000..4597c74 --- /dev/null +++ b/basis-library/libs/basis-1997/system/unix-convert.fun @@ -0,0 +1,14 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor UnixConvert + (structure Unix: UNIX) : + UNIX_1997 = + struct + open Unix + type proc = (TextIO.instream, TextIO.outstream) proc + end diff --git a/basis-library/libs/basis-1997/system/unix.sig b/basis-library/libs/basis-1997/system/unix.sig new file mode 100644 index 0000000..aa007ea --- /dev/null +++ b/basis-library/libs/basis-1997/system/unix.sig @@ -0,0 +1,11 @@ +signature UNIX_1997 = + sig + type proc + type signal + + val executeInEnv: string * string list * string list -> proc + val execute: string * string list -> proc + val streamsOf: proc -> TextIO.instream * TextIO.outstream + val reap: proc -> OS.Process.status + val kill: proc * signal -> unit + end diff --git a/basis-library/libs/basis-1997/text/string.sig b/basis-library/libs/basis-1997/text/string.sig new file mode 100644 index 0000000..9561e7f --- /dev/null +++ b/basis-library/libs/basis-1997/text/string.sig @@ -0,0 +1,31 @@ +signature STRING_1997 = + sig + eqtype string + structure Char: CHAR + val maxSize: int + val size: string -> int + val sub: (string * int) -> Char.char + val extract: (string * int * int option) -> string + val substring: (string * int * int) -> string + val concat: string list -> string + val ^ : (string * string) -> string + val str: Char.char -> string + val implode: Char.char list -> string + val explode: string -> Char.char list + val map: (Char.char -> Char.char) -> string -> string + val translate: (Char.char -> string) -> string -> string + val tokens: (Char.char -> bool) -> string -> string list + val fields: (Char.char -> bool) -> string -> string list + val isPrefix: string -> string -> bool + val compare: (string * string) -> order + val collate: (((Char.char * Char.char) -> order) + -> (string * string) -> order) + val < : (string * string) -> bool + val <= : (string * string) -> bool + val > : (string * string) -> bool + val >= : (string * string) -> bool + val fromString: String.string -> string option + val toString: string -> String.string + val fromCString: String.string -> string option + val toCString: string -> String.string + end diff --git a/basis-library/libs/basis-1997/text/substring.sig b/basis-library/libs/basis-1997/text/substring.sig new file mode 100644 index 0000000..d1689f0 --- /dev/null +++ b/basis-library/libs/basis-1997/text/substring.sig @@ -0,0 +1,42 @@ +signature SUBSTRING_1997 = + sig + structure String: STRING_1997 + type substring + val base: substring -> (String.string * int * int) + val string: substring -> String.string + val extract: (String.string * int * int option) -> substring + val substring: (String.string * int * int) -> substring + val all: String.string -> substring + val isEmpty: substring -> bool + val getc: substring -> (String.Char.char * substring) option + val first: substring -> String.Char.char option + val triml: int -> substring -> substring + val trimr: int -> substring -> substring + val slice: (substring * int * int option) -> substring + val sub: (substring * int) -> String.Char.char + val size: substring -> int + val concat: substring list -> String.string + val explode: substring -> String.Char.char list + val isPrefix: String.string -> substring -> bool + val compare: (substring * substring) -> order + val collate: ((String.Char.char * String.Char.char) -> order) + -> (substring * substring) -> order + val splitl: ((String.Char.char -> bool) + -> substring -> (substring * substring)) + val splitr: ((String.Char.char -> bool) + -> substring -> (substring * substring)) + val splitAt: (substring * int) -> (substring * substring) + val dropl: (String.Char.char -> bool) -> substring -> substring + val dropr: (String.Char.char -> bool) -> substring -> substring + val takel: (String.Char.char -> bool) -> substring -> substring + val taker: (String.Char.char -> bool) -> substring -> substring + val position: String.string -> substring -> (substring * substring) + val span: (substring * substring) -> substring + val translate: ((String.Char.char -> String.string) + -> substring -> String.string) + val tokens: (String.Char.char -> bool) -> substring -> substring list + val fields: (String.Char.char -> bool) -> substring -> substring list + val foldl: ((String.Char.char * 'a) -> 'a) -> 'a -> substring -> 'a + val foldr: ((String.Char.char * 'a) -> 'a) -> 'a -> substring -> 'a + val app: (String.Char.char -> unit) -> substring -> unit + end diff --git a/basis-library/libs/basis-1997/text/text-convert.fun b/basis-library/libs/basis-1997/text/text-convert.fun new file mode 100644 index 0000000..eba06ec --- /dev/null +++ b/basis-library/libs/basis-1997/text/text-convert.fun @@ -0,0 +1,29 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor TextConvert (structure Text: TEXT): + sig + structure Char: CHAR + structure String: STRING_1997 + structure Substring: SUBSTRING_1997 + sharing type Char.char = String.Char.char = Substring.String.Char.char + sharing type String.string = Substring.String.string + end = + struct + structure Char = Text.Char + structure String = + struct + structure Char = Char + open Text.String + end + structure Substring = + struct + structure String = String + open Text.Substring + val all = full + end + end diff --git a/basis-library/libs/basis-1997/top-level/basis-funs.sml b/basis-library/libs/basis-1997/top-level/basis-funs.sml new file mode 100644 index 0000000..7e878ce --- /dev/null +++ b/basis-library/libs/basis-1997/top-level/basis-funs.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Required functors *) + +(* Optional functors *) diff --git a/basis-library/libs/basis-1997/top-level/basis-sigs.sml b/basis-library/libs/basis-1997/top-level/basis-sigs.sml new file mode 100644 index 0000000..362894f --- /dev/null +++ b/basis-library/libs/basis-1997/top-level/basis-sigs.sml @@ -0,0 +1,69 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Required signatures *) +signature CHAR = CHAR +signature INTEGER = INTEGER +signature MATH = MATH +signature IMPERATIVE_IO = IMPERATIVE_IO +signature MONO_ARRAY = MONO_ARRAY_1997 +signature MONO_VECTOR = MONO_VECTOR_1997 +signature PRIM_IO = PRIM_IO +signature REAL = REAL_1997 +signature STREAM_IO = STREAM_IO +signature STRING = STRING_1997 +signature SUBSTRING = SUBSTRING_1997 +signature TEXT_IO = TEXT_IO +signature TEXT_STREAM_IO = TEXT_STREAM_IO +signature WORD = WORD_1997 + +signature ARRAY = ARRAY_1997 +signature BIN_IO = BIN_IO +signature BOOL = BOOL +signature BYTE = BYTE +signature COMMAND_LINE = COMMAND_LINE +signature DATE = DATE +signature GENERAL = GENERAL +signature IEEE_REAL = IEEE_REAL_1997 +signature IO = IO_1997 +signature LIST = LIST +signature LIST_PAIR = LIST_PAIR +signature OPTION = OPTION +signature OS = OS_1997 +signature OS_FILE_SYS = OS_FILE_SYS_1997 +signature OS_PATH = OS_PATH_1997 +signature OS_PROCESS = OS_PROCESS_1997 +signature OS_IO = OS_IO +signature SML90 = SML90 +signature STRING_CVT = STRING_CVT +signature TIME = TIME +signature TIMER = TIMER_1997 +signature VECTOR = VECTOR_1997 + +(* Optional signatures *) +signature ARRAY2 = ARRAY2 +signature INT_INF = INT_INF +(* +signature LOCALE = LOCALE +*) +signature MONO_ARRAY2 = MONO_ARRAY2_1997 +(* +signature MULTIBYTE = MULTIBYTE +*) +signature PACK_REAL = PACK_REAL +signature PACK_WORD = PACK_WORD +signature POSIX_FLAGS = POSIX_FLAGS_1997 +signature POSIX = POSIX_1997 +signature POSIX_ERROR = POSIX_ERROR +signature POSIX_SIGNAL = POSIX_SIGNAL +signature POSIX_PROCESS = POSIX_PROCESS_1997 +signature POSIX_PROC_ENV = POSIX_PROC_ENV +signature POSIX_FILE_SYS = POSIX_FILE_SYS_1997 +signature POSIX_IO = POSIX_IO_1997 +signature POSIX_SYS_DB = POSIX_SYS_DB +signature POSIX_TTY = POSIX_TTY_1997 +signature UNIX = UNIX_1997 diff --git a/basis-library/libs/basis-1997/top-level/basis.sig b/basis-library/libs/basis-1997/top-level/basis.sig new file mode 100644 index 0000000..1e64ffb --- /dev/null +++ b/basis-library/libs/basis-1997/top-level/basis.sig @@ -0,0 +1,256 @@ +signature BASIS_1997 = + sig + (* Top-level types *) + eqtype unit + eqtype int + eqtype word + type real + eqtype char + eqtype string + type substring + type exn + eqtype 'a array + eqtype 'a vector + datatype ref = datatype ref + datatype bool = datatype bool + datatype 'a option = NONE | SOME of 'a + datatype order = LESS | EQUAL | GREATER + datatype list = datatype list + + (* Top-level exceptions *) + exception Bind + exception Chr + exception Div + exception Domain + exception Empty + exception Fail of string + exception Match + exception Option + exception Overflow + exception Size + exception Span + exception Subscript + + (* Top-level values *) + val ! : 'a ref -> 'a + val := : 'a ref * 'a -> unit + val @ : ('a list * 'a list) -> 'a list + val ^ : string * string -> string + val app : ('a -> unit) -> 'a list -> unit + val before : 'a * unit -> 'a + val ceil : real -> int + val chr : int -> char + val concat : string list -> string + val exnMessage : exn -> string + val exnName : exn -> string + val explode : string -> char list + val floor : real -> int + val foldl : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val foldr : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val getOpt : ('a option * 'a) -> 'a + val hd : 'a list -> 'a + val ignore : 'a -> unit + val isSome : 'a option -> bool + val implode : char list -> string + val length : 'a list -> int + val map : ('a -> 'b) -> 'a list -> 'b list + val not : bool -> bool + val null : 'a list -> bool + val o : ('a -> 'b) * ('c -> 'a) -> 'c -> 'b + val ord : char -> int + val print : string -> unit + val real : int -> real +(* + val ref : 'a -> 'a ref +*) + val rev : 'a list -> 'a list + val round : real -> int + val size : string -> int + val str : char -> string + val substring : string * int * int -> string + val tl : 'a list -> 'a list + val trunc : real -> int +(* + val use : string -> unit +*) + val valOf : 'a option -> 'a + val vector : 'a list -> 'a vector + + val = : ''a * ''a -> bool + val <> : ''a * ''a -> bool + + (* Required structures *) + structure Array : ARRAY_1997 + structure BinIO : BIN_IO_1997 +(* + structure BinPrimIO : PRIM_IO +*) + structure Bool : BOOL + structure Byte : BYTE + structure Char : CHAR + structure CharArray : MONO_ARRAY_1997 + structure CharVector : MONO_VECTOR_1997 + structure CommandLine : COMMAND_LINE + structure Date : DATE + structure General : GENERAL + structure IEEEReal : IEEE_REAL_1997 + structure Int : INTEGER + structure IO : IO_1997 + structure LargeInt : INTEGER + structure LargeReal : REAL_1997 + structure LargeWord : WORD_1997 + structure List : LIST + structure ListPair : LIST_PAIR + structure Math : MATH + structure Option : OPTION + structure OS : OS_1997 +(* + structure OS.FileSys : OS_FILE_SYS_1997 + structure OS.Path : OS_PATH_1997 + structure OS.Process : OS_PROCESS_1997 + structure OS.IO : OS_IO +*) + structure Position : INTEGER + structure Real : REAL_1997 + structure SML90 : SML90 + structure String : STRING_1997 + structure StringCvt : STRING_CVT + structure Substring : SUBSTRING_1997 + structure TextIO : TEXT_IO_1997 +(* + structure TextPrimIO : PRIM_IO +*) + structure Time : TIME + structure Timer : TIMER_1997 + structure Vector : VECTOR_1997 + structure Word : WORD_1997 + structure Word8 : WORD_1997 + structure Word8Array : MONO_ARRAY_1997 + structure Word8Vector : MONO_VECTOR_1997 + + (* Optional structures *) + structure Array2 : ARRAY2 + structure BoolArray : MONO_ARRAY_1997 + structure BoolArray2 : MONO_ARRAY2_1997 + structure BoolVector : MONO_VECTOR_1997 + structure CharArray2 : MONO_ARRAY2_1997 + structure FixedInt : INTEGER + structure IntInf : INT_INF + structure Int1: INTEGER + structure Int2: INTEGER + structure Int3: INTEGER + structure Int4: INTEGER + structure Int5: INTEGER + structure Int6: INTEGER + structure Int7: INTEGER + structure Int8: INTEGER + structure Int9: INTEGER + structure Int10: INTEGER + structure Int11: INTEGER + structure Int12: INTEGER + structure Int13: INTEGER + structure Int14: INTEGER + structure Int15: INTEGER + structure Int16: INTEGER + structure Int17: INTEGER + structure Int18: INTEGER + structure Int19: INTEGER + structure Int20: INTEGER + structure Int21: INTEGER + structure Int22: INTEGER + structure Int23: INTEGER + structure Int24: INTEGER + structure Int25: INTEGER + structure Int26: INTEGER + structure Int27: INTEGER + structure Int28: INTEGER + structure Int29: INTEGER + structure Int30: INTEGER + structure Int31: INTEGER + structure Int32: INTEGER + structure Int64: INTEGER + structure IntArray : MONO_ARRAY_1997 + structure Int32Array : MONO_ARRAY_1997 + structure IntArray2 : MONO_ARRAY2_1997 + structure Int32Array2 : MONO_ARRAY2_1997 + structure IntVector : MONO_VECTOR_1997 + structure Int32Vector : MONO_VECTOR_1997 +(* + structure Locale : LOCALE + structure MultiByte : MULTIBYTE +*) +(* + structure PackReal64Big : PACK_REAL +*) + structure PackReal64Little : PACK_REAL +(* + structure PackRealBig : PACK_REAL +*) + structure PackRealLittle : PACK_REAL + structure Pack32Big : PACK_WORD + structure Pack32Little : PACK_WORD + + structure Posix : POSIX_1997 +(* + structure Posix.Error : POSIX_ERROR + structure Posix.Signal : POSIX_SIGNAL + structure Posix.Process : POSIX_PROCESS_1997 + structure Posix.ProcEnv : POSIX_PROC_ENV + structure Posix.FileSys : POSIX_FILE_SYS_1997 + structure Posix.IO : POSIX_IO_1997 + structure Posix.SysDB : POSIX_SYS_DB + structure Posix.TTY : POSIX_TTY_1997 +*) + structure RealArray : MONO_ARRAY_1997 + structure RealVector : MONO_VECTOR_1997 + structure Real64 : REAL_1997 + structure Real64Array : MONO_ARRAY_1997 + structure Real64Vector : MONO_VECTOR_1997 + structure RealArray2 : MONO_ARRAY2_1997 + structure Real64Array2 : MONO_ARRAY2_1997 + structure SysWord : WORD_1997 +(* + structure WideChar : CHAR + structure WideCharArray : MONO_ARRAY_1997 + structure WideCharArray2 : MONO_ARRAY2_1997 + structure WideCharVector : MONO_VECTOR_1997 + structure WideString : STRING + structure WideSubstring : SUBSTRING + structure WideTextPrimIO : PRIM_IO + structure WideTextIO : TEXT_IO +*) + structure Word1: WORD_1997 + structure Word2: WORD_1997 + structure Word3: WORD_1997 + structure Word4: WORD_1997 + structure Word5: WORD_1997 + structure Word6: WORD_1997 + structure Word7: WORD_1997 + structure Word9: WORD_1997 + structure Word10: WORD_1997 + structure Word11: WORD_1997 + structure Word12: WORD_1997 + structure Word13: WORD_1997 + structure Word14: WORD_1997 + structure Word15: WORD_1997 + structure Word16: WORD_1997 + structure Word17: WORD_1997 + structure Word18: WORD_1997 + structure Word19: WORD_1997 + structure Word20: WORD_1997 + structure Word21: WORD_1997 + structure Word22: WORD_1997 + structure Word23: WORD_1997 + structure Word24: WORD_1997 + structure Word25: WORD_1997 + structure Word26: WORD_1997 + structure Word27: WORD_1997 + structure Word28: WORD_1997 + structure Word29: WORD_1997 + structure Word30: WORD_1997 + structure Word31: WORD_1997 + structure Word32: WORD_1997 + structure Word64: WORD_1997 + structure Word8Array2 : MONO_ARRAY2_1997 + structure Unix : UNIX_1997 + end diff --git a/basis-library/libs/basis-1997/top-level/basis.sml b/basis-library/libs/basis-1997/top-level/basis.sml new file mode 100644 index 0000000..b965eb6 --- /dev/null +++ b/basis-library/libs/basis-1997/top-level/basis.sml @@ -0,0 +1,107 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Basis1997: BASIS_1997 = + struct + open Basis2002 + structure SML90 = SML90 + + structure VectorArray = VectorArrayConvert + (structure Vector = Vector + structure VectorSlice = VectorSlice + structure Array = Array + structure ArraySlice = ArraySlice) + structure Vector = VectorArray.Vector + structure Array = VectorArray.Array + structure BoolVectorArray = MonoVectorArrayArray2Convert + (structure Vector = BoolVector + structure VectorSlice = BoolVectorSlice + structure Array = BoolArray + structure ArraySlice = BoolArraySlice + structure Array2 = BoolArray2) + structure BoolVector = BoolVectorArray.Vector + structure BoolArray = BoolVectorArray.Array + structure BoolArray2 = BoolVectorArray.Array2 + structure CharVectorArray = MonoVectorArrayArray2Convert + (structure Vector = CharVector + structure VectorSlice = CharVectorSlice + structure Array = CharArray + structure ArraySlice = CharArraySlice + structure Array2 = CharArray2) + structure CharVector = CharVectorArray.Vector + structure CharArray = CharVectorArray.Array + structure CharArray2 = CharVectorArray.Array2 + structure IntVectorArray = MonoVectorArrayArray2Convert + (structure Vector = IntVector + structure VectorSlice = IntVectorSlice + structure Array = IntArray + structure ArraySlice = IntArraySlice + structure Array2 = IntArray2) + structure IntVector = IntVectorArray.Vector + structure IntArray = IntVectorArray.Array + structure IntArray2 = IntVectorArray.Array2 + structure Int32VectorArray = MonoVectorArrayArray2Convert + (structure Vector = Int32Vector + structure VectorSlice = Int32VectorSlice + structure Array = Int32Array + structure ArraySlice = Int32ArraySlice + structure Array2 = Int32Array2) + structure Int32Vector = Int32VectorArray.Vector + structure Int32Array = Int32VectorArray.Array + structure Int32Array2 = Int32VectorArray.Array2 + structure RealVectorArray = MonoVectorArrayArray2Convert + (structure Vector = RealVector + structure VectorSlice = RealVectorSlice + structure Array = RealArray + structure ArraySlice = RealArraySlice + structure Array2 = RealArray2) + structure RealVector = RealVectorArray.Vector + structure RealArray = RealVectorArray.Array + structure RealArray2 = RealVectorArray.Array2 + structure Real64VectorArray = MonoVectorArrayArray2Convert + (structure Vector = Real64Vector + structure VectorSlice = Real64VectorSlice + structure Array = Real64Array + structure ArraySlice = Real64ArraySlice + structure Array2 = Real64Array2) + structure Real64Vector = Real64VectorArray.Vector + structure Real64Array = Real64VectorArray.Array + structure Real64Array2 = Real64VectorArray.Array2 + structure Word8VectorArray = MonoVectorArrayArray2Convert + (structure Vector = Word8Vector + structure VectorSlice = Word8VectorSlice + structure Array = Word8Array + structure ArraySlice = Word8ArraySlice + structure Array2 = Word8Array2) + structure Word8Vector = Word8VectorArray.Vector + structure Word8Array = Word8VectorArray.Array + structure Word8Array2 = Word8VectorArray.Array2 + + structure Pack32Big = PackWord32Big + structure Pack32Little = PackWord32Little + + structure Text = TextConvert (structure Text = Text) + structure Char = Text.Char + structure String = Text.String + structure Substring = Text.Substring + + structure IEEEReal = IEEEReal1997 + structure LargeReal = RealConvert(structure Real = LargeReal) + structure Real = RealConvert(structure Real = Real) + structure Real64 = RealConvert(structure Real = Real64) + + structure Posix = PosixConvert(structure Posix = Posix) + + structure OS = OSConvert(structure OS = OS) + structure Timer = TimerConvert(structure Timer = Timer) + + structure IO = IOConvert(structure IO = IO) + structure TextIO = TextIOConvert(structure TextIO = TextIO) + structure BinIO = BinIOConvert(structure BinIO = BinIO) + + structure Unix = UnixConvert (structure Unix = Unix) + end diff --git a/basis-library/libs/basis-1997/top-level/infixes.sml b/basis-library/libs/basis-1997/top-level/infixes.sml new file mode 100644 index 0000000..6af18f3 --- /dev/null +++ b/basis-library/libs/basis-1997/top-level/infixes.sml @@ -0,0 +1,14 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +infix 7 * / mod div +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before diff --git a/basis-library/libs/basis-1997/top-level/overloads.sml b/basis-library/libs/basis-1997/top-level/overloads.sml new file mode 100644 index 0000000..03804c0 --- /dev/null +++ b/basis-library/libs/basis-1997/top-level/overloads.sml @@ -0,0 +1,101 @@ +(* Copyright (C) 1999-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +_overload ~ : ('a -> 'a) +as Int.~ +and IntInf.~ +and Real.~ + +_overload + : ('a * 'a -> 'a) +as Int.+ +and IntInf.+ +and Word.+ +and Word8.+ +and Real.+ + +_overload - : ('a * 'a -> 'a) +as Int.- +and IntInf.- +and Word.- +and Word8.- +and Real.- + +_overload * : ('a * 'a -> 'a) +as Int.* +and IntInf.* +and Word.* +and Word8.* +and Real.* + +(* Can't use the following overload, because then + * fun f (x, y) = x + y / y + * fails to type check. The problem is that because + and / are not constrained, + * the type checker chooses the default type for +, int * int -> int. It is + * then screwed because it can't chose that type for /. The problem happens + * when there are overloaded variables that have some compatible type (in this + * case real) but one of whose default types (int) is not a valid instance + * of the other. + *) +(* + * _overload / : ('a * 'a -> 'a) + * as Real./ + *) +val op / = Real./ + +_overload div: ('a * 'a -> 'a) +as Int.div +and IntInf.div +and Word.div +and Word8.div + +_overload mod: ('a * 'a -> 'a) +as Int.mod +and IntInf.mod +and Word.mod +and Word8.mod + +_overload < : ('a * 'a -> bool) +as Int.< +and IntInf.< +and Word.< +and Word8.< +and Real.< +and Char.< +and String.< + +_overload <= : ('a * 'a -> bool) +as Int.<= +and IntInf.<= +and Word.<= +and Word8.<= +and Real.<= +and Char.<= +and String.<= + +_overload > : ('a * 'a -> bool) +as Int.> +and IntInf.> +and Word.> +and Word8.> +and Real.> +and Char.> +and String.> + +_overload >= : ('a * 'a -> bool) +as Int.>= +and IntInf.>= +and Word.>= +and Word8.>= +and Real.>= +and Char.>= +and String.>= + +_overload abs: ('a -> 'a) +as Int.abs +and IntInf.abs +and Real.abs diff --git a/basis-library/libs/basis-1997/top-level/top-level.sml b/basis-library/libs/basis-1997/top-level/top-level.sml new file mode 100644 index 0000000..bd4cb01 --- /dev/null +++ b/basis-library/libs/basis-1997/top-level/top-level.sml @@ -0,0 +1,9 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + + +open Basis1997 diff --git a/basis-library/libs/basis-2002-strict/top-level/top-level.sml b/basis-library/libs/basis-2002-strict/top-level/top-level.sml new file mode 100644 index 0000000..552ea61 --- /dev/null +++ b/basis-library/libs/basis-2002-strict/top-level/top-level.sml @@ -0,0 +1,11 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +open Basis2002 + +val op = = op = diff --git a/basis-library/libs/basis-2002/basis-2002.mlb b/basis-library/libs/basis-2002/basis-2002.mlb new file mode 100644 index 0000000..1993576 --- /dev/null +++ b/basis-library/libs/basis-2002/basis-2002.mlb @@ -0,0 +1,25 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + ../basis-extra/basis-extra.mlb + ann "allowSpecifySpecialIds true" in + top-level/basis.sig + end + top-level/basis.sml + in + structure Basis2002 + end +end diff --git a/basis-library/libs/basis-2002/top-level/.gitignore b/basis-library/libs/basis-2002/top-level/.gitignore new file mode 100644 index 0000000..46124d2 --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/.gitignore @@ -0,0 +1,2 @@ +/generate-overloads +/generate-overloads.exe diff --git a/basis-library/libs/basis-2002/top-level/Makefile b/basis-library/libs/basis-2002/top-level/Makefile new file mode 100644 index 0000000..66d7783 --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/Makefile @@ -0,0 +1,16 @@ +## Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +GEN := generate-overloads + +overloads.sml: $(GEN).sml + mlton $(GEN).sml + $(GEN) >overloads.sml + +.PHONY: clean +clean: + ../../../../bin/clean diff --git a/basis-library/libs/basis-2002/top-level/basis-equal.sig b/basis-library/libs/basis-2002/top-level/basis-equal.sig new file mode 100644 index 0000000..d8c8df1 --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/basis-equal.sig @@ -0,0 +1,5 @@ +signature BASIS_2002_EQUAL = + sig + val = : ''a * ''a -> bool + val <> : ''a * ''a -> bool + end diff --git a/basis-library/libs/basis-2002/top-level/basis-exns.sig b/basis-library/libs/basis-2002/top-level/basis-exns.sig new file mode 100644 index 0000000..f9ff24f --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/basis-exns.sig @@ -0,0 +1,16 @@ +signature BASIS_2002_EXNS = + sig + (* Top-level exceptions *) + exception Bind + exception Chr + exception Div + exception Domain + exception Empty + exception Fail of string + exception Match + exception Option + exception Overflow + exception Size + exception Span + exception Subscript + end diff --git a/basis-library/libs/basis-2002/top-level/basis-funs.sml b/basis-library/libs/basis-2002/top-level/basis-funs.sml new file mode 100644 index 0000000..f96a9ce --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/basis-funs.sml @@ -0,0 +1,13 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Required functors *) + +(* Optional functors *) +functor PrimIO (S: PRIM_IO_ARG): PRIM_IO = PrimIO (S) +functor StreamIO (S: STREAM_IO_ARG): STREAM_IO = StreamIO (S) +functor ImperativeIO (S: IMPERATIVE_IO_ARG): IMPERATIVE_IO = ImperativeIO (S) diff --git a/basis-library/libs/basis-2002/top-level/basis-sigs.sml b/basis-library/libs/basis-2002/top-level/basis-sigs.sml new file mode 100644 index 0000000..34ba68f --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/basis-sigs.sml @@ -0,0 +1,77 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Required signatures *) +signature ARRAY = ARRAY +signature ARRAY_SLICE = ARRAY_SLICE +signature BIN_IO = BIN_IO +signature BOOL = BOOL +signature BYTE = BYTE +signature CHAR = CHAR +signature COMMAND_LINE = COMMAND_LINE +signature DATE = DATE +signature GENERAL = GENERAL +signature IEEE_REAL = IEEE_REAL +signature IMPERATIVE_IO = IMPERATIVE_IO +signature INTEGER = INTEGER +signature INT_INF = INT_INF +signature IO = IO +signature LIST = LIST +signature LIST_PAIR = LIST_PAIR +signature MATH = MATH +signature MONO_ARRAY = MONO_ARRAY +signature MONO_ARRAY_SLICE = MONO_ARRAY_SLICE +signature MONO_VECTOR = MONO_VECTOR +signature MONO_VECTOR_SLICE = MONO_VECTOR_SLICE +signature OPTION = OPTION +signature OS = OS +signature OS_FILE_SYS = OS_FILE_SYS +signature OS_IO = OS_IO +signature OS_PATH = OS_PATH +signature OS_PROCESS = OS_PROCESS +signature PRIM_IO = PRIM_IO +signature REAL = REAL +signature STREAM_IO = STREAM_IO +signature STRING = STRING +signature STRING_CVT = STRING_CVT +signature SUBSTRING = SUBSTRING +signature TEXT = TEXT +signature TEXT_IO = TEXT_IO +signature TEXT_STREAM_IO = TEXT_STREAM_IO +signature TIME = TIME +signature TIMER = TIMER +signature VECTOR = VECTOR +signature VECTOR_SLICE = VECTOR_SLICE +signature WORD = WORD + +(* Optional signatures *) +signature ARRAY2 = ARRAY2 +signature BIT_FLAGS = BIT_FLAGS +signature GENERIC_SOCK = GENERIC_SOCK +signature INET_SOCK = INET_SOCK +signature INT_INF = INT_INF +signature MONO_ARRAY2 = MONO_ARRAY2 +signature NET_HOST_DB = NET_HOST_DB +signature NET_PROT_DB = NET_PROT_DB +signature NET_SERV_DB = NET_SERV_DB +signature PACK_REAL = PACK_REAL +signature PACK_WORD = PACK_WORD +signature POSIX = POSIX +signature POSIX_ERROR = POSIX_ERROR +signature POSIX_FILE_SYS = POSIX_FILE_SYS +signature POSIX_IO = POSIX_IO +signature POSIX_PROC_ENV = POSIX_PROC_ENV +signature POSIX_PROCESS = POSIX_PROCESS +signature POSIX_SIGNAL = POSIX_SIGNAL +signature POSIX_SYS_DB = POSIX_SYS_DB +signature POSIX_TTY = POSIX_TTY +signature SOCKET = SOCKET +signature UNIX = UNIX +signature UNIX_SOCK = UNIX_SOCK +(* +signature WINDOWS = WINDOWS +*) diff --git a/basis-library/libs/basis-2002/top-level/basis-types.sig b/basis-library/libs/basis-2002/top-level/basis-types.sig new file mode 100644 index 0000000..381b87a --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/basis-types.sig @@ -0,0 +1,19 @@ +signature BASIS_2002_TYPES = + sig + (* Top-level types *) + eqtype 'a array + datatype bool = datatype bool + eqtype char + type exn + eqtype int + datatype 'a option = NONE | SOME of 'a + datatype order = LESS | EQUAL | GREATER + datatype list = datatype list + datatype ref = datatype ref + type real + eqtype string + type substring + eqtype unit + eqtype 'a vector + eqtype word + end diff --git a/basis-library/libs/basis-2002/top-level/basis-vals.sig b/basis-library/libs/basis-2002/top-level/basis-vals.sig new file mode 100644 index 0000000..2b4803f --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/basis-vals.sig @@ -0,0 +1,50 @@ +signature BASIS_2002_VALS = + sig + (* Top-level values *) + val ! : 'a ref -> 'a + val := : 'a ref * 'a -> unit + val @ : ('a list * 'a list) -> 'a list + val ^ : string * string -> string + val app : ('a -> unit) -> 'a list -> unit + val before : 'a * unit -> 'a + val ceil : real -> int + val chr : int -> char + val concat : string list -> string + val exnMessage : exn -> string + val exnName : exn -> string + val explode : string -> char list + val floor : real -> int + val foldl : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val foldr : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val getOpt : ('a option * 'a) -> 'a + val hd : 'a list -> 'a + val ignore : 'a -> unit + val isSome : 'a option -> bool + val implode : char list -> string + val length : 'a list -> int + val map : ('a -> 'b) -> 'a list -> 'b list + val not : bool -> bool + val null : 'a list -> bool + val o : ('a -> 'b) * ('c -> 'a) -> 'c -> 'b + val ord : char -> int + val print : string -> unit + val real : int -> real +(* + val ref : 'a -> 'a ref +*) + val rev : 'a list -> 'a list + val round : real -> int + val size : string -> int + val str : char -> string + val substring : string * int * int -> string + val tl : 'a list -> 'a list + val trunc : real -> int +(* + val use : string -> unit +*) + val valOf : 'a option -> 'a + val vector : 'a list -> 'a vector + + val = : ''a * ''a -> bool + val <> : ''a * ''a -> bool + end diff --git a/basis-library/libs/basis-2002/top-level/basis.sig b/basis-library/libs/basis-2002/top-level/basis.sig new file mode 100644 index 0000000..90239b7 --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/basis.sig @@ -0,0 +1,635 @@ +signature BASIS_2002 = + sig + (* Top-level types *) + eqtype 'a array + datatype bool = datatype BasisExtra.bool + eqtype char + type exn + eqtype int + datatype 'a option = NONE | SOME of 'a + datatype order = LESS | EQUAL | GREATER + datatype list = datatype BasisExtra.list + datatype ref = datatype BasisExtra.ref + type real + eqtype string + type substring + eqtype unit + eqtype 'a vector + eqtype word + + (* Top-level exceptions *) + exception Bind + exception Chr + exception Div + exception Domain + exception Empty + exception Fail of string + exception Match + exception Option + exception Overflow + exception Size + exception Span + exception Subscript + + (* Top-level values *) + val = : ''a * ''a -> bool + val <> : ''a * ''a -> bool + + val ! : 'a ref -> 'a + val := : 'a ref * 'a -> unit + val @ : ('a list * 'a list) -> 'a list + val ^ : string * string -> string + val app : ('a -> unit) -> 'a list -> unit + val before : 'a * unit -> 'a + val ceil : real -> int + val chr : int -> char + val concat : string list -> string + val exnMessage : exn -> string + val exnName : exn -> string + val explode : string -> char list + val floor : real -> int + val foldl : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val foldr : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val getOpt : ('a option * 'a) -> 'a + val hd : 'a list -> 'a + val ignore : 'a -> unit + val isSome : 'a option -> bool + val implode : char list -> string + val length : 'a list -> int + val map : ('a -> 'b) -> 'a list -> 'b list + val not : bool -> bool + val null : 'a list -> bool + val o : ('a -> 'b) * ('c -> 'a) -> 'c -> 'b + val ord : char -> int + val print : string -> unit + val real : int -> real +(* + val ref : 'a -> 'a ref +*) + val rev : 'a list -> 'a list + val round : real -> int + val size : string -> int + val str : char -> string + val substring : string * int * int -> string + val tl : 'a list -> 'a list + val trunc : real -> int +(* + val use : string -> unit +*) + val valOf : 'a option -> 'a + val vector : 'a list -> 'a vector + + (* Required structures *) + structure Array : ARRAY + structure ArraySlice : ARRAY_SLICE + structure BinIO : BIN_IO + structure BinPrimIO : PRIM_IO + structure Bool : BOOL + structure Byte : BYTE + structure Char : CHAR + structure CharArray : MONO_ARRAY + structure CharArraySlice : MONO_ARRAY_SLICE + structure CharVector : MONO_VECTOR + structure CharVectorSlice : MONO_VECTOR_SLICE + structure CommandLine : COMMAND_LINE + structure Date : DATE + structure General : GENERAL + structure IEEEReal : IEEE_REAL + structure Int : INTEGER + structure IO : IO + structure LargeInt : INTEGER + structure LargeReal : REAL + structure LargeWord : WORD + structure List : LIST + structure ListPair : LIST_PAIR + structure Math : MATH + structure Option : OPTION + structure OS : OS + structure Position : INTEGER + structure Real : REAL + structure StringCvt : STRING_CVT + structure String : STRING + structure Substring : SUBSTRING + structure TextIO : TEXT_IO + structure TextPrimIO : PRIM_IO + structure Text : TEXT + structure Time : TIME + structure Timer : TIMER + structure VectorSlice : VECTOR_SLICE + structure Vector : VECTOR + structure Word : WORD + structure Word8Array : MONO_ARRAY + structure Word8Array2 : MONO_ARRAY2 + structure Word8ArraySlice : MONO_ARRAY_SLICE + structure Word8Vector : MONO_VECTOR + structure Word8VectorSlice : MONO_VECTOR_SLICE + + (* Optional structures *) + structure Array2 : ARRAY2 + structure BoolArray : MONO_ARRAY + structure BoolArray2 : MONO_ARRAY2 + structure BoolArraySlice : MONO_ARRAY_SLICE + structure BoolVector : MONO_VECTOR + structure BoolVectorSlice : MONO_VECTOR_SLICE + structure CharArray2 : MONO_ARRAY2 + structure FixedInt : INTEGER + structure GenericSock : GENERIC_SOCK + structure INetSock : INET_SOCK + structure Int1: INTEGER + structure Int2: INTEGER + structure Int3: INTEGER + structure Int4: INTEGER + structure Int5: INTEGER + structure Int6: INTEGER + structure Int7: INTEGER + structure Int8: INTEGER + structure Int9: INTEGER + structure Int10: INTEGER + structure Int11: INTEGER + structure Int12: INTEGER + structure Int13: INTEGER + structure Int14: INTEGER + structure Int15: INTEGER + structure Int16: INTEGER + structure Int17: INTEGER + structure Int18: INTEGER + structure Int19: INTEGER + structure Int20: INTEGER + structure Int21: INTEGER + structure Int22: INTEGER + structure Int23: INTEGER + structure Int24: INTEGER + structure Int25: INTEGER + structure Int26: INTEGER + structure Int27: INTEGER + structure Int28: INTEGER + structure Int29: INTEGER + structure Int30: INTEGER + structure Int31: INTEGER + structure Int32: INTEGER + structure Int64: INTEGER + structure Int8Array : MONO_ARRAY + structure Int8Array2 : MONO_ARRAY2 + structure Int8ArraySlice : MONO_ARRAY_SLICE + structure Int8Vector : MONO_VECTOR + structure Int8VectorSlice : MONO_VECTOR_SLICE + structure Int16Array : MONO_ARRAY + structure Int16Array2 : MONO_ARRAY2 + structure Int16ArraySlice : MONO_ARRAY_SLICE + structure Int16Vector : MONO_VECTOR + structure Int16VectorSlice : MONO_VECTOR_SLICE + structure Int32Array : MONO_ARRAY + structure Int32Array2 : MONO_ARRAY2 + structure Int32ArraySlice : MONO_ARRAY_SLICE + structure Int32Vector : MONO_VECTOR + structure Int32VectorSlice : MONO_VECTOR_SLICE + structure Int64Array : MONO_ARRAY + structure Int64Array2 : MONO_ARRAY2 + structure Int64ArraySlice : MONO_ARRAY_SLICE + structure Int64Vector : MONO_VECTOR + structure Int64VectorSlice : MONO_VECTOR_SLICE + structure IntArray : MONO_ARRAY + structure IntArray2 : MONO_ARRAY2 + structure IntArraySlice : MONO_ARRAY_SLICE + structure IntVector : MONO_VECTOR + structure IntVectorSlice : MONO_VECTOR_SLICE + structure IntInf : INT_INF + structure LargeIntArray : MONO_ARRAY + structure LargeIntArray2 : MONO_ARRAY2 + structure LargeIntArraySlice : MONO_ARRAY_SLICE + structure LargeIntVector : MONO_VECTOR + structure LargeIntVectorSlice : MONO_VECTOR_SLICE + structure LargeRealArray : MONO_ARRAY + structure LargeRealArray2 : MONO_ARRAY2 + structure LargeRealArraySlice : MONO_ARRAY_SLICE + structure LargeRealVector : MONO_VECTOR + structure LargeRealVectorSlice : MONO_VECTOR_SLICE + structure LargeWordArray : MONO_ARRAY + structure LargeWordArray2 : MONO_ARRAY2 + structure LargeWordArraySlice : MONO_ARRAY_SLICE + structure LargeWordVector : MONO_VECTOR + structure LargeWordVectorSlice : MONO_VECTOR_SLICE + structure NetHostDB : NET_HOST_DB + structure NetProtDB : NET_PROT_DB + structure NetServDB : NET_SERV_DB + structure PackReal32Big : PACK_REAL + structure PackReal32Little : PACK_REAL + structure PackReal64Big : PACK_REAL + structure PackReal64Little : PACK_REAL + structure PackRealBig : PACK_REAL + structure PackRealLittle : PACK_REAL + structure PackWord16Big : PACK_WORD + structure PackWord16Little : PACK_WORD + structure PackWord32Big : PACK_WORD + structure PackWord32Little : PACK_WORD + structure PackWord64Big : PACK_WORD + structure PackWord64Little : PACK_WORD + structure Posix : POSIX + structure Real32 : REAL + structure Real32Array : MONO_ARRAY + structure Real32Array2 : MONO_ARRAY2 + structure Real32ArraySlice : MONO_ARRAY_SLICE + structure Real32Vector : MONO_VECTOR + structure Real32VectorSlice : MONO_VECTOR_SLICE + structure Real64 : REAL + structure Real64Array : MONO_ARRAY + structure Real64Array2 : MONO_ARRAY2 + structure Real64ArraySlice : MONO_ARRAY_SLICE + structure Real64Vector : MONO_VECTOR + structure Real64VectorSlice : MONO_VECTOR_SLICE + structure RealArray : MONO_ARRAY + structure RealArray2 : MONO_ARRAY2 + structure RealArraySlice : MONO_ARRAY_SLICE + structure RealVector : MONO_VECTOR + structure RealVectorSlice : MONO_VECTOR_SLICE + structure Socket : SOCKET + structure SysWord : WORD + structure Unix : UNIX + structure UnixSock : UNIX_SOCK + structure WideChar : CHAR + structure WideCharArray : MONO_ARRAY + structure WideCharArray2 : MONO_ARRAY2 + structure WideCharArraySlice : MONO_ARRAY_SLICE + structure WideCharVector : MONO_VECTOR + structure WideCharVectorSlice : MONO_VECTOR_SLICE + structure WideString : STRING + structure WideSubstring : SUBSTRING + structure WideText : TEXT +(* + structure WideTextIO : TEXT_IO + structure WideTextPrimIO : PRIM_IO +*) +(* + structure Windows : WINDOWS +*) + structure Word1: WORD + structure Word2: WORD + structure Word3: WORD + structure Word4: WORD + structure Word5: WORD + structure Word6: WORD + structure Word7: WORD + structure Word8: WORD + structure Word9: WORD + structure Word10: WORD + structure Word11: WORD + structure Word12: WORD + structure Word13: WORD + structure Word14: WORD + structure Word15: WORD + structure Word16: WORD + structure Word17: WORD + structure Word18: WORD + structure Word19: WORD + structure Word20: WORD + structure Word21: WORD + structure Word22: WORD + structure Word23: WORD + structure Word24: WORD + structure Word25: WORD + structure Word26: WORD + structure Word27: WORD + structure Word28: WORD + structure Word29: WORD + structure Word30: WORD + structure Word31: WORD + structure Word32: WORD + structure Word64: WORD + structure WordArray : MONO_ARRAY + structure WordArray2 : MONO_ARRAY2 + structure WordArraySlice : MONO_ARRAY_SLICE + structure WordVector : MONO_VECTOR + structure WordVectorSlice : MONO_VECTOR_SLICE + structure Word16Array : MONO_ARRAY + structure Word16Array2 : MONO_ARRAY2 + structure Word16ArraySlice : MONO_ARRAY_SLICE + structure Word16Vector : MONO_VECTOR + structure Word16VectorSlice : MONO_VECTOR_SLICE + structure Word32Array : MONO_ARRAY + structure Word32Array2 : MONO_ARRAY2 + structure Word32ArraySlice : MONO_ARRAY_SLICE + structure Word32Vector : MONO_VECTOR + structure Word32VectorSlice : MONO_VECTOR_SLICE + structure Word64Array : MONO_ARRAY + structure Word64Array2 : MONO_ARRAY2 + structure Word64ArraySlice : MONO_ARRAY_SLICE + structure Word64Vector : MONO_VECTOR + structure Word64VectorSlice : MONO_VECTOR_SLICE + + (* ************************************************** *) + (* ************************************************** *) + + (* Sharing constraints *) + + (* Top-level types *) + sharing type unit = General.unit + sharing type int = Int.int + sharing type word = Word.word + sharing type real = Real.real + sharing type char = Char.char + sharing type string = String.string + sharing type substring = Substring.substring + sharing type exn = General.exn +(* Can't use sharing on type array or vector, because they are rigid tycons. + * Don't need it anyways, since it's built into the ARRAY and VECTOR signatures. + *) +(* + sharing type array = Array.array + sharing type vector = Vector.vector +*) +(* + sharing type ref = General.ref +*) +(* + sharing type bool = Bool.bool +*) + sharing type option = Option.option + sharing type order = General.order +(* + sharing type list = List.list +*) + + (* Required structures *) +(* + sharing type BinIO.StreamIO.elem = Word8.word +*) + sharing type BinIO.StreamIO.reader = BinPrimIO.reader + sharing type BinIO.StreamIO.pos = BinPrimIO.pos +(* + sharing type BinIO.StreamIO.vector = Word8Vector.vector +*) + sharing type BinIO.StreamIO.writer = BinPrimIO.writer + sharing type BinPrimIO.array = Word8Array.array + sharing type BinPrimIO.array_slice = Word8ArraySlice.slice + sharing type BinPrimIO.elem = Word8.word + sharing type BinPrimIO.pos = Position.int + sharing type BinPrimIO.vector = Word8Vector.vector + sharing type BinPrimIO.vector_slice = Word8VectorSlice.slice + sharing type Char.char = char + sharing type Char.string = String.string + sharing type CharArray.elem = char + sharing type CharArray.vector = CharVector.vector + sharing type CharArraySlice.elem = char + sharing type CharArraySlice.array = CharArray.array + sharing type CharArraySlice.vector = CharVector.vector + sharing type CharArraySlice.vector_slice = CharVectorSlice.slice + sharing type CharVector.elem = char + sharing type CharVector.vector = String.string + sharing type CharVectorSlice.elem = char + sharing type CharVectorSlice.vector = String.string + sharing type CharVectorSlice.slice = Substring.substring + sharing type Int.int = int + sharing type Math.real = Real.real + sharing type Real.real = real + sharing type String.string = string + sharing type String.string = CharVector.vector + sharing type String.char = Char.char + sharing type Substring.substring = CharVectorSlice.slice + sharing type Substring.string = String.string + sharing type Substring.char = Char.char + sharing type Text.Char.char = Char.char + sharing type Text.String.string = String.string + sharing type Text.Substring.substring = Substring.substring + sharing type Text.CharVector.vector = CharVector.vector + sharing type Text.CharArray.array = CharArray.array + sharing type Text.CharArraySlice.slice = CharArraySlice.slice + sharing type Text.CharVectorSlice.slice = CharVectorSlice.slice + (* redundant *) +(* + sharing type TextIO.elem = char + sharing type TextIO.vector = string +*) + sharing type TextPrimIO.array = CharArray.array + sharing type TextPrimIO.array_slice = CharArraySlice.slice + sharing type TextPrimIO.elem = Char.char + sharing type TextPrimIO.pos = Position.int + sharing type TextPrimIO.vector = CharVector.vector + sharing type TextPrimIO.vector_slice = CharVectorSlice.slice + sharing type Word.word = word + sharing type Word8Array.elem = Word8.word + sharing type Word8Array.vector = Word8Vector.vector + sharing type Word8ArraySlice.elem = Word8.word + sharing type Word8ArraySlice.array = Word8Array.array + sharing type Word8ArraySlice.vector = Word8Vector.vector + sharing type Word8ArraySlice.vector_slice = Word8VectorSlice.slice + sharing type Word8Vector.elem = Word8.word + sharing type Word8VectorSlice.elem = Word8.word + sharing type Word8VectorSlice.vector = Word8Vector.vector + sharing type Word8Array2.elem = Word8.word + sharing type Word8Array2.vector = Word8Vector.vector + + (* Optional structures *) + sharing type BoolArray.vector = BoolVector.vector + sharing type BoolArraySlice.array = BoolArray.array + sharing type BoolArraySlice.vector = BoolVector.vector + sharing type BoolArraySlice.vector_slice = BoolVectorSlice.slice + sharing type BoolVectorSlice.vector = BoolVector.vector + sharing type BoolArray2.vector = BoolVector.vector + sharing type CharArray2.elem = char + sharing type CharArray2.vector = CharVector.vector + sharing type IntArray.elem = int + sharing type IntArray.vector = IntVector.vector + sharing type IntArraySlice.elem = int + sharing type IntArraySlice.array = IntArray.array + sharing type IntArraySlice.vector = IntVector.vector + sharing type IntArraySlice.vector_slice = IntVectorSlice.slice + sharing type IntVector.elem = int + sharing type IntVectorSlice.elem = int + sharing type IntVectorSlice.vector = IntVector.vector + sharing type IntArray2.elem = int + sharing type IntArray2.vector = IntVector.vector + sharing type Int8Array.elem = Int8.int + sharing type Int8Array.vector = Int8Vector.vector + sharing type Int8ArraySlice.elem = Int8.int + sharing type Int8ArraySlice.array = Int8Array.array + sharing type Int8ArraySlice.vector = Int8Vector.vector + sharing type Int8ArraySlice.vector_slice = Int8VectorSlice.slice + sharing type Int8Vector.elem = Int8.int + sharing type Int8VectorSlice.elem = Int8.int + sharing type Int8VectorSlice.vector = Int8Vector.vector + sharing type Int8Array2.elem = Int8.int + sharing type Int8Array2.vector = Int8Vector.vector + sharing type Int16Array.elem = Int16.int + sharing type Int16Array.vector = Int16Vector.vector + sharing type Int16ArraySlice.elem = Int16.int + sharing type Int16ArraySlice.array = Int16Array.array + sharing type Int16ArraySlice.vector = Int16Vector.vector + sharing type Int16ArraySlice.vector_slice = Int16VectorSlice.slice + sharing type Int16Vector.elem = Int16.int + sharing type Int16VectorSlice.elem = Int16.int + sharing type Int16VectorSlice.vector = Int16Vector.vector + sharing type Int16Array2.elem = Int16.int + sharing type Int16Array2.vector = Int16Vector.vector + sharing type Int32Array.elem = Int32.int + sharing type Int32Array.vector = Int32Vector.vector + sharing type Int32ArraySlice.elem = Int32.int + sharing type Int32ArraySlice.array = Int32Array.array + sharing type Int32ArraySlice.vector = Int32Vector.vector + sharing type Int32ArraySlice.vector_slice = Int32VectorSlice.slice + sharing type Int32Vector.elem = Int32.int + sharing type Int32VectorSlice.elem = Int32.int + sharing type Int32VectorSlice.vector = Int32Vector.vector + sharing type Int32Array2.elem = Int32.int + sharing type Int32Array2.vector = Int32Vector.vector + sharing type Int64Array.elem = Int64.int + sharing type Int64Array.vector = Int64Vector.vector + sharing type Int64ArraySlice.elem = Int64.int + sharing type Int64ArraySlice.array = Int64Array.array + sharing type Int64ArraySlice.vector = Int64Vector.vector + sharing type Int64ArraySlice.vector_slice = Int64VectorSlice.slice + sharing type Int64Vector.elem = Int64.int + sharing type Int64VectorSlice.elem = Int64.int + sharing type Int64VectorSlice.vector = Int64Vector.vector + sharing type Int64Array2.elem = Int64.int + sharing type Int64Array2.vector = Int64Vector.vector + sharing type LargeIntArray.elem = LargeInt.int + sharing type LargeIntArray.vector = LargeIntVector.vector + sharing type LargeIntArraySlice.elem = LargeInt.int + sharing type LargeIntArraySlice.array = LargeIntArray.array + sharing type LargeIntArraySlice.vector = LargeIntVector.vector + sharing type LargeIntArraySlice.vector_slice = LargeIntVectorSlice.slice + sharing type LargeIntVector.elem = LargeInt.int + sharing type LargeIntVectorSlice.elem = LargeInt.int + sharing type LargeIntVectorSlice.vector = LargeIntVector.vector + sharing type LargeIntArray2.elem = LargeInt.int + sharing type LargeIntArray2.vector = LargeIntVector.vector + sharing type LargeRealArray.elem = LargeReal.real + sharing type LargeRealArray.vector = LargeRealVector.vector + sharing type LargeRealArraySlice.elem = LargeReal.real + sharing type LargeRealArraySlice.array = LargeRealArray.array + sharing type LargeRealArraySlice.vector = LargeRealVector.vector + sharing type LargeRealArraySlice.vector_slice = LargeRealVectorSlice.slice + sharing type LargeRealVector.elem = LargeReal.real + sharing type LargeRealVectorSlice.elem = LargeReal.real + sharing type LargeRealVectorSlice.vector = LargeRealVector.vector + sharing type LargeRealArray2.elem = LargeReal.real + sharing type LargeRealArray2.vector = LargeRealVector.vector + sharing type LargeWordArray.elem = LargeWord.word + sharing type LargeWordArray.vector = LargeWordVector.vector + sharing type LargeWordArraySlice.elem = LargeWord.word + sharing type LargeWordArraySlice.array = LargeWordArray.array + sharing type LargeWordArraySlice.vector = LargeWordVector.vector + sharing type LargeWordArraySlice.vector_slice = LargeWordVectorSlice.slice + sharing type LargeWordVector.elem = LargeWord.word + sharing type LargeWordVectorSlice.elem = LargeWord.word + sharing type LargeWordVectorSlice.vector = LargeWordVector.vector + sharing type LargeWordArray2.elem = LargeWord.word + sharing type LargeWordArray2.vector = LargeWordVector.vector + sharing type PackRealBig.real = real + sharing type PackRealLittle.real = real + sharing type PackReal32Big.real = Real32.real + sharing type PackReal32Little.real = Real32.real + sharing type PackReal64Big.real = Real64.real + sharing type PackReal64Little.real = Real64.real + sharing type Posix.Error.syserror = OS.syserror + sharing type Posix.IO.file_desc = Posix.ProcEnv.file_desc + sharing type Posix.FileSys.dirstream = OS.FileSys.dirstream + sharing type Posix.FileSys.access_mode = OS.FileSys.access_mode + sharing type Posix.Process.exit_status = Unix.exit_status + sharing type Posix.Signal.signal = Unix.signal + sharing type RealArray.elem = real + sharing type RealArray.vector = RealVector.vector + sharing type RealArraySlice.elem = real + sharing type RealArraySlice.array = RealArray.array + sharing type RealArraySlice.vector = RealVector.vector + sharing type RealArraySlice.vector_slice = RealVectorSlice.slice + sharing type RealVector.elem = real + sharing type RealVectorSlice.elem = real + sharing type RealVectorSlice.vector = RealVector.vector + sharing type RealArray2.elem = real + sharing type RealArray2.vector = RealVector.vector + sharing type Real32Array.elem = Real32.real + sharing type Real32Array.vector = Real32Vector.vector + sharing type Real32ArraySlice.elem = Real32.real + sharing type Real32ArraySlice.array = Real32Array.array + sharing type Real32ArraySlice.vector = Real32Vector.vector + sharing type Real32ArraySlice.vector_slice = Real32VectorSlice.slice + sharing type Real32Vector.elem = Real32.real + sharing type Real32VectorSlice.elem = Real32.real + sharing type Real32VectorSlice.vector = Real32Vector.vector + sharing type Real32Array2.elem = Real32.real + sharing type Real32Array2.vector = Real32Vector.vector + sharing type Real64Array.elem = Real64.real + sharing type Real64Array.vector = Real64Vector.vector + sharing type Real64ArraySlice.elem = Real64.real + sharing type Real64ArraySlice.array = Real64Array.array + sharing type Real64ArraySlice.vector = Real64Vector.vector + sharing type Real64ArraySlice.vector_slice = Real64VectorSlice.slice + sharing type Real64Vector.elem = Real64.real + sharing type Real64VectorSlice.elem = Real64.real + sharing type Real64VectorSlice.vector = Real64Vector.vector + sharing type Real64Array2.elem = Real64.real + sharing type Real64Array2.vector = Real64Vector.vector + sharing type Unix.exit_status = Posix.Process.exit_status + sharing type WideChar.string = WideString.string + sharing type WideCharArray.elem = WideChar.char + sharing type WideCharArray.vector = WideCharVector.vector + sharing type WideCharArray2.elem = WideChar.char + sharing type WideCharArray2.vector = WideCharVector.vector + sharing type WideCharArraySlice.elem = WideChar.char + sharing type WideCharArraySlice.array = WideCharArray.array + sharing type WideCharArraySlice.vector = WideCharVector.vector + sharing type WideCharArraySlice.vector_slice = WideCharVectorSlice.slice + sharing type WideCharVector.elem = WideChar.char + sharing type WideCharVector.vector = WideString.string + sharing type WideCharVectorSlice.elem = WideChar.char + sharing type WideCharVectorSlice.slice = WideSubstring.substring + sharing type WideCharVectorSlice.vector = WideString.string + sharing type WideString.char = WideChar.char + (* next two are redundant? basis & char both do it... *) + sharing type WideString.string = WideCharVector.vector + sharing type WideSubstring.substring = WideCharVectorSlice.slice + sharing type WideSubstring.string = WideString.string + sharing type WideSubstring.char = WideChar.char + sharing type WideText.Char.char = WideChar.char + sharing type WideText.String.string = WideString.string + sharing type WideText.Substring.substring = WideSubstring.substring + sharing type WideText.CharVector.vector = WideCharVector.vector + sharing type WideText.CharArray.array = WideCharArray.array + sharing type WideText.CharArraySlice.slice = WideCharArraySlice.slice + sharing type WideText.CharVectorSlice.slice = WideCharVectorSlice.slice + sharing type WordArray.elem = word + sharing type WordArray.vector = WordVector.vector + sharing type WordArraySlice.elem = word + sharing type WordArraySlice.array = WordArray.array + sharing type WordArraySlice.vector = WordVector.vector + sharing type WordArraySlice.vector_slice = WordVectorSlice.slice + sharing type WordVector.elem = word + sharing type WordVectorSlice.elem = word + sharing type WordVectorSlice.vector = WordVector.vector + sharing type WordArray2.elem = word + sharing type WordArray2.vector = WordVector.vector + sharing type Word16Array.elem = Word16.word + sharing type Word16Array.vector = Word16Vector.vector + sharing type Word16ArraySlice.elem = Word16.word + sharing type Word16ArraySlice.array = Word16Array.array + sharing type Word16ArraySlice.vector = Word16Vector.vector + sharing type Word16ArraySlice.vector_slice = Word16VectorSlice.slice + sharing type Word16Vector.elem = Word16.word + sharing type Word16VectorSlice.elem = Word16.word + sharing type Word16VectorSlice.vector = Word16Vector.vector + sharing type Word16Array2.elem = Word16.word + sharing type Word16Array2.vector = Word16Vector.vector + sharing type Word32Array.elem = Word32.word + sharing type Word32Array.vector = Word32Vector.vector + sharing type Word32ArraySlice.elem = Word32.word + sharing type Word32ArraySlice.array = Word32Array.array + sharing type Word32ArraySlice.vector = Word32Vector.vector + sharing type Word32ArraySlice.vector_slice = Word32VectorSlice.slice + sharing type Word32Vector.elem = Word32.word + sharing type Word32VectorSlice.elem = Word32.word + sharing type Word32VectorSlice.vector = Word32Vector.vector + sharing type Word32Array2.elem = Word32.word + sharing type Word32Array2.vector = Word32Vector.vector + sharing type Word64Array.elem = Word64.word + sharing type Word64Array.vector = Word64Vector.vector + sharing type Word64ArraySlice.elem = Word64.word + sharing type Word64ArraySlice.array = Word64Array.array + sharing type Word64ArraySlice.vector = Word64Vector.vector + sharing type Word64ArraySlice.vector_slice = Word64VectorSlice.slice + sharing type Word64Vector.elem = Word64.word + sharing type Word64VectorSlice.elem = Word64.word + sharing type Word64VectorSlice.vector = Word64Vector.vector + sharing type Word64Array2.elem = Word64.word + sharing type Word64Array2.vector = Word64Vector.vector + end diff --git a/basis-library/libs/basis-2002/top-level/basis.sml b/basis-library/libs/basis-2002/top-level/basis.sml new file mode 100644 index 0000000..6f48870 --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/basis.sml @@ -0,0 +1,8 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Basis2002 : BASIS_2002 = BasisExtra diff --git a/basis-library/libs/basis-2002/top-level/generate-overloads.sml b/basis-library/libs/basis-2002/top-level/generate-overloads.sml new file mode 100644 index 0000000..205516f --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/generate-overloads.sml @@ -0,0 +1,64 @@ +(* Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure List = + struct + fun foreach (l, f) = List.app f l + fun map (l, f) = List.map f l + val tabulate = List.tabulate + end + +val int = + ["Int", "IntInf", "LargeInt", "FixedInt", "Position"] + @ List.map (List.tabulate (31, fn i => i + 2) @ [64], + fn i => concat ["Int", Int.toString i]) + +val real = ["Real", "Real32", "Real64", "LargeReal"] + +val word = + ["Word", "LargeWord", "SysWord"] + @ List.map (List.tabulate (32, fn i => i + 1) @ [64], + fn i => concat ["Word", Int.toString i]) + +val text = ["Char", "WideChar", "String", "WideString"] + +(* Order matters here in the appends, since the first element will be the + * default. + *) +val num = int @ word @ real +val numtext = num @ text +val realint = int @ real +val wordint = int @ word + +val binary = "'a * 'a -> 'a" +val compare = "'a * 'a -> bool" +val unary = "'a -> 'a" + +val () = print "(* This file is automatically generated. Do not edit. *)\n" + +val () = + List.foreach + ([(2, "~", unary, num), + (2, "+", binary, num), + (2, "-", binary, num), + (2, "*", binary, num), + (4, "/", binary, real), + (3, "div", binary, wordint), + (3, "mod", binary, wordint), + (3, "abs", unary, realint), + (1, "<", compare, numtext), + (1, "<=", compare, numtext), + (1, ">", compare, numtext), + (1, ">=", compare, numtext)], + fn (prec, f, ty, class) => + (print (concat ["\n_overload ", Int.toString prec, " ", f, " : ", ty, "\n"]) + ; (case class of + [] => () + | c :: class => + (print (concat ["as ", c, ".", f, "\n"]) + ; List.foreach (class, fn c => + print (concat ["and ", c, ".", f, "\n"])))))) diff --git a/basis-library/libs/basis-2002/top-level/infixes.sml b/basis-library/libs/basis-2002/top-level/infixes.sml new file mode 100644 index 0000000..6af18f3 --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/infixes.sml @@ -0,0 +1,14 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +infix 7 * / mod div +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before diff --git a/basis-library/libs/basis-2002/top-level/overloads.sml b/basis-library/libs/basis-2002/top-level/overloads.sml new file mode 100644 index 0000000..87eb3c7 --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/overloads.sml @@ -0,0 +1,848 @@ +(* This file is automatically generated. Do not edit. *) + +_overload 2 ~ : 'a -> 'a +as Int.~ +and IntInf.~ +and LargeInt.~ +and FixedInt.~ +and Position.~ +and Int2.~ +and Int3.~ +and Int4.~ +and Int5.~ +and Int6.~ +and Int7.~ +and Int8.~ +and Int9.~ +and Int10.~ +and Int11.~ +and Int12.~ +and Int13.~ +and Int14.~ +and Int15.~ +and Int16.~ +and Int17.~ +and Int18.~ +and Int19.~ +and Int20.~ +and Int21.~ +and Int22.~ +and Int23.~ +and Int24.~ +and Int25.~ +and Int26.~ +and Int27.~ +and Int28.~ +and Int29.~ +and Int30.~ +and Int31.~ +and Int32.~ +and Int64.~ +and Word.~ +and LargeWord.~ +and SysWord.~ +and Word1.~ +and Word2.~ +and Word3.~ +and Word4.~ +and Word5.~ +and Word6.~ +and Word7.~ +and Word8.~ +and Word9.~ +and Word10.~ +and Word11.~ +and Word12.~ +and Word13.~ +and Word14.~ +and Word15.~ +and Word16.~ +and Word17.~ +and Word18.~ +and Word19.~ +and Word20.~ +and Word21.~ +and Word22.~ +and Word23.~ +and Word24.~ +and Word25.~ +and Word26.~ +and Word27.~ +and Word28.~ +and Word29.~ +and Word30.~ +and Word31.~ +and Word32.~ +and Word64.~ +and Real.~ +and Real32.~ +and Real64.~ +and LargeReal.~ + +_overload 2 + : 'a * 'a -> 'a +as Int.+ +and IntInf.+ +and LargeInt.+ +and FixedInt.+ +and Position.+ +and Int2.+ +and Int3.+ +and Int4.+ +and Int5.+ +and Int6.+ +and Int7.+ +and Int8.+ +and Int9.+ +and Int10.+ +and Int11.+ +and Int12.+ +and Int13.+ +and Int14.+ +and Int15.+ +and Int16.+ +and Int17.+ +and Int18.+ +and Int19.+ +and Int20.+ +and Int21.+ +and Int22.+ +and Int23.+ +and Int24.+ +and Int25.+ +and Int26.+ +and Int27.+ +and Int28.+ +and Int29.+ +and Int30.+ +and Int31.+ +and Int32.+ +and Int64.+ +and Word.+ +and LargeWord.+ +and SysWord.+ +and Word1.+ +and Word2.+ +and Word3.+ +and Word4.+ +and Word5.+ +and Word6.+ +and Word7.+ +and Word8.+ +and Word9.+ +and Word10.+ +and Word11.+ +and Word12.+ +and Word13.+ +and Word14.+ +and Word15.+ +and Word16.+ +and Word17.+ +and Word18.+ +and Word19.+ +and Word20.+ +and Word21.+ +and Word22.+ +and Word23.+ +and Word24.+ +and Word25.+ +and Word26.+ +and Word27.+ +and Word28.+ +and Word29.+ +and Word30.+ +and Word31.+ +and Word32.+ +and Word64.+ +and Real.+ +and Real32.+ +and Real64.+ +and LargeReal.+ + +_overload 2 - : 'a * 'a -> 'a +as Int.- +and IntInf.- +and LargeInt.- +and FixedInt.- +and Position.- +and Int2.- +and Int3.- +and Int4.- +and Int5.- +and Int6.- +and Int7.- +and Int8.- +and Int9.- +and Int10.- +and Int11.- +and Int12.- +and Int13.- +and Int14.- +and Int15.- +and Int16.- +and Int17.- +and Int18.- +and Int19.- +and Int20.- +and Int21.- +and Int22.- +and Int23.- +and Int24.- +and Int25.- +and Int26.- +and Int27.- +and Int28.- +and Int29.- +and Int30.- +and Int31.- +and Int32.- +and Int64.- +and Word.- +and LargeWord.- +and SysWord.- +and Word1.- +and Word2.- +and Word3.- +and Word4.- +and Word5.- +and Word6.- +and Word7.- +and Word8.- +and Word9.- +and Word10.- +and Word11.- +and Word12.- +and Word13.- +and Word14.- +and Word15.- +and Word16.- +and Word17.- +and Word18.- +and Word19.- +and Word20.- +and Word21.- +and Word22.- +and Word23.- +and Word24.- +and Word25.- +and Word26.- +and Word27.- +and Word28.- +and Word29.- +and Word30.- +and Word31.- +and Word32.- +and Word64.- +and Real.- +and Real32.- +and Real64.- +and LargeReal.- + +_overload 2 * : 'a * 'a -> 'a +as Int.* +and IntInf.* +and LargeInt.* +and FixedInt.* +and Position.* +and Int2.* +and Int3.* +and Int4.* +and Int5.* +and Int6.* +and Int7.* +and Int8.* +and Int9.* +and Int10.* +and Int11.* +and Int12.* +and Int13.* +and Int14.* +and Int15.* +and Int16.* +and Int17.* +and Int18.* +and Int19.* +and Int20.* +and Int21.* +and Int22.* +and Int23.* +and Int24.* +and Int25.* +and Int26.* +and Int27.* +and Int28.* +and Int29.* +and Int30.* +and Int31.* +and Int32.* +and Int64.* +and Word.* +and LargeWord.* +and SysWord.* +and Word1.* +and Word2.* +and Word3.* +and Word4.* +and Word5.* +and Word6.* +and Word7.* +and Word8.* +and Word9.* +and Word10.* +and Word11.* +and Word12.* +and Word13.* +and Word14.* +and Word15.* +and Word16.* +and Word17.* +and Word18.* +and Word19.* +and Word20.* +and Word21.* +and Word22.* +and Word23.* +and Word24.* +and Word25.* +and Word26.* +and Word27.* +and Word28.* +and Word29.* +and Word30.* +and Word31.* +and Word32.* +and Word64.* +and Real.* +and Real32.* +and Real64.* +and LargeReal.* + +_overload 4 / : 'a * 'a -> 'a +as Real./ +and Real32./ +and Real64./ +and LargeReal./ + +_overload 3 div : 'a * 'a -> 'a +as Int.div +and IntInf.div +and LargeInt.div +and FixedInt.div +and Position.div +and Int2.div +and Int3.div +and Int4.div +and Int5.div +and Int6.div +and Int7.div +and Int8.div +and Int9.div +and Int10.div +and Int11.div +and Int12.div +and Int13.div +and Int14.div +and Int15.div +and Int16.div +and Int17.div +and Int18.div +and Int19.div +and Int20.div +and Int21.div +and Int22.div +and Int23.div +and Int24.div +and Int25.div +and Int26.div +and Int27.div +and Int28.div +and Int29.div +and Int30.div +and Int31.div +and Int32.div +and Int64.div +and Word.div +and LargeWord.div +and SysWord.div +and Word1.div +and Word2.div +and Word3.div +and Word4.div +and Word5.div +and Word6.div +and Word7.div +and Word8.div +and Word9.div +and Word10.div +and Word11.div +and Word12.div +and Word13.div +and Word14.div +and Word15.div +and Word16.div +and Word17.div +and Word18.div +and Word19.div +and Word20.div +and Word21.div +and Word22.div +and Word23.div +and Word24.div +and Word25.div +and Word26.div +and Word27.div +and Word28.div +and Word29.div +and Word30.div +and Word31.div +and Word32.div +and Word64.div + +_overload 3 mod : 'a * 'a -> 'a +as Int.mod +and IntInf.mod +and LargeInt.mod +and FixedInt.mod +and Position.mod +and Int2.mod +and Int3.mod +and Int4.mod +and Int5.mod +and Int6.mod +and Int7.mod +and Int8.mod +and Int9.mod +and Int10.mod +and Int11.mod +and Int12.mod +and Int13.mod +and Int14.mod +and Int15.mod +and Int16.mod +and Int17.mod +and Int18.mod +and Int19.mod +and Int20.mod +and Int21.mod +and Int22.mod +and Int23.mod +and Int24.mod +and Int25.mod +and Int26.mod +and Int27.mod +and Int28.mod +and Int29.mod +and Int30.mod +and Int31.mod +and Int32.mod +and Int64.mod +and Word.mod +and LargeWord.mod +and SysWord.mod +and Word1.mod +and Word2.mod +and Word3.mod +and Word4.mod +and Word5.mod +and Word6.mod +and Word7.mod +and Word8.mod +and Word9.mod +and Word10.mod +and Word11.mod +and Word12.mod +and Word13.mod +and Word14.mod +and Word15.mod +and Word16.mod +and Word17.mod +and Word18.mod +and Word19.mod +and Word20.mod +and Word21.mod +and Word22.mod +and Word23.mod +and Word24.mod +and Word25.mod +and Word26.mod +and Word27.mod +and Word28.mod +and Word29.mod +and Word30.mod +and Word31.mod +and Word32.mod +and Word64.mod + +_overload 3 abs : 'a -> 'a +as Int.abs +and IntInf.abs +and LargeInt.abs +and FixedInt.abs +and Position.abs +and Int2.abs +and Int3.abs +and Int4.abs +and Int5.abs +and Int6.abs +and Int7.abs +and Int8.abs +and Int9.abs +and Int10.abs +and Int11.abs +and Int12.abs +and Int13.abs +and Int14.abs +and Int15.abs +and Int16.abs +and Int17.abs +and Int18.abs +and Int19.abs +and Int20.abs +and Int21.abs +and Int22.abs +and Int23.abs +and Int24.abs +and Int25.abs +and Int26.abs +and Int27.abs +and Int28.abs +and Int29.abs +and Int30.abs +and Int31.abs +and Int32.abs +and Int64.abs +and Real.abs +and Real32.abs +and Real64.abs +and LargeReal.abs + +_overload 1 < : 'a * 'a -> bool +as Int.< +and IntInf.< +and LargeInt.< +and FixedInt.< +and Position.< +and Int2.< +and Int3.< +and Int4.< +and Int5.< +and Int6.< +and Int7.< +and Int8.< +and Int9.< +and Int10.< +and Int11.< +and Int12.< +and Int13.< +and Int14.< +and Int15.< +and Int16.< +and Int17.< +and Int18.< +and Int19.< +and Int20.< +and Int21.< +and Int22.< +and Int23.< +and Int24.< +and Int25.< +and Int26.< +and Int27.< +and Int28.< +and Int29.< +and Int30.< +and Int31.< +and Int32.< +and Int64.< +and Word.< +and LargeWord.< +and SysWord.< +and Word1.< +and Word2.< +and Word3.< +and Word4.< +and Word5.< +and Word6.< +and Word7.< +and Word8.< +and Word9.< +and Word10.< +and Word11.< +and Word12.< +and Word13.< +and Word14.< +and Word15.< +and Word16.< +and Word17.< +and Word18.< +and Word19.< +and Word20.< +and Word21.< +and Word22.< +and Word23.< +and Word24.< +and Word25.< +and Word26.< +and Word27.< +and Word28.< +and Word29.< +and Word30.< +and Word31.< +and Word32.< +and Word64.< +and Real.< +and Real32.< +and Real64.< +and LargeReal.< +and Char.< +and WideChar.< +and String.< +and WideString.< + +_overload 1 <= : 'a * 'a -> bool +as Int.<= +and IntInf.<= +and LargeInt.<= +and FixedInt.<= +and Position.<= +and Int2.<= +and Int3.<= +and Int4.<= +and Int5.<= +and Int6.<= +and Int7.<= +and Int8.<= +and Int9.<= +and Int10.<= +and Int11.<= +and Int12.<= +and Int13.<= +and Int14.<= +and Int15.<= +and Int16.<= +and Int17.<= +and Int18.<= +and Int19.<= +and Int20.<= +and Int21.<= +and Int22.<= +and Int23.<= +and Int24.<= +and Int25.<= +and Int26.<= +and Int27.<= +and Int28.<= +and Int29.<= +and Int30.<= +and Int31.<= +and Int32.<= +and Int64.<= +and Word.<= +and LargeWord.<= +and SysWord.<= +and Word1.<= +and Word2.<= +and Word3.<= +and Word4.<= +and Word5.<= +and Word6.<= +and Word7.<= +and Word8.<= +and Word9.<= +and Word10.<= +and Word11.<= +and Word12.<= +and Word13.<= +and Word14.<= +and Word15.<= +and Word16.<= +and Word17.<= +and Word18.<= +and Word19.<= +and Word20.<= +and Word21.<= +and Word22.<= +and Word23.<= +and Word24.<= +and Word25.<= +and Word26.<= +and Word27.<= +and Word28.<= +and Word29.<= +and Word30.<= +and Word31.<= +and Word32.<= +and Word64.<= +and Real.<= +and Real32.<= +and Real64.<= +and LargeReal.<= +and Char.<= +and WideChar.<= +and String.<= +and WideString.<= + +_overload 1 > : 'a * 'a -> bool +as Int.> +and IntInf.> +and LargeInt.> +and FixedInt.> +and Position.> +and Int2.> +and Int3.> +and Int4.> +and Int5.> +and Int6.> +and Int7.> +and Int8.> +and Int9.> +and Int10.> +and Int11.> +and Int12.> +and Int13.> +and Int14.> +and Int15.> +and Int16.> +and Int17.> +and Int18.> +and Int19.> +and Int20.> +and Int21.> +and Int22.> +and Int23.> +and Int24.> +and Int25.> +and Int26.> +and Int27.> +and Int28.> +and Int29.> +and Int30.> +and Int31.> +and Int32.> +and Int64.> +and Word.> +and LargeWord.> +and SysWord.> +and Word1.> +and Word2.> +and Word3.> +and Word4.> +and Word5.> +and Word6.> +and Word7.> +and Word8.> +and Word9.> +and Word10.> +and Word11.> +and Word12.> +and Word13.> +and Word14.> +and Word15.> +and Word16.> +and Word17.> +and Word18.> +and Word19.> +and Word20.> +and Word21.> +and Word22.> +and Word23.> +and Word24.> +and Word25.> +and Word26.> +and Word27.> +and Word28.> +and Word29.> +and Word30.> +and Word31.> +and Word32.> +and Word64.> +and Real.> +and Real32.> +and Real64.> +and LargeReal.> +and Char.> +and WideChar.> +and String.> +and WideString.> + +_overload 1 >= : 'a * 'a -> bool +as Int.>= +and IntInf.>= +and LargeInt.>= +and FixedInt.>= +and Position.>= +and Int2.>= +and Int3.>= +and Int4.>= +and Int5.>= +and Int6.>= +and Int7.>= +and Int8.>= +and Int9.>= +and Int10.>= +and Int11.>= +and Int12.>= +and Int13.>= +and Int14.>= +and Int15.>= +and Int16.>= +and Int17.>= +and Int18.>= +and Int19.>= +and Int20.>= +and Int21.>= +and Int22.>= +and Int23.>= +and Int24.>= +and Int25.>= +and Int26.>= +and Int27.>= +and Int28.>= +and Int29.>= +and Int30.>= +and Int31.>= +and Int32.>= +and Int64.>= +and Word.>= +and LargeWord.>= +and SysWord.>= +and Word1.>= +and Word2.>= +and Word3.>= +and Word4.>= +and Word5.>= +and Word6.>= +and Word7.>= +and Word8.>= +and Word9.>= +and Word10.>= +and Word11.>= +and Word12.>= +and Word13.>= +and Word14.>= +and Word15.>= +and Word16.>= +and Word17.>= +and Word18.>= +and Word19.>= +and Word20.>= +and Word21.>= +and Word22.>= +and Word23.>= +and Word24.>= +and Word25.>= +and Word26.>= +and Word27.>= +and Word28.>= +and Word29.>= +and Word30.>= +and Word31.>= +and Word32.>= +and Word64.>= +and Real.>= +and Real32.>= +and Real64.>= +and LargeReal.>= +and Char.>= +and WideChar.>= +and String.>= +and WideString.>= diff --git a/basis-library/libs/basis-2002/top-level/pervasive-equal.sml b/basis-library/libs/basis-2002/top-level/pervasive-equal.sml new file mode 100644 index 0000000..95c5cbb --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/pervasive-equal.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + structure B = Basis2002 : BASIS_2002_EQUAL +in + open B +end diff --git a/basis-library/libs/basis-2002/top-level/pervasive-exns.sml b/basis-library/libs/basis-2002/top-level/pervasive-exns.sml new file mode 100644 index 0000000..b805040 --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/pervasive-exns.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + structure B : BASIS_2002_EXNS = Basis2002 +in + open B +end diff --git a/basis-library/libs/basis-2002/top-level/pervasive-types.sml b/basis-library/libs/basis-2002/top-level/pervasive-types.sml new file mode 100644 index 0000000..09539d1 --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/pervasive-types.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + structure B : BASIS_2002_TYPES = Basis2002 +in + open B +end diff --git a/basis-library/libs/basis-2002/top-level/pervasive-vals.sml b/basis-library/libs/basis-2002/top-level/pervasive-vals.sml new file mode 100644 index 0000000..d2e35ea --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/pervasive-vals.sml @@ -0,0 +1,12 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + structure B : BASIS_2002_VALS = Basis2002 +in + open B +end diff --git a/basis-library/libs/basis-2002/top-level/top-level.sml b/basis-library/libs/basis-2002/top-level/top-level.sml new file mode 100644 index 0000000..da6037d --- /dev/null +++ b/basis-library/libs/basis-2002/top-level/top-level.sml @@ -0,0 +1,92 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +open Basis2002 + +(* Rebind some structures so that their definitions appear later, so that they + * will be used for displaying tycon names. + * + * Order here matters! Do not alphabetize or otherwise reorder without thinking. + *) +structure Posix = Posix +structure OS = OS +structure BoolArray = BoolArray +structure BoolArray2 = BoolArray2 +structure BoolVector = BoolVector +structure CharArraySlice = CharArraySlice +structure CharArray = CharArray +structure CharArray2 = CharArray2 +structure Int8Array = Int8Array +structure Int8Array2 = Int8Array2 +structure Int8Vector = Int8Vector +structure Int16Array = Int16Array +structure Int16Array2 = Int16Array2 +structure Int16Vector = Int16Vector +structure Int32Array = Int32Array +structure Int32Array2 = Int32Array2 +structure Int32Vector = Int32Vector +structure Int64Array = Int64Array +structure Int64Array2 = Int64Array2 +structure Int64Vector = Int64Vector +structure IntArray = IntArray +structure IntArray2 = IntArray2 +structure IntVector = IntVector +structure LargeIntArray = LargeIntArray +structure LargeIntArray2 = LargeIntArray2 +structure LargeIntVector = LargeIntVector +structure LargeRealArray = LargeRealArray +structure LargeRealArray2 = LargeRealArray2 +structure LargeRealVector = LargeRealVector +structure LargeWordArray = LargeWordArray +structure LargeWordArray2 = LargeWordArray2 +structure LargeWordVector = LargeWordVector +structure Real32Array = Real32Array +structure Real32Array2 = Real32Array2 +structure Real32Vector = Real32Vector +structure Real64Array = Real64Array +structure Real64Array2 = Real64Array2 +structure Real64Vector = Real64Vector +structure RealArray = RealArray +structure RealArray2 = RealArray2 +structure RealVector = RealVector +structure Word8Array = Word8Array +structure Word8Array2 = Word8Array2 +structure Word8Vector = Word8Vector +structure Word16Array = Word16Array +structure Word16Array2 = Word16Array2 +structure Word16Vector = Word16Vector +structure Word32Array = Word32Array +structure Word32Array2 = Word32Array2 +structure Word32Vector = Word32Vector +structure Word64Array = Word64Array +structure Word64Array2 = Word64Array2 +structure Word64Vector = Word64Vector +structure WordArray = WordArray +structure WordArray2 = WordArray2 +structure WordVector = WordVector +structure Array = Array +structure Array2 = Array2 +structure Vector = Vector +structure Int8 = Int8 +structure Int16 = Int16 +structure Int32 = Int32 +structure Int64 = Int64 +structure IntInf = IntInf +structure LargeInt = LargeInt +structure Int = Int +structure Real32 = Real32 +structure Real64 = Real64 +structure LargeReal = LargeReal +structure Real = Real +structure Word8 = Word8 +structure Word16 = Word16 +structure Word32 = Word32 +structure Word64 = Word64 +structure LargeWord = LargeWord +structure Word = Word diff --git a/basis-library/libs/basis-extra/basis-extra.mlb b/basis-library/libs/basis-extra/basis-extra.mlb new file mode 100644 index 0000000..ab83c71 --- /dev/null +++ b/basis-library/libs/basis-extra/basis-extra.mlb @@ -0,0 +1,31 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + ../../build/sources.mlb + + ann "allowSpecifySpecialIds true" in + top-level/basis.sig + end + ann "allowRedefineSpecialIds true" in + top-level/basis.sml + end + in + structure BasisExtra + top-level/basis-sigs.sml + top-level/basis-funs.sml + top-level/top-level.sml + end +end diff --git a/basis-library/libs/basis-extra/top-level/basis-funs.sml b/basis-library/libs/basis-extra/top-level/basis-funs.sml new file mode 100644 index 0000000..9db10f9 --- /dev/null +++ b/basis-library/libs/basis-extra/top-level/basis-funs.sml @@ -0,0 +1,13 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Required functors *) + +(* Optional functors *) +functor PrimIO (S: PRIM_IO_ARG): PRIM_IO = PrimIO (S) +functor StreamIO (S: STREAM_IO_ARG): STREAM_IO = StreamIO (S) +functor ImperativeIO (S: IMPERATIVE_IO_ARG): IMPERATIVE_IO = ImperativeIO (S) diff --git a/basis-library/libs/basis-extra/top-level/basis-sigs.sml b/basis-library/libs/basis-extra/top-level/basis-sigs.sml new file mode 100644 index 0000000..efb52bc --- /dev/null +++ b/basis-library/libs/basis-extra/top-level/basis-sigs.sml @@ -0,0 +1,116 @@ +(* Copyright (C) 2013 Matthew Fluet. + * Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Required signatures *) +signature ARRAY = ARRAY +signature ARRAY_SLICE = ARRAY_SLICE +signature BIN_IO = BIN_IO +signature BOOL = BOOL +signature BYTE = BYTE +signature CHAR = CHAR +signature COMMAND_LINE = COMMAND_LINE +signature DATE = DATE +signature GENERAL = GENERAL +signature IEEE_REAL = IEEE_REAL +signature IMPERATIVE_IO = IMPERATIVE_IO +signature INTEGER = INTEGER +signature INT_INF = INT_INF +signature IO = IO +signature LIST = LIST +signature LIST_PAIR = LIST_PAIR +signature MATH = MATH +signature MONO_ARRAY = MONO_ARRAY +signature MONO_ARRAY_SLICE = MONO_ARRAY_SLICE +signature MONO_VECTOR = MONO_VECTOR +signature MONO_VECTOR_SLICE = MONO_VECTOR_SLICE +signature OPTION = OPTION +signature OS = OS +signature OS_FILE_SYS = OS_FILE_SYS +signature OS_IO = OS_IO +signature OS_PATH = OS_PATH +signature OS_PROCESS = OS_PROCESS +signature PRIM_IO = PRIM_IO +signature REAL = REAL +signature STREAM_IO = STREAM_IO +signature STRING = STRING +signature STRING_CVT = STRING_CVT +signature SUBSTRING = SUBSTRING +signature TEXT = TEXT +signature TEXT_IO = TEXT_IO +signature TEXT_STREAM_IO = TEXT_STREAM_IO +signature TIME = TIME +signature TIMER = TIMER +signature VECTOR = VECTOR +signature VECTOR_SLICE = VECTOR_SLICE +signature WORD = WORD + +(* Optional signatures *) +signature ARRAY2 = ARRAY2 +signature BIT_FLAGS = BIT_FLAGS +signature GENERIC_SOCK = GENERIC_SOCK +signature INET_SOCK = INET_SOCK +signature INT_INF = INT_INF +signature MONO_ARRAY2 = MONO_ARRAY2 +signature NET_HOST_DB = NET_HOST_DB +signature NET_PROT_DB = NET_PROT_DB +signature NET_SERV_DB = NET_SERV_DB +signature PACK_REAL = PACK_REAL +signature PACK_WORD = PACK_WORD +signature POSIX = POSIX +signature POSIX_ERROR = POSIX_ERROR +signature POSIX_FILE_SYS = POSIX_FILE_SYS +signature POSIX_IO = POSIX_IO +signature POSIX_PROC_ENV = POSIX_PROC_ENV +signature POSIX_PROCESS = POSIX_PROCESS +signature POSIX_SIGNAL = POSIX_SIGNAL +signature POSIX_SYS_DB = POSIX_SYS_DB +signature POSIX_TTY = POSIX_TTY +signature SOCKET = SOCKET +signature UNIX = UNIX +signature UNIX_SOCK = UNIX_SOCK +(* +signature WINDOWS = WINDOWS +*) + +(* Non-standard signatures *) +signature PRIM_IO_ARG = PRIM_IO_ARG +signature STREAM_IO_ARG = STREAM_IO_ARG +signature IMPERATIVE_IO_ARG = IMPERATIVE_IO_ARG +signature SML90 = SML90 + +signature MLTON = MLTON +signature MLTON_ARRAY = MLTON_ARRAY +signature MLTON_BIN_IO = MLTON_BIN_IO +signature MLTON_CONT = MLTON_CONT +signature MLTON_EXN = MLTON_EXN +signature MLTON_FINALIZABLE = MLTON_FINALIZABLE +signature MLTON_GC = MLTON_GC +signature MLTON_INT_INF = MLTON_INT_INF +signature MLTON_IO = MLTON_IO +signature MLTON_ITIMER = MLTON_ITIMER +signature MLTON_MONO_ARRAY = MLTON_MONO_ARRAY +signature MLTON_MONO_VECTOR = MLTON_MONO_VECTOR +signature MLTON_PLATFORM = MLTON_PLATFORM +signature MLTON_POINTER = MLTON_POINTER +signature MLTON_PROC_ENV = MLTON_PROC_ENV +signature MLTON_PROCESS = MLTON_PROCESS +signature MLTON_PROFILE = MLTON_PROFILE +signature MLTON_RANDOM = MLTON_RANDOM +signature MLTON_REAL = MLTON_REAL +signature MLTON_RLIMIT = MLTON_RLIMIT +signature MLTON_RUSAGE = MLTON_RUSAGE +signature MLTON_SIGNAL = MLTON_SIGNAL +signature MLTON_SYSLOG = MLTON_SYSLOG +signature MLTON_TEXT_IO = MLTON_TEXT_IO +signature MLTON_THREAD = MLTON_THREAD +signature MLTON_VECTOR = MLTON_VECTOR +signature MLTON_WEAK = MLTON_WEAK +signature MLTON_WORD = MLTON_WORD +signature MLTON_WORLD = MLTON_WORLD +signature SML_OF_NJ = SML_OF_NJ +signature UNSAFE = UNSAFE diff --git a/basis-library/libs/basis-extra/top-level/basis.sig b/basis-library/libs/basis-extra/top-level/basis.sig new file mode 100644 index 0000000..f811c27 --- /dev/null +++ b/basis-library/libs/basis-extra/top-level/basis.sig @@ -0,0 +1,888 @@ +signature BASIS_EXTRA = + sig + (* Top-level types *) + eqtype 'a array + datatype bool = datatype bool + eqtype char + type exn + eqtype int + datatype 'a option = NONE | SOME of 'a + datatype order = LESS | EQUAL | GREATER + datatype list = datatype list + datatype ref = datatype ref + type real + eqtype string + type substring + eqtype unit + eqtype 'a vector + eqtype word + + (* Top-level exceptions *) + exception Bind + exception Chr + exception Div + exception Domain + exception Empty + exception Fail of string + exception Match + exception Option + exception Overflow + exception Size + exception Span + exception Subscript + + (* Top-level values *) + val = : ''a * ''a -> bool + val <> : ''a * ''a -> bool + + val ! : 'a ref -> 'a + val := : 'a ref * 'a -> unit + val @ : ('a list * 'a list) -> 'a list + val ^ : string * string -> string + val app : ('a -> unit) -> 'a list -> unit + val before : 'a * unit -> 'a + val ceil : real -> int + val chr : int -> char + val concat : string list -> string + val exnMessage : exn -> string + val exnName : exn -> string + val explode : string -> char list + val floor : real -> int + val foldl : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val foldr : ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val getOpt : ('a option * 'a) -> 'a + val hd : 'a list -> 'a + val ignore : 'a -> unit + val isSome : 'a option -> bool + val implode : char list -> string + val length : 'a list -> int + val map : ('a -> 'b) -> 'a list -> 'b list + val not : bool -> bool + val null : 'a list -> bool + val o : ('a -> 'b) * ('c -> 'a) -> 'c -> 'b + val ord : char -> int + val print : string -> unit + val real : int -> real +(* + val ref : 'a -> 'a ref +*) + val rev : 'a list -> 'a list + val round : real -> int + val size : string -> int + val str : char -> string + val substring : string * int * int -> string + val tl : 'a list -> 'a list + val trunc : real -> int +(* + val use : string -> unit +*) + val valOf : 'a option -> 'a + val vector : 'a list -> 'a vector + + (* Required structures *) + structure Array : ARRAY + structure ArraySlice : ARRAY_SLICE + structure BinIO : BIN_IO + structure BinPrimIO : PRIM_IO + structure Bool : BOOL + structure Byte : BYTE + structure Char : CHAR + structure CharArray : MONO_ARRAY + structure CharArraySlice : MONO_ARRAY_SLICE + structure CharVector : MONO_VECTOR + structure CharVectorSlice : MONO_VECTOR_SLICE + structure CommandLine : COMMAND_LINE + structure Date : DATE + structure General : GENERAL + structure IEEEReal : IEEE_REAL + structure Int : INTEGER + structure IO : IO + structure LargeInt : INTEGER + structure LargeReal : REAL + structure LargeWord : WORD + structure List : LIST + structure ListPair : LIST_PAIR + structure Math : MATH + structure Option : OPTION + structure OS : OS + structure Position : INTEGER + structure Real : REAL + structure StringCvt : STRING_CVT + structure String : STRING + structure Substring : SUBSTRING + structure TextIO : TEXT_IO + structure TextPrimIO : PRIM_IO + structure Text : TEXT + structure Time : TIME + structure Timer : TIMER + structure VectorSlice : VECTOR_SLICE + structure Vector : VECTOR + structure Word : WORD + structure Word8: WORD + structure Word8Array : MONO_ARRAY + structure Word8Array2 : MONO_ARRAY2 + structure Word8ArraySlice : MONO_ARRAY_SLICE + structure Word8Vector : MONO_VECTOR + structure Word8VectorSlice : MONO_VECTOR_SLICE + + (* Optional structures *) + structure Array2 : ARRAY2 + structure BoolArray : MONO_ARRAY + structure BoolArray2 : MONO_ARRAY2 + structure BoolArraySlice : MONO_ARRAY_SLICE + structure BoolVector : MONO_VECTOR + structure BoolVectorSlice : MONO_VECTOR_SLICE + structure CharArray2 : MONO_ARRAY2 + structure FixedInt : INTEGER + structure GenericSock : GENERIC_SOCK + structure INetSock : INET_SOCK + structure IntArray : MONO_ARRAY + structure IntArray2 : MONO_ARRAY2 + structure IntArraySlice : MONO_ARRAY_SLICE + structure IntVector : MONO_VECTOR + structure IntVectorSlice : MONO_VECTOR_SLICE + structure Int1: INTEGER + structure Int2: INTEGER + structure Int3: INTEGER + structure Int4: INTEGER + structure Int5: INTEGER + structure Int6: INTEGER + structure Int7: INTEGER + structure Int8: INTEGER + structure Int9: INTEGER + structure Int10: INTEGER + structure Int11: INTEGER + structure Int12: INTEGER + structure Int13: INTEGER + structure Int14: INTEGER + structure Int15: INTEGER + structure Int16: INTEGER + structure Int17: INTEGER + structure Int18: INTEGER + structure Int19: INTEGER + structure Int20: INTEGER + structure Int21: INTEGER + structure Int22: INTEGER + structure Int23: INTEGER + structure Int24: INTEGER + structure Int25: INTEGER + structure Int26: INTEGER + structure Int27: INTEGER + structure Int28: INTEGER + structure Int29: INTEGER + structure Int30: INTEGER + structure Int31: INTEGER + structure Int32: INTEGER + structure Int64: INTEGER + structure Int8Array : MONO_ARRAY + structure Int8Array2 : MONO_ARRAY2 + structure Int8ArraySlice : MONO_ARRAY_SLICE + structure Int8Vector : MONO_VECTOR + structure Int8VectorSlice : MONO_VECTOR_SLICE + structure Int16Array : MONO_ARRAY + structure Int16Array2 : MONO_ARRAY2 + structure Int16ArraySlice : MONO_ARRAY_SLICE + structure Int16Vector : MONO_VECTOR + structure Int16VectorSlice : MONO_VECTOR_SLICE + structure Int32Array : MONO_ARRAY + structure Int32Array2 : MONO_ARRAY2 + structure Int32ArraySlice : MONO_ARRAY_SLICE + structure Int32Vector : MONO_VECTOR + structure Int32VectorSlice : MONO_VECTOR_SLICE + structure Int64Array : MONO_ARRAY + structure Int64Array2 : MONO_ARRAY2 + structure Int64ArraySlice : MONO_ARRAY_SLICE + structure Int64Vector : MONO_VECTOR + structure Int64VectorSlice : MONO_VECTOR_SLICE + structure IntInf : INT_INF + structure IntInfArray : MONO_ARRAY + structure IntInfArray2 : MONO_ARRAY2 + structure IntInfArraySlice : MONO_ARRAY_SLICE + structure IntInfVector : MONO_VECTOR + structure IntInfVectorSlice : MONO_VECTOR_SLICE + structure LargeIntArray : MONO_ARRAY + structure LargeIntArray2 : MONO_ARRAY2 + structure LargeIntArraySlice : MONO_ARRAY_SLICE + structure LargeIntVector : MONO_VECTOR + structure LargeIntVectorSlice : MONO_VECTOR_SLICE + structure LargeRealArray : MONO_ARRAY + structure LargeRealArray2 : MONO_ARRAY2 + structure LargeRealArraySlice : MONO_ARRAY_SLICE + structure LargeRealVector : MONO_VECTOR + structure LargeRealVectorSlice : MONO_VECTOR_SLICE + structure LargeWordArray : MONO_ARRAY + structure LargeWordArray2 : MONO_ARRAY2 + structure LargeWordArraySlice : MONO_ARRAY_SLICE + structure LargeWordVector : MONO_VECTOR + structure LargeWordVectorSlice : MONO_VECTOR_SLICE + structure NetHostDB : NET_HOST_DB + structure NetProtDB : NET_PROT_DB + structure NetServDB : NET_SERV_DB + structure PackReal32Big : PACK_REAL + structure PackReal32Little : PACK_REAL + structure PackReal64Big : PACK_REAL + structure PackReal64Little : PACK_REAL + structure PackRealBig : PACK_REAL + structure PackRealLittle : PACK_REAL + structure PackWord16Big : PACK_WORD + structure PackWord16Little : PACK_WORD + structure PackWord32Big : PACK_WORD + structure PackWord32Little : PACK_WORD + structure PackWord64Big : PACK_WORD + structure PackWord64Little : PACK_WORD + structure Posix : POSIX + structure RealArray : MONO_ARRAY + structure RealArray2 : MONO_ARRAY2 + structure RealArraySlice : MONO_ARRAY_SLICE + structure RealVector : MONO_VECTOR + structure RealVectorSlice : MONO_VECTOR_SLICE + structure Real32 : REAL + structure Real32Array : MONO_ARRAY + structure Real32Array2 : MONO_ARRAY2 + structure Real32ArraySlice : MONO_ARRAY_SLICE + structure Real32Vector : MONO_VECTOR + structure Real32VectorSlice : MONO_VECTOR_SLICE + structure Real64 : REAL + structure Real64Array : MONO_ARRAY + structure Real64Array2 : MONO_ARRAY2 + structure Real64ArraySlice : MONO_ARRAY_SLICE + structure Real64Vector : MONO_VECTOR + structure Real64VectorSlice : MONO_VECTOR_SLICE + structure Socket : SOCKET + structure SysWord : WORD + structure Unix : UNIX + structure UnixSock : UNIX_SOCK + structure WideChar : CHAR + structure WideCharArray : MONO_ARRAY + structure WideCharArray2 : MONO_ARRAY2 + structure WideCharArraySlice : MONO_ARRAY_SLICE + structure WideCharVector : MONO_VECTOR + structure WideCharVectorSlice : MONO_VECTOR_SLICE + structure WideString : STRING + structure WideSubstring : SUBSTRING + structure WideText : TEXT +(* + structure WideTextIO : TEXT_IO + structure WideTextPrimIO : PRIM_IO +*) +(* + structure Windows : WINDOWS +*) + structure WordArray : MONO_ARRAY + structure WordArray2 : MONO_ARRAY2 + structure WordArraySlice : MONO_ARRAY_SLICE + structure WordVector : MONO_VECTOR + structure WordVectorSlice : MONO_VECTOR_SLICE + structure Word1: WORD + structure Word2: WORD + structure Word3: WORD + structure Word4: WORD + structure Word5: WORD + structure Word6: WORD + structure Word7: WORD + (* structure Word8: WORD (* Word8 is a required structure *)*) + structure Word9: WORD + structure Word10: WORD + structure Word11: WORD + structure Word12: WORD + structure Word13: WORD + structure Word14: WORD + structure Word15: WORD + structure Word16: WORD + structure Word17: WORD + structure Word18: WORD + structure Word19: WORD + structure Word20: WORD + structure Word21: WORD + structure Word22: WORD + structure Word23: WORD + structure Word24: WORD + structure Word25: WORD + structure Word26: WORD + structure Word27: WORD + structure Word28: WORD + structure Word29: WORD + structure Word30: WORD + structure Word31: WORD + structure Word32: WORD + structure Word64: WORD + structure Word16Array : MONO_ARRAY + structure Word16Array2 : MONO_ARRAY2 + structure Word16ArraySlice : MONO_ARRAY_SLICE + structure Word16Vector : MONO_VECTOR + structure Word16VectorSlice : MONO_VECTOR_SLICE + structure Word32Array : MONO_ARRAY + structure Word32Array2 : MONO_ARRAY2 + structure Word32ArraySlice : MONO_ARRAY_SLICE + structure Word32Vector : MONO_VECTOR + structure Word32VectorSlice : MONO_VECTOR_SLICE + structure Word64Array : MONO_ARRAY + structure Word64Array2 : MONO_ARRAY2 + structure Word64ArraySlice : MONO_ARRAY_SLICE + structure Word64Vector : MONO_VECTOR + structure Word64VectorSlice : MONO_VECTOR_SLICE + + (* Non-standard structures *) + structure SML90: SML90 + structure MLton: MLTON + structure SMLofNJ: SML_OF_NJ + structure Unsafe: UNSAFE + + sharing type MLton.IntInf.t = IntInf.int + sharing type MLton.Process.pid = Posix.Process.pid + sharing type MLton.ProcEnv.gid = Posix.ProcEnv.gid + sharing type MLton.LargeReal.t = LargeReal.real + sharing type MLton.LargeWord.t = LargeWord.word + sharing type MLton.Real.t = Real.real + sharing type MLton.Real32.t = Real32.real + sharing type MLton.Real64.t = Real64.real + sharing type MLton.Signal.t = Posix.Signal.signal + sharing type MLton.Word.t = Word.word + sharing type MLton.Word8.t = Word8.word + sharing type MLton.Word16.t = Word16.word + sharing type MLton.Word32.t = Word32.word + sharing type MLton.Word64.t = Word64.word + sharing Unsafe.BoolArray = BoolArray + sharing Unsafe.BoolVector = BoolVector + sharing Unsafe.CharArray = CharArray + sharing Unsafe.CharVector = CharVector + sharing Unsafe.IntArray = IntArray + sharing Unsafe.IntVector = IntVector + sharing Unsafe.Int8Array = Int8Array + sharing Unsafe.Int8Vector = Int8Vector + sharing Unsafe.Int16Array = Int16Array + sharing Unsafe.Int16Vector = Int16Vector + sharing Unsafe.Int32Array = Int32Array + sharing Unsafe.Int32Vector = Int32Vector + sharing Unsafe.Int64Array = Int64Array + sharing Unsafe.Int64Vector = Int64Vector + sharing Unsafe.IntInfArray = IntInfArray + sharing Unsafe.IntInfVector = IntInfVector + sharing Unsafe.LargeIntArray = LargeIntArray + sharing Unsafe.LargeIntVector = LargeIntVector + sharing Unsafe.LargeRealArray = LargeRealArray + sharing Unsafe.LargeRealVector = LargeRealVector + sharing Unsafe.LargeWordArray = LargeWordArray + sharing Unsafe.LargeWordVector = LargeWordVector + sharing Unsafe.RealArray = RealArray + sharing Unsafe.RealVector = RealVector + sharing Unsafe.Real32Array = Real32Array + sharing Unsafe.Real32Vector = Real32Vector + sharing Unsafe.Real64Array = Real64Array + sharing Unsafe.Real64Vector = Real64Vector + sharing Unsafe.WordArray = WordArray + sharing Unsafe.WordVector = WordVector + sharing Unsafe.Word8Array = Word8Array + sharing Unsafe.Word8Vector = Word8Vector + sharing Unsafe.Word16Array = Word16Array + sharing Unsafe.Word16Vector = Word16Vector + sharing Unsafe.Word32Array = Word32Array + sharing Unsafe.Word32Vector = Word32Vector + sharing Unsafe.Word64Array = Word64Array + sharing Unsafe.Word64Vector = Word64Vector + sharing Unsafe.PackReal32Big = PackReal32Big + sharing Unsafe.PackReal32Little = PackReal32Little + sharing Unsafe.PackReal64Big = PackReal64Big + sharing Unsafe.PackReal64Little = PackReal64Little + sharing Unsafe.PackRealBig = PackRealBig + sharing Unsafe.PackRealLittle = PackRealLittle + sharing Unsafe.PackWord16Big = PackWord16Big + sharing Unsafe.PackWord16Little = PackWord16Little + sharing Unsafe.PackWord32Big = PackWord32Big + sharing Unsafe.PackWord32Little = PackWord32Little + sharing Unsafe.PackWord64Big = PackWord64Big + sharing Unsafe.PackWord64Little = PackWord64Little + + (* ************************************************** *) + (* ************************************************** *) + + (* Sharing constraints *) + + (* Top-level types *) + sharing type unit = General.unit + sharing type int = Int.int + sharing type word = Word.word + sharing type real = Real.real + sharing type char = Char.char + sharing type string = String.string + sharing type substring = Substring.substring + sharing type exn = General.exn +(* Can't use sharing on type array or vector, because they are rigid tycons. + * Don't need it anyways, since it's built into the ARRAY and VECTOR signatures. + *) +(* + sharing type array = Array.array + sharing type vector = Vector.vector +*) +(* + sharing type ref = General.ref +*) +(* + sharing type bool = Bool.bool +*) + sharing type option = Option.option + sharing type order = General.order +(* + sharing type list = List.list +*) + + (* Required structures *) +(* + sharing type BinIO.StreamIO.elem = Word8.word +*) + sharing type BinIO.StreamIO.reader = BinPrimIO.reader + sharing type BinIO.StreamIO.pos = BinPrimIO.pos +(* + sharing type BinIO.StreamIO.vector = Word8Vector.vector +*) + sharing type BinIO.StreamIO.writer = BinPrimIO.writer + sharing type BinPrimIO.array = Word8Array.array + sharing type BinPrimIO.array_slice = Word8ArraySlice.slice + sharing type BinPrimIO.elem = Word8.word + sharing type BinPrimIO.pos = Position.int + sharing type BinPrimIO.vector = Word8Vector.vector + sharing type BinPrimIO.vector_slice = Word8VectorSlice.slice + sharing type Char.char = char + sharing type Char.string = String.string + sharing type CharArray.elem = char + sharing type CharArray.vector = CharVector.vector + sharing type CharArraySlice.elem = char + sharing type CharArraySlice.array = CharArray.array + sharing type CharArraySlice.vector = CharVector.vector + sharing type CharArraySlice.vector_slice = CharVectorSlice.slice + sharing type CharVector.elem = char + sharing type CharVector.vector = String.string + sharing type CharVectorSlice.elem = char + sharing type CharVectorSlice.vector = String.string + sharing type CharVectorSlice.slice = Substring.substring + sharing type Int.int = int + sharing type Math.real = Real.real + sharing type Real.real = real + sharing type String.string = string + sharing type String.string = CharVector.vector + sharing type String.char = Char.char + sharing type Substring.substring = CharVectorSlice.slice + sharing type Substring.string = String.string + sharing type Substring.char = Char.char + sharing type Text.Char.char = Char.char + sharing type Text.String.string = String.string + sharing type Text.Substring.substring = Substring.substring + sharing type Text.CharVector.vector = CharVector.vector + sharing type Text.CharArray.array = CharArray.array + sharing type Text.CharArraySlice.slice = CharArraySlice.slice + sharing type Text.CharVectorSlice.slice = CharVectorSlice.slice + (* redundant *) +(* + sharing type TextIO.elem = char + sharing type TextIO.vector = string +*) + sharing type TextPrimIO.array = CharArray.array + sharing type TextPrimIO.array_slice = CharArraySlice.slice + sharing type TextPrimIO.elem = Char.char + sharing type TextPrimIO.pos = Position.int + sharing type TextPrimIO.vector = CharVector.vector + sharing type TextPrimIO.vector_slice = CharVectorSlice.slice + sharing type Word.word = word + sharing type Word8Array.elem = Word8.word + sharing type Word8Array.vector = Word8Vector.vector + sharing type Word8ArraySlice.elem = Word8.word + sharing type Word8ArraySlice.array = Word8Array.array + sharing type Word8ArraySlice.vector = Word8Vector.vector + sharing type Word8ArraySlice.vector_slice = Word8VectorSlice.slice + sharing type Word8Vector.elem = Word8.word + sharing type Word8VectorSlice.elem = Word8.word + sharing type Word8VectorSlice.vector = Word8Vector.vector + sharing type Word8Array2.elem = Word8.word + sharing type Word8Array2.vector = Word8Vector.vector + + (* Optional structures *) + sharing type BoolArray.vector = BoolVector.vector + sharing type BoolArraySlice.array = BoolArray.array + sharing type BoolArraySlice.vector = BoolVector.vector + sharing type BoolArraySlice.vector_slice = BoolVectorSlice.slice + sharing type BoolVectorSlice.vector = BoolVector.vector + sharing type BoolArray2.vector = BoolVector.vector + sharing type CharArray2.elem = char + sharing type CharArray2.vector = CharVector.vector + sharing type IntArray.elem = int + sharing type IntArray.vector = IntVector.vector + sharing type IntArraySlice.elem = int + sharing type IntArraySlice.array = IntArray.array + sharing type IntArraySlice.vector = IntVector.vector + sharing type IntArraySlice.vector_slice = IntVectorSlice.slice + sharing type IntVector.elem = int + sharing type IntVectorSlice.elem = int + sharing type IntVectorSlice.vector = IntVector.vector + sharing type IntArray2.elem = int + sharing type IntArray2.vector = IntVector.vector + sharing type Int8Array.elem = Int8.int + sharing type Int8Array.vector = Int8Vector.vector + sharing type Int8ArraySlice.elem = Int8.int + sharing type Int8ArraySlice.array = Int8Array.array + sharing type Int8ArraySlice.vector = Int8Vector.vector + sharing type Int8ArraySlice.vector_slice = Int8VectorSlice.slice + sharing type Int8Vector.elem = Int8.int + sharing type Int8VectorSlice.elem = Int8.int + sharing type Int8VectorSlice.vector = Int8Vector.vector + sharing type Int8Array2.elem = Int8.int + sharing type Int8Array2.vector = Int8Vector.vector + sharing type Int16Array.elem = Int16.int + sharing type Int16Array.vector = Int16Vector.vector + sharing type Int16ArraySlice.elem = Int16.int + sharing type Int16ArraySlice.array = Int16Array.array + sharing type Int16ArraySlice.vector = Int16Vector.vector + sharing type Int16ArraySlice.vector_slice = Int16VectorSlice.slice + sharing type Int16Vector.elem = Int16.int + sharing type Int16VectorSlice.elem = Int16.int + sharing type Int16VectorSlice.vector = Int16Vector.vector + sharing type Int16Array2.elem = Int16.int + sharing type Int16Array2.vector = Int16Vector.vector + sharing type Int32Array.elem = Int32.int + sharing type Int32Array.vector = Int32Vector.vector + sharing type Int32ArraySlice.elem = Int32.int + sharing type Int32ArraySlice.array = Int32Array.array + sharing type Int32ArraySlice.vector = Int32Vector.vector + sharing type Int32ArraySlice.vector_slice = Int32VectorSlice.slice + sharing type Int32Vector.elem = Int32.int + sharing type Int32VectorSlice.elem = Int32.int + sharing type Int32VectorSlice.vector = Int32Vector.vector + sharing type Int32Array2.elem = Int32.int + sharing type Int32Array2.vector = Int32Vector.vector + sharing type Int64Array.elem = Int64.int + sharing type Int64Array.vector = Int64Vector.vector + sharing type Int64ArraySlice.elem = Int64.int + sharing type Int64ArraySlice.array = Int64Array.array + sharing type Int64ArraySlice.vector = Int64Vector.vector + sharing type Int64ArraySlice.vector_slice = Int64VectorSlice.slice + sharing type Int64Vector.elem = Int64.int + sharing type Int64VectorSlice.elem = Int64.int + sharing type Int64VectorSlice.vector = Int64Vector.vector + sharing type Int64Array2.elem = Int64.int + sharing type Int64Array2.vector = Int64Vector.vector + sharing type LargeIntArray.elem = LargeInt.int + sharing type LargeIntArray.vector = LargeIntVector.vector + sharing type LargeIntArraySlice.elem = LargeInt.int + sharing type LargeIntArraySlice.array = LargeIntArray.array + sharing type LargeIntArraySlice.vector = LargeIntVector.vector + sharing type LargeIntArraySlice.vector_slice = LargeIntVectorSlice.slice + sharing type LargeIntVector.elem = LargeInt.int + sharing type LargeIntVectorSlice.elem = LargeInt.int + sharing type LargeIntVectorSlice.vector = LargeIntVector.vector + sharing type LargeIntArray2.elem = LargeInt.int + sharing type LargeIntArray2.vector = LargeIntVector.vector + sharing type LargeRealArray.elem = LargeReal.real + sharing type LargeRealArray.vector = LargeRealVector.vector + sharing type LargeRealArraySlice.elem = LargeReal.real + sharing type LargeRealArraySlice.array = LargeRealArray.array + sharing type LargeRealArraySlice.vector = LargeRealVector.vector + sharing type LargeRealArraySlice.vector_slice = LargeRealVectorSlice.slice + sharing type LargeRealVector.elem = LargeReal.real + sharing type LargeRealVectorSlice.elem = LargeReal.real + sharing type LargeRealVectorSlice.vector = LargeRealVector.vector + sharing type LargeRealArray2.elem = LargeReal.real + sharing type LargeRealArray2.vector = LargeRealVector.vector + sharing type LargeWordArray.elem = LargeWord.word + sharing type LargeWordArray.vector = LargeWordVector.vector + sharing type LargeWordArraySlice.elem = LargeWord.word + sharing type LargeWordArraySlice.array = LargeWordArray.array + sharing type LargeWordArraySlice.vector = LargeWordVector.vector + sharing type LargeWordArraySlice.vector_slice = LargeWordVectorSlice.slice + sharing type LargeWordVector.elem = LargeWord.word + sharing type LargeWordVectorSlice.elem = LargeWord.word + sharing type LargeWordVectorSlice.vector = LargeWordVector.vector + sharing type LargeWordArray2.elem = LargeWord.word + sharing type LargeWordArray2.vector = LargeWordVector.vector + sharing type PackRealBig.real = real + sharing type PackRealLittle.real = real + sharing type PackReal32Big.real = Real32.real + sharing type PackReal32Little.real = Real32.real + sharing type PackReal64Big.real = Real64.real + sharing type PackReal64Little.real = Real64.real + sharing type Posix.Error.syserror = OS.syserror + sharing type Posix.IO.file_desc = Posix.ProcEnv.file_desc + sharing type Posix.FileSys.dirstream = OS.FileSys.dirstream + sharing type Posix.FileSys.access_mode = OS.FileSys.access_mode + sharing type Posix.Process.exit_status = Unix.exit_status + sharing type Posix.Signal.signal = Unix.signal + sharing type RealArray.elem = real + sharing type RealArray.vector = RealVector.vector + sharing type RealArraySlice.elem = real + sharing type RealArraySlice.array = RealArray.array + sharing type RealArraySlice.vector = RealVector.vector + sharing type RealArraySlice.vector_slice = RealVectorSlice.slice + sharing type RealVector.elem = real + sharing type RealVectorSlice.elem = real + sharing type RealVectorSlice.vector = RealVector.vector + sharing type RealArray2.elem = real + sharing type RealArray2.vector = RealVector.vector + sharing type Real32Array.elem = Real32.real + sharing type Real32Array.vector = Real32Vector.vector + sharing type Real32ArraySlice.elem = Real32.real + sharing type Real32ArraySlice.array = Real32Array.array + sharing type Real32ArraySlice.vector = Real32Vector.vector + sharing type Real32ArraySlice.vector_slice = Real32VectorSlice.slice + sharing type Real32Vector.elem = Real32.real + sharing type Real32VectorSlice.elem = Real32.real + sharing type Real32VectorSlice.vector = Real32Vector.vector + sharing type Real32Array2.elem = Real32.real + sharing type Real32Array2.vector = Real32Vector.vector + sharing type Real64Array.elem = Real64.real + sharing type Real64Array.vector = Real64Vector.vector + sharing type Real64ArraySlice.elem = Real64.real + sharing type Real64ArraySlice.array = Real64Array.array + sharing type Real64ArraySlice.vector = Real64Vector.vector + sharing type Real64ArraySlice.vector_slice = Real64VectorSlice.slice + sharing type Real64Vector.elem = Real64.real + sharing type Real64VectorSlice.elem = Real64.real + sharing type Real64VectorSlice.vector = Real64Vector.vector + sharing type Real64Array2.elem = Real64.real + sharing type Real64Array2.vector = Real64Vector.vector + sharing type Unix.exit_status = Posix.Process.exit_status + sharing type WideChar.string = WideString.string + sharing type WideCharArray.elem = WideChar.char + sharing type WideCharArray.vector = WideCharVector.vector + sharing type WideCharArray2.elem = WideChar.char + sharing type WideCharArray2.vector = WideCharVector.vector + sharing type WideCharArraySlice.elem = WideChar.char + sharing type WideCharArraySlice.array = WideCharArray.array + sharing type WideCharArraySlice.vector = WideCharVector.vector + sharing type WideCharArraySlice.vector_slice = WideCharVectorSlice.slice + sharing type WideCharVector.elem = WideChar.char + sharing type WideCharVector.vector = WideString.string + sharing type WideCharVectorSlice.elem = WideChar.char + sharing type WideCharVectorSlice.slice = WideSubstring.substring + sharing type WideCharVectorSlice.vector = WideString.string + sharing type WideString.char = WideChar.char + (* next two are redundant? basis & char both do it... *) + sharing type WideString.string = WideCharVector.vector + sharing type WideSubstring.substring = WideCharVectorSlice.slice + sharing type WideSubstring.string = WideString.string + sharing type WideSubstring.char = WideChar.char + sharing type WideText.Char.char = WideChar.char + sharing type WideText.String.string = WideString.string + sharing type WideText.Substring.substring = WideSubstring.substring + sharing type WideText.CharVector.vector = WideCharVector.vector + sharing type WideText.CharArray.array = WideCharArray.array + sharing type WideText.CharArraySlice.slice = WideCharArraySlice.slice + sharing type WideText.CharVectorSlice.slice = WideCharVectorSlice.slice +(* + sharing type WideTextIO. + sharing type WideTextPrimIO.array = WideCharArray.array + sharing type WideTextPrimIO.vector = WideCharVector.vector + sharing type WideTextPrimIO.elem = WideChar.char +*) + sharing type WordArray.elem = word + sharing type WordArray.vector = WordVector.vector + sharing type WordArraySlice.elem = word + sharing type WordArraySlice.array = WordArray.array + sharing type WordArraySlice.vector = WordVector.vector + sharing type WordArraySlice.vector_slice = WordVectorSlice.slice + sharing type WordVector.elem = word + sharing type WordVectorSlice.elem = word + sharing type WordVectorSlice.vector = WordVector.vector + sharing type WordArray2.elem = word + sharing type WordArray2.vector = WordVector.vector + sharing type Word16Array.elem = Word16.word + sharing type Word16Array.vector = Word16Vector.vector + sharing type Word16ArraySlice.elem = Word16.word + sharing type Word16ArraySlice.array = Word16Array.array + sharing type Word16ArraySlice.vector = Word16Vector.vector + sharing type Word16ArraySlice.vector_slice = Word16VectorSlice.slice + sharing type Word16Vector.elem = Word16.word + sharing type Word16VectorSlice.elem = Word16.word + sharing type Word16VectorSlice.vector = Word16Vector.vector + sharing type Word16Array2.elem = Word16.word + sharing type Word16Array2.vector = Word16Vector.vector + sharing type Word32Array.elem = Word32.word + sharing type Word32Array.vector = Word32Vector.vector + sharing type Word32ArraySlice.elem = Word32.word + sharing type Word32ArraySlice.array = Word32Array.array + sharing type Word32ArraySlice.vector = Word32Vector.vector + sharing type Word32ArraySlice.vector_slice = Word32VectorSlice.slice + sharing type Word32Vector.elem = Word32.word + sharing type Word32VectorSlice.elem = Word32.word + sharing type Word32VectorSlice.vector = Word32Vector.vector + sharing type Word32Array2.elem = Word32.word + sharing type Word32Array2.vector = Word32Vector.vector + sharing type Word64Array.elem = Word64.word + sharing type Word64Array.vector = Word64Vector.vector + sharing type Word64ArraySlice.elem = Word64.word + sharing type Word64ArraySlice.array = Word64Array.array + sharing type Word64ArraySlice.vector = Word64Vector.vector + sharing type Word64ArraySlice.vector_slice = Word64VectorSlice.slice + sharing type Word64Vector.elem = Word64.word + sharing type Word64VectorSlice.elem = Word64.word + sharing type Word64VectorSlice.vector = Word64Vector.vector + sharing type Word64Array2.elem = Word64.word + sharing type Word64Array2.vector = Word64Vector.vector + sharing type MLton.BinIO.instream = BinIO.instream + sharing type MLton.BinIO.outstream = BinIO.outstream + sharing type MLton.CharArray.t = CharArray.array + sharing type MLton.CharArray.elem = CharArray.elem + sharing type MLton.CharVector.t = CharVector.vector + sharing type MLton.CharVector.elem = CharVector.elem + sharing type MLton.TextIO.instream = TextIO.instream + sharing type MLton.TextIO.outstream = TextIO.outstream + sharing type MLton.Word8Array.t = Word8Array.array + sharing type MLton.Word8Array.elem = Word8Array.elem + sharing type MLton.Word8Vector.t = Word8Vector.vector + sharing type MLton.Word8Vector.elem = Word8Vector.elem + end + (* bool is already defined as bool and so cannot be shared. + * So, we where these to get the needed sharing. + *) + where type BoolArray.elem = bool + where type BoolArray2.elem = bool + where type BoolArraySlice.elem = bool + where type BoolVector.elem = bool + where type BoolVectorSlice.elem = bool + + (* Top-level types. These appear free in basis signatures and hence must be + * the same in the basis as at the top level. + *) + where type 'a array = 'a array + where type 'a option = 'a option + where type 'a vector = 'a vector + where type char = char + where type exn = exn + where type int = int + where type order = order + where type real = real + where type string = string + where type substring = substring + where type unit = unit + where type word = word + + (* Types referenced in signatures by structure name *) +(* + where type 'a Array.array = 'a Array.array +*) + where type Array2.traversal = Array2.traversal + where type 'a ArraySlice.slice = 'a ArraySlice.slice + where type BinIO.instream = BinIO.instream (* UNIX *) + where type BinIO.outstream = BinIO.outstream (* UNIX *) + where type BinPrimIO.reader = BinPrimIO.reader (* POSIX_IO *) + where type BinPrimIO.writer = BinPrimIO.writer (* POSIX_IO *) + where type IO.buffer_mode = IO.buffer_mode + where type LargeInt.int = LargeInt.int + where type LargeReal.real = LargeReal.real + where type LargeWord.word = LargeWord.word + where type IEEEReal.real_order = IEEEReal.real_order + where type IEEEReal.float_class = IEEEReal.float_class + where type IEEEReal.rounding_mode = IEEEReal.rounding_mode + where type NetHostDB.in_addr = NetHostDB.in_addr + where type NetHostDB.addr_family = NetHostDB.addr_family + where type OS.IO.iodesc = OS.IO.iodesc (* PRIM_IO, POSIX_FILE_SYS *) + where type OS.Process.status = OS.Process.status (* UNIX, POSIX_PROCESS *) + where type Position.int = Position.int + where type Posix.IO.file_desc = Posix.IO.file_desc + where type Posix.Process.exit_status = Posix.Process.exit_status + where type Posix.Signal.signal = Posix.Signal.signal + where type Socket.dgram = Socket.dgram + where type ('a, 'b) Socket.sock = ('a, 'b) Socket.sock + where type 'a Socket.sock_addr = 'a Socket.sock_addr + where type Socket.SOCK.sock_type = Socket.SOCK.sock_type (* GENERIC_SOCK *) + where type 'a Socket.stream = 'a Socket.stream + where type StringCvt.radix = StringCvt.radix + where type StringCvt.realfmt = StringCvt.realfmt +(* + where type ('a, 'b) StringCvt.reader = ('a, 'b) StringCvt.reader +*) + where type SysWord.word = SysWord.word + where type TextIO.instream = TextIO.instream (* UNIX *) + where type TextIO.outstream = TextIO.outstream (* UNIX *) + where type TextPrimIO.reader = TextPrimIO.reader (* POSIX_IO *) + where type TextPrimIO.writer = TextPrimIO.writer (* POSIX_IO *) + where type Time.time = Time.time +(* + where type 'a Vector.vector = 'a Vector.vector +*) + where type 'a VectorSlice.slice = 'a VectorSlice.slice +(* + where type WideTextIO.instream = WideTextIO.instream + where type WideTextIO.outstream = WideTextIO.outstream + where type WideTextPrimIO.reader = WideTextPrimIO.reader + where type WideTextPrimIO.writer = WideTextPrimIO.writer +*) + where type Word8Array.array = Word8Array.array + where type Word8ArraySlice.slice = Word8ArraySlice.slice + where type Word8ArraySlice.vector_slice = Word8ArraySlice.vector_slice + where type Word8Vector.vector = Word8Vector.vector + + where type MLton.Pointer.t = MLton.Pointer.t + where type 'a MLton.Thread.t = 'a MLton.Thread.t + where type MLton.Thread.Runnable.t = MLton.Thread.Runnable.t + + (* Types that must be exposed because constants denote them. *) + where type FixedInt.int = FixedInt.int + where type Int1.int = Int1.int + where type Int2.int = Int2.int + where type Int3.int = Int3.int + where type Int4.int = Int4.int + where type Int5.int = Int5.int + where type Int6.int = Int6.int + where type Int7.int = Int7.int + where type Int8.int = Int8.int + where type Int9.int = Int9.int + where type Int10.int = Int10.int + where type Int11.int = Int11.int + where type Int12.int = Int12.int + where type Int13.int = Int13.int + where type Int14.int = Int14.int + where type Int15.int = Int15.int + where type Int16.int = Int16.int + where type Int17.int = Int17.int + where type Int18.int = Int18.int + where type Int19.int = Int19.int + where type Int20.int = Int20.int + where type Int21.int = Int21.int + where type Int22.int = Int22.int + where type Int23.int = Int23.int + where type Int24.int = Int24.int + where type Int25.int = Int25.int + where type Int26.int = Int26.int + where type Int27.int = Int27.int + where type Int28.int = Int28.int + where type Int29.int = Int29.int + where type Int30.int = Int30.int + where type Int31.int = Int31.int + where type Int32.int = Int32.int + where type Int64.int = Int64.int + where type IntInf.int = IntInf.int + where type Real32.real = Real32.real + where type Real64.real = Real64.real + where type WideChar.char = WideChar.char + where type WideString.string = WideString.string + where type Word1.word = Word1.word + where type Word2.word = Word2.word + where type Word3.word = Word3.word + where type Word4.word = Word4.word + where type Word5.word = Word5.word + where type Word6.word = Word6.word + where type Word7.word = Word7.word + where type Word8.word = Word8.word + where type Word9.word = Word9.word + where type Word10.word = Word10.word + where type Word11.word = Word11.word + where type Word12.word = Word12.word + where type Word13.word = Word13.word + where type Word14.word = Word14.word + where type Word15.word = Word15.word + where type Word16.word = Word16.word + where type Word17.word = Word17.word + where type Word18.word = Word18.word + where type Word19.word = Word19.word + where type Word20.word = Word20.word + where type Word21.word = Word21.word + where type Word22.word = Word22.word + where type Word23.word = Word23.word + where type Word24.word = Word24.word + where type Word25.word = Word25.word + where type Word26.word = Word26.word + where type Word27.word = Word27.word + where type Word28.word = Word28.word + where type Word29.word = Word29.word + where type Word30.word = Word30.word + where type Word31.word = Word31.word + where type Word32.word = Word32.word + where type Word64.word = Word64.word diff --git a/basis-library/libs/basis-extra/top-level/basis.sml b/basis-library/libs/basis-extra/top-level/basis.sml new file mode 100644 index 0000000..7d7b26c --- /dev/null +++ b/basis-library/libs/basis-extra/top-level/basis.sml @@ -0,0 +1,278 @@ +(* Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure BasisExtra :> BASIS_EXTRA = + struct + (* Required structures *) + structure Array = Array + structure ArraySlice = ArraySlice + structure BinIO = BinIO + structure BinPrimIO = BinPrimIO + structure Bool = Bool + structure Byte = Byte + structure Char = Char + structure CharArray = CharArray + structure CharArraySlice = CharArraySlice + structure CharVector = CharVector + structure CharVectorSlice = CharVectorSlice + structure CommandLine = CommandLine + structure Date = Date + structure General = General + structure IEEEReal = IEEEReal + structure IO = IO + structure Int = Int + structure LargeInt = LargeInt + structure LargeReal = LargeReal + structure LargeWord = LargeWord + structure List = List + structure ListPair = ListPair + structure OS = OS + structure Option = Option + structure Position = Position + structure Real = Real + structure String = String + structure StringCvt = StringCvt + structure Substring = Substring + structure Text = Text + structure TextIO = TextIO + structure TextPrimIO = TextPrimIO + structure Time = Time + structure Timer = Timer + structure Vector = Vector + structure VectorSlice = VectorSlice + structure Word = Word + structure Word8 = Word8 + structure Word8Array = Word8Array + structure Word8Array2 = Word8Array2 + structure Word8ArraySlice = Word8ArraySlice + structure Word8Vector = Word8Vector + structure Word8VectorSlice = Word8VectorSlice + + (* Optional structures *) + structure Array2 = Array2 + structure BoolArray = BoolArray + structure BoolArray2 = BoolArray2 + structure BoolArraySlice = BoolArraySlice + structure BoolVector = BoolVector + structure BoolVectorSlice = BoolVectorSlice + structure CharArray2 = CharArray2 + structure FixedInt = FixedInt + structure GenericSock = GenericSock + structure INetSock = INetSock + structure Int1 = Int1 + structure Int2 = Int2 + structure Int3 = Int3 + structure Int4 = Int4 + structure Int5 = Int5 + structure Int6 = Int6 + structure Int7 = Int7 + structure Int8 = Int8 + structure Int9 = Int9 + structure Int10 = Int10 + structure Int11 = Int11 + structure Int12 = Int12 + structure Int13 = Int13 + structure Int14 = Int14 + structure Int15 = Int15 + structure Int16 = Int16 + structure Int16 = Int16 + structure Int17 = Int17 + structure Int18 = Int18 + structure Int19 = Int19 + structure Int20 = Int20 + structure Int21 = Int21 + structure Int22 = Int22 + structure Int23 = Int23 + structure Int24 = Int24 + structure Int25 = Int25 + structure Int26 = Int26 + structure Int27 = Int27 + structure Int28 = Int28 + structure Int29 = Int29 + structure Int30 = Int30 + structure Int31 = Int31 + structure Int32 = Int32 + structure Int64 = Int64 + structure IntArray = IntArray + structure IntArray2 = IntArray2 + structure IntArraySlice = IntArraySlice + structure IntVector = IntVector + structure IntVectorSlice = IntVectorSlice + structure Int8Array = Int8Array + structure Int8Array2 = Int8Array2 + structure Int8ArraySlice = Int8ArraySlice + structure Int8Vector = Int8Vector + structure Int8VectorSlice = Int8VectorSlice + structure Int16Array = Int16Array + structure Int16Array2 = Int16Array2 + structure Int16ArraySlice = Int16ArraySlice + structure Int16Vector = Int16Vector + structure Int16VectorSlice = Int16VectorSlice + structure Int32Array = Int32Array + structure Int32Array2 = Int32Array2 + structure Int32ArraySlice = Int32ArraySlice + structure Int32Vector = Int32Vector + structure Int32VectorSlice = Int32VectorSlice + structure Int64Array = Int64Array + structure Int64Array2 = Int64Array2 + structure Int64ArraySlice = Int64ArraySlice + structure Int64Vector = Int64Vector + structure Int64VectorSlice = Int64VectorSlice + structure IntInf = IntInf + structure IntInfArray = IntInfArray + structure IntInfArray2 = IntInfArray2 + structure IntInfArraySlice = IntInfArraySlice + structure IntInfVector = IntInfVector + structure IntInfVectorSlice = IntInfVectorSlice + structure LargeIntArray = LargeIntArray + structure LargeIntArray2 = LargeIntArray2 + structure LargeIntArraySlice = LargeIntArraySlice + structure LargeIntVector = LargeIntVector + structure LargeIntVectorSlice = LargeIntVectorSlice + structure LargeRealArray = LargeRealArray + structure LargeRealArray2 = LargeRealArray2 + structure LargeRealArraySlice = LargeRealArraySlice + structure LargeRealVector = LargeRealVector + structure LargeRealVectorSlice = LargeRealVectorSlice + structure LargeWordArray = LargeWordArray + structure LargeWordArray2 = LargeWordArray2 + structure LargeWordArraySlice = LargeWordArraySlice + structure LargeWordVector = LargeWordVector + structure LargeWordVectorSlice = LargeWordVectorSlice + structure NetHostDB = NetHostDB + structure NetProtDB = NetProtDB + structure NetServDB = NetServDB + structure PackReal32Big = PackReal32Big + structure PackReal32Little = PackReal32Little + structure PackReal64Big = PackReal64Big + structure PackReal64Little = PackReal64Little + structure PackRealBig = PackRealBig + structure PackRealLittle = PackRealLittle + structure PackWord16Big = PackWord16Big + structure PackWord16Little = PackWord16Little + structure PackWord32Big = PackWord32Big + structure PackWord32Little = PackWord32Little + structure PackWord64Big = PackWord64Big + structure PackWord64Little = PackWord64Little + structure Posix = Posix + structure Real32 = Real32 + structure Real32Array = Real32Array + structure Real32Array2 = Real32Array2 + structure Real32ArraySlice = Real32ArraySlice + structure Real32Vector = Real32Vector + structure Real32VectorSlice = Real32VectorSlice + structure Real64 = Real64 + structure Real64Array = Real64Array + structure Real64Array2 = Real64Array2 + structure Real64ArraySlice = Real64ArraySlice + structure Real64Vector = Real64Vector + structure Real64VectorSlice = Real64VectorSlice + structure RealArray = RealArray + structure RealArray2 = RealArray2 + structure RealArraySlice = RealArraySlice + structure RealVector = RealVector + structure RealVectorSlice = RealVectorSlice + structure Socket = Socket + structure SysWord = SysWord + structure Unix = Unix + structure UnixSock = UnixSock + structure WideChar = WideChar + structure WideCharArray = WideCharArray + structure WideCharArray2 = WideCharArray2 + structure WideCharArraySlice = WideCharArraySlice + structure WideCharVector = WideCharVector + structure WideCharVectorSlice = WideCharVectorSlice + structure WideString = WideString + structure WideSubstring = WideSubstring + structure WideText = WideText +(* + structure WideTextIO = WideTextIO + structure WideTextPrimIO = WideTextPrimIO +*) +(* + structure Windows = Windows +*) + structure Word1 = Word1 + structure Word2 = Word2 + structure Word3 = Word3 + structure Word4 = Word4 + structure Word5 = Word5 + structure Word6 = Word6 + structure Word7 = Word7 + structure Word8 = Word8 + structure Word9 = Word9 + structure Word10 = Word10 + structure Word11 = Word11 + structure Word12 = Word12 + structure Word13 = Word13 + structure Word14 = Word14 + structure Word15 = Word15 + structure Word16 = Word16 + structure Word17 = Word17 + structure Word18 = Word18 + structure Word19 = Word19 + structure Word20 = Word20 + structure Word21 = Word21 + structure Word22 = Word22 + structure Word23 = Word23 + structure Word24 = Word24 + structure Word25 = Word25 + structure Word26 = Word26 + structure Word27 = Word27 + structure Word28 = Word28 + structure Word29 = Word29 + structure Word30 = Word30 + structure Word31 = Word31 + structure Word32 = Word32 + structure Word64 = Word64 + structure Word16 = Word16 + structure WordArray = WordArray + structure WordArray2 = WordArray2 + structure WordArraySlice = WordArraySlice + structure WordVector = WordVector + structure WordVectorSlice = WordVectorSlice + structure Word16Array = Word16Array + structure Word16Array2 = Word16Array2 + structure Word16ArraySlice = Word16ArraySlice + structure Word16Vector = Word16Vector + structure Word16VectorSlice = Word16VectorSlice + structure Word32Array = Word32Array + structure Word32Array2 = Word32Array2 + structure Word32ArraySlice = Word32ArraySlice + structure Word32Vector = Word32Vector + structure Word32VectorSlice = Word32VectorSlice + structure Word64Array = Word64Array + structure Word64Array2 = Word64Array2 + structure Word64ArraySlice = Word64ArraySlice + structure Word64Vector = Word64Vector + structure Word64VectorSlice = Word64VectorSlice + + (* Non-standard structures *) + structure SML90 = SML90 + structure MLton = MLton + structure SMLofNJ = SMLofNJ + structure Unsafe = Unsafe + + open ArrayGlobal + BoolGlobal + CharGlobal + IntGlobal + GeneralGlobal + ListGlobal + OptionGlobal + RealGlobal + StringGlobal + SubstringGlobal + TextIOGlobal + VectorGlobal + WordGlobal + val real = real + val op = = op = + val op <> = op <> + val vector = vector + datatype ref = datatype ref + end diff --git a/basis-library/libs/basis-extra/top-level/top-level.sml b/basis-library/libs/basis-extra/top-level/top-level.sml new file mode 100644 index 0000000..2afcbbb --- /dev/null +++ b/basis-library/libs/basis-extra/top-level/top-level.sml @@ -0,0 +1,15 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + open BasisExtra +in + structure SML90 = SML90 + structure MLton = MLton + structure SMLofNJ = SMLofNJ + structure Unsafe = Unsafe +end diff --git a/basis-library/libs/basis-none/top-level/basis.sig b/basis-library/libs/basis-none/top-level/basis.sig new file mode 100644 index 0000000..c5b57e1 --- /dev/null +++ b/basis-library/libs/basis-none/top-level/basis.sig @@ -0,0 +1,24 @@ +signature BASIS_NONE = + sig + (* Top-level types *) + eqtype 'a array + datatype bool = datatype BasisExtra.bool + eqtype char + type exn + eqtype int + datatype list = datatype BasisExtra.list + datatype ref = datatype BasisExtra.ref + type real + eqtype string + type substring + eqtype unit + eqtype 'a vector + eqtype word + + exception Bind + exception Match + exception Overflow + + val = : ''a * ''a -> bool + val <> : ''a * ''a -> bool + end diff --git a/basis-library/libs/basis-none/top-level/basis.sml b/basis-library/libs/basis-none/top-level/basis.sml new file mode 100644 index 0000000..3d3254e --- /dev/null +++ b/basis-library/libs/basis-none/top-level/basis.sml @@ -0,0 +1,8 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure BasisNone : BASIS_NONE = BasisExtra diff --git a/basis-library/libs/basis-none/top-level/infixes.sml b/basis-library/libs/basis-none/top-level/infixes.sml new file mode 100644 index 0000000..214a8b3 --- /dev/null +++ b/basis-library/libs/basis-none/top-level/infixes.sml @@ -0,0 +1,9 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +infix 4 = diff --git a/basis-library/libs/basis-none/top-level/top-level.sml b/basis-library/libs/basis-none/top-level/top-level.sml new file mode 100644 index 0000000..e34573f --- /dev/null +++ b/basis-library/libs/basis-none/top-level/top-level.sml @@ -0,0 +1,9 @@ +(* Copyright (C) 2002-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + + +open BasisNone diff --git a/basis-library/list/list-pair.sig b/basis-library/list/list-pair.sig new file mode 100644 index 0000000..27ce667 --- /dev/null +++ b/basis-library/list/list-pair.sig @@ -0,0 +1,18 @@ +signature LIST_PAIR = + sig + exception UnequalLengths + val zip: 'a list * 'b list -> ('a * 'b) list + val zipEq: 'a list * 'b list -> ('a * 'b) list + val unzip: ('a * 'b) list -> 'a list * 'b list + val app: ('a * 'b -> unit) -> 'a list * 'b list -> unit + val appEq: ('a * 'b -> unit) -> 'a list * 'b list -> unit + val map: ('a * 'b -> 'c) -> 'a list * 'b list -> 'c list + val mapEq: ('a * 'b -> 'c) -> 'a list * 'b list -> 'c list + val foldl: ('a * 'b * 'c -> 'c) -> 'c -> 'a list * 'b list -> 'c + val foldr: ('a * 'b * 'c -> 'c) -> 'c -> 'a list * 'b list -> 'c + val foldlEq: ('a * 'b * 'c -> 'c) -> 'c -> 'a list * 'b list -> 'c + val foldrEq: ('a * 'b * 'c -> 'c) -> 'c -> 'a list * 'b list -> 'c + val all: ('a * 'b -> bool) -> 'a list * 'b list -> bool + val exists: ('a * 'b -> bool) -> 'a list * 'b list -> bool + val allEq: ('a * 'b -> bool) -> 'a list * 'b list -> bool + end diff --git a/basis-library/list/list-pair.sml b/basis-library/list/list-pair.sml new file mode 100644 index 0000000..d84f1ca --- /dev/null +++ b/basis-library/list/list-pair.sml @@ -0,0 +1,91 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure ListPair: LIST_PAIR = + struct + exception UnequalLengths + + fun id x = x + + fun ul _ = raise UnequalLengths + + fun unzip l = + List.foldr (fn ((x, y), (xs, ys)) => (x :: xs, y :: ys)) ([], []) l + + fun foldl' w f b (l1, l2) = + let + fun loop (l1, l2, b) = + case (l1, l2) of + ([], []) => b + | (x1 :: l1, x2 :: l2) => loop (l1, l2, f (x1, x2, b)) + | _ => w b + in + loop (l1, l2, b) + end + + fun foldl f = foldl' id f + + fun foldlEq f = foldl' ul f + + fun foldr' w f b (l1, l2) = + let + fun loop (l1, l2) = + case (l1, l2) of + ([], []) => b + | (x1 :: l1, x2 :: l2) => f (x1, x2, loop (l1, l2)) + | _ => w b + in + loop (l1, l2) + end + + fun foldr f = foldr' id f + + fun foldrEq f = foldr' ul f + + fun zip' w (l1, l2) = + rev (foldl' w (fn (x, x', l) => (x, x') :: l) [] (l1, l2)) + + fun zip (l1, l2) = zip' id (l1, l2) + + fun zipEq (l1, l2) = zip' ul (l1, l2) + + fun map' w f = rev o (foldl' w (fn (x1, x2, l) => f (x1, x2) :: l) []) + + fun map f = map' id f + + fun mapEq f = map' ul f + + fun app' w f = foldl' w (fn (x1, x2, ()) => f (x1, x2)) () + + fun app f = app' id f + + fun appEq f = app' ul f + + fun exists p (l1, l2) = + let + fun loop (l1, l2) = + case (l1, l2) of + (x1 :: l1, x2 :: l2) => p (x1, x2) orelse loop (l1, l2) + | _ => false + in + loop (l1, l2) + end + + fun all p ls = not (exists (not o p) ls) + + fun allEq p = + let + fun loop (l1, l2) = + case (l1, l2) of + ([], []) => true + | (x1 :: l1, x2 :: l2) => p (x1, x2) andalso loop (l1, l2) + | _ => false + in + loop + end + end diff --git a/basis-library/list/list.sig b/basis-library/list/list.sig new file mode 100644 index 0000000..6dacb05 --- /dev/null +++ b/basis-library/list/list.sig @@ -0,0 +1,38 @@ +signature LIST_GLOBAL = + sig + datatype list = datatype list + + exception Empty + + val @ : 'a list * 'a list -> 'a list + val app: ('a -> unit) -> 'a list -> unit + val foldl: ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val foldr: ('a * 'b -> 'b) -> 'b -> 'a list -> 'b + val hd: 'a list -> 'a + val length: 'a list -> int + val map: ('a -> 'b) -> 'a list -> 'b list + val null: 'a list -> bool + val rev: 'a list -> 'a list + val tl: 'a list -> 'a list + end + +signature LIST = + sig + include LIST_GLOBAL + + val all: ('a -> bool) -> 'a list -> bool + val collate: ('a * 'a -> order) -> 'a list * 'a list -> order + val concat: 'a list list -> 'a list + val drop: 'a list * int -> 'a list + val exists: ('a -> bool) -> 'a list -> bool + val filter: ('a -> bool) -> 'a list -> 'a list + val find: ('a -> bool) -> 'a list -> 'a option + val getItem: 'a list -> ('a * 'a list) option + val last: 'a list -> 'a + val mapPartial: ('a -> 'b option) -> 'a list -> 'b list + val nth: 'a list * int -> 'a + val partition: ('a -> bool) -> 'a list -> 'a list * 'a list + val revAppend: 'a list * 'a list -> 'a list + val tabulate: int * (int -> 'a) -> 'a list + val take: 'a list * int -> 'a list + end diff --git a/basis-library/list/list.sml b/basis-library/list/list.sml new file mode 100644 index 0000000..521df6b --- /dev/null +++ b/basis-library/list/list.sml @@ -0,0 +1,171 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure List: LIST = + struct + open Int + + datatype list = datatype Primitive.List.list + + exception Empty + + val null = + fn [] => true + | _ => false + + val hd = + fn x :: _ => x + | _ => raise Empty + + val tl = + fn _ :: l => l + | _ => raise Empty + + val rec last = + fn [] => raise Empty + | [x] => x + | _ :: l => last l + + val getItem = + fn [] => NONE + | x :: r => SOME (x, r) + + fun foldl f b l = + let + fun loop (l, b) = + case l of + [] => b + | x :: l => loop (l, f (x, b)) + in loop (l, b) + end + + fun length l = foldl (fn (_, n) => n +? 1) 0 l + + fun appendRev (l1, l2) = foldl (op ::) l2 l1 + + val revAppend = appendRev + + fun rev l = appendRev (l, []) + + fun l1 @ l2 = + case l2 of + [] => l1 + | _ => appendRev (rev l1, l2) + + fun foldr f b l = foldl f b (rev l) + + fun concat ls = foldr (op @) [] ls + + fun app f = foldl (f o #1) () + + fun map f l = rev (foldl (fn (x, l) => f x :: l) [] l) + + fun mapPartial pred l = + rev (foldl (fn (x, l) => (case pred x of + NONE => l + | SOME y => y :: l)) + [] l) + + fun filter pred = mapPartial (fn x => if pred x then SOME x else NONE) + + fun partition pred l = + let + val (pos, neg) = + foldl (fn (x, (trues, falses)) => + if pred x then (x :: trues, falses) + else (trues, x :: falses)) + ([], []) l + in (rev pos, rev neg) + end + + fun find pred = + let + val rec loop = + fn [] => NONE + | x :: l => if pred x + then SOME x + else loop l + in loop + end + + fun exists pred l = + case find pred l of + NONE => false + | SOME _ => true + + fun all pred = not o (exists (not o pred)) + + fun tabulate (n, f) = + if Primitive.Controls.safe andalso n < 0 + then raise Size + else let + fun loop (i, ac) = + if i < n + then loop (i + 1, f i :: ac) + else rev ac + in loop (0, []) + end + + fun nth (l, n) = + let + fun loop (l, n) = + case l of + [] => raise Subscript + | x :: l => + if n > 0 + then loop (l, n - 1) + else x + in + if Primitive.Controls.safe andalso n < 0 + then raise Subscript + else loop (l, n) + end + + fun take (l, n) = + let + fun loop (l, n, ac) = + if n > 0 + then (case l of + [] => raise Subscript + | x :: l => loop (l, n - 1, x :: ac)) + else rev ac + in + if Primitive.Controls.safe andalso n < 0 + then raise Subscript + else loop (l, n, []) + end + + fun drop (l, n) = + let + fun loop (l, n) = + if n > 0 + then (case l of + [] => raise Subscript + | _ :: l => loop (l, n - 1)) + else l + in + if Primitive.Controls.safe andalso n < 0 + then raise Subscript + else loop (l, n) + end + + fun collate cmp = + let + val rec loop = + fn ([], []) => EQUAL + | ([], _) => LESS + | (_, []) => GREATER + | (x1::l1,x2::l2) => (case cmp (x1, x2) of + EQUAL => loop (l1, l2) + | ans => ans) + in loop + end + end + +structure ListGlobal: LIST_GLOBAL = List +open ListGlobal diff --git a/basis-library/maps/array-metadata-size128.map b/basis-library/maps/array-metadata-size128.map new file mode 100644 index 0000000..ef03053 --- /dev/null +++ b/basis-library/maps/array-metadata-size128.map @@ -0,0 +1 @@ +ARRAY_METADATA_SIZE size128 diff --git a/basis-library/maps/array-metadata-size192.map b/basis-library/maps/array-metadata-size192.map new file mode 100644 index 0000000..05156b8 --- /dev/null +++ b/basis-library/maps/array-metadata-size192.map @@ -0,0 +1 @@ +ARRAY_METADATA_SIZE size192 diff --git a/basis-library/maps/array-metadata-size256.map b/basis-library/maps/array-metadata-size256.map new file mode 100644 index 0000000..f8feac6 --- /dev/null +++ b/basis-library/maps/array-metadata-size256.map @@ -0,0 +1 @@ +ARRAY_METADATA_SIZE size256 diff --git a/basis-library/maps/array-metadata-size96.map b/basis-library/maps/array-metadata-size96.map new file mode 100644 index 0000000..765240c --- /dev/null +++ b/basis-library/maps/array-metadata-size96.map @@ -0,0 +1 @@ +ARRAY_METADATA_SIZE size96 diff --git a/basis-library/maps/normal-metadata-size128.map b/basis-library/maps/normal-metadata-size128.map new file mode 100644 index 0000000..beb2ce7 --- /dev/null +++ b/basis-library/maps/normal-metadata-size128.map @@ -0,0 +1 @@ +NORMAL_METADATA_SIZE size128 diff --git a/basis-library/maps/normal-metadata-size32.map b/basis-library/maps/normal-metadata-size32.map new file mode 100644 index 0000000..dfb5a90 --- /dev/null +++ b/basis-library/maps/normal-metadata-size32.map @@ -0,0 +1 @@ +NORMAL_METADATA_SIZE size32 diff --git a/basis-library/maps/normal-metadata-size64.map b/basis-library/maps/normal-metadata-size64.map new file mode 100644 index 0000000..9ea75de --- /dev/null +++ b/basis-library/maps/normal-metadata-size64.map @@ -0,0 +1 @@ +NORMAL_METADATA_SIZE size64 diff --git a/basis-library/maps/objptr-rep32.map b/basis-library/maps/objptr-rep32.map new file mode 100644 index 0000000..e901698 --- /dev/null +++ b/basis-library/maps/objptr-rep32.map @@ -0,0 +1 @@ +OBJPTR_REP rep32 diff --git a/basis-library/maps/objptr-rep64.map b/basis-library/maps/objptr-rep64.map new file mode 100644 index 0000000..fafd3aa --- /dev/null +++ b/basis-library/maps/objptr-rep64.map @@ -0,0 +1 @@ +OBJPTR_REP rep64 diff --git a/basis-library/maps/seqindex-int32.map b/basis-library/maps/seqindex-int32.map new file mode 100644 index 0000000..c1f5b08 --- /dev/null +++ b/basis-library/maps/seqindex-int32.map @@ -0,0 +1 @@ +SEQINDEX_INT int32 diff --git a/basis-library/maps/seqindex-int64.map b/basis-library/maps/seqindex-int64.map new file mode 100644 index 0000000..2661893 --- /dev/null +++ b/basis-library/maps/seqindex-int64.map @@ -0,0 +1 @@ +SEQINDEX_INT int64 diff --git a/basis-library/mlton.mlb b/basis-library/mlton.mlb new file mode 100644 index 0000000..a773aa8 --- /dev/null +++ b/basis-library/mlton.mlb @@ -0,0 +1,51 @@ +(* Copyright (C) 2013 Matthew Fluet. + * Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + libs/basis-extra/basis-extra.mlb + in + signature MLTON + signature MLTON_ARRAY + signature MLTON_BIN_IO + signature MLTON_CONT + signature MLTON_EXN + signature MLTON_FINALIZABLE + signature MLTON_GC + signature MLTON_INT_INF + signature MLTON_IO + signature MLTON_ITIMER + signature MLTON_MONO_ARRAY + signature MLTON_MONO_VECTOR + signature MLTON_PLATFORM + signature MLTON_POINTER + signature MLTON_PROC_ENV + signature MLTON_PROCESS + signature MLTON_PROFILE + signature MLTON_RANDOM + signature MLTON_REAL + signature MLTON_RLIMIT + signature MLTON_RUSAGE + signature MLTON_SIGNAL + signature MLTON_SYSLOG + signature MLTON_TEXT_IO + signature MLTON_THREAD + signature MLTON_VECTOR + signature MLTON_WEAK + signature MLTON_WORD + signature MLTON_WORLD + + structure MLton + end +end diff --git a/basis-library/mlton/array.sig b/basis-library/mlton/array.sig new file mode 100644 index 0000000..071aff5 --- /dev/null +++ b/basis-library/mlton/array.sig @@ -0,0 +1,14 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +type int = Int.int + +signature MLTON_ARRAY = + sig + val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b + end diff --git a/basis-library/mlton/bin-io.sig b/basis-library/mlton/bin-io.sig new file mode 100644 index 0000000..f82bd73 --- /dev/null +++ b/basis-library/mlton/bin-io.sig @@ -0,0 +1,8 @@ +(* Copyright (C) 2002-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_BIN_IO = MLTON_IO diff --git a/basis-library/mlton/call-stack.sig b/basis-library/mlton/call-stack.sig new file mode 100644 index 0000000..110a0fc --- /dev/null +++ b/basis-library/mlton/call-stack.sig @@ -0,0 +1,15 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_CALL_STACK = + sig + type t + + val keep: bool + val current: unit -> t + val toStrings: t -> string list + end diff --git a/basis-library/mlton/call-stack.sml b/basis-library/mlton/call-stack.sml new file mode 100644 index 0000000..d5361a7 --- /dev/null +++ b/basis-library/mlton/call-stack.sml @@ -0,0 +1,55 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonCallStack = + struct + open Primitive.MLton.CallStack + + val gcState = Primitive.MLton.GCState.gcState + structure Pointer = MLtonPointer + + val current: unit -> t = + fn () => + if not keep + then T (Array.array (0, 0wx0)) + else + let + val a = Array.alloc (Word32.toInt (numStackFrames gcState)) + val () = callStack (gcState, a) + in + T a + end + + val toStrings: t -> string list = + fn T a => + if not keep + then [] + else + let + val skip = Array.length a - 1 + in + Array.foldri + (fn (i, frameIndex, ac) => + if i >= skip + then ac + else + let + val p = frameIndexSourceSeq (gcState, frameIndex) + val max = Int32.toInt (Pointer.getInt32 (p, 0)) + fun loop (j, ac) = + if j > max + then ac + else loop (j + 1, + CUtil.C_String.toString (sourceName (gcState, Pointer.getWord32 (p, j))) + :: ac) + in + loop (1, ac) + end) + [] a + end + end diff --git a/basis-library/mlton/cont.sig b/basis-library/mlton/cont.sig new file mode 100644 index 0000000..3eaaf88 --- /dev/null +++ b/basis-library/mlton/cont.sig @@ -0,0 +1,18 @@ +(* Copyright (C) 1999-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_CONT = + sig + type 'a t + + val callcc: ('a t -> 'a) -> 'a + val isolate: ('a -> unit) -> 'a t + val prepend: 'a t * ('b -> 'a) -> 'b t + val throw: 'a t * 'a -> 'b + val throw': 'a t * (unit -> 'a) -> 'b + end diff --git a/basis-library/mlton/cont.sml b/basis-library/mlton/cont.sml new file mode 100644 index 0000000..e7792cf --- /dev/null +++ b/basis-library/mlton/cont.sml @@ -0,0 +1,104 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonCont:> MLTON_CONT = +struct + +structure Thread = + struct + open Primitive.MLton.Thread + val savedPre = fn () => savedPre Primitive.MLton.GCState.gcState + end + +fun die (s: string): 'a = + (PrimitiveFFI.Stdio.print s + ; PrimitiveFFI.Posix.Process.exit 1 + ; let exception DieFailed + in raise DieFailed + end) + +type 'a t = (unit -> 'a) -> unit + +fun callcc (f: 'a t -> 'a): 'a = + if MLtonThread.amInSignalHandler () + then die "MLton.Cont.callcc can not be used in a signal handler\n" + else + let + datatype 'a state = + Original of 'a t -> 'a + | Copy of unit -> 'a + | Clear + val r: 'a state ref = ref (Original f) + val _ = Thread.atomicBegin () (* Match 1 *) + val _ = Thread.copyCurrent () + in + case (!r before r := Clear) of + Clear => raise Fail "MLton.Cont.callcc: Clear" + | Copy v => + let + val _ = Thread.atomicEnd () (* Match 2 *) + in + v () + end + | Original f => + let + val t = Thread.savedPre () + val _ = Thread.atomicEnd () (* Match 1 *) + in + f (fn v => + let + val _ = Thread.atomicBegin () (* Match 2 *) + val _ = r := Copy v + val new = Thread.copy t + val _ = Thread.atomicBegin () (* Match 3 *) + in + Thread.switchTo new (* Match 3 *) + end) + end + end + +fun ('a, 'b) throw' (k: 'a t, v: unit -> 'a): 'b = + (k v; raise Fail "MLton.Cont.throw': return from continuation") + +fun ('a, 'b) throw (k: 'a t, v: 'a): 'b = throw' (k, fn () => v) + +fun prepend (k, f) v = throw' (k, f o v) + +local +val thRef: (unit -> unit) option ref = ref NONE +val base: Thread.preThread = + let + val () = Thread.copyCurrent () + in + case !thRef of + NONE => Thread.savedPre () + | SOME th => + let + val () = thRef := NONE + val () = Thread.atomicEnd () (* Match 1 *) + val _ = (th () ; Exit.topLevelSuffix ()) + handle exn => MLtonExn.topLevelHandler exn + in + raise Fail "MLton.Cont.isolate: return from (wrapped) func" + end + end +in +val isolate: ('a -> unit) -> 'a t = + fn (f: 'a -> unit) => + fn (v: unit -> 'a) => + let + val _ = Thread.atomicBegin () (* Match 1 *) + val _ = Thread.atomicBegin () (* Match 2 *) + val () = thRef := SOME (f o v) + val new = Thread.copy base + in + Thread.switchTo new (* Match 2 *) + end +end + +end diff --git a/basis-library/mlton/exit.sml b/basis-library/mlton/exit.sml new file mode 100644 index 0000000..ecaf077 --- /dev/null +++ b/basis-library/mlton/exit.sml @@ -0,0 +1,87 @@ +(* Copyright (C) 2004-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Exit = + struct + structure Status = + struct + open PreOS.Status + val fromInt = fromRep o C_Status.fromInt + val toInt = C_Status.toInt o toRep + val failure = fromInt 1 + val success = fromInt 0 + end + + val exiting = ref false + + fun atExit f = + if !exiting + then () + else Cleaner.addNew (Cleaner.atExit, f) + + fun halt (status: Status.t) = + Primitive.MLton.halt (Status.toRep status) + + fun exit (status: Status.t): 'a = + if !exiting + then raise Fail "MLton.Exit.exit" + else + let + val _ = exiting := true + val i = Status.toInt status + in + if 0 <= i andalso i < 256 + then (let open Cleaner in clean atExit end + ; halt status + ; raise Fail "MLton.Exit.exit") + else raise Fail (concat ["MLton.Exit.exit(", Int.toString i, "): ", + "exit must have 0 <= status < 256"]) + end + + local + val message = PrimitiveFFI.Stdio.print + fun 'a wrapSuffix (suffix: unit -> unit) () : 'a = + (suffix () + ; message "Top-level suffix returned.\n" + ; exit Status.failure) + handle _ => (message "Top-level suffix raised exception.\n" + ; halt Status.failure + ; raise Fail "MLton.Exit.wrapSuffix") + + fun suffixArchiveOrLibrary () = + let + (* Return to 'lib_open'. *) + val () = Primitive.MLton.Thread.returnToC () + (* Enter from 'lib_close'. *) + val _ = exiting := true + val () = let open Cleaner in clean atExit end + (* Return to 'lib_close'. *) + val () = Primitive.MLton.Thread.returnToC () + in + () + end + fun suffixExecutable () = exit Status.success + val defaultSuffix = + let open Primitive.MLton.Platform.Format + in + case host of + Archive => suffixArchiveOrLibrary + | Executable => suffixExecutable + | LibArchive => suffixArchiveOrLibrary + | Library => suffixArchiveOrLibrary + end + in + val getTopLevelSuffix = Primitive.TopLevel.getSuffix + val setTopLevelSuffix = Primitive.TopLevel.setSuffix o wrapSuffix + fun 'a defaultTopLevelSuffix ((): unit): 'a = + wrapSuffix defaultSuffix () + fun 'a topLevelSuffix ((): unit) : 'a = + (getTopLevelSuffix () () + ; raise Fail "MLton.Exit.topLevelSuffix") + end + + end diff --git a/basis-library/mlton/exn.sig b/basis-library/mlton/exn.sig new file mode 100644 index 0000000..908547b --- /dev/null +++ b/basis-library/mlton/exn.sig @@ -0,0 +1,17 @@ +(* Copyright (C) 2001-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_EXN = + sig + val addExnMessager: (exn -> string option) -> unit + val history: exn -> string list + + val defaultTopLevelHandler: exn -> 'a (* does not return *) + val getTopLevelHandler: unit -> (exn -> unit) + val setTopLevelHandler: (exn -> unit) -> unit + val topLevelHandler: exn -> 'a (* does not return *) + end diff --git a/basis-library/mlton/exn.sml b/basis-library/mlton/exn.sml new file mode 100644 index 0000000..b2f6c32 --- /dev/null +++ b/basis-library/mlton/exn.sml @@ -0,0 +1,69 @@ +(* Copyright (C) 2001-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonExn = + struct + open Primitive.MLton.Exn + + type t = exn + + val addExnMessager = General.addExnMessager + + val history: t -> string list = + if keepHistory then + (setExtendExtra (fn e => + case e of + NONE => SOME (MLtonCallStack.current ()) + | SOME _ => e) + ; (fn e => + case extra e of + NONE => [] + | SOME cs => + let + (* Gets rid of the anonymous function passed to + * setExtendExtra above. + *) + fun loop xs = + case xs of + [] => [] + | x :: xs => + if String.isPrefix "MLtonExn.fn " x then + xs + else + loop xs + in + loop (MLtonCallStack.toStrings cs) + end)) + else fn _ => [] + + local + val message = PrimitiveFFI.Stdio.print + fun 'a wrapHandler (handler: exn -> unit) exn : 'a = + (handler exn + ; message "Top-level handler returned.\n" + ; Exit.exit Exit.Status.failure) + handle _ => (message "Top-level handler raised exception.\n" + ; Exit.halt Exit.Status.failure + ; raise Fail "MLton.Exn.wrapHandler") + val defaultHandler = fn exn => + (message (concat ["unhandled exception: ", exnMessage exn, "\n"]) + ; (case history exn of + [] => () + | l => + (message "with history:\n" + ; List.app (fn s => message (concat ["\t", s, "\n"])) l)) + ; Exit.exit Exit.Status.failure) + in + val getTopLevelHandler = Primitive.TopLevel.getHandler + val setTopLevelHandler = Primitive.TopLevel.setHandler o wrapHandler + fun 'a defaultTopLevelHandler (exn: exn): 'a = + wrapHandler defaultHandler exn + fun 'a topLevelHandler (exn: exn) : 'a = + (getTopLevelHandler () exn + ; raise Fail "MLton.Exn.topLevelHandler") + end + end diff --git a/basis-library/mlton/ffi.sig b/basis-library/mlton/ffi.sig new file mode 100644 index 0000000..f483566 --- /dev/null +++ b/basis-library/mlton/ffi.sig @@ -0,0 +1,47 @@ +(* Copyright (C) 2003-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_FFI = + sig + val getBool: MLtonPointer.t * int -> bool + val getChar8: MLtonPointer.t * int -> Char.char +(* + val getChar16: MLtonPointer.t * int -> Char16.char + val getChar32: MLtonPointer.t * int -> Char32.char +*) + val getCPointer: MLtonPointer.t * int -> MLtonPointer.t + val getInt8: MLtonPointer.t * int -> Int8.int + val getInt16: MLtonPointer.t * int -> Int16.int + val getInt32: MLtonPointer.t * int -> Int32.int + val getInt64: MLtonPointer.t * int -> Int64.int + val getObjptr: MLtonPointer.t * int -> 'a + val getReal32: MLtonPointer.t * int -> Real32.real + val getReal64: MLtonPointer.t * int -> Real64.real + val getWord8: MLtonPointer.t * int -> Word8.word + val getWord16: MLtonPointer.t * int -> Word16.word + val getWord32: MLtonPointer.t * int -> Word32.word + val getWord64: MLtonPointer.t * int -> Word64.word + val register: int * (MLtonPointer.t -> unit) -> unit + val setBool: MLtonPointer.t * int * bool -> unit + val setChar8: MLtonPointer.t * int * Char.char -> unit +(* + val setChar16: MLtonPointer.t * Char16.char -> unit + val setChar32: MLtonPointer.t * Char32.char -> unit +*) + val setCPointer: MLtonPointer.t * int * MLtonPointer.t -> unit + val setInt8: MLtonPointer.t * int * Int8.int -> unit + val setInt16: MLtonPointer.t * int * Int16.int -> unit + val setInt32: MLtonPointer.t * int * Int32.int -> unit + val setInt64: MLtonPointer.t * int * Int64.int -> unit + val setObjptr: MLtonPointer.t * int * 'a -> unit + val setReal32: MLtonPointer.t * int * Real32.real -> unit + val setReal64: MLtonPointer.t * int * Real64.real -> unit + val setWord8: MLtonPointer.t * int * Word8.word -> unit + val setWord16: MLtonPointer.t * int * Word16.word -> unit + val setWord32: MLtonPointer.t * int * Word32.word -> unit + val setWord64: MLtonPointer.t * int * Word64.word -> unit + end diff --git a/basis-library/mlton/ffi.sml b/basis-library/mlton/ffi.sml new file mode 100644 index 0000000..7ec364f --- /dev/null +++ b/basis-library/mlton/ffi.sml @@ -0,0 +1,63 @@ +(* Copyright (C) 2003-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonFFI: MLTON_FFI = +struct + +val register = MLtonThread.register + +local + fun makeGet get (p,i) = get (MLtonPointer.getPointer (p, i), 0) + fun makeSet set (p,i,x) = set (MLtonPointer.getPointer (p, i), 0, x) + fun make (get,set) = (makeGet get, makeSet set) +in + val (getCPointer, setCPointer) = + make (MLtonPointer.getCPointer, MLtonPointer.setCPointer) + val (getInt8, setInt8) = + make (MLtonPointer.getInt8, MLtonPointer.setInt8) + val (getInt16, setInt16) = + make (MLtonPointer.getInt16, MLtonPointer.setInt16) + val (getInt32, setInt32) = + make (MLtonPointer.getInt32, MLtonPointer.setInt32) + val (getInt64, setInt64) = + make (MLtonPointer.getInt64, MLtonPointer.setInt64) + val getObjptr = fn (p,i) => makeGet MLtonPointer.getObjptr (p,i) + val setObjptr = fn (p,i,x) => makeSet MLtonPointer.setObjptr (p,i,x) + val (getReal32, setReal32) = + make (MLtonPointer.getReal32, MLtonPointer.setReal32) + val (getReal64, setReal64) = + make (MLtonPointer.getReal64, MLtonPointer.setReal64) + val (getWord8, setWord8) = + make (MLtonPointer.getWord8, MLtonPointer.setWord8) + val (getWord16, setWord16) = + make (MLtonPointer.getWord16, MLtonPointer.setWord16) + val (getWord32, setWord32) = + make (MLtonPointer.getWord32, MLtonPointer.setWord32) + val (getWord64, setWord64) = + make (MLtonPointer.getWord64, MLtonPointer.setWord64) +end + +(* To the C-world, chars are unsigned integers. *) +val getChar8 = fn (p, i) => Primitive.Char8.idFromWord8 (getWord8 (p, i)) +(* +val getChar16 = fn (p, i) => Primitive.Char16.idFromWord16 (getWord16 (p, i)) +val getChar32 = fn (p, i) => Primitive.Char32.idFromWord32 (getWord32 (p, i)) +*) + +val setChar8 = fn (p, i, x) => setWord8 (p, i, Primitive.Char8.idToWord8 x) +(* +val setChar16 = fn (p, i, x) => setWord16 (p, i, Primitive.Char16.idToWord16 x) +val setChar32 = fn (p, i, x) => setWord32 (p, i, Primitive.Char32.idToWord32 x) +*) + +(* To the C-world, booleans are 32-bit integers. *) +fun intToBool (i: Int32.int): bool = i <> 0 +val getBool = fn (p, i) => intToBool(getInt32 (p, i)) +fun boolToInt (b: bool): Int32.int = if b then 1 else 0 +val setBool = fn (p, i, x) => setInt32 (p, i, boolToInt x) + +end diff --git a/basis-library/mlton/finalizable.sig b/basis-library/mlton/finalizable.sig new file mode 100644 index 0000000..9db0227 --- /dev/null +++ b/basis-library/mlton/finalizable.sig @@ -0,0 +1,17 @@ +(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_FINALIZABLE = + sig + type 'a t + + val addFinalizer: 'a t * ('a -> unit) -> unit + val finalizeBefore: 'a t * 'b t -> unit + val new: 'a -> 'a t + val touch: 'a t -> unit + val withValue: 'a t * ('a -> 'b) -> 'b + end diff --git a/basis-library/mlton/finalizable.sml b/basis-library/mlton/finalizable.sml new file mode 100644 index 0000000..836c40e --- /dev/null +++ b/basis-library/mlton/finalizable.sml @@ -0,0 +1,91 @@ +(* Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonFinalizable: MLTON_FINALIZABLE = +struct + +structure List = + struct + open List + + fun push (l, x) = l := x :: !l + + fun foreach (l, f) = app f l + end + +datatype 'a t = T of {afters: (unit -> unit) list ref, + finalizers: ('a -> unit) list ref, + value: 'a ref} + +fun touch (T {value, ...}) = Primitive.MLton.Finalizable.touch value + +fun withValue (f as T {value, ...}, g) = + DynamicWind.wind (fn () => g (!value), + fn () => touch f) + +fun addFinalizer (T {finalizers, ...}, f) = + List.push (finalizers, f) + +val finalize = + let + val r: {clean: unit -> unit, + isAlive: unit -> bool} list ref = ref [] + fun clean l = + List.foldl (fn (z as {clean: unit -> unit, isAlive}, + (gotOne, zs)) => + if isAlive () + then (gotOne, z :: zs) + else (clean (); (true, zs))) + (false, []) l + val _ = MLtonSignal.handleGC (fn () => r := #2 (clean (!r))) + val _ = + Cleaner.addNew + (Cleaner.atExit, fn () => + let + val l = !r + (* Must clear r so that the handler doesn't interfere and so that + * all other references to the finalizers are dropped. + *) + val _ = r := [] + fun loop l = + let + val _ = MLtonGC.collect () + val (gotOne, l) = clean l + in + if gotOne + then loop l + else () + end + in + loop l + end) + in + fn z => r := z :: !r + end + +fun new (v: 'a): 'a t = + let + val afters = ref [] + val finalizers = ref [] + val value = ref v + val f = T {afters = afters, + finalizers = finalizers, + value = value} + val weak = MLtonWeak.new value + fun clean () = + (List.foreach (!finalizers, fn f => f v) + ; List.foreach (!afters, fn f => f ())) + fun isAlive () = isSome (MLtonWeak.get weak) + val _ = finalize {clean = clean, isAlive = isAlive} + in + f + end + +fun finalizeBefore (T {afters, ...}, f) = + List.push (afters, fn () => touch f) + +end diff --git a/basis-library/mlton/gc.sig b/basis-library/mlton/gc.sig new file mode 100644 index 0000000..bc67357 --- /dev/null +++ b/basis-library/mlton/gc.sig @@ -0,0 +1,27 @@ +(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_GC = + sig + val collect: unit -> unit + val pack: unit -> unit + val setMessages: bool -> unit + val setSummary: bool -> unit + val unpack: unit -> unit + + (* Most meaningful immediately after 'collect()'. *) + structure Statistics : + sig + val bytesAllocated: unit -> IntInf.int + val lastBytesLive: unit -> IntInf.int + val numCopyingGCs: unit -> IntInf.int + val numMarkCompactGCs: unit -> IntInf.int + val numMinorGCs: unit -> IntInf.int + val maxBytesLive: unit -> IntInf.int + end + end diff --git a/basis-library/mlton/gc.sml b/basis-library/mlton/gc.sml new file mode 100644 index 0000000..3d9961c --- /dev/null +++ b/basis-library/mlton/gc.sml @@ -0,0 +1,46 @@ +(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonGC = + struct + open Primitive.MLton.GC + + val gcState = Primitive.MLton.GCState.gcState + + val pack : unit -> unit = + fn () => pack gcState + val unpack : unit -> unit = + fn () => unpack gcState + + val setHashConsDuringGC : bool -> unit = + fn b => setHashConsDuringGC (gcState, b) + val setMessages : bool -> unit = + fn b => setMessages (gcState, b) + val setRusageMeasureGC : bool -> unit = + fn b => setRusageMeasureGC (gcState, b) + val setSummary : bool -> unit = + fn b => setSummary (gcState, b) + + structure Statistics = + struct + local + fun mk conv prim = + fn () => conv (prim gcState) + val mkSize = mk C_Size.toLargeInt + val mkUIntmax = mk C_UIntmax.toLargeInt + in + val bytesAllocated = mkUIntmax getBytesAllocated + val lastBytesLive = mkSize getLastBytesLive + val maxBytesLive = mkSize getMaxBytesLive + val numCopyingGCs = mkUIntmax getNumCopyingGCs + val numMarkCompactGCs = mkUIntmax getNumMarkCompactGCs + val numMinorGCs = mkUIntmax getNumMinorGCs + end + end + + end diff --git a/basis-library/mlton/int-inf.sig b/basis-library/mlton/int-inf.sig new file mode 100644 index 0000000..0480adc --- /dev/null +++ b/basis-library/mlton/int-inf.sig @@ -0,0 +1,23 @@ +(* Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_INT_INF = + sig + type t + + val areSmall: t * t -> bool + val gcd: t * t -> t + val isSmall: t -> bool + + structure BigWord : WORD + structure SmallInt : INTEGER + datatype rep = + Big of BigWord.word vector + | Small of SmallInt.int + val rep: t -> rep + val fromRep: rep -> t option + end diff --git a/basis-library/mlton/io.fun b/basis-library/mlton/io.fun new file mode 100644 index 0000000..3e51628 --- /dev/null +++ b/basis-library/mlton/io.fun @@ -0,0 +1,45 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor MLtonIO (S: MLTON_IO_ARG): MLTON_IO = +struct + +open S + +fun mkstemps {prefix, suffix}: string * outstream = + let + fun loop () = + let + val name = concat [prefix, MLtonRandom.alphaNumString 6, suffix] + open Posix.FileSys + in + (name, + newOut (createf (name, O_WRONLY, O.flags [O.excl], + let open S + in flags [irusr, iwusr] + end), + name)) + end handle e as PosixError.SysErr (_, s) => + if s = SOME Posix.Error.exist + then loop () + else raise e + in + loop () + end + +fun mkstemp s = mkstemps {prefix = s, suffix = ""} + +fun tempPrefix file = + case MLtonPlatform.OS.host of + MLtonPlatform.OS.MinGW => + (case MinGW.getTempPath () of + SOME d => d + | NONE => "C:\\temp\\") ^ file + | _ => "/tmp/" ^ file + +end diff --git a/basis-library/mlton/io.sig b/basis-library/mlton/io.sig new file mode 100644 index 0000000..e33efa2 --- /dev/null +++ b/basis-library/mlton/io.sig @@ -0,0 +1,31 @@ +(* Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_IO_ARG = + sig + type instream + type outstream + + val inFd: instream -> Posix.IO.file_desc + val newIn: Posix.IO.file_desc * string -> instream + val newOut: Posix.IO.file_desc * string -> outstream + val outFd: outstream -> Posix.IO.file_desc + end + +signature MLTON_IO = + sig + include MLTON_IO_ARG + + (* mkstemp s creates and opens a new temp file with prefix s, returning + * the name of the temp file and the outstream to write to it. + *) + val mkstemp: string -> string * outstream + (* mkstemps is like mkstemp, except it has both a prefix and suffix. *) + val mkstemps: {prefix: string, suffix: string} -> string * outstream + (* adds a suitable system or user specific prefix (dir) for temp files *) + val tempPrefix : string -> string + end diff --git a/basis-library/mlton/itimer.sig b/basis-library/mlton/itimer.sig new file mode 100644 index 0000000..e4d2b12 --- /dev/null +++ b/basis-library/mlton/itimer.sig @@ -0,0 +1,18 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_ITIMER = + sig + datatype t = + Prof + | Real + | Virtual + + val set: t * {interval: Time.time, value: Time.time} -> unit + val signal: t -> Posix.Signal.signal + end diff --git a/basis-library/mlton/itimer.sml b/basis-library/mlton/itimer.sml new file mode 100644 index 0000000..9881f9d --- /dev/null +++ b/basis-library/mlton/itimer.sml @@ -0,0 +1,49 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonItimer = + struct + structure Prim = PrimitiveFFI.MLton.Itimer + + datatype t = Prof | Real | Virtual + + val signal = + fn Prof => PosixSignal.prof + | Real => PosixSignal.alrm + | Virtual => PosixSignal.vtalrm + + val toInt = + fn Prof => Prim.PROF + | Real => Prim.REAL + | Virtual => Prim.VIRTUAL + + fun set' (t, {interval, value}) = + let + fun split t = + let + val q = LargeInt.quot (Time.toMicroseconds t, 1000000) + val r = LargeInt.rem (Time.toMicroseconds t, 1000000) + in + (C_Time.fromLargeInt q, C_SUSeconds.fromLargeInt r) + end + val (s1, u1) = split interval + val (s2, u2) = split value + in + ignore (Prim.set (toInt t, s1, u1, s2, u2)) + end + + fun set (z as (t, _)) = + if Primitive.MLton.Profile.isOn + andalso t = Prof + then let + open PosixError + in + raiseSys inval + end + else set' z + end diff --git a/basis-library/mlton/mlton.sig b/basis-library/mlton/mlton.sig new file mode 100644 index 0000000..f480443 --- /dev/null +++ b/basis-library/mlton/mlton.sig @@ -0,0 +1,81 @@ +(* Copyright (C) 2013 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON = + sig +(* val cleanAtExit: unit -> unit *) + val debug: bool +(* val deserialize: Word8Vector.vector -> 'a *) + (* Pointer equality. The usual caveats about lack of a well-defined + * semantics. + *) + val eq: 'a * 'a -> bool + (* Structural equality. Equivalent to SML's polymorphic + * equality on equality types and a conservative approximation + * of equivalence other types. + *) + val equal: 'a * 'a -> bool + (* Structural hash. *) + val hash: 'a -> Word32.word +(* val errno: unit -> int *) (* the value of the C errno global *) + val isMLton: bool + val safe: bool +(* val serialize: 'a -> Word8Vector.vector *) + val share: 'a -> unit + val shareAll: unit -> unit + val size: 'a -> int + + structure Array: MLTON_ARRAY + structure BinIO: MLTON_BIN_IO +(* structure CallStack: MLTON_CALL_STACK *) + structure CharArray: MLTON_MONO_ARRAY + structure CharVector: MLTON_MONO_VECTOR + structure Cont: MLTON_CONT + structure Exn: MLTON_EXN + structure Finalizable: MLTON_FINALIZABLE + structure GC: MLTON_GC + structure IntInf: MLTON_INT_INF + structure Itimer: MLTON_ITIMER + structure LargeReal: MLTON_REAL + structure LargeWord: MLTON_WORD + structure Platform: MLTON_PLATFORM + structure Pointer: MLTON_POINTER + structure ProcEnv: MLTON_PROC_ENV + structure Process: MLTON_PROCESS + structure Profile: MLTON_PROFILE +(* structure Ptrace: MLTON_PTRACE *) + structure Random: MLTON_RANDOM + structure Real: MLTON_REAL + structure Real32: sig + include MLTON_REAL + val castFromWord: Word32.word -> t + val castToWord: t -> Word32.word + end + structure Real64: sig + include MLTON_REAL + val castFromWord: Word64.word -> Real64.real + val castToWord: Real64.real -> Word64.word + end + structure Rlimit: MLTON_RLIMIT + structure Rusage: MLTON_RUSAGE + structure Signal: MLTON_SIGNAL + structure Syslog: MLTON_SYSLOG + structure TextIO: MLTON_TEXT_IO + structure Thread: MLTON_THREAD + structure Vector: MLTON_VECTOR + structure Weak: MLTON_WEAK + structure Word: MLTON_WORD + structure Word8: MLTON_WORD + structure Word16: MLTON_WORD + structure Word32: MLTON_WORD + structure Word64: MLTON_WORD + structure Word8Array: MLTON_MONO_ARRAY + structure Word8Vector: MLTON_MONO_VECTOR + structure World: MLTON_WORLD + end diff --git a/basis-library/mlton/mlton.sml b/basis-library/mlton/mlton.sml new file mode 100644 index 0000000..07f3a0e --- /dev/null +++ b/basis-library/mlton/mlton.sml @@ -0,0 +1,162 @@ +(* Copyright (C) 2010,2013,2016-2017 Matthew Fluet. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLton: MLTON = +struct + +val isMLton = true + +(* The ref stuff is so that the (de)serializer always deals with pointers + * to heap objects. + *) +(* val serialize = fn x => serialize (ref x) + * val deserialize = fn x => !(deserialize x) + *) + +val share = Primitive.MLton.share + +structure GC = MLtonGC + +fun shareAll () = + (GC.setHashConsDuringGC true + ; GC.collect ()) + +fun size x = + C_Size.toInt (Primitive.MLton.size x) + +(* fun cleanAtExit () = let open Cleaner in clean atExit end *) + +val debug = Primitive.Controls.debug +val eq = Primitive.MLton.eq +val equal = Primitive.MLton.equal +val hash = Primitive.MLton.hash +(* val errno = Primitive.errno *) +val safe = Primitive.Controls.safe + +structure Array = Array +structure BinIO = MLtonIO (BinIO) +(*structure CallStack = MLtonCallStack*) +structure CharArray = struct + open CharArray + type t = array +end +structure CharVector = struct + open CharVector + type t = vector +end +structure Cont = MLtonCont +structure Exn = MLtonExn +structure Finalizable = MLtonFinalizable +structure IntInf = + struct + open IntInf + type t = int + end +structure Itimer = MLtonItimer +structure LargeReal = + struct + open LargeReal + type t = real + end +structure LargeWord = + struct + open LargeWord + type t = word + end +structure Platform = MLtonPlatform +structure Pointer = MLtonPointer +structure ProcEnv = MLtonProcEnv +structure Process = MLtonProcess +(* structure Ptrace = MLtonPtrace *) +structure Profile = MLtonProfile +structure Random = MLtonRandom +structure Real = + struct + open Real + type t = real + end +structure Real32 = + struct + open Real32 + type t = real + open Primitive.PackReal32 + end +structure Real64 = + struct + open Real64 + type t = real + open Primitive.PackReal64 + end +structure Rlimit = MLtonRlimit +structure Rusage = MLtonRusage +structure Signal = MLtonSignal +structure Syslog = MLtonSyslog +structure TextIO = MLtonIO (TextIO) +structure Thread = MLtonThread +structure Vector = Vector +structure Weak = MLtonWeak +structure World = MLtonWorld +structure Word = + struct + open Word + type t = word + end +structure Word8 = + struct + open Word8 + type t = word + end +structure Word16 = + struct + open Word16 + type t = word + end +structure Word32 = + struct + open Word32 + type t = word + end +structure Word64 = + struct + open Word64 + type t = word + end +structure Word8Array = struct + open Word8Array + type t = array +end +structure Word8Vector = struct + open Word8Vector + type t = vector +end + +val _ = + (Primitive.TopLevel.setHandler MLtonExn.defaultTopLevelHandler + ; Primitive.TopLevel.setSuffix Exit.defaultTopLevelSuffix) +end + +(* Patch OS.FileSys.tmpName to use mkstemp. *) +structure OS = + struct + open OS + + structure FileSys = + struct + open FileSys + + fun tmpName () = + let + val (f, out) = + MLton.TextIO.mkstemp (MLton.TextIO.tempPrefix "file") + val _ = TextIO.closeOut out + in + f + end + end + end diff --git a/basis-library/mlton/mono-array.sig b/basis-library/mlton/mono-array.sig new file mode 100644 index 0000000..d2fa5c8 --- /dev/null +++ b/basis-library/mlton/mono-array.sig @@ -0,0 +1,6 @@ +signature MLTON_MONO_ARRAY = sig + type t + type elem + val fromPoly: elem array -> t + val toPoly: t -> elem array +end diff --git a/basis-library/mlton/mono-vector.sig b/basis-library/mlton/mono-vector.sig new file mode 100644 index 0000000..6211553 --- /dev/null +++ b/basis-library/mlton/mono-vector.sig @@ -0,0 +1,6 @@ +signature MLTON_MONO_VECTOR = sig + type t + type elem + val fromPoly: elem vector -> t + val toPoly: t -> elem vector +end diff --git a/basis-library/mlton/platform.sig b/basis-library/mlton/platform.sig new file mode 100644 index 0000000..7edfeb2 --- /dev/null +++ b/basis-library/mlton/platform.sig @@ -0,0 +1,38 @@ +(* Copyright (C) 2003-2009 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_PLATFORM = + sig + structure Arch: + sig + datatype t = Alpha | AMD64 | ARM | ARM64 | HPPA | IA64 | m68k | + MIPS | PowerPC | PowerPC64 | S390 | Sparc | X86 + + val fromString: string -> t option + val host: t + val toString: t -> string + end + + structure Format: + sig + datatype t = Archive | Executable | LibArchive | Library + + val fromString: string -> t option + val host: t + val toString: t -> string + end + + structure OS: + sig + datatype t = AIX | Cygwin | Darwin | FreeBSD | Hurd | HPUX + | Linux | MinGW | NetBSD | OpenBSD | Solaris + + val fromString: string -> t option + val host: t + val toString: t -> string + end + end diff --git a/basis-library/mlton/platform.sml b/basis-library/mlton/platform.sml new file mode 100644 index 0000000..edaa5c8 --- /dev/null +++ b/basis-library/mlton/platform.sml @@ -0,0 +1,90 @@ +(* Copyright (C) 2003-2009 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonPlatform: MLTON_PLATFORM = + struct + open Primitive.MLton.Platform + + fun peek (l, f) = List.find f l + fun omap (opt, f) = Option.map f opt + + structure Arch = + struct + open Arch + + val all = [ + (Alpha, "Alpha"), + (AMD64, "AMD64"), + (ARM, "ARM"), + (ARM64, "ARM64"), + (HPPA, "HPPA"), + (IA64, "IA64"), + (m68k, "m68k"), + (MIPS, "MIPS"), + (PowerPC, "PowerPC"), + (PowerPC64, "PowerPC64"), + (S390, "S390"), + (Sparc, "Sparc"), + (X86, "X86")] + + fun fromString s = + let + val s = String.toLower s + in + omap (peek (all, fn (_, s') => s = String.toLower s'), #1) + end + + fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a'))) + end + + structure Format = + struct + open Format + + val all = [ + (Archive, "Archive"), + (Executable, "Executable"), + (LibArchive, "LibArchive"), + (Library, "Library")] + + fun fromString s = + let + val s = String.toLower s + in + omap (peek (all, fn (_, s') => s = String.toLower s'), #1) + end + + fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a'))) + end + + structure OS = + struct + open OS + + val all = [ + (AIX, "AIX"), + (Cygwin, "Cygwin"), + (Darwin, "Darwin"), + (FreeBSD, "FreeBSD"), + (Hurd, "Hurd"), + (HPUX, "HPUX"), + (Linux, "Linux"), + (MinGW, "MinGW"), + (NetBSD, "NetBSD"), + (OpenBSD, "OpenBSD"), + (Solaris, "Solaris")] + + fun fromString s = + let + val s = String.toLower s + in + omap (peek (all, fn (_, s') => s = String.toLower s'), #1) + end + + fun toString a = #2 (valOf (peek (all, fn (a', _) => a = a'))) + end + end diff --git a/basis-library/mlton/pointer.sig b/basis-library/mlton/pointer.sig new file mode 100644 index 0000000..7543051 --- /dev/null +++ b/basis-library/mlton/pointer.sig @@ -0,0 +1,51 @@ +(* Copyright (C) 2003-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_POINTER = + sig + eqtype t + + val add: t * word -> t + val compare: t * t -> order + val diff: t * t -> word + (* val free: t -> unit *) + val getInt8: t * int -> Int8.int + val getInt16: t * int -> Int16.int + val getInt32: t * int -> Int32.int + val getInt64: t * int -> Int64.int + val getPointer: t * int -> t + val getReal32: t * int -> Real32.real + val getReal64: t * int -> Real64.real + val getWord8: t * int -> Word8.word + val getWord16: t * int -> Word16.word + val getWord32: t * int -> Word32.word + val getWord64: t * int -> Word64.word + val null: t + val setInt8: t * int * Int8.int -> unit + val setInt16: t * int * Int16.int -> unit + val setInt32: t * int * Int32.int -> unit + val setInt64: t * int * Int64.int -> unit + val setPointer: t * int * t -> unit + val setReal32: t * int * Real32.real -> unit + val setReal64: t * int * Real64.real -> unit + val setWord8: t * int * Word8.word -> unit + val setWord16: t * int * Word16.word -> unit + val setWord32: t * int * Word32.word -> unit + val setWord64: t * int * Word64.word -> unit + val sizeofPointer: word + val sub: t * word -> t + end + +signature MLTON_POINTER_EXTRA = + sig + include MLTON_POINTER + + val getCPointer: t * int -> t + val setCPointer: t * int * t -> unit + val getObjptr: t * int -> 'a + val setObjptr: t * int * 'a -> unit + end diff --git a/basis-library/mlton/pointer.sml b/basis-library/mlton/pointer.sml new file mode 100644 index 0000000..dca14f3 --- /dev/null +++ b/basis-library/mlton/pointer.sml @@ -0,0 +1,62 @@ +(* Copyright (C) 2010 Matthew Fluet. + * Copyright (C) 2003-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonPointer: MLTON_POINTER_EXTRA = +struct + +open Primitive.MLton.Pointer + +val sizeofPointer = + Word.div (Word.fromInt C_Size.wordSize, 0w8) + +val add = fn (p, t) => + add (p, C_Ptrdiff.fromLarge (Word.toLargeIntX t)) +val sub = fn (p, t) => + sub (p, C_Ptrdiff.fromLarge (Word.toLargeIntX t)) +val diff = fn (p, p') => + Word.fromLargeInt (C_Ptrdiff.toLarge (diff (p, p'))) + +local + fun wrap f (p, i) = + f (p, C_Ptrdiff.fromInt i) +in + val getCPointer = wrap getCPointer + val getInt8 = wrap getInt8 + val getInt16 = wrap getInt16 + val getInt32 = wrap getInt32 + val getInt64 = wrap getInt64 + val getObjptr = fn (p, i) => (wrap getObjptr) (p, i) + val getReal32 = wrap getReal32 + val getReal64 = wrap getReal64 + val getWord8 = wrap getWord8 + val getWord16 = wrap getWord16 + val getWord32 = wrap getWord32 + val getWord64 = wrap getWord64 +end +val getPointer = getCPointer + +local + fun wrap f (p, i, x) = + f (p, C_Ptrdiff.fromInt i, x) +in + val setCPointer = wrap setCPointer + val setInt8 = wrap setInt8 + val setInt16 = wrap setInt16 + val setInt32 = wrap setInt32 + val setInt64 = wrap setInt64 + val setObjptr = fn (p, i, x) => (wrap setObjptr) (p, i, x) + val setReal32 = wrap setReal32 + val setReal64 = wrap setReal64 + val setWord8 = wrap setWord8 + val setWord16 = wrap setWord16 + val setWord32 = wrap setWord32 + val setWord64 = wrap setWord64 +end +val setPointer = setCPointer + +end diff --git a/basis-library/mlton/proc-env.sig b/basis-library/mlton/proc-env.sig new file mode 100644 index 0000000..75dbb02 --- /dev/null +++ b/basis-library/mlton/proc-env.sig @@ -0,0 +1,15 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_PROC_ENV = + sig + type gid + + val setenv: {name: string, value: string} -> unit + val setgroups: gid list -> unit + end diff --git a/basis-library/mlton/proc-env.sml b/basis-library/mlton/proc-env.sml new file mode 100644 index 0000000..ec3ed5f --- /dev/null +++ b/basis-library/mlton/proc-env.sml @@ -0,0 +1,31 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonProcEnv: MLTON_PROC_ENV = + struct + structure GId = PrePosix.GId + type gid = GId.t + + fun setenv {name, value} = + let + val name = NullString.nullTerm name + val value = NullString.nullTerm value + in + PosixError.SysCall.simple + (fn () => PrimitiveFFI.Posix.ProcEnv.setenv (name, value)) + end + + fun setgroups gs = + let + val v = GId.vectorToRep (Vector.fromList gs) + val n = C_Int.fromInt (Vector.length v) + in + PosixError.SysCall.simple + (fn () => PrimitiveFFI.Posix.ProcEnv.setgroups (n, v)) + end + end diff --git a/basis-library/mlton/process.sig b/basis-library/mlton/process.sig new file mode 100644 index 0000000..e906b30 --- /dev/null +++ b/basis-library/mlton/process.sig @@ -0,0 +1,76 @@ +(* Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_PROCESS = + sig + type pid + + val spawn: {args: string list, path: string} -> pid + val spawne: {args: string list, env: string list, path: string} -> pid + val spawnp: {file: string, args: string list} -> pid + + (* Process handle *) + type ('stdin, 'stdout, 'stderr) t + + (* is the io 'dir input or output *) + type input + type output + + (* to what use can the stdio channel be put *) + type none (* it's not connected to a pipe *) + type chain (* connect one child to another *) + type any (* any use is allowed -- dangerous *) + + exception MisuseOfForget (* you avoided the type safety and broke it *) + exception DoublyRedirected (* you tried to reuse a Param.child *) + + structure Child: + sig + type ('use, 'dir) t + + val binIn: (BinIO.instream, input) t -> BinIO.instream + val binOut: (BinIO.outstream, output) t -> BinIO.outstream + (* not necessarily available on all systems; may raise an exception *) + val fd: (Posix.FileSys.file_desc, 'dir) t -> Posix.FileSys.file_desc + (* used for situations where 'forget' was needed for arbitrary redir *) + val remember: (any, 'dir) t -> ('use, 'dir) t + val textIn: (TextIO.instream, input) t -> TextIO.instream + val textOut: (TextIO.outstream, output) t -> TextIO.outstream + end + + structure Param: + sig + type ('use, 'dir) t + + (* {child,fd} close their parameter when create is called. + * therefore they may only be used once! + *) + val child: (chain, 'dir) Child.t -> (none, 'dir) t + (* Not necessarily available on all systems; may raise an exception *) + val fd: Posix.FileSys.file_desc -> (none, 'dir) t + val file: string -> (none, 'dir) t + (* used if you want to return two posibilities; use with care *) + val forget: ('use, 'dir) t -> (any, 'dir) t + val null: (none, 'dir) t + val pipe: ('use, 'dir) t + val self: (none, 'dir) t + end + + val create: + {args: string list, + env: string list option, + path: string, + stderr: ('stderr, output) Param.t, + stdin: ('stdin, input) Param.t, + stdout: ('stdout, output) Param.t} + -> ('stdin, 'stdout, 'stderr) t + val getStderr: ('stdin, 'stdout, 'stderr) t -> ('stderr, input) Child.t + val getStdin: ('stdin, 'stdout, 'stderr) t -> ('stdin, output) Child.t + val getStdout: ('stdin, 'stdout, 'stderr) t -> ('stdout, input) Child.t + val kill: ('stdin, 'stdout, 'stderr) t * Posix.Signal.signal -> unit + val reap: ('stdin, 'stdout, 'stderr) t -> Posix.Process.exit_status + end diff --git a/basis-library/mlton/process.sml b/basis-library/mlton/process.sml new file mode 100644 index 0000000..9d1375b --- /dev/null +++ b/basis-library/mlton/process.sml @@ -0,0 +1,451 @@ +(* Copyright (C) 2009 Matthew Fluet. + * Copyright (C) 2002-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonProcess = + struct + structure Prim = PrimitiveFFI.MLton.Process + structure MLton = Primitive.MLton + local + open Posix + in + structure FileSys = FileSys + structure IO = IO + structure ProcEnv = ProcEnv + structure Process = Process + structure FileDesc = PrePosix.FileDesc + structure PId = PrePosix.PId + structure Signal = PrePosix.Signal + end + structure Mask = MLtonSignal.Mask + structure SysCall = PosixError.SysCall + + type pid = PId.t + + exception MisuseOfForget + exception DoublyRedirected + + type input = unit + type output = unit + + type none = unit + type chain = unit + type any = unit + + val useWindowsProcess = MLton.Platform.OS.useWindowsProcess + + val readWrite = + let + open FileSys.S + in + flags [irusr, iwusr, irgrp, iwgrp, iroth, iwoth] + end + + structure Child = + struct + datatype 'use childt = + FileDesc of FileSys.file_desc + | Stream of 'use * ('use -> unit) + | Term + type ('use, 'dir) t = 'use childt ref + + (* This is _not_ the identity; by rebuilding it we get type + * ('a, 'b) t -> ('c, 'd) t + *) + fun remember x = + case !x of + FileDesc f => + (x := Stream ((), fn () => ()) + ; ref (FileDesc f)) + | Stream _ => raise MisuseOfForget (* remember twice = bad *) + | Term => ref Term + + local + fun convert (new, close) p = + case !p of + FileDesc fd => + let + val str = new (fd, "") + val () = p := Stream (str, close) + in + str + end + | Stream (str, _) => str + | Term => raise MisuseOfForget + in + val binIn = convert (BinIO.newIn, BinIO.closeIn) + val binOut = convert (BinIO.newOut, BinIO.closeOut) + val textIn = convert (TextIO.newIn, TextIO.closeIn) + val textOut = convert (TextIO.newOut, TextIO.closeOut) + end + + fun fd p = + case !p of + FileDesc fd => fd + | _ => raise MisuseOfForget + + fun close ch = + case ch of + FileDesc fd => IO.close fd + | Stream (str, close) => close str + | Term => () + + val close = + fn (stdin, stdout, stderr) => + (close stdin; close stdout; close stderr) + end + + structure Param = + struct + datatype ('use, 'dir) t = + File of string + | FileDesc of FileSys.file_desc + | Pipe + | Self + + (* This is _not_ the identity; by rebuilding it we get type + * ('a, 'b) t -> ('c, 'd) t + *) + val forget = fn + File x => File x + | FileDesc f => FileDesc f + | Pipe => Pipe + | Self => Self + + val pipe = Pipe + local + val null = if useWindowsProcess then "nul" else "/dev/null" + in + val null = File null + end + val self = Self + fun file f = File f + fun fd f = FileDesc f + + fun child c = + FileDesc + (case !c of + Child.FileDesc f => (c := Child.Stream ((), fn () => ()); f) + | Child.Stream _ => raise DoublyRedirected + | Child.Term => raise MisuseOfForget) + + fun setCloseExec fd = + if useWindowsProcess + then () + else IO.setfd (fd, IO.FD.flags [IO.FD.cloexec]) + + local + fun openOut std p = + case p of + File s => (FileSys.creat (s, readWrite), Child.Term) + | FileDesc f => (f, Child.Term) + | Pipe => + let + val {infd, outfd} = IO.pipe () + val () = setCloseExec infd + in + (outfd, Child.FileDesc infd) + end + | Self => (std, Child.Term) + in + fun openStdout p = openOut FileSys.stdout p + fun openStderr p = openOut FileSys.stderr p + end + + fun openStdin p = + case p of + File s => + (FileSys.openf (s, FileSys.O_RDONLY, FileSys.O.flags []), + Child.Term) + | FileDesc f => (f, Child.Term) + | Pipe => + let + val {infd, outfd} = IO.pipe () + val () = setCloseExec outfd + in + (infd, Child.FileDesc outfd) + end + | Self => (FileSys.stdin, Child.Term) + + fun close p fd = + case p of + File _ => IO.close fd + | FileDesc _ => IO.close fd + | Pipe => IO.close fd + | _ => () + end + + datatype ('stdin, 'stdout, 'stderr) t = + T of {pid: Process.pid, (* if useWindowsProcess, + * then this is a Windows process handle + * and can't be passed to + * Posix.Process.* functions. + *) + status: Posix.Process.exit_status option ref, + stderr: ('stderr, input) Child.t, + stdin: ('stdin, output) Child.t, + stdout: ('stdout, input) Child.t} + + local + fun make f (T r) = f r + in + val getStderr = fn z => make #stderr z + val getStdin = fn z => make #stdin z + val getStdout = fn z => make #stdout z + end + + fun ('a, 'b) protect (f: 'a -> 'b, x: 'a): 'b = + let + val () = Mask.block Mask.all + in + DynamicWind.wind (fn () => f x, fn () => Mask.unblock Mask.all) + end + + local + fun reap reapFn (T {pid, status, stderr, stdin, stdout, ...}) = + case !status of + NONE => + let + val _ = Child.close (!stdin, !stdout, !stderr) + val st = reapFn pid + in + status := SOME st + ; st + end + | SOME st => st + in + fun reapForFork p = + reap (fn pid => + let + (* protect is probably too much; typically, one + * would only mask SIGINT, SIGQUIT and SIGHUP. + *) + val (_, st) = + protect (Process.waitpid, (Process.W_CHILD pid, [])) + in + st + end) + p + fun reapForCreate p = + reap (fn pid => + let + val pid' = PId.toRep pid + val status' = ref (C_Status.fromInt 0) + val () = + SysCall.simple + (fn () => + PrimitiveFFI.Windows.Process.getexitcode + (pid', status')) + in + Process.fromStatus' (!status') + end) + p + end + val reap = fn p => + (if useWindowsProcess then reapForCreate else reapForFork) p + + local + fun kill killFn (p as T {pid, status, ...}, signal) = + case !status of + NONE => + let + val () = killFn (pid, signal) + in + ignore (reap p) + end + | SOME _ => () + in + fun killForFork p = + kill (fn (pid, signal) => + Process.kill (Process.K_PROC pid, signal)) + p + fun killForCreate p = + kill (fn (pid, signal) => + SysCall.simple + (fn () => + PrimitiveFFI.Windows.Process.terminate + (PId.toRep pid, Signal.toRep signal))) + p + end + val kill = fn (p, signal) => + (if useWindowsProcess then killForCreate else killForFork) (p, signal) + + fun launchWithFork (path, args, env, stdin, stdout, stderr) = + case protect (Process.fork, ()) of + NONE => (* child *) + let + fun dup2 (old, new) = + if old = new + then () + else (IO.dup2 {old = old, new = new}; IO.close old) + val args = path :: args + val execTh = + case env of + NONE => + (fn () => Process.exec (path, args)) + | SOME env => + (fn () => Process.exece (path, args, env)) + in + dup2 (stdin, FileSys.stdin) + ; dup2 (stdout, FileSys.stdout) + ; dup2 (stderr, FileSys.stderr) + ; ignore (execTh ()) + ; Process.exit 0w127 (* just in case *) + end + | SOME pid => pid (* parent *) + + fun strContains seps s = + CharVector.exists (Char.contains seps) s + (* In MinGW, a string must be escaped if it contains " \t" or is "". + * Escaping means adds "s on the front and end. Any quotes inside + * must be escaped with \. Any \s already in the string must be + * doubled ONLY when they precede a " or the end of string. + *) + fun mingwEscape (l, 0) = l + | mingwEscape (l, i) = mingwEscape (#"\\"::l, i-1) + fun mingwFold (#"\\", (l, escapeCount)) = (#"\\"::l, escapeCount+1) + | mingwFold (#"\"", (l, escapeCount)) = + (#"\"" :: mingwEscape (#"\\"::l, escapeCount), 0) + | mingwFold (x, (l, _)) = (x :: l, 0) + val mingwQuote = mingwEscape o CharVector.foldl mingwFold ([#"\""], 0) + fun mingwEscape y = + if not (strContains " \t\"" y) andalso y<>"" then y else + String.implode (List.rev (#"\"" :: mingwQuote y)) + + fun cygwinEscape y = + if not (strContains " \t\"\r\n\f'" y) andalso y<>"" then y else + concat ["\"", + String.translate + (fn #"\"" => "\\\"" | #"\\" => "\\\\" | x => String.str x) y, + "\""] + + val cmdEscapeCreate = + if MLton.Platform.OS.host = MLton.Platform.OS.MinGW + then mingwEscape else cygwinEscape + + val cmdEscapeSpawn = + if MLton.Platform.OS.host = MLton.Platform.OS.MinGW + then mingwEscape else (fn s => s) + + fun launchWithCreate (path, args, env, stdin, stdout, stderr) = + let + val path' = + NullString.nullTerm + (let + open MLton.Platform.OS + in + case host of + Cygwin => Cygwin.toFullWindowsPath path + | MinGW => path + | _ => raise Fail "MLton.Process.launchWithCreate: path'" + end) + val args' = + NullString.nullTerm + (String.concatWith " " (List.map cmdEscapeCreate (path :: args))) + val env' = + Option.map + (fn env => + NullString.nullTerm + ((String.concatWith "\000" env) ^ "\000")) + env + val stdin' = FileDesc.toRep stdin + val stdout' = FileDesc.toRep stdout + val stderr' = FileDesc.toRep stderr + val createTh = + case env' of + NONE => + (fn () => + PrimitiveFFI.Windows.Process.createNull + (path', args', stdin', stdout', stderr')) + | SOME env' => + (fn () => + PrimitiveFFI.Windows.Process.create + (path', args', env', stdin', stdout', stderr')) + val pid' = + SysCall.simpleResult' + ({errVal = C_PId.castFromFixedInt ~1}, fn () => + createTh ()) + val pid = PId.fromRep pid' + in + pid + end + + val launch = + fn z => + (if useWindowsProcess then launchWithCreate else launchWithFork) z + + fun create {args, env, path, stderr, stdin, stdout} = + if not (FileSys.access (path, [FileSys.A_EXEC])) + then PosixError.raiseSys PosixError.noent + else + let + val () = TextIO.flushOut TextIO.stdOut + val (fstdin, cstdin) = Param.openStdin stdin + val (fstdout, cstdout) = Param.openStdout stdout + val (fstderr, cstderr) = Param.openStderr stderr + val closeStdio = + fn () => (Param.close stdin fstdin + ; Param.close stdout fstdout + ; Param.close stderr fstderr) + val pid = + launch (path, args, env, fstdin, fstdout, fstderr) + handle ex => (closeStdio () + ; Child.close (cstdin, cstdout, cstderr) + ; raise ex) + val () = closeStdio () + in + T {pid = pid, + status = ref NONE, + stderr = ref cstderr, + stdin = ref cstdin, + stdout = ref cstdout} + end + + fun spawne {path, args, env} = + if useWindowsProcess + then + let + val args = List.map cmdEscapeSpawn args + val path = NullString.nullTerm path + val args = CUtil.C_StringArray.fromList args + val env = CUtil.C_StringArray.fromList env + in + (PId.fromRep o SysCall.simpleResult') + ({errVal = C_PId.castFromFixedInt ~1}, fn () => + Prim.spawne (path, args, env)) + end + else + case Posix.Process.fork () of + NONE => (Posix.Process.exece (path, args, env) handle _ => () + ; Posix.Process.exit 0w127) + | SOME pid => pid + + fun spawn {args, path}= + spawne {args = args, + env = ProcEnv.environ (), + path = path} + + fun spawnp {args, file} = + if useWindowsProcess + then + let + val file = NullString.nullTerm file + val args = List.map cmdEscapeSpawn args + val args = CUtil.C_StringArray.fromList args + in + (PId.fromRep o SysCall.simpleResult') + ({errVal = C_PId.castFromFixedInt ~1}, fn () => + Prim.spawnp (file, args)) + end + else + case Posix.Process.fork () of + NONE => (Posix.Process.execp (file, args) handle _ => () + ; Posix.Process.exit 0w127) + | SOME pid => pid + + open Exit + end diff --git a/basis-library/mlton/profile.sig b/basis-library/mlton/profile.sig new file mode 100644 index 0000000..d977e0c --- /dev/null +++ b/basis-library/mlton/profile.sig @@ -0,0 +1,22 @@ +(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_PROFILE = + sig + structure Data: + sig + type t + + val equals: t * t -> bool + val free: t -> unit + val malloc: unit -> t + val write: t * string -> unit + end + + val isOn: bool (* a compile-time constant *) + val withData: Data.t * (unit -> 'a) -> 'a + end diff --git a/basis-library/mlton/profile.sml b/basis-library/mlton/profile.sml new file mode 100644 index 0000000..9627be6 --- /dev/null +++ b/basis-library/mlton/profile.sml @@ -0,0 +1,132 @@ +(* Copyright (C) 2003-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonProfile: MLTON_PROFILE = +struct + +structure P = Primitive.MLton.Profile + +val gcState = Primitive.MLton.GCState.gcState + +val isOn = P.isOn + +structure Data = + struct + datatype t = T of {isCurrent: bool ref, + isFreed: bool ref, + raw: P.Data.t} + + val all: t list ref = ref [] + + local + fun make f (T r) = f r + in + val isFreed = make #isFreed + val raw = make #raw + end + + fun equals (d, d') = + isFreed d = isFreed d' + + fun free (d as T {isCurrent, isFreed, raw, ...}) = + if not isOn + then () + else + if !isFreed + then raise Fail "free of freed profile data" + else if !isCurrent + then raise Fail "free of current profile data" + else + (all := List.foldl (fn (d', ac) => + if equals (d, d') + then ac + else d' :: ac) [] (!all) + ; P.Data.free (gcState, raw) + ; isFreed := true) + + fun make (raw: P.Data.t): t = + T {isCurrent = ref false, + isFreed = ref false, + raw = raw} + + fun malloc (): t = + let + val array = + if isOn + then P.Data.malloc gcState + else P.Data.dummy + val d = make array + val _ = all := d :: !all + in + d + end + + fun write (T {isFreed, raw, ...}, file) = + if not isOn then + () + else if !isFreed then + raise Fail "write of freed profile data" + else + P.Data.write (gcState, raw, + Primitive.NullString8.fromString + (String.nullTerm file)) + end + +val r: Data.t ref = ref (Data.make P.Data.dummy) + +fun current () = !r + +fun setCurrent (d as Data.T {isCurrent, isFreed, raw, ...}) = + if not isOn + then () + else + if !isFreed + then raise Fail "setCurrent of freed profile data" + else + let + val Data.T {isCurrent = ic, ...} = current () + val _ = ic := false + val _ = isCurrent := true + val _ = r := d + val _ = P.setCurrent (gcState, raw) + in + () + end + +fun withData (d: Data.t, f: unit -> 'a): 'a = + let + val old = current () + val _ = setCurrent d + in + DynamicWind.wind (f, fn () => setCurrent old) + end + +fun init () = setCurrent (Data.make (P.getCurrent gcState)) + +val _ = + if not isOn + then () + else + let + val _ = + Cleaner.addNew + (Cleaner.atExit, fn () => + (P.done gcState + ; Data.write (current (), "mlmon.out") + ; List.app (fn d => P.Data.free (gcState, Data.raw d)) + (!Data.all))) + val _ = + Cleaner.addNew + (Cleaner.atLoadWorld, fn () => + ((* In a new world, all of the old profiling data is invalid. *) + Data.all := [] + ; init ())) + in + init () + end + +end diff --git a/basis-library/mlton/ptrace.sig b/basis-library/mlton/ptrace.sig new file mode 100644 index 0000000..424ee34 --- /dev/null +++ b/basis-library/mlton/ptrace.sig @@ -0,0 +1,20 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_PTRACE = + sig + type pid + + val attach: pid -> unit + val cont: pid -> unit + val detach: pid -> unit + val kill: pid -> unit + val peekText: pid * Word.word -> Word.word + val singleStep: pid -> unit + val sysCall: pid -> unit + end diff --git a/basis-library/mlton/ptrace.sml b/basis-library/mlton/ptrace.sml new file mode 100644 index 0000000..dee3581 --- /dev/null +++ b/basis-library/mlton/ptrace.sml @@ -0,0 +1,34 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonPtrace: MLTON_PTRACE = + struct + open Primitive.Ptrace + + type pid = Pid.t + + local + fun make request pid = PosixError.checkResult(ptrace2(request, pid)) + in + val attach = make ATTACH + val cont = make CONT + val detach = make DETACH + val kill = make KILL + val singleStep = make SINGLESTEP + val sysCall = make SYSCALL + end + + local + in + fun peekText(pid, addr) = + let val data: word ref = ref 0w0 + in PosixError.checkResult(ptrace4(PEEKTEXT, pid, addr, data)) + ; !data + end + end + end diff --git a/basis-library/mlton/random.sig b/basis-library/mlton/random.sig new file mode 100644 index 0000000..035676c --- /dev/null +++ b/basis-library/mlton/random.sig @@ -0,0 +1,34 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_RANDOM = + sig + (* Return a random alphanumeric character. *) + val alphaNumChar: unit -> char + + (* Return a string of random alphanumeric characters of specified + * length. + *) + val alphaNumString: int -> string + + (* Get the next pseudrandom. *) + val rand: unit -> word + + (* Use /dev/random to get a word. Useful as an arg to srand. + * Return NONE if /dev/random can't be read. + *) + val seed: unit -> word option + + (* Set the seed used by rand. *) + val srand: word -> unit + + (* Use /dev/urandom to get a word. Useful as an arg to srand. + * Return NONE if /dev/urandom can't be read. + *) + val useed: unit -> word option + end diff --git a/basis-library/mlton/random.sml b/basis-library/mlton/random.sml new file mode 100644 index 0000000..1404fa0 --- /dev/null +++ b/basis-library/mlton/random.sml @@ -0,0 +1,104 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonRandom: MLTON_RANDOM = + struct + (* Uses /dev/random and /dev/urandom to get a random word. + * If they can't be read from, return NONE. + *) + local + fun make (file, name) = + let + val buf = Word8Array.array (4, 0w0) + in + fn () => + (let + val fd = + let + open Posix.FileSys + in + openf (file, O_RDONLY, O.flags []) + end + fun loop rem = + let + val n = Posix.IO.readArr (fd, + Word8ArraySlice.slice + (buf, 4 - rem, SOME rem)) + val _ = if n = 0 + then (Posix.IO.close fd; raise Fail name) + else () + val rem = rem - n + in + if rem = 0 + then () + else loop rem + end + val _ = loop 4 + val _ = Posix.IO.close fd + in + SOME (Word.fromLarge (PackWord32Little.subArr (buf, 0))) + end + handle OS.SysErr _ => NONE) + end + in + val seed = make ("/dev/random", "Random.seed") + val useed = make ("/dev/urandom", "Random.useed") + end + + local + open Word + val seed: word ref = ref 0w13 + in + (* From page 284 of Numerical Recipes in C. *) + fun rand (): word = + let + val res = 0w1664525 * !seed + 0w1013904223 + val _ = seed := res + in + res + end + + fun srand (w: word): unit = seed := w + end + + local + val chars = + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" + val numChars = String.size chars + val refresh = + let + val numChars = IntInf.fromInt numChars + fun loop (i: IntInf.int, c: int): int = + if IntInf.< (i, numChars) + then c + else loop (IntInf.div (i, numChars), c + 1) + in + loop (IntInf.pow (2, Word.wordSize), 0) + end + val r: word ref = ref 0w0 + val count: int ref = ref refresh + val numChars = Word.fromInt numChars + in + fun alphaNumChar (): char = + let + val n = !count + val _ = if n = refresh + then (r := rand () + ; count := 1) + else (count := n + 1) + val w = !r + val c = String.sub (chars, Word.toInt (Word.mod (w, numChars))) + val _ = r := Word.div (w, numChars) + in + c + end + end + + fun alphaNumString (length: int): string = + String.tabulate (length, fn _ => alphaNumChar ()) + end diff --git a/basis-library/mlton/real.sig b/basis-library/mlton/real.sig new file mode 100644 index 0000000..e8125c6 --- /dev/null +++ b/basis-library/mlton/real.sig @@ -0,0 +1,17 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_REAL = + sig + type t + + val fromWord: word -> t + val fromLargeWord: LargeWord.word -> t + val toWord: IEEEReal.rounding_mode -> t -> word + val toLargeWord: IEEEReal.rounding_mode -> t -> LargeWord.word + end diff --git a/basis-library/mlton/rlimit.sig b/basis-library/mlton/rlimit.sig new file mode 100644 index 0000000..706d4f3 --- /dev/null +++ b/basis-library/mlton/rlimit.sig @@ -0,0 +1,37 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_RLIMIT = + sig + structure RLim : sig + type t + val castFromSysWord: SysWord.word -> t + val castToSysWord: t -> SysWord.word + end + + val infinity: RLim.t + + type t + + val coreFileSize: t (* CORE max core file size *) + val cpuTime: t (* CPU CPU time in seconds *) + val dataSize: t (* DATA max data size *) + val fileSize: t (* FSIZE Maximum filesize *) + val numFiles: t (* NOFILE max number of open files *) + val stackSize: t (* STACK max stack size *) + val virtualMemorySize: t (* AS virtual memory limit *) + +(* NOT STANDARD *) + val lockedInMemorySize: t (* MEMLOCK max locked address space *) + val numProcesses: t (* NPROC max number of processes *) + val residentSetSize: t (* RSS max resident set size *) +(* *) + + val get: t -> {hard: RLim.t, soft: RLim.t} + val set: t * {hard: RLim.t, soft: RLim.t} -> unit + end diff --git a/basis-library/mlton/rlimit.sml b/basis-library/mlton/rlimit.sml new file mode 100644 index 0000000..48f8e96 --- /dev/null +++ b/basis-library/mlton/rlimit.sml @@ -0,0 +1,50 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonRlimit: MLTON_RLIMIT = + struct + open PrimitiveFFI.MLton.Rlimit + structure RLim = + struct + type t = C_RLim.t + val castFromSysWord = C_RLim.castFromSysWord + val castToSysWord = C_RLim.castToSysWord + end + type t = C_Int.t + + val get = + fn (r: t) => + PosixError.SysCall.syscall + (fn () => + (get r, fn _ => + {hard = getHard (), + soft = getSoft ()})) + + val set = + fn (r: t, {hard, soft}) => + PosixError.SysCall.simple + (fn () => set (r, hard, soft)) + + val infinity = INFINITY + + val coreFileSize = CORE + val cpuTime = CPU + val dataSize = DATA + val fileSize = FSIZE + val numFiles = NOFILE + val stackSize = STACK + val virtualMemorySize = AS + +(* NOT STANDARD *) + val lockedInMemorySize = MEMLOCK + val numProcesses = NPROC + val residentSetSize = RSS +(* *) + + end diff --git a/basis-library/mlton/rusage.sig b/basis-library/mlton/rusage.sig new file mode 100644 index 0000000..daff6a3 --- /dev/null +++ b/basis-library/mlton/rusage.sig @@ -0,0 +1,16 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_RUSAGE = + sig + type t = {utime: Time.time, (* user time *) + stime: Time.time} (* system time *) + + val measureGC: bool -> unit + val rusage: unit -> {children: t, gc: t, self: t} + end diff --git a/basis-library/mlton/rusage.sml b/basis-library/mlton/rusage.sml new file mode 100644 index 0000000..51b4495 --- /dev/null +++ b/basis-library/mlton/rusage.sml @@ -0,0 +1,50 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonRusage: MLTON_RUSAGE = + struct + structure Prim = PrimitiveFFI.MLton.Rusage + + type t = {utime: Time.time, stime: Time.time} + + fun collect (utimeSec, utimeUsec, stimeSec, stimeUsec) = + let + fun toTime (sec, usec) = + let + val time_sec = + Time.fromSeconds (C_Time.toLargeInt (sec ())) + val time_usec = + Time.fromMicroseconds (C_SUSeconds.toLargeInt (usec ())) + in + Time.+ (time_sec, time_usec) + end + in + {stime = toTime (stimeSec, stimeUsec), + utime = toTime (utimeSec, utimeUsec)} + end + + val measureGC = MLtonGC.setRusageMeasureGC + + val rusage = + let + val () = measureGC true + in + fn () => + let + val () = Prim.getrusage () + open Prim + in + {children = collect (children_utime_sec, children_utime_usec, + children_stime_sec, children_stime_usec), + gc = collect (gc_utime_sec, gc_utime_usec, + gc_stime_sec, gc_stime_usec), + self = collect (self_utime_sec, self_utime_usec, + self_stime_sec, self_stime_usec)} + end + end + end diff --git a/basis-library/mlton/signal.sig b/basis-library/mlton/signal.sig new file mode 100644 index 0000000..f82dcfb --- /dev/null +++ b/basis-library/mlton/signal.sig @@ -0,0 +1,58 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_SIGNAL = + sig + type t + type signal = t + + structure Handler: + sig + type t + + val default: t + val handler: (MLtonThread.Runnable.t -> MLtonThread.Runnable.t) -> t + val ignore: t + val isDefault: t -> bool + val isIgnore: t -> bool + val simple: (unit -> unit) -> t + end + + structure Mask: + sig + type t + + val all: t + val allBut: signal list -> t + val block: t -> unit + val getBlocked: unit -> t + val isMember: t * signal -> bool + val none: t + val setBlocked: t -> unit + val some: signal list -> t + val unblock: t -> unit + end + + val getHandler: t -> Handler.t + val handled: unit -> Mask.t + val prof: t + val restart: bool ref + val setHandler: t * Handler.t -> unit + (* suspend m temporarily sets the signal mask to m and suspends until an + * unmasked signal is received and handled, and then resets the mask. + *) + val suspend: Mask.t -> unit + val vtalrm: t + end + +signature MLTON_SIGNAL_EXTRA = + sig + include MLTON_SIGNAL + + val handleGC: (unit -> unit) -> unit + end diff --git a/basis-library/mlton/signal.sml b/basis-library/mlton/signal.sml new file mode 100644 index 0000000..db60708 --- /dev/null +++ b/basis-library/mlton/signal.sml @@ -0,0 +1,225 @@ +(* Copyright (C) 2015 Matthew Fluet. + * Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonSignal: MLTON_SIGNAL_EXTRA = +struct + +open Posix.Signal +structure Prim = PrimitiveFFI.Posix.Signal +structure Error = PosixError +structure SysCall = Error.SysCall +val restart = SysCall.restartFlag + +type t = signal + +type how = C_Int.t + +fun raiseInval () = + let + open PosixError + in + raiseSys inval + end + +structure Mask = + struct + type pre_sig_set = Word8.word array + type sig_set = Word8.word vector + fun newSigSet (): (pre_sig_set * (unit -> sig_set)) = + let + val sslen = C_Size.toInt Prim.sigSetLen + val ss = Array.array (sslen, 0wx0: Word8.word) + in + (ss, fn () => Array.vector ss) + end + + type t = sig_set + + fun allBut sigs = + let + val (ss, finish) = newSigSet () + val () = SysCall.simple (fn () => Prim.sigfillset ss) + val () = List.app (fn s => SysCall.simple + (fn () => Prim.sigdelset (ss, toRep s))) + sigs + in + finish () + end + val all = allBut [] + fun some sigs = + let + val (ss, finish) = newSigSet () + val () = SysCall.simple (fn () => Prim.sigemptyset ss) + val () = List.app (fn s => SysCall.simple + (fn () => Prim.sigaddset (ss, toRep s))) + sigs + in + finish () + end + val none = some [] + + fun isMember (ss, s) = + SysCall.simpleResult (fn () => Prim.sigismember (ss, toRep s)) <> C_Int.zero + + local + fun make (how: how) (ss: t) = + let + val (oss, finish) = newSigSet () + val () = SysCall.simpleRestart (fn () => Prim.sigprocmask (how, ss, oss)) + in + finish () + end + in + val block = ignore o make Prim.SIG_BLOCK + val unblock = ignore o make Prim.SIG_UNBLOCK + val setBlocked = ignore o make Prim.SIG_SETMASK + fun getBlocked () = make Prim.SIG_BLOCK none + end + end + +structure Handler = + struct + datatype t = + Default + | Handler of MLtonThread.Runnable.t -> MLtonThread.Runnable.t + | Ignore + | InvalidSignal + end + +datatype handler = datatype Handler.t + +local + val r = ref C_Int.zero +in + fun initHandler (s: signal): Handler.t = + SysCall.syscallErr + ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () => + {return = Prim.isDefault (toRep s, r), + post = fn _ => if !r <> C_Int.zero then Default else Ignore, + handlers = [(Error.inval, fn () => InvalidSignal)]}) +end + +val (getHandler, setHandler, handlers) = + let + val handlers = Array.tabulate (C_Int.toInt Prim.NSIG, initHandler o fromInt) + val _ = + Cleaner.addNew + (Cleaner.atLoadWorld, fn () => + Array.modifyi (initHandler o fromInt o #1) handlers) + in + (fn s: t => Array.sub (handlers, toInt s), + fn (s: t, h) => if Primitive.MLton.Profile.isOn andalso s = prof + then raiseInval () + else Array.update (handlers, toInt s, h), + handlers) + end + +val gcHandler = ref Ignore + +fun handled () = + Mask.some + (Array.foldri + (fn (s, h, sigs) => + case h of + Handler _ => (fromInt s)::sigs + | _ => sigs) [] handlers) + +structure Handler = + struct + open Handler + + val default = Default + val ignore = Ignore + + val isDefault = fn Default => true | _ => false + val isIgnore = fn Ignore => true | _ => false + + val handler = + (* This let is used so that Thread.setHandler is only used if + * Handler.handler is used. This prevents threads from being part + * of every program. + *) + let + (* As far as C is concerned, there is only one signal handler. + * As soon as possible after a C signal is received, this signal + * handler walks over the array of all SML handlers, and invokes any + * one for which a C signal has been received. + * + * Any exceptions raised by a signal handler will be caught by + * the topLevelHandler, which is installed in thread.sml. + *) + val _ = + PosixError.SysCall.blocker := + (fn () => let + val m = Mask.getBlocked () + val () = Mask.block (handled ()) + in + fn () => Mask.setBlocked m + end) + + val () = + MLtonThread.setSignalHandler + (fn t => + let + val mask = Mask.getBlocked () + val () = Mask.block (handled ()) + val fs = + case !gcHandler of + Handler f => if Prim.isPendingGC () <> C_Int.zero + then [f] + else [] + | _ => [] + val fs = + Array.foldri + (fn (s, h, fs) => + case h of + Handler f => + if Prim.isPending (repFromInt s) <> C_Int.zero + then f::fs + else fs + | _ => fs) fs handlers + val () = Prim.resetPending () + val () = Mask.setBlocked mask + in + List.foldl (fn (f, t) => f t) t fs + end) + in + Handler + end + + fun simple (f: unit -> unit) = handler (fn t => (f (); t)) + end + +val setHandler = fn (s, h) => + case (getHandler s, h) of + (InvalidSignal, _) => raiseInval () + | (_, InvalidSignal) => raiseInval () + | (Default, Default) => () + | (_, Default) => + (setHandler (s, Default) + ; SysCall.simpleRestart (fn () => Prim.default (toRep s))) + | (Handler _, Handler _) => + setHandler (s, h) + | (_, Handler _) => + (setHandler (s, h) + ; SysCall.simpleRestart (fn () => Prim.handlee (toRep s))) + | (Ignore, Ignore) => () + | (_, Ignore) => + (setHandler (s, Ignore) + ; SysCall.simpleRestart (fn () => Prim.ignore (toRep s))) + +fun suspend m = + (Prim.sigsuspend m + ; MLtonThread.switchToSignalHandler ()) + +fun handleGC f = + (Prim.handleGC () + ; gcHandler := Handler.simple f) + +end diff --git a/basis-library/mlton/syslog.sig b/basis-library/mlton/syslog.sig new file mode 100644 index 0000000..4d313a6 --- /dev/null +++ b/basis-library/mlton/syslog.sig @@ -0,0 +1,78 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* From Tom 7 . *) +(* A rather complete interface to the syslog facilities. + * + * See + * man 3 syslog + * + * .. for descriptions of these constants. + *) +signature MLTON_SYSLOG = + sig + type openflag + + val CONS : openflag + val NDELAY : openflag + val NOWAIT : openflag + val ODELAY : openflag +(* NOT STANDARD *) + val PERROR : openflag +(* *) + val PID : openflag + + type facility + + val AUTHPRIV : facility + val CRON : facility + val DAEMON : facility + val KERN : facility + val LOCAL0 : facility + val LOCAL1 : facility + val LOCAL2 : facility + val LOCAL3 : facility + val LOCAL4 : facility + val LOCAL5 : facility + val LOCAL6 : facility + val LOCAL7 : facility + val LPR : facility + val MAIL : facility + val NEWS : facility +(* NOT STANDARD *) + val SYSLOG : facility +(* *) + val USER : facility + val UUCP : facility + + type loglevel + + val EMERG : loglevel + val ALERT : loglevel + val CRIT : loglevel + val ERR : loglevel + val WARNING : loglevel + val NOTICE : loglevel + val INFO : loglevel + val DEBUG : loglevel + + (* Closelog is also optional. *) + val closelog: unit -> unit + + (* log a message at a particular loglevel. *) + val log: loglevel * string -> unit + + (* + * Openlog opens a connection to the system logger. + * Calling openlog is optional but recommended. + * From the man pages. + * The string is prefixed to each message, and is typically set to the + * program name. + *) + val openlog: string * openflag list * facility -> unit + end diff --git a/basis-library/mlton/syslog.sml b/basis-library/mlton/syslog.sml new file mode 100644 index 0000000..dafbebd --- /dev/null +++ b/basis-library/mlton/syslog.sml @@ -0,0 +1,89 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* From Tom 7 . *) +(* Implementation of the SYSLOG interface using MLton FFI. + * This will only work in MLton. + *) + +structure MLtonSyslog :> MLTON_SYSLOG = +struct + +open PrimitiveFFI.MLton.Syslog + +type openflag = C_Int.t + +local + open Logopt +in + val CONS = LOG_CONS + val NDELAY = LOG_NDELAY + val NOWAIT = LOG_NOWAIT + val ODELAY = LOG_ODELAY +(* NOT STANDARD *) + val PERROR = LOG_PERROR +(* *) + val PID = LOG_PID +end + +type facility = C_Int.t + +local + open Facility +in + val AUTHPRIV = LOG_AUTH + val CRON = LOG_CRON + val DAEMON = LOG_DAEMON + val KERN = LOG_KERN + val LOCAL0 = LOG_LOCAL0 + val LOCAL1 = LOG_LOCAL1 + val LOCAL2 = LOG_LOCAL2 + val LOCAL3 = LOG_LOCAL3 + val LOCAL4 = LOG_LOCAL4 + val LOCAL5 = LOG_LOCAL5 + val LOCAL6 = LOG_LOCAL6 + val LOCAL7 = LOG_LOCAL7 + val LPR = LOG_LPR + val MAIL = LOG_MAIL + val NEWS = LOG_NEWS +(* NOT STANDARD *) + val SYSLOG = LOG_SYSLOG +(* *) + val USER = LOG_USER + val UUCP = LOG_UUCP +end + +type loglevel = C_Int.t + +local + open Severity +in + val ALERT = LOG_ALERT + val CRIT = LOG_CRIT + val DEBUG = LOG_DEBUG + val EMERG = LOG_EMERG + val ERR = LOG_ERR + val INFO = LOG_INFO + val NOTICE = LOG_NOTICE + val WARNING = LOG_WARNING +end + +val openlog = fn (s, opt, fac) => + let + val optf = foldl C_Int.orb 0 opt + in + openlog (NullString.nullTerm s, optf, fac) + end + +val closelog = fn () => + closelog () + +val log = fn (lev, msg) => + syslog (lev, NullString.nullTerm msg) + +end diff --git a/basis-library/mlton/text-io.sig b/basis-library/mlton/text-io.sig new file mode 100644 index 0000000..468c918 --- /dev/null +++ b/basis-library/mlton/text-io.sig @@ -0,0 +1,9 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_TEXT_IO = MLTON_IO diff --git a/basis-library/mlton/thread.sig b/basis-library/mlton/thread.sig new file mode 100644 index 0000000..ffc59f5 --- /dev/null +++ b/basis-library/mlton/thread.sig @@ -0,0 +1,68 @@ +(* Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +type int = Int.int + +signature MLTON_THREAD = + sig + structure AtomicState : + sig + datatype t = NonAtomic | Atomic of int + end + val atomically: (unit -> 'a) -> 'a + val atomicBegin: unit -> unit + val atomicEnd: unit -> unit + val atomicState: unit -> AtomicState.t + + structure Runnable : + sig + type t + end + + type 'a t + + (* atomicSwitch f + * as switch, but assumes an atomic calling context. Upon + * switch-ing back to the current thread, an implicit atomicEnd is + * performed. + *) + val atomicSwitch: ('a t -> Runnable.t) -> 'a + (* new f + * create a new thread that, when run, applies f to + * the value given to the thread. f must terminate by + * switch-ing to another thread or exiting the process. + *) + val new: ('a -> unit) -> 'a t + (* prepend(t, f) + * create a new thread (destroying t in the process) that first + * applies f to the value given to the thread and then continues + * with t. This is a constant time operation. + *) + val prepend: 'a t * ('b -> 'a) -> 'b t + (* prepare(t, v) + * create a new runnable thread (destroying t in the process) + * that will evaluate t on v. + *) + val prepare: 'a t * 'a -> Runnable.t + (* switch f + * apply f to the current thread to get rt, and then start + * running thread rt. It is an error for f to + * perform another switch. f is guaranteed to run + * atomically. + *) + val switch: ('a t -> Runnable.t) -> 'a + end + +signature MLTON_THREAD_EXTRA = + sig + include MLTON_THREAD + + val amInSignalHandler: unit -> bool + val register: int * (MLtonPointer.t -> unit) -> unit + val setSignalHandler: (Runnable.t -> Runnable.t) -> unit + val switchToSignalHandler: unit -> unit + end diff --git a/basis-library/mlton/thread.sml b/basis-library/mlton/thread.sml new file mode 100644 index 0000000..6a3694a --- /dev/null +++ b/basis-library/mlton/thread.sml @@ -0,0 +1,286 @@ +(* Copyright (C) 2014 Matthew Fluet. + * Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonThread:> MLTON_THREAD_EXTRA = +struct + +structure Prim = Primitive.MLton.Thread + +fun die (s: string): 'a = + (PrimitiveFFI.Stdio.print s + ; PrimitiveFFI.Posix.Process.exit 1 + ; let exception DieFailed + in raise DieFailed + end) + +val gcState = Primitive.MLton.GCState.gcState + +structure AtomicState = + struct + datatype t = NonAtomic | Atomic of int + end + +local + open Prim +in + val atomicBegin = atomicBegin + val atomicEnd = atomicEnd + val atomicState = fn () => + case atomicState () of + 0wx0 => AtomicState.NonAtomic + | w => AtomicState.Atomic (Word32.toInt w) +end + +fun atomically f = + (atomicBegin (); DynamicWind.wind (f, atomicEnd)) + +datatype 'a thread = + Dead + | Interrupted of Prim.thread + | New of 'a -> unit + (* In Paused (f, t), f is guaranteed to not raise an exception. *) + | Paused of ((unit -> 'a) -> unit) * Prim.thread + +datatype 'a t = T of 'a thread ref + +structure Runnable = + struct + type t = unit t + end + +fun prepend (T r: 'a t, f: 'b -> 'a): 'b t = + let + val t = + case !r of + Dead => raise Fail "prepend to a Dead thread" + | Interrupted _ => raise Fail "prepend to a Interrupted thread" + | New g => New (g o f) + | Paused (g, t) => Paused (fn h => g (f o h), t) + in r := Dead + ; T (ref t) + end + +fun prepare (t: 'a t, v: 'a): Runnable.t = + prepend (t, fn () => v) + +fun new f = T (ref (New f)) + +local + local + val func: (unit -> unit) option ref = ref NONE + val base: Prim.preThread = + let + val () = Prim.copyCurrent () + in + case !func of + NONE => Prim.savedPre gcState + | SOME x => + (* This branch never returns. *) + let + (* Atomic 1 *) + val () = func := NONE + val () = atomicEnd () + (* Atomic 0 *) + in + (x () handle e => MLtonExn.topLevelHandler e) + ; die "Thread didn't exit properly.\n" + end + end + in + fun newThread (f: unit -> unit) : Prim.thread = + let + (* Atomic 2 *) + val () = func := SOME f + in + Prim.copy base + end + end + val switching = ref false +in + fun 'a atomicSwitch (f: 'a t -> Runnable.t): 'a = + (* Atomic 1 *) + if !switching + then let + val () = atomicEnd () + (* Atomic 0 *) + in + raise Fail "nested Thread.switch" + end + else + let + val _ = switching := true + val r : (unit -> 'a) ref = + ref (fn () => die "Thread.atomicSwitch didn't set r.\n") + val t: 'a thread ref = + ref (Paused (fn x => r := x, Prim.current gcState)) + fun fail e = (t := Dead + ; switching := false + ; atomicEnd () + ; raise e) + val (T t': Runnable.t) = f (T t) handle e => fail e + val primThread = + case !t' before t' := Dead of + Dead => fail (Fail "switch to a Dead thread") + | Interrupted t => t + | New g => (atomicBegin (); newThread g) + | Paused (f, t) => (f (fn () => ()); t) + val _ = switching := false + (* Atomic 1 when Paused/Interrupted, Atomic 2 when New *) + val _ = Prim.switchTo primThread (* implicit atomicEnd() *) + (* Atomic 0 when resuming *) + in + !r () + end + + fun switch f = + (atomicBegin () + ; atomicSwitch f) +end + +fun fromPrimitive (t: Prim.thread): Runnable.t = + T (ref (Interrupted t)) + +fun toPrimitive (t as T r : unit t): Prim.thread = + case !r of + Dead => die "Thread.toPrimitive saw Dead.\n" + | Interrupted t => + (r := Dead + ; t) + | New _ => + switch + (fn cur : Prim.thread t => + prepare + (prepend (t, fn () => + switch + (fn t' : unit t => + prepare (cur, toPrimitive t'))), + ())) + | Paused (f, t) => + (r := Dead + ; f (fn () => ()) + ; t) + + +local + val signalHandler: Prim.thread option ref = ref NONE + datatype state = Normal | InHandler + val state: state ref = ref Normal +in + fun amInSignalHandler () = InHandler = !state + + fun setSignalHandler (f: Runnable.t -> Runnable.t): unit = + let + val _ = Primitive.MLton.installSignalHandler () + fun loop (): unit = + let + (* Atomic 1 *) + val _ = state := InHandler + val t = f (fromPrimitive (Prim.saved gcState)) + val _ = state := Normal + val _ = Prim.finishSignalHandler gcState + val _ = + atomicSwitch + (fn (T r) => + let + val _ = + case !r of + Paused (f, _) => f (fn () => ()) + | _ => raise die "Thread.setSignalHandler saw strange thread" + in + t + end) (* implicit atomicEnd () *) + in + loop () + end + val p = + toPrimitive + (new (fn () => loop () handle e => MLtonExn.topLevelHandler e)) + val _ = signalHandler := SOME p + in + Prim.setSignalHandler (gcState, p) + end + + fun switchToSignalHandler () = + let + (* Atomic 0 *) + val () = atomicBegin () + (* Atomic 1 *) + val () = Prim.startSignalHandler gcState (* implicit atomicBegin () *) + (* Atomic 2 *) + in + case !signalHandler of + NONE => raise Fail "no signal handler installed" + | SOME t => Prim.switchTo t (* implicit atomicEnd() *) + end +end + + +local + +in + val register: int * (MLtonPointer.t -> unit) -> unit = + let + val exports = + Array.array (Int32.toInt (Primitive.MLton.FFI.numExports), + fn _ => raise Fail "undefined export") + val worker : (Prim.thread * Prim.thread option ref) option ref = ref NONE + fun mkWorker (): Prim.thread * Prim.thread option ref = + let + val thisWorker : (Prim.thread * Prim.thread option ref) option ref = ref NONE + val savedRef : Prim.thread option ref = ref NONE + fun workerLoop () = + let + (* Atomic 1 *) + val p = Primitive.MLton.FFI.getOpArgsResPtr () + val _ = atomicEnd () + (* Atomic 0 *) + val i = MLtonPointer.getInt32 (MLtonPointer.getPointer (p, 0), 0) + val _ = + (Array.sub (exports, Int32.toInt i) p) + handle e => + (TextIO.output + (TextIO.stdErr, "Call from C to SML raised exception.\n") + ; MLtonExn.topLevelHandler e) + (* Atomic 0 *) + val _ = atomicBegin () + (* Atomic 1 *) + val _ = worker := !thisWorker + val _ = Prim.setSaved (gcState, valOf (!savedRef)) + val _ = savedRef := NONE + val _ = Prim.returnToC () (* implicit atomicEnd() *) + in + workerLoop () + end + val workerThread = toPrimitive (new workerLoop) + val _ = thisWorker := SOME (workerThread, savedRef) + in + (workerThread, savedRef) + end + fun handlerLoop (): unit = + let + (* Atomic 2 *) + val saved = Prim.saved gcState + val (workerThread, savedRef) = + case !worker of + NONE => mkWorker () + | SOME (workerThread, savedRef) => + (worker := NONE + ; (workerThread, savedRef)) + val _ = savedRef := SOME saved + val _ = Prim.switchTo (workerThread) (* implicit atomicEnd() *) + in + handlerLoop () + end + val handlerThread = toPrimitive (new handlerLoop) + val _ = Prim.setCallFromCHandler (gcState, handlerThread) + in + fn (i, f) => Array.update (exports, i, f) + end +end + +end diff --git a/basis-library/mlton/vector.sig b/basis-library/mlton/vector.sig new file mode 100644 index 0000000..ab03c2e --- /dev/null +++ b/basis-library/mlton/vector.sig @@ -0,0 +1,17 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +type int = Int.int + +signature MLTON_VECTOR = + sig + val create: int -> {done: unit -> 'a vector, + sub: int -> 'a, + update: int * 'a -> unit} + val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b + end diff --git a/basis-library/mlton/weak.sig b/basis-library/mlton/weak.sig new file mode 100644 index 0000000..f70efe6 --- /dev/null +++ b/basis-library/mlton/weak.sig @@ -0,0 +1,14 @@ +(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_WEAK = + sig + type 'a t + + val get: 'a t -> 'a option + val new: 'a -> 'a t + end diff --git a/basis-library/mlton/weak.sml b/basis-library/mlton/weak.sml new file mode 100644 index 0000000..ee9e4b1 --- /dev/null +++ b/basis-library/mlton/weak.sml @@ -0,0 +1,28 @@ +(* Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonWeak = + struct + structure Weak = Primitive.MLton.Weak + + type 'a t = 'a Weak.t + + val new = Weak.new + + fun get (w: 'a t): 'a option = + let + (* Need to do the canGet after the get. If you did the canGet first, + * there could be a GC that invalidates the pointer between the + * canGet and the get. + *) + val x = Weak.get w + in + if Weak.canGet w + then SOME x + else NONE + end + end diff --git a/basis-library/mlton/word.sig b/basis-library/mlton/word.sig new file mode 100644 index 0000000..d7ddbbe --- /dev/null +++ b/basis-library/mlton/word.sig @@ -0,0 +1,16 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_WORD = + sig + type t + + val bswap: t -> t + val rol: t * word -> t + val ror: t * word -> t + end diff --git a/basis-library/mlton/world.sig b/basis-library/mlton/world.sig new file mode 100644 index 0000000..96a3546 --- /dev/null +++ b/basis-library/mlton/world.sig @@ -0,0 +1,18 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature MLTON_WORLD = + sig + datatype status = Clone | Original + + val load: string -> 'a + (* Save the world to resume with the current thread. *) + val save: string -> status + (* Save the world to resume with the given thread. *) + val saveThread: string * MLtonThread.Runnable.t -> unit + end diff --git a/basis-library/mlton/world.sml b/basis-library/mlton/world.sml new file mode 100644 index 0000000..0cfeb5a --- /dev/null +++ b/basis-library/mlton/world.sml @@ -0,0 +1,57 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MLtonWorld: MLTON_WORLD = + struct + structure Prim = Primitive.MLton.World + structure Error = PosixError + structure SysCall = Error.SysCall + + val gcState = Primitive.MLton.GCState.gcState + + datatype status = Clone | Original + + (* Need to worry about: + * - open file descriptors + * - redetermine buffer status when restart + *) + fun save' (file: string): status = + let + val () = + SysCall.simple' + ({errVal = false}, + fn () => (Prim.save (NullString.nullTerm file) + ; Prim.getSaveStatus (gcState))) + in + if Prim.getAmOriginal gcState + then Original + else (Prim.setAmOriginal (gcState, true) + ; Cleaner.clean Cleaner.atLoadWorld + ; Clone) + end + + fun saveThread (file: string, t: MLtonThread.Runnable.t): unit = + case save' file of + Clone => MLtonThread.switch (fn _ => t) + | Original => () + + fun save (file: string): status = + if MLtonThread.amInSignalHandler () + then raise Fail "cannot call MLton.World.save within signal handler" + else save' file + + fun load (file: string): 'a = + if let open OS_FileSys + in access (file, [A_READ]) + end + then + let val c = CommandLine.name () + in Posix.Process.exec (c, [c, "@MLton", "load-world", file, "--"]) + end + else raise Fail (concat ["World.load can not read ", file]) + end diff --git a/basis-library/net/generic-sock.sig b/basis-library/net/generic-sock.sig new file mode 100644 index 0000000..a46c309 --- /dev/null +++ b/basis-library/net/generic-sock.sig @@ -0,0 +1,11 @@ +signature GENERIC_SOCK = + sig + val socket: Socket.AF.addr_family * Socket.SOCK.sock_type -> + ('af, 'sock_type) Socket.sock + val socketPair: Socket.AF.addr_family * Socket.SOCK.sock_type -> + ('af, 'sock_type) Socket.sock * ('af, 'sock_type) Socket.sock + val socket': Socket.AF.addr_family * Socket.SOCK.sock_type * int -> + ('af, 'sock_type) Socket.sock + val socketPair': Socket.AF.addr_family * Socket.SOCK.sock_type * int -> + ('af, 'sock_type) Socket.sock * ('af, 'sock_type) Socket.sock + end diff --git a/basis-library/net/generic-sock.sml b/basis-library/net/generic-sock.sml new file mode 100644 index 0000000..58894a0 --- /dev/null +++ b/basis-library/net/generic-sock.sml @@ -0,0 +1,36 @@ +(* Copyright (C) 2002-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure GenericSock : GENERIC_SOCK = + struct + structure Prim = PrimitiveFFI.Socket.GenericSock + structure PE = Posix.Error + structure PESC = PE.SysCall + + fun socket' (af, st, p) = + (Socket.fromRep o PESC.simpleResult) + (fn () => Prim.socket (Net.AddrFamily.toRep af, + Socket.SOCKExtra.toRep st, + C_Int.fromInt p)) + + fun socketPair' (af, st, p) = + let + val a : C_Sock.t array = Array.array (2, C_Sock.fromInt 0) + val get = fn i => Socket.fromRep (Array.sub (a, i)) + in + PESC.syscall + (fn () => (Prim.socketPair (Net.AddrFamily.toRep af, + Socket.SOCKExtra.toRep st, + C_Int.fromInt p, + a), + fn _ => (get 0, get 1))) + end + + fun socket (af, st) = socket' (af, st, 0) + + fun socketPair (af, st) = socketPair' (af, st, 0) + end diff --git a/basis-library/net/inet-sock.sig b/basis-library/net/inet-sock.sig new file mode 100644 index 0000000..416c9ae --- /dev/null +++ b/basis-library/net/inet-sock.sig @@ -0,0 +1,24 @@ +signature INET_SOCK = + sig + type inet + type 'sock_type sock = (inet, 'sock_type) Socket.sock + type dgram_sock = Socket.dgram sock + type sock_addr = inet Socket.sock_addr + type 'mode stream_sock = 'mode Socket.stream sock + val inetAF: Socket.AF.addr_family + val toAddr: NetHostDB.in_addr * int -> sock_addr + val fromAddr: sock_addr -> NetHostDB.in_addr * int + val any: int -> sock_addr + structure UDP: + sig + val socket: unit -> dgram_sock + val socket': int -> dgram_sock + end + structure TCP: + sig + val socket: unit -> 'mode stream_sock + val socket': int -> 'mode stream_sock + val getNODELAY: 'mode stream_sock -> bool + val setNODELAY: 'mode stream_sock * bool -> unit + end + end diff --git a/basis-library/net/inet-sock.sml b/basis-library/net/inet-sock.sml new file mode 100644 index 0000000..25e7d7b --- /dev/null +++ b/basis-library/net/inet-sock.sml @@ -0,0 +1,68 @@ +(* Copyright (C) 2002-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure INetSock:> INET_SOCK = + struct + structure Prim = PrimitiveFFI.Socket.INetSock + + datatype inet = INET (* a phantom type*) + type 'sock_type sock = (inet, 'sock_type) Socket.sock + type 'mode stream_sock = 'mode Socket.stream sock + type dgram_sock = Socket.dgram sock + type sock_addr = inet Socket.sock_addr + + val inetAF = Net.AddrFamily.fromRep PrimitiveFFI.Socket.AF.INET + + fun toAddr (in_addr, port) = + let + val port = Word16.fromInt port + handle Overflow => PosixError.raiseSys PosixError.inval + val port = Net.Word16.hton port + val (sa, salen, finish) = Socket.newSockAddr () + val _ = Prim.toAddr (NetHostDB.inAddrToWord8Vector in_addr, + port, sa, salen) + + in + finish () + end + + fun any port = toAddr (NetHostDB.any (), port) + + fun fromAddr sa = + let + val () = Prim.fromAddr (Socket.unpackSockAddr sa) + val port = Prim.getPort () + val port = Net.Word16.ntoh port + val port = Word16.toInt port + val (ia, finish) = NetHostDB.newInAddr () + val _ = Prim.getInAddr (NetHostDB.preInAddrToWord8Array ia) + in + (finish (), port) + end + + structure UDP = + struct + fun socket' prot = GenericSock.socket' (inetAF, Socket.SOCK.dgram, prot) + fun socket () = socket' 0 + end + + structure TCP = + struct + structure Prim = Prim.Ctl + + fun socket' prot = GenericSock.socket' (inetAF, Socket.SOCK.stream, prot) + fun socket () = socket' 0 + + fun getNODELAY sock = + Socket.CtlExtra.getSockOptBool + (Prim.IPPROTO_TCP, Prim.TCP_NODELAY) sock + + fun setNODELAY (sock, optval) = + Socket.CtlExtra.setSockOptBool + (Prim.IPPROTO_TCP, Prim.TCP_NODELAY) (sock,optval) + end + end diff --git a/basis-library/net/net-host-db.sig b/basis-library/net/net-host-db.sig new file mode 100644 index 0000000..f3f3512 --- /dev/null +++ b/basis-library/net/net-host-db.sig @@ -0,0 +1,29 @@ +signature NET_HOST_DB = + sig + eqtype addr_family + type entry + eqtype in_addr + + val addr: entry -> in_addr + val addrType: entry -> addr_family + val addrs: entry -> in_addr list + val aliases: entry -> string list + val fromString: string -> in_addr option + val getByAddr: in_addr -> entry option + val getByName: string -> entry option + val getHostName: unit -> string + val name: entry -> string + val scan: (char, 'a) StringCvt.reader -> (in_addr, 'a) StringCvt.reader + val toString: in_addr -> string + end + +signature NET_HOST_DB_EXTRA = + sig + include NET_HOST_DB + type pre_in_addr + + val any: unit -> in_addr + val inAddrToWord8Vector: in_addr -> Word8.word vector + val newInAddr: unit -> pre_in_addr * (unit -> in_addr) + val preInAddrToWord8Array: pre_in_addr -> Word8.word array + end diff --git a/basis-library/net/net-host-db.sml b/basis-library/net/net-host-db.sml new file mode 100644 index 0000000..db2bfdf --- /dev/null +++ b/basis-library/net/net-host-db.sml @@ -0,0 +1,222 @@ +(* Copyright (C) 2002-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure NetHostDB: NET_HOST_DB_EXTRA = + struct + structure Prim = PrimitiveFFI.NetHostDB + + (* network byte order (big-endian) *) + type pre_in_addr = Word8.word array + type in_addr = Word8.word vector + + val preInAddrToWord8Array = fn a => a + val inAddrToWord8Vector = fn v => v + + val inAddrLen = C_Size.toInt Prim.inAddrSize + fun newInAddr () = + let + val ia: pre_in_addr = Array.array (inAddrLen, 0wx0: Word8.word) + fun finish () = Array.vector ia + in + (ia, finish) + end + fun any () = + let + val (wa, finish) = newInAddr () + fun loop (i, acc) = + if i >= inAddrLen + then () + else let + val w = Word8.castFromSysWord (C_Int.castToSysWord acc) + val () = + Array.update + (wa, (inAddrLen - 1) - i, w) + in + loop (i + 1, C_Int.>> (acc, 0w4)) + end + in + loop (0, Prim.INADDR_ANY) + ; finish () + end + + structure AddrFamily = Net.AddrFamily + type addr_family = AddrFamily.t + + datatype entry = T of {name: string, + aliases: string list, + addrType: addr_family, + addrs: in_addr list} + + local + fun make s (T r) = s r + in + val name = make #name + val aliases = make #aliases + val addrType = make #addrType + val addrs = make #addrs + end + fun addr entry = hd (addrs entry) + + local + fun get (i: C_Int.t): entry option = + if i <> C_Int.zero + then let + val name = CUtil.C_String.toString (Prim.getEntryName ()) + val numAliases = Prim.getEntryAliasesNum () + fun fill (n, aliases) = + if C_Int.< (n, numAliases) + then let + val alias = + CUtil.C_String.toString (Prim.getEntryAliasesN n) + in + fill (C_Int.+ (n, 1), alias::aliases) + end + else List.rev aliases + val aliases = fill (0, []) + val addrType = Prim.getEntryAddrType () + val length = Prim.getEntryLength () + val numAddrs = Prim.getEntryAddrsNum () + fun fill (n, addrs) = + if C_Int.< (n, numAddrs) + then let + val addr = Word8Array.array (C_Int.toInt length, 0wx0) + val _ = Prim.getEntryAddrsN (n, Word8Array.toPoly addr) + val addr = Word8Vector.toPoly (Word8Array.vector addr) + in + fill (C_Int.+ (n, 1), addr::addrs) + end + else List.rev addrs + val addrs = fill (0, []) + in + SOME (T {name = name, + aliases = aliases, + addrType = AddrFamily.fromRep addrType, + addrs = addrs}) + end + else NONE + in + fun getByAddr in_addr = + get (Prim.getByAddress (in_addr, C_Socklen.fromInt (Vector.length in_addr))) + fun getByName name = + get (Prim.getByName (NullString.nullTerm name)) + end + + fun getHostName () = + let + val n = 128 + val buf = CharArray.array (n, #"\000") + val () = + Posix.Error.SysCall.simple + (fn () => Prim.getHostName (CharArray.toPoly buf, C_Size.fromInt n)) + in + case CharArray.findi (fn (_, c) => c = #"\000") buf of + NONE => CharArray.vector buf + | SOME (i, _) => + CharArraySlice.vector (CharArraySlice.slice (buf, 0, SOME i)) + end + + fun scan reader state = + let + fun scanW state = + case reader state of + SOME (#"0", state') => + (case reader state' of + NONE => SOME (0w0, state') + | SOME (c, state'') => + if Char.isDigit c + then StringCvt.wdigits StringCvt.OCT reader state' + else if c = #"x" orelse c = #"X" + then StringCvt.wdigits StringCvt.HEX reader state'' + else SOME (0w0, state')) + | _ => StringCvt.wdigits StringCvt.DEC reader state + fun loop (n, state, acc) = + if n <= 0 + then List.rev acc + else let + fun finish (w, state) = + case reader state of + SOME (#".", state') => + loop (n - 1, state', (w, state)::acc) + | _ => List.rev ((w, state)::acc) + in + case scanW state of + SOME (w, state') => finish (w, state') + | NONE => List.rev acc + end + val l = loop (4, state, []) + fun get1 w = + (Word8.fromLarge (Word.toLarge (Word.andb (w, 0wxFF))), + Word.>>(w, 0w8)) + fun get2 w = + let + val (a,w) = get1 w + val (b,w) = get1 w + in (a,b,w) + end + fun get3 w = + let + val (a,b,w) = get2 w + val (c,w) = get1 w + in (a,b,c,w) + end + fun get4 w = + let + val (a,b,c,w) = get3 w + val (d,w) = get1 w + in (a,b,c,d,w) + end + fun try l = + case l of + [] => NONE + | [(w, statew)] => + let + val (d,c,b,a,w) = get4 w + in + if w = 0wx0 + then SOME (Vector.fromList [a,b,c,d], statew) + else NONE + end + | [(x, statex), (w, statew)] => + let + val (d,c,b,w) = get3 w + val (a,x) = get1 x + in + if w = 0wx0 andalso x = 0wx0 + then SOME (Vector.fromList [a,b,c,d], statew) + else try [(x, statex)] + end + | [(y, statey), (x, statex), (w, statew)] => + let + val (d,c,w) = get2 w + val (b,x) = get1 x + val (a,y) = get1 y + in + if w = 0wx0 andalso x = 0wx0 andalso y = 0wx0 + then SOME (Vector.fromList [a,b,c,d], statew) + else try [(y, statey), (x, statex)] + end + | [(z, statez), (y, statey), (x, statex), (w, statew)] => + let + val (d,w) = get1 w + val (c,x) = get1 x + val (b,y) = get1 y + val (a,z) = get1 z + in + if w = 0wx0 andalso x = 0wx0 andalso y = 0wx0 andalso z = 0wx0 + then SOME (Vector.fromList [a,b,c,d], statew) + else try [(z, statez), (y, statey), (x, statex)] + end + | _ => NONE + in + try l + end + + fun fromString s = StringCvt.scanString scan s + fun toString in_addr = + String.concatWith "." + (Vector.foldr (fn (w,ss) => (Word8.fmt StringCvt.DEC w)::ss) [] in_addr) + end diff --git a/basis-library/net/net-prot-db.sig b/basis-library/net/net-prot-db.sig new file mode 100644 index 0000000..dd3fd97 --- /dev/null +++ b/basis-library/net/net-prot-db.sig @@ -0,0 +1,9 @@ +signature NET_PROT_DB = + sig + type entry + val name: entry -> string + val aliases: entry -> string list + val protocol: entry -> int + val getByName: string -> entry option + val getByNumber: int -> entry option + end diff --git a/basis-library/net/net-prot-db.sml b/basis-library/net/net-prot-db.sml new file mode 100644 index 0000000..f2e8532 --- /dev/null +++ b/basis-library/net/net-prot-db.sml @@ -0,0 +1,52 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure NetProtDB: NET_PROT_DB = + struct + structure Prim = PrimitiveFFI.NetProtDB + + datatype entry = T of {name: string, + aliases: string list, + protocol: C_Int.t} + + local + fun make s (T r) = s r + in + val name = make #name + val aliases = make #aliases + val protocol = C_Int.toInt o (make #protocol) + end + + local + fun get (i: C_Int.t): entry option = + if i <> C_Int.zero + then let + val name = CUtil.C_String.toString (Prim.getEntryName ()) + val numAliases = Prim.getEntryAliasesNum () + fun fill (n, aliases) = + if C_Int.< (n, numAliases) + then let + val alias = CUtil.C_String.toString (Prim.getEntryAliasesN n) + in + fill (C_Int.+ (n, 1), alias::aliases) + end + else List.rev aliases + val aliases = fill (0, []) + val protocol = Prim.getEntryProto () + in + SOME (T {name = name, + aliases = aliases, + protocol = protocol}) + end + else NONE + in + fun getByName name = + get (Prim.getByName (NullString.nullTerm name)) + fun getByNumber proto = + get (Prim.getByNumber (C_Int.fromInt proto)) + end + end diff --git a/basis-library/net/net-serv-db.sig b/basis-library/net/net-serv-db.sig new file mode 100644 index 0000000..7ae2f07 --- /dev/null +++ b/basis-library/net/net-serv-db.sig @@ -0,0 +1,10 @@ +signature NET_SERV_DB = + sig + type entry + val name: entry -> string + val aliases: entry -> string list + val port: entry -> int + val protocol: entry -> string + val getByName: string * string option -> entry option + val getByPort: int * string option -> entry option + end diff --git a/basis-library/net/net-serv-db.sml b/basis-library/net/net-serv-db.sml new file mode 100644 index 0000000..7954f22 --- /dev/null +++ b/basis-library/net/net-serv-db.sml @@ -0,0 +1,66 @@ +(* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure NetServDB: NET_SERV_DB = + struct + structure Prim = PrimitiveFFI.NetServDB + + datatype entry = T of {name: string, + aliases: string list, + port: C_Int.t, + protocol: string} + + local + fun make s (T r) = s r + in + val name = make #name + val aliases = make #aliases + val port = C_Int.toInt o (make #port) + val protocol = make #protocol + end + + local + fun get (i: C_Int.t): entry option = + if i <> C_Int.zero + then let + val name = CUtil.C_String.toString (Prim.getEntryName ()) + val numAliases = Prim.getEntryAliasesNum () + fun fill (n, aliases) = + if C_Int.< (n, numAliases) + then let + val alias = CUtil.C_String.toString (Prim.getEntryAliasesN n) + in + fill (C_Int.+ (n, 1), alias::aliases) + end + else List.rev aliases + val aliases = fill (0, []) + val port = Net.C_Int.ntoh (Prim.getEntryPort ()) + val protocol = CUtil.C_String.toString (Prim.getEntryProto ()) + in + SOME (T {name = name, + aliases = aliases, + port = port, + protocol = protocol}) + end + else NONE + in + fun getByName (name, proto) = + case proto of + SOME proto => get (Prim.getByName (NullString.nullTerm name, + NullString.nullTerm proto)) + | NONE => get (Prim.getByNameNull (NullString.nullTerm name)) + fun getByPort (port, proto) = + let + val port = Net.C_Int.hton (C_Int.fromInt port) + in + case proto of + NONE => get (Prim.getByPortNull port) + | SOME proto => + get (Prim.getByPort (port, NullString.nullTerm proto)) + end + end + end diff --git a/basis-library/net/net.sig b/basis-library/net/net.sig new file mode 100644 index 0000000..7af86b8 --- /dev/null +++ b/basis-library/net/net.sig @@ -0,0 +1,24 @@ +(* Copyright (C) 2002-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature NET = + sig + structure AddrFamily : ABS_REP_EQ where type Rep.t = C_Int.t + structure Sock : ABS_REP where type Rep.t = C_Sock.t + structure SockType : ABS_REP_EQ where type Rep.t = C_Sock.t + + structure Word16 : + sig + val hton: Word16.word -> Word16.word + val ntoh: Word16.word -> Word16.word + end + structure C_Int : + sig + val hton: C_Int.t -> C_Int.t + val ntoh: C_Int.t -> C_Int.t + end + end diff --git a/basis-library/net/net.sml b/basis-library/net/net.sml new file mode 100644 index 0000000..1a34583 --- /dev/null +++ b/basis-library/net/net.sml @@ -0,0 +1,76 @@ +(* Copyright (C) 2012 Matthew Fluet. + * Copyright (C) 2002-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Net : NET = + struct + structure AddrFamily = MkAbsRepEq(type rep = C_Int.t) + structure Sock = MkAbsRep(type rep = C_Sock.t) + structure SockType = MkAbsRepEq(type rep = C_Int.t) + + structure Prim = PrimitiveFFI.Net + + structure Word32 = + struct + val hton = Prim.htonl + val ntoh = Prim.ntohl + end + structure Word16 = + struct + val hton = Prim.htons + val ntoh = Prim.ntohs + end + + structure Int32 = + struct + val hton = + Primitive.IntWordConv.idFromWord32ToInt32 + o Word32.hton + o Primitive.IntWordConv.idFromInt32ToWord32 + val ntoh = + Primitive.IntWordConv.idFromWord32ToInt32 + o Word32.ntoh + o Primitive.IntWordConv.idFromInt32ToWord32 + end + structure Int16 = + struct + val hton = + Primitive.IntWordConv.idFromWord16ToInt16 + o Word16.hton + o Primitive.IntWordConv.idFromInt16ToWord16 + val ntoh = + Primitive.IntWordConv.idFromWord16ToInt16 + o Word16.ntoh + o Primitive.IntWordConv.idFromInt16ToWord16 + end + + structure C_Int = + struct + local + structure S = + C_Int_ChooseIntN + (type 'a t = 'a -> 'a + val fInt8 = fn _ => raise Fail "Net.C_Int.hton: fInt8" + val fInt16 = Int16.hton + val fInt32 = Int32.hton + val fInt64 = fn _ => raise Fail "Net.C_Int.hton: fInt64") + in + val hton = S.f + end + local + structure S = + C_Int_ChooseIntN + (type 'a t = 'a -> 'a + val fInt8 = fn _ => raise Fail "Net.C_Int.ntoh: fInt8" + val fInt16 = Int16.ntoh + val fInt32 = Int32.ntoh + val fInt64 = fn _ => raise Fail "Net.C_Int.ntoh: fInt64") + in + val ntoh = S.f + end + end + end diff --git a/basis-library/net/socket.sig b/basis-library/net/socket.sig new file mode 100644 index 0000000..4d4a2a9 --- /dev/null +++ b/basis-library/net/socket.sig @@ -0,0 +1,192 @@ +signature SOCKET = + sig + type active + type dgram + type in_flags = {peek: bool, oob: bool} + type out_flags = {don't_route: bool, oob: bool} + type passive + datatype shutdown_mode = + NO_RECVS + | NO_SENDS + | NO_RECVS_OR_SENDS + type ('af,'sock_type) sock + type 'af sock_addr + type sock_desc + type 'mode stream + + structure AF: + sig + type addr_family = NetHostDB.addr_family + + val fromString: string -> addr_family option + val list: unit -> (string * addr_family) list + val toString: addr_family -> string + end + + structure SOCK: + sig + eqtype sock_type + + val dgram: sock_type + val fromString: string -> sock_type option + val list: unit -> (string * sock_type) list + val stream: sock_type + val toString: sock_type -> string + end + + structure Ctl: + sig + val getATMARK: ('af, active stream) sock -> bool + val getBROADCAST: ('af, 'sock_type) sock -> bool + val getDEBUG: ('af, 'sock_type) sock -> bool + val getDONTROUTE: ('af, 'sock_type) sock -> bool + val getERROR: ('af, 'sock_type) sock -> bool + val getKEEPALIVE: ('af, 'sock_type) sock -> bool + val getLINGER: ('af, 'sock_type) sock -> Time.time option + val getNREAD: ('af, 'sock_type) sock -> int + val getOOBINLINE: ('af, 'sock_type) sock -> bool + val getPeerName: ('af, 'sock_type) sock -> 'af sock_addr + val getRCVBUF: ('af, 'sock_type) sock -> int + val getREUSEADDR: ('af, 'sock_type) sock -> bool + val getSNDBUF: ('af, 'sock_type) sock -> int + val getSockName: ('af, 'sock_type) sock -> 'af sock_addr + val getTYPE: ('af, 'sock_type) sock -> SOCK.sock_type + val setBROADCAST: ('af, 'sock_type) sock * bool -> unit + val setDEBUG: ('af, 'sock_type) sock * bool -> unit + val setDONTROUTE: ('af, 'sock_type) sock * bool -> unit + val setKEEPALIVE: ('af, 'sock_type) sock * bool -> unit + val setLINGER: ('af, 'sock_type) sock * Time.time option -> unit + val setOOBINLINE: ('af, 'sock_type) sock * bool -> unit + val setRCVBUF: ('af, 'sock_type) sock * int -> unit + val setREUSEADDR: ('af, 'sock_type) sock * bool -> unit + val setSNDBUF: ('af, 'sock_type) sock * int -> unit + end + + val accept: ('af, passive stream) sock -> (('af, active stream) sock + * 'af sock_addr) + val acceptNB: ('af, passive stream) sock -> (('af, active stream) sock + * 'af sock_addr) option + val bind: ('af, 'sock_type) sock * 'af sock_addr -> unit + val close: ('af, 'sock_type) sock -> unit + val connect: ('af, 'sock_type) sock * 'af sock_addr -> unit + val connectNB: ('af, 'sock_type) sock * 'af sock_addr -> bool + val familyOfAddr: 'af sock_addr -> AF.addr_family + val ioDesc: ('af, 'sock_type) sock -> OS.IO.iodesc + val listen: ('af, passive stream) sock * int -> unit + val recvArr: ('af, active stream) sock * Word8ArraySlice.slice -> int + val recvArr': (('af, active stream) sock + * Word8ArraySlice.slice + * in_flags) -> int + val recvArrFrom: (('af, dgram) sock * Word8ArraySlice.slice + -> int * 'af sock_addr) + val recvArrFrom': (('af, dgram) sock * Word8ArraySlice.slice * in_flags + -> int * 'af sock_addr) + val recvArrFromNB: (('af, dgram) sock * Word8ArraySlice.slice + -> (int * 'af sock_addr) option) + val recvArrFromNB': (('af, dgram) sock * Word8ArraySlice.slice * in_flags + -> (int * 'af sock_addr) option) + val recvArrNB: (('af, active stream) sock + * Word8ArraySlice.slice) -> int option + val recvArrNB': (('af, active stream) sock + * Word8ArraySlice.slice + * in_flags) -> int option + val recvVec: ('af, active stream) sock * int -> Word8Vector.vector + val recvVec': (('af, active stream) sock * int * in_flags + -> Word8Vector.vector) + val recvVecFrom: (('af, dgram) sock * int + -> Word8Vector.vector * 'af sock_addr) + val recvVecFrom': (('af, dgram) sock * int * in_flags + -> Word8Vector.vector * 'af sock_addr) + val recvVecFromNB: (('af, dgram) sock * int + -> (Word8Vector.vector * 'af sock_addr) option) + val recvVecFromNB': (('af, dgram) sock * int * in_flags + -> (Word8Vector.vector * 'af sock_addr) option) + val recvVecNB: ('af, active stream) sock * int -> Word8Vector.vector option + val recvVecNB': (('af, active stream) sock * int * in_flags + -> Word8Vector.vector option) + val sameAddr: 'af sock_addr * 'af sock_addr -> bool + val sameDesc: sock_desc * sock_desc -> bool + val select: {exs: sock_desc list, + rds: sock_desc list, + timeout: Time.time option, + wrs: sock_desc list} -> {exs: sock_desc list, + rds: sock_desc list, + wrs: sock_desc list} + val sendArr: ('af, active stream) sock * Word8ArraySlice.slice -> int + val sendArr': (('af, active stream) sock + * Word8ArraySlice.slice + * out_flags) -> int + val sendArrNB: (('af, active stream) sock * Word8ArraySlice.slice + -> int option) + val sendArrNB': (('af, active stream) sock + * Word8ArraySlice.slice + * out_flags) -> int option + val sendArrTo: (('af, dgram) sock + * 'af sock_addr + * Word8ArraySlice.slice) -> unit + val sendArrTo': (('af, dgram) sock + * 'af sock_addr + * Word8ArraySlice.slice + * out_flags) -> unit + val sendArrToNB: (('af, dgram) sock + * 'af sock_addr + * Word8ArraySlice.slice) -> bool + val sendArrToNB': (('af, dgram) sock + * 'af sock_addr + * Word8ArraySlice.slice + * out_flags) -> bool + val sendVec: ('af, active stream) sock * Word8VectorSlice.slice -> int + val sendVec': (('af, active stream) sock + * Word8VectorSlice.slice + * out_flags) -> int + val sendVecNB: (('af, active stream) sock + * Word8VectorSlice.slice) -> int option + val sendVecNB': (('af, active stream) sock + * Word8VectorSlice.slice + * out_flags) -> int option + val sendVecTo: (('af, dgram) sock + * 'af sock_addr + * Word8VectorSlice.slice) -> unit + val sendVecTo': (('af, dgram) sock + * 'af sock_addr + * Word8VectorSlice.slice + * out_flags) -> unit + val sendVecToNB: (('af, dgram) sock + * 'af sock_addr + * Word8VectorSlice.slice) -> bool + val sendVecToNB': (('af, dgram) sock + * 'af sock_addr + * Word8VectorSlice.slice + * out_flags) -> bool + val shutdown: ('af, 'mode stream) sock * shutdown_mode -> unit + val sockDesc: ('af, 'sock_type) sock -> sock_desc + end + +signature SOCKET_EXTRA = + sig + include SOCKET + val fromRep : C_Sock.t -> ('af, 'sock_type) sock + val toRep : ('af, 'sock_type) sock -> C_Sock.t + val sockToWord: ('af, 'sock_type) sock -> SysWord.word + val wordToSock: SysWord.word -> ('af, 'sock_type) sock + val sockToFD: ('af, 'sock_type) sock -> Posix.FileSys.file_desc + val fdToSock: Posix.FileSys.file_desc -> ('af, 'sock_type) sock + type pre_sock_addr = Word8.word array + val unpackSockAddr: 'af sock_addr -> Word8.word vector + val newSockAddr: unit -> (pre_sock_addr * C_Socklen.t ref * (unit -> 'af sock_addr)) + + structure SOCKExtra: + sig + val toRep : SOCK.sock_type -> C_Sock.t + end + + structure CtlExtra: + sig + type level = C_Int.int + type optname = C_Int.int + + val getERROR: ('af, 'sock_type) sock -> (string * Posix.Error.syserror option) option + val getSockOptBool: level * optname -> ('af, 'sock_type) sock -> bool + val setSockOptBool: level * optname -> ('af, 'sock_type) sock * bool -> unit + end + end diff --git a/basis-library/net/socket.sml b/basis-library/net/socket.sml new file mode 100644 index 0000000..c199ef7 --- /dev/null +++ b/basis-library/net/socket.sml @@ -0,0 +1,590 @@ +(* Copyright (C) 2012,2013,2015,2017 Matthew Fluet. + * Copyright (C) 2002-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Socket :> SOCKET_EXTRA = +struct + +structure Prim = PrimitiveFFI.Socket +structure Error = Posix.Error +structure Syscall = Error.SysCall +structure FileSys = Posix.FileSys + +structure Sock = Net.Sock +type sock = Sock.t +val fromRep = Sock.fromRep +val toRep = Sock.toRep +val sockToWord = C_Sock.castToSysWord o Sock.toRep +val wordToSock = Sock.fromRep o C_Sock.castFromSysWord +val sockToFD = PrePosix.FileDesc.fromRep o Sock.toRep +val fdToSock = Sock.fromRep o PrePosix.FileDesc.toRep + +type pre_sock_addr = Word8.word array +datatype sock_addr = SA of Word8.word vector +fun unpackSockAddr (SA sa) = sa +fun newSockAddr (): (pre_sock_addr * C_Socklen.t ref * (unit -> sock_addr)) = + let + val salen = C_Size.toInt Prim.sockAddrStorageLen + val sa = Array.array (salen, 0wx0: Word8.word) + val salenRef = ref (C_Socklen.fromInt salen) + fun finish () = + SA (ArraySlice.vector + (ArraySlice.slice (sa, 0, SOME (C_Socklen.toInt (!salenRef))))) + in + (sa, salenRef, finish) + end +datatype dgram = DGRAM (* phantom *) +datatype stream = MODE (* phantom *) +datatype passive = PASSIVE (* phantom *) +datatype active = ACTIVE (* phantom *) + +structure AddrFamily = Net.AddrFamily +structure AF = + struct + type addr_family = AddrFamily.t + val names : (string * addr_family) list = + ("UNIX", AddrFamily.fromRep Prim.AF.UNIX) :: + ("INET", AddrFamily.fromRep Prim.AF.INET) :: + ("INET6", AddrFamily.fromRep Prim.AF.INET6) :: + ("UNSPEC", AddrFamily.fromRep Prim.AF.UNSPEC) :: + nil + fun list () = names + fun toString af' = + case List.find (fn (_, af) => af = af') names of + SOME (name, _) => name + | NONE => raise (Fail "Internal error: bogus addr_family") + fun fromString name' = + case List.find (fn (name, _) => name = name') names of + SOME (_, af) => SOME af + | NONE => NONE + end + +structure SockType = Net.SockType +structure SOCK = + struct + type sock_type = SockType.t + val toRep = SockType.toRep + val fromRep = SockType.fromRep + val stream = SockType.fromRep Prim.SOCK.STREAM + val dgram = SockType.fromRep Prim.SOCK.DGRAM + val names : (string * sock_type) list = + ("STREAM", stream) :: + ("DGRAM", dgram) :: + nil + fun list () = names + fun toString st' = + case List.find (fn (_, st) => st = st') names of + SOME (name, _) => name + | NONE => raise (Fail "Internal error: bogus sock_type") + fun fromString name' = + case List.find (fn (name, _) => name = name') names of + SOME (_, st) => SOME st + | NONE => NONE + end +structure SOCKExtra = SOCK + +structure CtlExtra = + struct + type level = C_Int.t + type optname = C_Int.t + type request = C_Int.t + + fun getSockOptC_Int (level: level, optname: optname) s : C_Int.t = + let + val optval = ref (C_Int.fromInt 0) + val () = + Syscall.simple + (fn () => Prim.Ctl.getSockOptC_Int (Sock.toRep s, level, optname, optval)) + in + ! optval + end + fun setSockOptC_Int (level: level, optname: optname) (s, optval: C_Int.t) : unit = + let + val () = + Syscall.simple + (fn () => Prim.Ctl.setSockOptC_Int (Sock.toRep s, level, optname, optval)) + in + () + end + + fun getSockOptBool (level: level, optname: optname) s : bool = + if getSockOptC_Int (level, optname) s = 0 then false else true + fun setSockOptBool (level: level, optname: optname) (s, optval: bool) : unit = + setSockOptC_Int (level, optname) (s, if optval then C_Int.fromInt 1 else C_Int.fromInt 0) + fun gsSockOptBool (level: level, optname: optname) = + (getSockOptBool (level, optname), setSockOptBool (level, optname)) + + fun getSockOptInt (level: level, optname: optname) s : int = + C_Int.toInt (getSockOptC_Int (level, optname) s) + fun setSockOptInt (level: level, optname: optname) (s, optval: int) : unit = + setSockOptC_Int (level, optname) (s, C_Int.fromInt optval) + fun gsSockOptInt (level: level, optname: optname) = + (getSockOptInt (level, optname), setSockOptInt (level, optname)) + + fun getSockOptTimeOption (level: level, optname: optname) s : Time.time option = + let + val optval_l_onoff = ref (C_Int.fromInt 0) + val optval_l_linger = ref (C_Int.fromInt 0) + val () = + Syscall.simple + (fn () => Prim.Ctl.getSockOptC_Linger (Sock.toRep s, level, optname, + optval_l_onoff, optval_l_linger)) + + in + if ! optval_l_onoff = 0 + then NONE + else SOME (Time.fromSeconds (C_Int.toLarge (! optval_l_linger))) + end + fun setSockOptTimeOption (level: level, optname: optname) (s, optval: Time.time option) : unit = + let + val (optval_l_onoff, optval_l_linger) = + case optval of + NONE => (C_Int.fromInt 0, C_Int.fromInt 0) + | SOME t => (C_Int.fromInt 1, C_Int.fromLarge (Time.toSeconds t)) + val () = + Syscall.simple + (fn () => Prim.Ctl.setSockOptC_Linger (Sock.toRep s, level, optname, + optval_l_onoff, optval_l_linger)) + + in + () + end + + val (getDEBUG, setDEBUG) = gsSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_DEBUG) + val (getREUSEADDR, setREUSEADDR) = gsSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_REUSEADDR) + val (getKEEPALIVE, setKEEPALIVE) = gsSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_KEEPALIVE) + val (getDONTROUTE, setDONTROUTE) = gsSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_DONTROUTE) + val getLINGER = getSockOptTimeOption (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_LINGER) + val setLINGER = setSockOptTimeOption (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_LINGER) + val (getBROADCAST, setBROADCAST) = gsSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_BROADCAST) + val (getOOBINLINE, setOOBINLINE) = gsSockOptBool (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_OOBINLINE) + val (getSNDBUF, setSNDBUF) = gsSockOptInt (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_SNDBUF) + val (getRCVBUF, setRCVBUF) = gsSockOptInt (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_RCVBUF) + fun getTYPE s = SOCK.fromRep (getSockOptC_Int (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_TYPE) s) + fun getERROR s = + let + val se = getSockOptC_Int (Prim.Ctl.SOL_SOCKET, Prim.Ctl.SO_ERROR) s + val se = PrePosix.SysError.fromRep se + in + if PosixError.cleared = se + then NONE + else SOME (Error.errorMsg se, SOME se) + end handle Error.SysErr z => SOME z + + local + fun getName (s, f: C_Sock.t * pre_sock_addr * C_Socklen.t ref -> C_Int.int C_Errno.t) = + let + val (sa, salen, finish) = newSockAddr () + val () = Syscall.simple (fn () => f (Sock.toRep s, sa, salen)) + in + finish () + end + in + fun getPeerName s = getName (s, Prim.Ctl.getPeerName) + fun getSockName s = getName (s, Prim.Ctl.getSockName) + end + fun getNREAD s = + let + val argp = ref (C_Int.fromInt ~1) + val () = Syscall.simple (fn () => Prim.Ctl.getNREAD (Sock.toRep s, argp)) + in + C_Int.toInt (!argp) + end + fun getATMARK s = + let + val argp = ref (C_Int.fromInt ~1) + val () = Syscall.simple (fn () => Prim.Ctl.getATMARK (Sock.toRep s, argp)) + in + if C_Int.toInt (!argp) = 0 then false else true + end + end + +structure Ctl = + struct + open CtlExtra + + val getERROR = isSome o CtlExtra.getERROR + end + +fun sameAddr (SA sa1, SA sa2) = sa1 = sa2 + +fun familyOfAddr (SA sa) = AddrFamily.fromRep (Prim.familyOfAddr sa) + +fun bind (s, SA sa) = + Syscall.simple (fn () => Prim.bind (Sock.toRep s, sa, C_Socklen.fromInt (Vector.length sa))) + +fun listen (s, n) = + Syscall.simple (fn () => Prim.listen (Sock.toRep s, C_Int.fromInt n)) + +fun nonBlock' ({restart: bool}, + errVal : ''a, f : unit -> ''a C_Errno.t, post : ''a -> 'b, again, no : 'b) = + Syscall.syscallErr + ({clear = false, restart = restart, errVal = errVal}, fn () => + {return = f (), + post = post, + handlers = [(again, fn () => no)]}) + +fun nonBlock (errVal, f, post, no) = + nonBlock' ({restart = true}, errVal, f, post, Error.again, no) + +local + structure PIO = PrimitiveFFI.Posix.IO + structure OS = Primitive.MLton.Platform.OS + structure MinGW = PrimitiveFFI.MinGW + + fun withNonBlockNormal (s, f: unit -> 'a) = + let + val fd = Sock.toRep s + val flags = + Syscall.simpleResultRestart (fn () => PIO.fcntl2 (fd, PIO.F_GETFL)) + val () = + Syscall.simpleRestart + (fn () => + PIO.fcntl3 (fd, PIO.F_SETFL, + C_Int.orb (flags, PrimitiveFFI.Posix.FileSys.O.NONBLOCK))) + in + DynamicWind.wind + (f, fn () => + Syscall.simpleRestart (fn () => PIO.fcntl3 (fd, PIO.F_SETFL, flags))) + end + + fun withNonBlockMinGW (s, f: unit -> 'a) = + let + val fd = Sock.toRep s + val () = MinGW.setNonBlock fd + in + DynamicWind.wind + (f, fn () => MinGW.clearNonBlock fd) + end +in + val withNonBlock = fn x => + case OS.host of + OS.MinGW => withNonBlockMinGW x + | _ => withNonBlockNormal x +end + +fun connect (s, SA sa) = + Syscall.simple (fn () => Prim.connect (Sock.toRep s, sa, C_Socklen.fromInt (Vector.length sa))) + +fun connectNB (s, SA sa) = + nonBlock' + ({restart = false}, C_Int.fromInt ~1, fn () => + withNonBlock (s, fn () => Prim.connect (Sock.toRep s, sa, C_Socklen.fromInt (Vector.length sa))), + fn _ => true, + Error.inprogress, false) + +fun accept s = + let + val (sa, salen, finish) = newSockAddr () + val s = Syscall.simpleResultRestart (fn () => Prim.accept (Sock.toRep s, sa, salen)) + in + (Sock.fromRep s, finish ()) + end + +fun acceptNB s = + let + val (sa, salen, finish) = newSockAddr () + in + nonBlock + (C_Int.fromInt ~1, + fn () => withNonBlock (s, fn () => Prim.accept (Sock.toRep s, sa, salen)), + fn s => SOME (Sock.fromRep s, finish ()), + NONE) + end + +fun close s = Syscall.simple (fn () => Prim.close (Sock.toRep s)) + +datatype shutdown_mode = NO_RECVS | NO_SENDS | NO_RECVS_OR_SENDS + +fun shutdownModeToHow m = + case m of + NO_RECVS => Prim.SHUT_RD + | NO_SENDS => Prim.SHUT_WR + | NO_RECVS_OR_SENDS => Prim.SHUT_RDWR + +fun shutdown (s, m) = + let val m = shutdownModeToHow m + in Syscall.simple (fn () => Prim.shutdown (Sock.toRep s, m)) + end + +type sock_desc = FileSys.file_desc + +fun sockDesc sock = sockToFD sock + +fun sameDesc (desc1, desc2) = desc1 = desc2 + +fun select {rds: sock_desc list, + wrs: sock_desc list, + exs: sock_desc list, + timeout: Time.time option} = + let + local + fun mk l = + let + val vec = Vector.fromList l + val arr = Array.array (Vector.length vec, 0: C_Int.t) + in + (PrePosix.FileDesc.vectorToRep vec, arr) + end + in + val (read_vec, read_arr) = mk rds + val (write_vec, write_arr) = mk wrs + val (except_vec, except_arr) = mk exs + end + val setTimeout = + case timeout of + NONE => Prim.setTimeoutNull + | SOME t => + if Time.< (t, Time.zeroTime) + then Error.raiseSys Error.inval + else let + val q = LargeInt.quot (Time.toMicroseconds t, 1000000) + val q = C_Time.fromLargeInt q + val r = LargeInt.rem (Time.toMicroseconds t, 1000000) + val r = C_SUSeconds.fromLargeInt r + in + fn () => Prim.setTimeout (q, r) + end handle Overflow => Error.raiseSys Error.inval + val res = + Syscall.simpleResult + (fn () => + (setTimeout () + ; Prim.select (read_vec, write_vec, except_vec, + read_arr, write_arr, except_arr))) + val (rds, wrs, exs) = + if res = 0 + then ([],[],[]) + else + let + fun mk (l, arr) = + (List.rev o #1) + (List.foldl (fn (sd, (l, i)) => + (if Array.sub (arr, i) <> (0: C_Int.t) then sd::l else l, i + 1)) + ([], 0) + l) + in + (mk (rds, read_arr), + mk (wrs, write_arr), + mk (exs, except_arr)) + end + in + {rds = rds, + wrs = wrs, + exs = exs} + end + +val ioDesc = FileSys.fdToIOD o sockDesc + +type out_flags = {don't_route: bool, oob: bool} + +val no_out_flags = {don't_route = false, oob = false} + +fun mk_out_flags {don't_route, oob} = + C_Int.orb (if don't_route then Prim.MSG_DONTROUTE else 0x0, + C_Int.orb (if oob then Prim.MSG_OOB else 0x0, + 0x0)) + +local + fun make (toPoly, base, primSend, primSendTo) = + let + val base = fn sl => let val (buf, i, sz) = base sl + in (toPoly buf, i, sz) + end + fun send' (s, sl, out_flags) = + let + val (buf, i, sz) = base sl + in + (C_SSize.toInt o Syscall.simpleResultRestart') + ({errVal = C_SSize.castFromFixedInt ~1}, fn () => + primSend (Sock.toRep s, buf, C_Int.fromInt i, C_Size.fromInt sz, + mk_out_flags out_flags)) + end + fun send (sock, buf) = send' (sock, buf, no_out_flags) + fun sendNB' (s, sl, out_flags) = + let + val (buf, i, sz) = base sl + in + nonBlock + (C_SSize.castFromFixedInt ~1, + fn () => + primSend (Sock.toRep s, buf, C_Int.fromInt i, C_Size.fromInt sz, + C_Int.orb (Prim.MSG_DONTWAIT, mk_out_flags out_flags)), + SOME o C_SSize.toInt, + NONE) + end + fun sendNB (sock, sl) = sendNB' (sock, sl, no_out_flags) + fun sendTo' (s, SA sa, sl, out_flags) = + let + val (buf, i, sz) = base sl + in + Syscall.simpleRestart' + ({errVal = C_SSize.castFromFixedInt ~1}, fn () => + primSendTo (Sock.toRep s, buf, C_Int.fromInt i, C_Size.fromInt sz, + mk_out_flags out_flags, + sa, C_Socklen.fromInt (Vector.length sa))) + end + fun sendTo (sock, sock_addr, sl) = + sendTo' (sock, sock_addr, sl, no_out_flags) + fun sendToNB' (s, SA sa, sl, out_flags) = + let + val (buf, i, sz) = base sl + in + nonBlock + (C_SSize.castFromFixedInt ~1, + fn () => + primSendTo (Sock.toRep s, buf, C_Int.fromInt i, C_Size.fromInt sz, + C_Int.orb (Prim.MSG_DONTWAIT, mk_out_flags out_flags), + sa, C_Socklen.fromInt (Vector.length sa)), + fn _ => true, + false) + end + fun sendToNB (sock, sa, sl) = + sendToNB' (sock, sa, sl, no_out_flags) + in + (send, send', sendNB, sendNB', sendTo, sendTo', sendToNB, sendToNB') + end +in + val (sendArr, sendArr', sendArrNB, sendArrNB', + sendArrTo, sendArrTo', sendArrToNB, sendArrToNB') = + make (Word8Array.toPoly, Word8ArraySlice.base, Prim.sendArr, Prim.sendArrTo) + val (sendVec, sendVec', sendVecNB, sendVecNB', + sendVecTo, sendVecTo', sendVecToNB, sendVecToNB') = + make (Word8Vector.toPoly, Word8VectorSlice.base, Prim.sendVec, Prim.sendVecTo) +end + +type in_flags = {peek: bool, oob: bool} + +val no_in_flags = {peek = false, oob = false} + +fun mk_in_flags {peek, oob} = + C_Int.orb (if peek then Prim.MSG_PEEK else 0x0, + C_Int.orb (if oob then Prim.MSG_OOB else 0x0, + 0x0)) + +fun recvArr' (s, sl, in_flags) = + let + val (buf, i, sz) = Word8ArraySlice.base sl + in + (C_SSize.toInt o Syscall.simpleResultRestart') + ({errVal = C_SSize.castFromFixedInt ~1}, fn () => + Prim.recv (Sock.toRep s, Word8Array.toPoly buf, C_Int.fromInt i, C_Size.fromInt sz, + mk_in_flags in_flags)) + end + +fun getVec (a, n, bytesRead) = + if n = bytesRead + then Word8Vector.unsafeFromArray a + else Word8ArraySlice.vector (Word8ArraySlice.slice (a, 0, SOME bytesRead)) + +fun recvVec' (sock, n, in_flags) = + let + val a = Word8Array.alloc n + val bytesRead = + recvArr' (sock, Word8ArraySlice.full a, in_flags) + in + getVec (a, n, bytesRead) + end + +fun recvArr (sock, sl) = recvArr' (sock, sl, no_in_flags) + +fun recvVec (sock, n) = recvVec' (sock, n, no_in_flags) + +fun recvArrFrom' (s, sl, in_flags) = + let + val (buf, i, sz) = Word8ArraySlice.base sl + val (sa, salen, finish) = newSockAddr () + val n = + (C_SSize.toInt o Syscall.simpleResultRestart') + ({errVal = C_SSize.castFromFixedInt ~1}, fn () => + Prim.recvFrom (Sock.toRep s, Word8Array.toPoly buf, C_Int.fromInt i, C_Size.fromInt sz, + mk_in_flags in_flags, + sa, salen)) + in + (n, finish ()) + end + +fun recvVecFrom' (sock, n, in_flags) = + let + val a = Word8Array.alloc n + val (bytesRead, sock_addr) = + recvArrFrom' (sock, Word8ArraySlice.full a, in_flags) + in + (getVec (a, n, bytesRead), sock_addr) + end + +fun recvArrFrom (sock, sl) = recvArrFrom' (sock, sl, no_in_flags) + +fun recvVecFrom (sock, n) = recvVecFrom' (sock, n, no_in_flags) + +fun mk_in_flagsNB in_flags = C_Int.orb (mk_in_flags in_flags, Prim.MSG_DONTWAIT) + +fun recvArrNB' (s, sl, in_flags) = + let + val (buf, i, sz) = Word8ArraySlice.base sl + in + nonBlock + (C_SSize.castFromFixedInt ~1, + fn () => Prim.recv (Sock.toRep s, Word8Array.toPoly buf, C_Int.fromInt i, C_Size.fromInt sz, + mk_in_flagsNB in_flags), + SOME o C_SSize.toInt, + NONE) + end + +fun recvVecNB' (s, n, in_flags) = + let + val a = Word8Array.alloc n + in + nonBlock + (C_SSize.castFromFixedInt ~1, + fn () => Prim.recv (Sock.toRep s, Word8Array.toPoly a, 0, C_Size.fromInt n, + mk_in_flagsNB in_flags), + fn bytesRead => SOME (getVec (a, n, C_SSize.toInt bytesRead)), + NONE) + end + +fun recvArrNB (sock, sl) = recvArrNB' (sock, sl, no_in_flags) + +fun recvVecNB (sock, n) = recvVecNB' (sock, n, no_in_flags) + +fun recvArrFromNB' (s, sl, in_flags) = + let + val (buf, i, sz) = Word8ArraySlice.base sl + val (sa, salen, finish) = newSockAddr () + in + nonBlock + (C_SSize.castFromFixedInt ~1, + fn () => Prim.recvFrom (Sock.toRep s, Word8Array.toPoly buf, C_Int.fromInt i, C_Size.fromInt sz, + mk_in_flagsNB in_flags, sa, salen), + fn n => SOME (C_SSize.toInt n, finish ()), + NONE) + end + +fun recvVecFromNB' (s, n, in_flags) = + let + val a = Word8Array.alloc n + val (sa, salen, finish) = newSockAddr () + in + nonBlock + (C_SSize.castFromFixedInt ~1, + fn () => Prim.recvFrom (Sock.toRep s, Word8Array.toPoly a, 0, C_Size.fromInt n, + mk_in_flagsNB in_flags, sa, salen), + fn bytesRead => SOME (getVec (a, n, C_SSize.toInt bytesRead), finish ()), + NONE) + end + +fun recvArrFromNB (sock, sl) = recvArrFromNB' (sock, sl, no_in_flags) + +fun recvVecFromNB (sock, n) = recvVecFromNB' (sock, n, no_in_flags) + +(* Phantom type. *) +type ('af, 'sock_type) sock = sock + +type 'af sock_addr = sock_addr + +type 'mode stream = stream + +end diff --git a/basis-library/net/unix-sock.sig b/basis-library/net/unix-sock.sig new file mode 100644 index 0000000..a82864d --- /dev/null +++ b/basis-library/net/unix-sock.sig @@ -0,0 +1,21 @@ +signature UNIX_SOCK = + sig + type unix + type 'sock_type sock = (unix, 'sock_type) Socket.sock + type 'mode stream_sock = 'mode Socket.stream sock + type dgram_sock = Socket.dgram sock + type sock_addr = unix Socket.sock_addr + val unixAF: Socket.AF.addr_family + val toAddr: string -> sock_addr + val fromAddr: sock_addr -> string + structure Strm : + sig + val socket: unit -> 'mode stream_sock + val socketPair: unit -> 'mode stream_sock * 'mode stream_sock + end + structure DGrm : + sig + val socket: unit -> dgram_sock + val socketPair: unit -> dgram_sock * dgram_sock + end + end diff --git a/basis-library/net/unix-sock.sml b/basis-library/net/unix-sock.sml new file mode 100644 index 0000000..e964010 --- /dev/null +++ b/basis-library/net/unix-sock.sml @@ -0,0 +1,49 @@ +(* Copyright (C) 2002-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure UnixSock : UNIX_SOCK = + struct + structure Prim = PrimitiveFFI.Socket.UnixSock + + datatype unix = UNIX + type 'sock_type sock = (unix, 'sock_type) Socket.sock + type 'mode stream_sock = 'mode Socket.stream sock + type dgram_sock = Socket.dgram sock + type sock_addr = unix Socket.sock_addr + val unixAF = Net.AddrFamily.fromRep PrimitiveFFI.Socket.AF.UNIX + + fun toAddr s = + let + val (sa, salen, finish) = Socket.newSockAddr () + val _ = Prim.toAddr (NullString.nullTerm s, + C_Size.fromInt (String.size s), + sa, salen) + in + finish () + end + + fun fromAddr sa = + let + val sa = Socket.unpackSockAddr sa + val len = Prim.pathLen sa + val a = CharArray.array (C_Size.toInt len, #"\000") + val _ = Prim.fromAddr (sa, CharArray.toPoly a, len) + in + CharArraySlice.vector (CharArraySlice.slice (a, 0, SOME (C_Size.toInt len))) + end + + structure Strm = + struct + fun socket () = GenericSock.socket (unixAF, Socket.SOCK.stream) + fun socketPair () = GenericSock.socketPair (unixAF, Socket.SOCK.stream) + end + structure DGrm = + struct + fun socket () = GenericSock.socket (unixAF, Socket.SOCK.dgram) + fun socketPair () = GenericSock.socketPair (unixAF, Socket.SOCK.dgram) + end + end diff --git a/basis-library/notes.txt b/basis-library/notes.txt new file mode 100644 index 0000000..61513ac --- /dev/null +++ b/basis-library/notes.txt @@ -0,0 +1,1360 @@ + +Date: Tue, 23 Jul 2002 11:49:57 -0400 (EDT) +From: Matthew Fluet + + +John and SML implementers, + +Here are a loose collection of notes I've taken while starting to +update the MLton implementation of the SML Basis Library to the latest +version. They span quite a range: errata and typos, signature +constraint concerns, and some design questions. Thus far, I've looked +at the structures that had been grouped under the headings General, +Text, Integer, Reals, Lists, and Arrays and Vectors (i.e., excluding +IO, System, and Posix) in the "old" web specification. + +A few high level comments: + +* As an organizational principal, I liked the grouping of modules into + larger collections used in the "old" web specification better than + the long alphabetical list. +* I'm quite happy to see opaque signature matches for most structures. + In particular, I think it will help avoid porting problems between + implementations that provide different INTEGER structures, especially + when LargeInt = Int in one implementation and LargeInt = IntInf in + another. + +Required and optional components, Top-level: + +* A number of structures have an opaque signature match in + overview.html, but not in the corresponding structure specific page: + General, Bool, Option, List, ListPair, IntInf, + Array, ArraySlice, Vector, VectorSlice. +* Word8Array2 is listed as required in overview.html, + but its signature, MONO_ARRAY2, is not required. + Furthermore, Word8Array2 is marked optional in mono-array2.html. + I don't quite see a rationale for Word8Array2 being required. +* With the addition of val ~ : word -> word to the WORD signature, + presumably ~ should be overloaded at num, rather than at intreal. + +Reals: + +* In pack-float.html, the where type clauses are incorrect: + structure PackRealBig :> PACK_REAL + where type PackRealBig.real = Real.real + should be + structure PackRealBig :> PACK_REAL + where type real = Real.real +* Likewise, in most places, references to basic types are unqualifed, + so perhaps the where clause should read + where type real = real + for the PackRealBig and PackRealLittle structures. + +Arrays and Vectors: + +* In vector-slice.html, the description of subslice references |arr| + when it should reference |sl|. +* In {[mono-]array[-slice],[mono-]vector[-slice]}.html, the + description of findi references appi when it should reference findi. +* In mono-array-slice.html, structure CharArraySlice has the clause + where type array = CharVector.vector + which should be + where type array = CharArray.array. +* In mono-{vector[-slice],array[-slice],array2}.html, there are + Word structures but no (default word) Word structures. +* In mono-vector.html, structure CharVector has the clause + where type elem = Char.char + while the other monomorphic vectors of basic types reference + the unqualified type; i.e. structure BoolVector has the clause + where type elem = bool. +* There are no "See also"'s into MONO_VECTOR_SLICE or MONO_ARRAY_SLICE + from MONO_VECTOR or MONO_ARRAY. +* A long discussion about types defined in + [MONO_]{ARRAY,VECTOR}[_SLICE] signatures; deferred to a separate + email. + +Really nit-picky: + +* Ordering of comparison functions (>, >=, etc.) and unary negation + are different within INTEGER and WORD. +* Ordering of functions in CHAR seems awkward. +* Ordering of full, slice, subslice different in ARRAY_SLICE and + VECTOR_SLICE. +* Ordering of foldi/fold and modifi/modify different in ARRAY2 and + MONO_ARRAY2. + +Top-level and opaque signatures: +* I think it would be useful to see the entire top-level of required + structures written out with their respective signature constraints. + For example, in the description of the Math structure, the spec + reads: "The top-level structure Math provides these functions for + the default real type Real.real." Because the top-level Math + structure has an opaque signature match (in overview.html), then the + sentence above implies that there ought to be the constraint + where type real = real (or Real.real). + Granted, none of the other structures in overview.html have where + clauses, and most type constraints are documented in the structure + specific pages, but the constraint on the top-level Math.real + slipped my mind when I first looked at it. + +-Matthew + +****************************************************************************** +****************************************************************************** + +Date: Tue, 23 Jul 2002 11:54:09 -0400 (EDT) +From: Matthew Fluet + + +As promised, here is a longish look at the types used in Arrays and +Vectors. + +Array and Vector design: + +* The ARRAY signature includes type 'a vector. + Presumably, type 'a Array.vector = type 'a Vector.vector, but no + constraint makes this explicit. +* MONO_ARRAY_SLICE includes type vector and type vector_slice, + while the ARRAY_SLICE signature explicitly references + 'a VectorSlice.slice and 'a Vector.vector. +* VECTOR_SLICE doesn't include 'a vector, but has + val mapi : (int * 'a -> 'b) -> 'a slice -> 'b vector + val map : ('a -> 'b) -> 'a slice -> 'b vector; + On the other hand, full, slice, base, vector, and concat + reference 'a Vector.vector. + +For consistency, I'd prefer to see +signature VECTOR = + sig type 'a vector ... end +signature VECTOR_SLICE = + sig type 'a vector type 'a slice ... end +signature ARRAY = + sig type 'a vector type 'a array ... end +signature ARRAY_SLICE = + sig type 'a vector type 'a vector_slice + tyep 'a array type 'a slice ... end +signature MONO_VECTOR = + sig type elem type vector ... end +signature MONO_VECTOR_SLICE = + sig type elem type vector type slice ... end +signature MONO_ARRAY = + sig type elem type vector type array ... end +signature MONO_ARRAY_SLICE = + sig type elem type vector type vector_slice + type array type slice ... end + +structure Vector :> VECTOR +structure VectorSlice :> VECTOR_SLICE + where type 'a vector = 'a Vector.vector +structure Array :> ARRAY + where type 'a vector = 'a Vector.vector +structure ArraySlice :> ARRAY_SLICE + where type 'a vector = 'a Vector + where type 'a vector_slice = 'a VectorSlice.slice + where type 'a array = 'a Array.array +structure BoolVector :> MONO_VECTOR + where type elem = bool +structure BoolVectorSlice :> MONO_VECTOR_SLICE + where type elem = bool + where type vector = BoolVector.vector +structure BoolArray :> MONO_ARRAY + where type elem = bool + where type vector = BoolVector.vector +structure BoolArraySlice :> MONO_ARRAY_SLICE + where type elem = bool + where type vector = BoolVector.vector + where type vector_slice = BoolVectorSlice.slice + where type array = BoolArray.array + +While semantically, this shouldn't be any different than the +specification, it could effect type-error messages. For example, if I +have the structure Foo: + +structure Foo = struct + open BoolArraySlice + + val copyVec0 {src: vector_slice, + dst: array} = copyVec {src = src, dst = dst, di = 0} +end + +which I decide to generalize to polymorphic array slices, then just +changing BoolArraySlice to ArraySlice will lead to different +type-error messages: either "ubound type constructor: vector_slice" +(under the specification) or "type constructor vector_slice given 0 +arguments, wants 1" (under the signatures given above); and an arity +error for array in either case. It's not much of an argument, but I +need to replace vector_slice with 'a VectorSlice.slice under the +specification, while I only need to add 'a under the sigs above. + + +Array2: +* Why not have an ARRAY2_REGION analagous to ARRAY_SLICE? + Likewise, how about VECTOR2 and VECTOR2_REGION? + I think the decision to separate Arrays and Vectors from + their corresponding slices is a nice design choice, and I'd be in + favor of extending it to multi-dimentional ones. +* Should ARRAY2 have findi/find, exists, all? collate? + +****************************************************************************** +****************************************************************************** + +Date: Thu, 25 Jul 2002 15:20:01 +0200 +From: Andreas Rossberg + + +Like Matthew I started implementing the latest version of the Basis spec +for Alice and Hamlet. I'm quite happy with most of the changes. It was a +surprise to discover the presence of a Windows structure, though :-) + +Here is my list of comments, some of which may duplicate observations +already made by Matthew. They primarily cover global issues and the +required part of the library, though I haven't looked deeper into the IO +and Posix parts yet. I also included some proposals for modest additions +to the library, which I believe are useful and fit its spirit. + + +Trivial bugs, typos, cosmetics +------------------------------ + +* Overview: + - INT_INF appears in the list of required signatures. + - WordArray2 appears under the list of required structures, + instead of optional ones. + +* LIST_PAIR: + - Typo in description of allEq: double "the". + +* SUBSTRING: + - The scan example uses the deprecated "all" function. + +* VECTOR_SLICE: + - Typo in synopsis of subslice: s/opt/sz/. + - Typo in description of subslice: s/|arr|/|sl|/. + - Typo in description of findi: s/appi/findi/. + - Signature sometimes uses Vector.vector instead of plain vector. + - The equation for mapi can be simplified to: + Vector.fromList (foldri (fn (i,a,l) => f(i,a)::l) [] slice) + +* MONO_VECTOR_SLICE and ARRAY_SLICE and MONO_ARRAY_SLICE: + - Typo in synopsis of subslice: s/opt/sz/. + - Typo in description of findi: s/appi/findi/. + +* BYTE: + - Accidental "val" keyword in synopsis of some functions. + +* TEXT_IO: + - The "where" constraints contain erroneously qualified ids. + - The specification of the TEXT_IO signature is not valid SML'97, + since StreamIO is specified twice. You might want to add a + comment regarding that. + - The constraints for types vector and elem are redundant + (in fact, invalid), because the signature TEXT_STREAM_IO + already specifies the necessary equations. + +* The use of variable names is sometimes inconsistent: + - Predicate arguments to higher-order functions are usually + named "f" (eg. List.all), sometimes "p" (eg. String.tokens, + StringCvt.splitl), and sometimes even "pred" (eg. ListPair.all). + - Similarly, fold functions mostly use "init" to name initial + accumulators, except in the List and ListPair modules. + + + +Ambiguities / Unclear Details +----------------------------- + +* Overview: + - The subsection about dependencies among optional modules has + disappeared. Does that mean that there aren't any anymore? + (The nice subsection about design rules and conventions also + has gone.) + +* The intended meaning of opaque signature constraints is not always + clear to me. Sometimes the prose contains remarks about additional + equalities that are not appearent from the signature constraints. + For example, is or isn't + - Text.Char.char = Char.char ? (and so on for the rest of Text) + - LargeInt.int = IntN.int (for some structure IntN) ? + (likewise LargeWord.word, LargeReal.real) + - Char.string = String.string ? + - Math.real = Real.real ? + In particular, the spec sometimes speaks of "equal structures", + which has no real technical meaning in SML'97. + Note that from the opaque matching on the overview page one might + even conclude that General.unit <> {} ! + +* The type specification of String.string and CharVector.vector + is circular: + structure String :> STRING + where type string = CharVector.vector + structure CharVector :> MONO_VECTOR + where type vector = String.string + Likewise for Substring.substring and CharVectorSlice.slice. + A respective defining structure should be chosen. + +* STRING: + - Function fromString has a special case that is not covered by + implementing the function through straight-forward iterative + application of the Char.scan function, namely a trailing gap + escape (\f...f\) as in "foo\\ \\" or "foo\\ \\\000" (where \000 + is an non-convertible character). Several implementations I + tried get that detail wrong, so a corresponding note might be + in order. Moreover, it is not completely obvious from the + description what the result should be for strings that contain + a gap escape as the only convertible sequence, e.g. "\\ \\" or + "\\ \\\000" - it is supposed to be SOME "", I guess. + +* SUBSTRING: + - Shouldn't span raise Span if i' < i? Otherwise, contrary + to the prose, it in fact accepts arguments where ss' is + left to ss, as long as they overlap (which is rather odd). + - For the curried triml/trimr it is not clear whether an + Subscript exception has to be raised already if k < 0 but no + second argument is applied. + + + +Naming and structuring +---------------------- + +Its nicely chosen regular naming conventions and structure are two of +the aspects I like most about the Standard Basis. The following list +enumerates the few cases where I feel that the spec violates its own +conventions. + +* WORD: + - The fromLargeWord and toLargeWord functions should drop + the "Word" suffix to be consistent with the corresponding + functions in the REAL and INTEGER signatures. + +* CHAR: + - The functions contains/notContains should be moved to the + STRING signature, as they are similar to find/exist + operations and thus functionality of the aggregate. The + type string could then be removed from the signature. + +* ARRAY_SLICE and MONO_ARRAY_SLICE: + - The function copyVec seems completely out of place: it does + neither operate on array slices, nor on vectors. But honestly + I have got no idea where else to put it :-( + +* STRING and SUBSTRING: + - There is a certain asymmetry between slices and substrings + which tends to confuse at least myself when hacking. For more + consistency I propose: + (1) changing the type of Substring.substring to + string * int * int option -> substring + (for consistency with VectorSlice.slice), + (2) renaming Substring.slice to Substring.subsubstring, + (for consistency with VectorSlice.subslice), + (3) removing Substring.{app,foldl,foldr} (there are no similar + functions in the STRING signature, and in both cases they + are available through CharVector/CharVectorSlice), + (4) removing String.extract and Substring.extract (the same + functionality is available through CharVector[Slice]). + - I believe the deprecated Substring.all can be removed for good. + After all, there are more serious incompatible changes being + made (e.g. array copying functions). + +* Vectors and arrays: + - While the lib consistently uses the to/from convention for + conversions on basic types, it sometimes uses adhoc conventions + for aggregates. I propose renaming: + (1) Array.vector to Array.toVector + (2) VectorSlice.vector to VectorSlice.toVector, + (3) ArraySlice.vector to ArraySlice.toVector, + (4) Substring.string to Substring.toString, + - Since the copy functions have only 3, mostly distinctly typed + arguments now, there no longer seems to be a strong reason to + require passing those by notationally heavy records. + +* INT_INF: + - The presence of bit fiddling operators in that signature is + something that feels exceptionally ad-hoc. Either they should + be available for all integer types, or there should be a + separate WORD_INF, with appropriate conversions, that makes + these available. + +* Toplevel: + - Now that there is Word.~ (which is good) it seems rather odd + that the toplevel ~ is not overloaded for words, i.e. does not + have type num-> num. + +* Net functionality: + - I really like the idea of structuring the library namespace as + it has been done with the OS and Posix structures. I would + prefer to see something similar being done for the added + network functionality. More precisely, I propose + (1) moving the structures Socket, INetSock, GenericSock, and + the three Net*DB structures into a new wrapper structure + Net (renaming Net*DB to *DB), + (2) defining a corresponding signature NET, + (3) renaming the signatures SOCKET, GENERIC_SOCK and INET_SOCK + to NET_SOCKET, NET_GENERIC_SOCK and NET_INET_SOCK, resp., + (4) moving UnixSock to the Unix structure (renamed as Socket). + + + +Misc. proposals for additional functionality +-------------------------------------------- + +Here is a small collection of miscellaneous simple functions which I +believe the library is still lacking, either because they are commonly +useful or because they would make the library more regular. + +* LIST and LIST_PAIR: + - The IMHO single most convenient extension to the library would + be indexed morphisms on lists, i.e. adding + val appi : (int * 'a -> unit) -> 'a list -> unit + val mapi : (int * 'a -> 'b) -> 'a list -> 'b list + val foldli : (int * 'a * 'b -> 'b) -> 'b -> 'a list -> 'b + val foldri : (int * 'a * 'b -> 'b) -> 'b -> 'a list -> 'b + val findi : (int * 'a -> bool) -> 'a list -> (int * 'a) option + - Likewise for LIST_PAIR. + - LIST_PAIR does not support partial mapping: + val mapPartial : ('a * 'b -> 'c option) -> + 'a list * 'b list -> 'c list + +* LIST, VECTOR, ARRAY, etc.: + - Another function on lists that would be very useful from my + perspective is + val appr : ('a -> unit) -> 'a list -> unit + and its indexed sibling + val appri : (int * 'a -> unit) -> 'a list -> unit + which traverse the list from right to left. + - Likewise for all aggregate types. + - All aggregates come with a fromList function. I often feel the + need to have inverse toList functions. Use of foldr is obfuscating. + +* OPTION: + - Often using isSome is a bit clumsy. I thus propose adding the dual + val isNone : 'a option -> bool + +* STRING and SUBSTRING: + - For historical reasons we have {String,Substring}.size instead + of *.length, which is inconsistent with all other aggregates and + frequently lets me mix them up when I use them side by side. + I propose adding aliases + String.maxLen + String.length + Substring.length + +* WideChar and WideString: + - There is no convenient way to convert between the standard and + wide character set. Would it be reasonable to introduce LargeChar + and LargeString structures (and so on) and have the CHAR and + STRING signatures enriched by fromLarge/toLarge functions, as for + numbers? That would also allow a program to select the widest + character set available (which is currently impossible within the + language). + +* String conversion: + - I don't quite see the rationale for which signatures contain a + scan function and which don't. I believe it makes sense to have + scan in every signature that has fromString. + - There should be a function + val scanC : (Char.char, 'a) StringCvt.reader + -> (char, 'a) StringCvt.reader + to scan strings as C characters. This would make Char.fromCString + and particularly String.fromCString more modular. + - How about a dual writer abstraction as with + type ('a,'b) writer = 'a * 'b -> 'b option + and supporting fmt functions for basic types? Such a thing might + be useful for writing to streams or buffers. + +* Vectors: + For some time now I have been trying to use vectors more often + instead of an often inappropriate list representation. This is + sometimes made more difficult simply because the library support + isn't as good as for lists. It improved in the updated version + but still I miss: + - Array.fromVector, + - Vector.mapPartial, + - Vector.rev, + - Vector.append (though I guess concat is good enough), + - most of all: a VectorPair structure. + +* Hash functions: + - Giving every basic type a (default) hash function in addition to + comparison would be quite useful in conjunction with container + libraries. + +* There is no defining structure for references. I would like to see + signature REF + structure Ref : REF + where REF contains: + datatype ref = datatype ref + val ! : 'a ref -> 'a + val := : 'a ref * 'a -> unit + val swap : 'a ref * 'a ref -> unit (* or :=: ? *) + val map : ('a -> 'a) -> 'a ref -> 'a ref + You might then consider removing ! and := from GENERAL. + +* Signature conventions: + Some additional conventions would make use of Basis types as + functor arguments more convenient: + - Each signature defining an abstract type should make that + type available under the alias "t" as well (this includes + monomorphic types as well as polymorphic ones). + - Every equality type should come with an explicit equality + function + val eq : t * t -> bool + to move away from the reliance on eqtypes. + - There should be a uniform name for canonical constructor + functions, e.g. "new" (or at least an alias). + +-- +Andreas Rossberg, rossberg@ps.uni-sb.de + +****************************************************************************** +****************************************************************************** + +Date: Fri, 2 Aug 2002 14:04:16 +0100 +From: David Matthews + + +I've been having another look at the Basis library implementation in +Poly/ML and in particular the I/O library. I'm still not sure I fully +understand the implications of the Stream IO (functional IO) layer and +in particular the way "canInput" works and interacts with "input". + +The definition says that canInput(f, n) returns SOME k "if a call to +input would return immediately with at least k characters". +Specifically it does not say "if a call to inputN(f, k) would return +immediately". Secondly it says that it "should attempt to return as +large a k as possible" and gives the example of a buffer containing 10 +characters with the user calling canInput(f, 15). This suggests that a +call to canInput could have the effect of committing the stream since a +perfectly good implementation of "input" would be to return what was +left of the buffer, i.e. 10 characters, and only read from the +underlying stream on a subsequent call to "input". Yet after a call to +canInput(f, 15) which returns SOME 15 the call to "input" is forced to +return at least 15. In other words a call to canInput changes the +behaviour of a subsequent call to "input". Generally, what is the +behaviour of canInput with an argument larger than the buffer size? How +far ahead is canInput expected to read? + +A few other notes of things I've discovered, some of which are trivial: + +The signature for TextIO.StreamIO contains duplicates of + where type StreamIO.reader = TextPrimIO.reader + where type StreamIO.writer = TextPrimIO.writer + +There are declared constants for platformWin32Windows2000 and +platformWin32WindowsXP in the Windows structure. When I proposed the +Windows.Config structure I didn't include constants for these versions +of the OS because the underlying GetVersionEx function returns the same +value, VER_PLATFORM_WIN32_NT in the dwPlatformId field for NT, Windows +2000 and XP It is possible to distinguish these but only using the +major and minor version fields. Windows CE does give a different value +for the platformID. I would say it is confusing to have these here +because it implies that it's possible to discriminate on the basis of +the platformID field. + +The example definition of input1 at the bottom of STREAM_IO returns a +value of type elem option * instream when the signature says it should +be (elem * instream) option. + +Description of "input" function in STREAM_IO signature. The word "ay" +should be "may". + +-- +David. + +****************************************************************************** +****************************************************************************** + +Date: Fri, 11 Oct 2002 17:46:59 -0400 (EDT) +From: Matthew Fluet + + +Following up my previous post, here is another loose collection of +notes I've taken while updating the MLton implementation of the SML +Basis Library. This includes the structures that had been grouped +under the headings System, Posix, and IO in the "old" web +specification. + +Required and optional components: +* The optional functors PrimIO, StreamIO, and ImperativeIO are not + listed among the optional components in overview.html. + +Lists: +* The discussion for the ListPair structure says: + "Note that a function requiring equal length arguments may determine + this lazily, i.e. , it may act as though the lists have equal length + and invoke the user-supplied function argument, but raise the + exception when it arrives at the end of one list before the end of the + other." + Such an implementation choice seems to go against the spirit that + programs run under conforming implementations of the Basis Library + should behave the same. + +Posix: +* In posix.html, last sentence in Discussion: "onsult" instead of + "consult" +PosixSignal: +* In posix-signal.html, in Discussion: "The name of the coressponding + ..." sentence is repeated. +PosixError: +* In the discussion of POSIX_ERROR: + "The name of a corresponding POSIX error can be derived by + capitalizing all letters and adding the character ``E'' as a + prefix. For example, the POSIX error associated with nodev is + ENODEV. The only exception to this rule is the error toobig, whose + associated POSIX error is E2BIG." + It isn't clear if this is the intended semantics for errorName and + syserror. + +Time: +* The type time now includes "negative values moving to the past." + In the absence of negative values, the text for the the + to{Seconds,Milliseconds,Microseconds} functions to drop fractions of + the time unit was unambigous. With negative values, I would + interpret this as rounding towards zero. Is this correct? Would it + be clearer to describe the rounding as such? +* The + and - functions are required to raise Overflow, although most + other "result not representable as a time value" error raises Time. +* The - function is written prefix instead of infix in the + description. +* The scan and fromString functions do not specify how to treat a + value with greater precision than the internal representation; + should it have rounding or truncation semantics? Also, the + functions are required to raise Overflow for an unrepresentable + time value. + +IO: +* The nice introduction to IO that appears at + http://cm.bell-labs.com/cm/cs/what/smlnj/doc/basis/pages/io-explain.html + doesn't seem to be included with the new pages. +* The functor arguments in PrimIO, StreamIO, and ImperativIO functors + don't match; some use structure A: MONO_ARRAY and others use + structure Array: MONO_ARRAY. + +PrimIO() and PRIM_IO +* The PRIM_IO signature requires pos to be an eqtype, but the PrimIO + functor argument only requires pos to be a type. +* readArr[NB], write{Vec,Arr}[NB] take "slices" (records of type {buf: + {vector,array}, i: int, sz: int option}) but no description of the + appropriate action to take when the slices are invalid. Presumably, + they should raise Subscript. +* There are a number of "contradictory" statments: + "Readers and writers should not, in general, raise the IO.Io + exception. It is assumed that the higher levels will appropriately + handle these exceptions." + "A reader is required to raise IO.Io if any of its functions, except + close or getPos, is invoked after a call to close. A writer is + required to raise IO.Io if any of its functions, except close, is + invoked after a call to close." + "closes the reader and frees operating system resources. Further + operations on the reader (besides close and getPos) raise + IO.ClosedStream." + "closes the writer and frees operating system resources. Further + operations (other than close) raise IO.ClosedStream." +* The augment_reader and augment_writer functions may introduce new + functions. Should the synthesized operations handle IO.Io + exceptions and change the function field? Maybe this falls under + the "intentionally unspecified" clause. + +StreamIO() and STREAM_IO: +* What is the difference between a terminated output stream and a + closed output stream? Some operations say what to do when the + stream is terminated or closed, but many are unspecified when the + other condition holds. I resolved this by looking at the IO + introduction mentioned above, where it discusses stream states. + But, closeOut is still confusing: "flushes f's buffers, marks the + stream closed, and closes the underlying writer. This operation has + no effect if f is already closed. If f is terminated, it should + close the underlying writer." Shouldn't closeOut always execute the + underlying writer's close function? The only way to terminate an + outstream is to getOutstream, but I would really expect + TextIO.closeOut to "really" close the underlying + file/outstream/writer. +* The IO structure has dropped the TerminatedStream exception, but + there seem to be sufficient cases when a stream should raise an + exception when it is terminated. +* The semantics of the vector returned by getReader are unclear. At + the very least, the source code for SML/NJ and PolyML have very + different interpretations, and I've chosen yet another. I think + part of the problem is that the word "[un]consumed" only appears in + the description of this function, so it's unclear what corresponds + to consumed input. +* I suspect the example under endOfStream is wrong: + + In these cases the StreamIO.instream will also have multiple EOF's; + that is, it can be that + + val true = endOfStream(f) + val ("",f') = input f + val true = endOfStream(f') + val ("xyz",f'') = input f + + The fact that input f can return two different values would seem to + violate the principal argument for functional streams! Looking at + the aforementioned IO introduction in the "old" pages, I see the + more reasonable example: + + Consequently, the following is not guaranteed to be true: + + let val z = TextIO.StreamIO.endOfStream f + val (a,f') = TextIO.StreamIO.input f + val x = TextIO.StreamIO.endOfStream f' + in x=z (* not necessarily true! *) + end + + whereas the following is guaranteed to be true: + + let val z = TextIO.StreamIO.endOfStream f + val (a,f') = TextIO.StreamIO.input f + val x = TextIO.StreamIO.endOfStream f (* note, no prime! *) + in x=z (* guaranteed true! *) + end +* David Matthews's post on Aug. 2 raised questions about canInput + which are unresolved. + +General comments: +* Various operations in IO take "slices", but aren't expressed in + terms of {Vector,Array}Slice structures. One difficulty with this + is that the slice types are not in scope within the IO signatures. + + I would really advocate making the VectorSlice structure a + substructure of the Vector structure (and likewise for arrays). + Even if this isn't done for the polymorphic vector/array structures, + it would be extremely beneficial for the monomorphic structures, + where in the {Prim,Stream,Imperative}IO functors, it is impossible + to access the corresponding monomorphic vector/array slice + structures. I found myself using Vector.tabulate when I really + wanted ArraySlice.vector. + + The "old" MONO_ARRAY signature included structure Vector: + MONO_VECTOR which gave access to the corresponding monomorphic + vectors. + +-Matthew + +****************************************************************************** +****************************************************************************** + +Date: Fri, 13 Dec 2002 15:57:55 +0100 +From: Andreas Rossberg + + +Here is a collection of issues and comments we gathered when +implementing the I/O stack from the Standard Basis (primitive, stream, +imperative I/O) for Alice. While in general the specification seems to +be pretty precise and complete, we sometimes found it hard to understand +the semantic details of stream I/O, especially since many of them can +only be derived indirectly from the examples in the discussion section +and there appear to be some minor ambiguities and inconsistencies. Also, +the PrimIO and StreamIO functors cannot always be implemented as +suggested, because of their parametricity in types such as position and +element. + +As a general note, the I/O interface does not seem to have been designed +with concurrency in mind. In particular, augmenting readers and writers +cannot be made thread-safe, AFAWCS. This is a bit of a problem for us, +since Alice is relying on concurrency. However, that does not seem to be +an issue easily solved. + + - Leif Kornstaedt, Andreas Rossberg + + +The IO structure +---------------- + +* exception Io: + + - function field: (pedantic) The wording seems to imply that only + functions from STREAM_IO raise the Io exception, but this is + clearly not the case (consider TextIO.openIn to name just one). + +* datatype buffer_mode: + + - There is no specification of what precisely line buffering is + supposed to mean, in particular for non-text streams. + + + +The PRIM_IO signature +--------------------- + +* Synopsis: + + - (pedantic) It says that "higher level I/O facilities do not + access the OS structure directly...". That's somewhat misleading + since OS does not provide the same functionality anyway (if any, + it was the Posix structure). + +* type reader: + + - Unlike for writers, it is not specified what the minimal set of + operations is that a reader must support. + + - It is not specified whether multiple end-of-streams may occur. + Since they are anticipated for StreamIO, one should expect them + to be possible for underlying readers as well. However, this + requires clarification of the semantics of several operations. + + - readArr, readArrNB: It is specified nowhere what the option for + sz is supposed to mean, i.e. what the semantics of NONE is + (presumably as for slices). + + - readVec, readVecNB: Unlike all other similar read and write + functions, these two do not accept an option for the size + argument. + + - avail: The description suggests that the function can be used as + a hint by inputAll. However, this information is too inaccurate + to be useful, since (apart from translation issues) the physical + size of elements cannot be obtained (in particular in the + StreamIO functor, which is parametric in the element type). In + practice, endPos seems to be more useful for this purpose. So it + is not clear what purpose avail could actually serve at all at + the abstraction level provided by readers. + + - endPos: + (1) May it block? For example, when reading from terminal or + from another kind of stream, this can be naturally expected. + + (2) Which position is returned if there are multiple + end-of-streams? + + - getPos, setPos, endPos, verifyPos: Description should start with + "when present". + + - setPos, endPos: Should not raise an exception if unimplemented, + but rather be NONE. Actually, the implementation notes on writers + state that endPos *must* be implemented for readers. + + - Implementation note, item 6: Why is it likely that the client + uses getPos frequently? And why should the reader count + *untranslated* elements (and how would there be actual elements + before translation)? + (See also comments on STREAM_IO.filePosIn) + +* type writer: + + - writeVec, writeArr, writeVecNB, writeArrNB: + (1) Again, it is not specified what the optional size means. + + (2) When may k < sz occur without having IO failure? If it is + arbitrary, then there appears to be no correct way to write a + sequence of elements, because it is neither possible to detect + partial element writes (which are explained in the paragraph + before the Implementation Notes), nor to complete such writes. + This particularly implies that the StreamIO functor cannot + implement flushing correctly (see below). + + - getPos, setPos, endPos, verifyPos: Description should start with + "when present". + + - getPos, setPos: Should not raise an exception if unimplemented, + but rather be NONE. + + - last paragraph before Implementation Note: Typo, double "plus". + + - first sentence in Implementation Note: (pedantic) Why is this + put into the implementation notes when it actually seems to be a + requirement of the specification? + + - last paragraph of Implementation Note: + (1) States that readers must implement getPos, which seems to be + contradicted by its optional type. + + (2) Typo, double "need". + +* openVector: + + - Is this supposed to support random access? Note that for types + generated with the PrimIO functor it cannot (see below)! That + seems to make this function rather useless. + +* augmentReader, augmentWriter: + + - It is not possible to synthesize operations in a way that is + thread-safe in concurrent systems, hence it should be noted that + augmenting is potentially dangerous. + +* There is no reference to the PrimIO functor. + + + +The PrimIO functor +------------------ + +* General problems: + + - Since the implementation is necessarily parametric in the pos + type, openVector, nullRd, nullWr cannot create readers that + allow random access, although one would expect that at least for + openVector. + +* Functor argument: + + - Structure names A and V are inconsistent with the StreamIO and + ImperativeIO functors. + + - Type pos has to be an eqtype to match the result signature. + + - Since the extract and copy functions have been removed/changed + from ARRAY and VECTOR signatures, the PrimIO functor now + naturally requires slice structures for efficient + implementation. (Likewise the StreamIO functor) + +* Functor result: + + - Type sharing of the pos type is not specified, though essential + for this functor being useful at all. + + + + +The STREAM_IO signature +----------------------- + +* Synopsis: + + - An exception likely to be raised in by the underlying + reader/writer is Size, which is not mentioned. OTOH, Fail can + only occur in the rare case of user-supplied readers/writers, as + the Basis itself is supposed to never raise it. + +* type out_pos: + + - A note on the meaning of this type would be desirable, since its + canonical representation is (outstream * pos) rather than pos. + (That also may have caused confusion in the discussion of + imperative I/O, see below.) + +* input1: + + - The signature of this function is inconsistent with all other + input functions. It should rather have type + + instream -> elem option * instream + + which in fact appears to be the type assumed in the discussion + example relating input1 to inputN. + +* input: + + - Typo, s/ay/may/ + +* inputN: + + - This function is somewhat underspecified for n=0. In particular, + may it block? Is it required to raise Io if the underlying + reader is closed? + +* input, input1, inputN, inputAll: + + - (pedantic) Descriptions speak of "underlying system calls", + although the reader may not actually depend on system calls. + Preferably speak of "underlying reader" only. + +* closeIn: + + - Likewise, description speaks of "releasing system resources". + This should be replaced by saying that it closes the underlying + reader (which is not even specified as is). + +* closeOut: + + - Does the function attempt to close the stream even if flushing + fails? + + - Why is it possible to close terminated streams? That seems to + allow unfortunate interference with another stream that has been + created from the extracted writer. + +* mkInstream, getReader: + + - The table seems to imply that mkInstream always augments its + reader. This is inappropriate for concurrent environments (see + above). + + - Should getReader return the original or the augmented reader? + + - The table still includes the removed getPosIn and setPosIn + functions. + +* mkOutstream, getWriter: + + - Likewise. + +* filePosIn: + + - There seems to be no way to implement this function for buffered + I/O, because the reader position that corresponds to a + mid-block-element is not available and cannot be calculated in + general. So how is this meant? + + - Typo, s/character/element/ + +* filePosOut: + + - Likewise. + +* getWriter: + + - It is non-obvious what the precise meaning of "terminating" a + stream is. If this is merely setting a status flag then a + corresponding note would be helpful. + +* getPosOut: + + - May this flush the stream (and hence raise Io exceptions)? + +* setPosOut: + + - This may raise an exception because the position has been + invalidated after obtaining it (e.g. by file truncation + performed by another process). + + - Typo, s/underlying device/underlying writer/ + +* setBufferMode, getBufferMode: + + - There is no specification of the semantics of line buffering, in + particular for non-text streams. + (See also comments on StreamIO functor) + + - It is not specified whether the stream may be flushed when set + to LINE_BUF mode (may cause Io exception). It seems unreasonable + to require it not to do so (assuming that line buffering is + intended to maintain the invariant that the buffer never + contains line breaks). + + - The synopsis of this function uses "ostr", while all others + use "f" for streams. + +* setPosOut, setBufferMode, getWriter: + + - Can raise an exception if flushing fails. + +* Discussion: + + - The statement that closing a stream just causes the + not-yet-determined part of the stream to be empty should + probably be generalised to explain what *truncating* a stream + means (getReader also truncates the stream). + + - Example of freshly opened stream: + s/mkInstream r/mkInstream(r, vector [])/ + s/size/length/ + + - nreads example: + s/mkInstream r/mkInstream(r, vector [])/ + s/size/length/ + + - input1/inputN relation example: + (1) Inconsistent with the actual typing of input1 (see above). + + (2) Typo, s/inputN f/inputN(f,1)/ + + - Unbuffered I/O, 1st example: + (1) Typos, + s/mkInstream(reader)/mkInstream(reader, vector [])/ + s/PrimIO.Rd{chunkSize,...}/(PrimIO.RD{chunksize,...}, v)/ + + (2) More importantly, the actual condition appears to be + incorrect. It should read: + (chunkSize > 1 orelse length v = 1) andalso endOfStream f' + + - Unbuffered I/O, 2nd example: + s/mkInstream(reader)/mkInstream(reader, vector [])/ + s/PrimIO.Rd{chunkSize,...}/(PrimIO.RD{chunksize,...}, v)/ + The condition must be corrected as above. + +* There is no reference to the StreamIO functor. + + + +The StreamIO functor +-------------------- + +* General problems: + + - It is impossible for this functor to support line buffering, + since it has no way of knowing which element consists a line + break. This could be solved by changing the someElem functor + argument to a breakElem argument. + + - It is also impossible to utilize reader's endPos for + pre-allocation, because the functor is parametric in the + position type. + +* Functor argument: + + - Since the extract and copy functions have been removed/changed + from ARRAY and VECTOR signatures, the StreamIO functor now + naturally requires slice structures for efficient + implementation. (Likewise the PrimIO functor) + +* Functor result: + + - Type sharing of the result types is not specified. + +* Discussion, paragraph on flushing: + + - Most of this discussion rather belongs to the description of + STREAM_IO. + + - Everything said here is not restricted to flushOut, but applies + to flushing in general. + + - Unfortunately, it is left unspecified where flushing may happen + and, consequently, where respective Io exceptions may occur. + + - Write retries as suggested here seem to be impossible to + implement correctly using the writer interface as specified (see + comments on PRIM_IO.writer). + + - According to the writer description, write operations may never + return an element count of 0, so the last sentence is + misleading. + +* Discussion, last paragraph: + + - Typo, missing ")" + +* Implementation note: + + - 3rd bullet: typo, s/PrimIO.augmentIn/PrimIO.augmentReader/ + + - 5th and 6th bullet: The endPos function cannot be utilized as + suggested, because the functor is necessarily parametric in the + position type. + + + +The IMPERATIVE_IO signature +--------------------------- + +* General comment: + + - It is unfortunate that imperative I/O is asymmetric with respect + to providing (limited) random access on input vs. output streams + - the former requires going down to the lower-level stream I/O. + That makes imperative I/O a somewhat incomplete abstraction + layer. + + - Likewise, it would be desirable if there were ways for + performing full-fledged random access without leaving the + imperative I/O abstraction layer, at least for streams were it + is suitable (e.g. BinIO). Despite the statement in the + discussion this is neither available for input nor for output + streams (see comments below). + +* closeIn: + + - Typo, s/S.closeIn/StreamIO.closeIn/ + +* flushOut: + + - Typo, s/S.flushOut/StreamIO.flushOut/ + +* closeOut: + + - Typo, s/S.closeOut/StreamIO.closeOut/ + +* Discussion: + + - Equivalences, last line: s/StreamIO.output/StreamIO.flushOut/ + + - Paragraph about random-access on output streams: It says that + BinIO.StreamIO.out_pos = Position.int. This is not true, we have + BinPrimIO.pos = Position.int, but that is a completely different + type. In fact, it is impossible to implement out_pos as + Position.int. + +* There is no reference to the ImperativeIO functor. + + + +The ImperativeIO functor +------------------------ + +* Functor argument: + + - The Array argument is unnecessary. + +* Functor result: + + - Type sharing of the result types is not specified. + + + +The TEXT_STREAM_IO signature +---------------------------- + +* General comment: + + - Why bother separating this signature from STREAM_IO? + => outputSubstr can easily be generalised to outputSlice + (for good), + => if line buffering is part of STREAM_IO, inputLine + might be as well. + + + +The TextIO structure +-------------------- + +* General comment: + + - Systems providing WideText should also provide a WideTextIO + structure (they have to provide WideTextPrimIO already, which + seems inconsistent). + +* Interface: + + - Duplicated type constraints for StreamIO.reader and + StreamIO.writer. + + + +The BinIO structure +-------------------- + +* Interface: + + - Type sharing with BinPrimIO is not specified (unlike for + TextIO), i.e. the following constraints are missing: + + where type StreamIO.reader = BinPrimIO.reader + where type StreamIO.writer = BinPrimIO.writer + where type StreamIO.pos = BinPrimIO.pos + +****************************************************************************** +****************************************************************************** +****************************************************************************** +****************************************************************************** + +Doing host/network byte order conversions on ML side. + +Socket.Ctl +* Semantics of setNBIO, getNREAD, getATMARK are unclear; + Don't seem to be accessible via {get,set}sockopt; + Instead, using ioctl. + +****************************************************************************** +****************************************************************************** + +Posix.FileSys: +* Within structure S, the type mode is constrained equal to flags, + but flags is an eqtype. + +STREAM_IO.pos +* "This is the type of positions in the underlying readers and + writers. In some instantiations of this signature (e.g., + TextIO.StreamIO), pos is abstract; in others (e.g., BinIO.StreamIO) + it is Position.int." But, the equality of BinIO.StreamIO.pos and + Position.int is never specified in any where constraint of BinIO. +* How can filePosIn be implemented with completely abstract pos? + +Not sent to list: + +* (In general, probably a good idea to look at the entire top-level + structure/signature matches and choose a consistent usage of base + types. For example, Int:>INTEGER would seem to hide the top-level + int; unless Int is opened afterwards. But, then what about all the + other structures that reference int? Is top-level int = Int.int or + is Int.int = top-level int.) +--> I think I'm biased from looking at the MLton implementation, +becuase I'm finding it hard to think about how to really express all +of the sharing constraints in a way that will be acceptable. This +might be the wrong way to look at things: the listing of structures +and signatures with clauses doesn't correspond to a build order, it +corresponds to the way the environment should look to the program. + +Sequences and Slices: +Why not existsi, alli? + +Vector: +Why no vector: int * 'a -> 'a vector? + + +Resolved: + +If one defines VECTOR_SLICE by including a type 'a vector and replace +'a Vector.vector with the local 'a vector, but then binds +structure Vector: VECTOR +structure VectorSlice: VECTOR_SLICE where type 'a vector = 'a Vector.vector +at the top-level, does one violate the basis spec? +Rationale: it's easiset to implement Vector and VectorSlice +simultaneously, say with VectorSlice as a substructure of Vector (in +fact, with all of the Vector operations being dispatched to the +corresponding VectorSlice ops with full slices), so Vector isn't in +scope for the VECTOR_SLICE. +*** No, it's not o.k., because opening VectorSlice will introduce a binding + for 'a vector; but, if we're lucky, John will accept the proposal. + +IEEEReal: +toString prepends a #"~" even when the class is NAN? +*** I guess this is o.k.; there is an explicit sign field. + +PACK_WORD: +structure PackBig :> PACK_WORD (* OPTIONAL *) +structure PackLittle :> PACK_WORD (* OPTIONAL *) +but PACK_WORD has +val subVec : Word8Vector.vector * int -> LargeWord.word +i.e., reference to LargeWord.word. +Should it be +PACK_WORD +type word +val subVec : Word8Vector.vector * int -> word +with +structure PackBig :> PACK_WORD with word = Word.word (* OPTIONAL *) +Should there be PackBig and PackLittle with word = Word.word? +Should there be PackLargeBig with word = LargeWord.word? +There aren't many structures that refine on LargeXYZ; most refine on XYZ. +*** O.k., we always unpack into a LargeWord, which we could then + Word.fromLargeWord back to the size. I guess this is o.k.; It + lets an implementation give more PackBig structures than there + are Word structures. + +MLton specific: + + why are Int32_gtu and Int32_geu primitive? + Why not just Word.fromInt and use Word comparisons? + + Real:>REAL doesn't match basis because it may peform + arithmetic at extended precision. Should this be mentioned + in the user guide? + + QUESTION: proc-env.sml + + QUESTION: char.sml + + check uses of {Vector,Array}Slice.slice for replacement by unsafeSlice. + + +****************************************************************************** +****************************************************************************** + +UNIX: +I'm not quite sure how the ('a, 'b) proc type is supposed to work in +practice; The old Unix structure just used them as +TextIO.{in,out}streams. My suspicion is that we're supposed to use +Posix.IO.mk{Bin,Text}{Reader,Writer} functions and then use the type +system to ensure that if we force a stream to be bin or text, then all +other uses have to be the same. I also suspect that we're only +supposed to lift the file_desc up to an instream/outstream once; i.e., +multiple textInstreamOf calls should continue to return the same +TextIO.instream. That would seem to suggest we need an 'a option ref +that can be banged at the first call to a streamOf function, and +subsequent calls just return the value there. + +textInstreamOf pr +binInstreamOf pr + return a text or binary instream connected to the standard output + stream of the process pr. Note the multiple calls to these + functions on the same proc will result in multiple streams that + all share the same underlying Unix stream. + +textOutstreamOf pr +binOutstreamOf pr + return a text or binary outstream connected to the standard input + stream of the process pr. Note the multiple calls to these + functions on the same proc will result in multiple streams that + all share the same underlying Unix stream. + +streamsOf pr + returns a pair of input and output text streams associated with + pr. This function is equivalent to (textInstream pr, textOutstream + pr) and is provided for backward compatibility. diff --git a/basis-library/overloads.mlb b/basis-library/overloads.mlb new file mode 100644 index 0000000..e8b229f --- /dev/null +++ b/basis-library/overloads.mlb @@ -0,0 +1,23 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + basis-2002.mlb + in + ann "allowOverload true" + in + libs/basis-2002/top-level/overloads.sml + end + end +end diff --git a/basis-library/pervasive-exns.mlb b/basis-library/pervasive-exns.mlb new file mode 100644 index 0000000..1d6801c --- /dev/null +++ b/basis-library/pervasive-exns.mlb @@ -0,0 +1,22 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + libs/basis-2002/basis-2002.mlb + basis-2002.mlb + libs/basis-2002/top-level/basis-exns.sig + in + libs/basis-2002/top-level/pervasive-exns.sml + end +end diff --git a/basis-library/pervasive-types.mlb b/basis-library/pervasive-types.mlb new file mode 100644 index 0000000..ccf0e52 --- /dev/null +++ b/basis-library/pervasive-types.mlb @@ -0,0 +1,22 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + libs/basis-2002/basis-2002.mlb + basis-2002.mlb + libs/basis-2002/top-level/basis-types.sig + in + libs/basis-2002/top-level/pervasive-types.sml + end +end diff --git a/basis-library/pervasive-vals.mlb b/basis-library/pervasive-vals.mlb new file mode 100644 index 0000000..11c06c9 --- /dev/null +++ b/basis-library/pervasive-vals.mlb @@ -0,0 +1,25 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + libs/basis-2002/basis-2002.mlb + basis-2002.mlb + ann "allowSpecifySpecialIds true" in + libs/basis-2002/top-level/basis-vals.sig + end + in + libs/basis-2002/top-level/pervasive-vals.sml + end +end diff --git a/basis-library/pervasive.mlb b/basis-library/pervasive.mlb new file mode 100644 index 0000000..9d12678 --- /dev/null +++ b/basis-library/pervasive.mlb @@ -0,0 +1,13 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +pervasive-types.mlb +pervasive-exns.mlb +pervasive-vals.mlb +infixes.mlb +equal.mlb +overloads.mlb diff --git a/basis-library/platform/cygwin.sml b/basis-library/platform/cygwin.sml new file mode 100644 index 0000000..d22209a --- /dev/null +++ b/basis-library/platform/cygwin.sml @@ -0,0 +1,14 @@ +(* Copyright (C) 2009 Matthew Fluet. + * Copyright (C) 2004-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Cygwin = + struct + fun toFullWindowsPath p = + CUtil.C_String.toString + (PrimitiveFFI.Cygwin.toFullWindowsPath (NullString.nullTerm p)) + end diff --git a/basis-library/platform/mingw.sml b/basis-library/platform/mingw.sml new file mode 100644 index 0000000..ab71a87 --- /dev/null +++ b/basis-library/platform/mingw.sml @@ -0,0 +1,30 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure MinGW = + struct + fun getTempPath () = + let + fun lp bufSz = + let + val buf = CharArray.alloc (C_Size.toInt bufSz) + val reqSz = PrimitiveFFI.MinGW.getTempPath (bufSz, buf) + in + if 0w0 = reqSz + then NONE + else if C_Size.< (reqSz, bufSz) + then SOME (CharArraySlice.vector + (CharArraySlice.unsafeSlice + (buf, 0, SOME (C_Size.toInt reqSz)))) + else lp reqSz + end + in + (* Win32 MAX_PATH is 260, but some subsystems allow longer names *) + lp 0w261 + end + end diff --git a/basis-library/posix/error.sig b/basis-library/posix/error.sig new file mode 100644 index 0000000..6d5e94b --- /dev/null +++ b/basis-library/posix/error.sig @@ -0,0 +1,133 @@ +signature POSIX_ERROR = + sig + eqtype syserror + + val toWord: syserror -> SysWord.word + val fromWord: SysWord.word -> syserror + + val errorMsg: syserror -> string + val errorName: syserror -> string + val syserror: string -> syserror option + + val acces: syserror + val again: syserror + val badf: syserror + val badmsg: syserror + val busy: syserror + val canceled: syserror + val child: syserror + val deadlk: syserror + val dom: syserror + val exist: syserror + val fault: syserror + val fbig: syserror + val inprogress: syserror + val intr: syserror + val inval: syserror + val io: syserror + val isdir: syserror + val loop: syserror + val mfile: syserror + val mlink: syserror + val msgsize: syserror + val nametoolong: syserror + val nfile: syserror + val nodev: syserror + val noent: syserror + val noexec: syserror + val nolck: syserror + val nomem: syserror + val nospc: syserror + val nosys: syserror + val notdir: syserror + val notempty: syserror + val notsup: syserror + val notty: syserror + val nxio: syserror + val perm: syserror + val pipe: syserror + val range: syserror + val rofs: syserror + val spipe: syserror + val srch: syserror + val toobig: syserror + val xdev: syserror + + end + +signature POSIX_ERROR_EXTRA = + sig + include POSIX_ERROR + + exception SysErr of string * syserror option + + val cleared: syserror + val raiseSys: syserror -> 'a + val raiseSysWithMsg: syserror * string -> 'a + + structure SysCall : + sig + val blocker: (unit -> (unit -> unit)) ref + val restartFlag: bool ref + + val syscallErr: + {clear: bool, restart: bool, errVal: ''a} * + (unit -> {return: ''a C_Errno.t, + post: ''a -> 'b, + handlers: (syserror * (unit -> 'b)) list}) -> 'b + + (* clear = false, restart = false, errVal = ~1 + * post = fn _ => (), handlers = [] + *) + val simple: (unit -> C_Int.t C_Errno.t) -> unit + (* clear = false, restart = false, + * post = fn _ => (), handlers = [] + *) + val simple': {errVal: ''a} * (unit -> ''a C_Errno.t) -> unit + + (* clear = false, restart = true, errVal = ~1 + * post = fn _ => (), handlers = [] + *) + val simpleRestart: (unit -> C_Int.t C_Errno.t) -> unit + (* clear = false, restart = true, + * post = fn _ => (), handlers = [] + *) + val simpleRestart': {errVal: ''a} * (unit -> ''a C_Errno.t) -> unit + + (* clear = false, restart = false, errVal = ~1 + * post = fn ret => ret, handlers = [] + *) + val simpleResult: (unit -> C_Int.t C_Errno.t) -> C_Int.t + (* clear = false, restart = false, + * post = fn ret => ret, handlers = [] + *) + val simpleResult': {errVal: ''a} * (unit -> ''a C_Errno.t) -> ''a + + (* clear = false, restart = true, errVal = ~1 + * post = fn ret => ret, handlers = [] + *) + val simpleResultRestart: (unit -> C_Int.t C_Errno.t) -> C_Int.t + (* clear = false, restart = true, + * post = fn ret => ret, handlers = [] + *) + val simpleResultRestart': {errVal: ''a} * (unit -> ''a C_Errno.t) -> ''a + + (* clear = false, restart = false, errVal = ~1 + * handlers = [] + *) + val syscall: (unit -> C_Int.t C_Errno.t * (C_Int.t -> 'a)) -> 'a + (* clear = false, restart = false, + * handlers = [] + *) + val syscall': {errVal: ''a} * (unit -> ''a C_Errno.t * (''a -> 'b)) -> 'b + + (* clear = false, restart = true, errVal = ~1 + * handlers = [] + *) + val syscallRestart: (unit -> C_Int.t C_Errno.t * (C_Int.t -> 'a)) -> 'a + (* clear = false, restart = true, + * handlers = [] + *) + val syscallRestart': {errVal: ''a} * (unit -> ''a C_Errno.t * (''a -> 'b)) -> 'b + end + end diff --git a/basis-library/posix/error.sml b/basis-library/posix/error.sml new file mode 100644 index 0000000..c81e136 --- /dev/null +++ b/basis-library/posix/error.sml @@ -0,0 +1,336 @@ +(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PosixError: POSIX_ERROR_EXTRA = + struct + structure Prim = PrimitiveFFI.Posix.Error + open Prim + structure SysError = PrePosix.SysError + + type syserror = SysError.t + + val acces = SysError.fromRep EACCES + val addrinuse = SysError.fromRep EADDRINUSE + val addrnotavail = SysError.fromRep EADDRNOTAVAIL + val afnosupport = SysError.fromRep EAFNOSUPPORT + val again = SysError.fromRep EAGAIN + val already = SysError.fromRep EALREADY + val badf = SysError.fromRep EBADF + val badmsg = SysError.fromRep EBADMSG + val busy = SysError.fromRep EBUSY + val canceled = SysError.fromRep ECANCELED + val child = SysError.fromRep ECHILD + val connaborted = SysError.fromRep ECONNABORTED + val connrefused = SysError.fromRep ECONNREFUSED + val connreset = SysError.fromRep ECONNRESET + val deadlk = SysError.fromRep EDEADLK + val destaddrreq = SysError.fromRep EDESTADDRREQ + val dom = SysError.fromRep EDOM + val dquot = SysError.fromRep EDQUOT + val exist = SysError.fromRep EEXIST + val fault = SysError.fromRep EFAULT + val fbig = SysError.fromRep EFBIG + val hostunreach = SysError.fromRep EHOSTUNREACH + val idrm = SysError.fromRep EIDRM + val ilseq = SysError.fromRep EILSEQ + val inprogress = SysError.fromRep EINPROGRESS + val intr = SysError.fromRep EINTR + val inval = SysError.fromRep EINVAL + val io = SysError.fromRep EIO + val isconn = SysError.fromRep EISCONN + val isdir = SysError.fromRep EISDIR + val loop = SysError.fromRep ELOOP + val mfile = SysError.fromRep EMFILE + val mlink = SysError.fromRep EMLINK + val msgsize = SysError.fromRep EMSGSIZE + val multihop = SysError.fromRep EMULTIHOP + val nametoolong = SysError.fromRep ENAMETOOLONG + val netdown = SysError.fromRep ENETDOWN + val netreset = SysError.fromRep ENETRESET + val netunreach = SysError.fromRep ENETUNREACH + val nfile = SysError.fromRep ENFILE + val nobufs = SysError.fromRep ENOBUFS + val nodata = SysError.fromRep ENODATA + val nodev = SysError.fromRep ENODEV + val noent = SysError.fromRep ENOENT + val noexec = SysError.fromRep ENOEXEC + val nolck = SysError.fromRep ENOLCK + val nolink = SysError.fromRep ENOLINK + val nomem = SysError.fromRep ENOMEM + val nomsg = SysError.fromRep ENOMSG + val noprotoopt = SysError.fromRep ENOPROTOOPT + val nospc = SysError.fromRep ENOSPC + val nosr = SysError.fromRep ENOSR + val nostr = SysError.fromRep ENOSTR + val nosys = SysError.fromRep ENOSYS + val notconn = SysError.fromRep ENOTCONN + val notdir = SysError.fromRep ENOTDIR + val notempty = SysError.fromRep ENOTEMPTY + val notsock = SysError.fromRep ENOTSOCK + val notsup = SysError.fromRep ENOTSUP + val notty = SysError.fromRep ENOTTY + val nxio = SysError.fromRep ENXIO + val opnotsupp = SysError.fromRep EOPNOTSUPP + val overflow = SysError.fromRep EOVERFLOW + val perm = SysError.fromRep EPERM + val pipe = SysError.fromRep EPIPE + val proto = SysError.fromRep EPROTO + val protonosupport = SysError.fromRep EPROTONOSUPPORT + val prototype = SysError.fromRep EPROTOTYPE + val range = SysError.fromRep ERANGE + val rofs = SysError.fromRep EROFS + val spipe = SysError.fromRep ESPIPE + val srch = SysError.fromRep ESRCH + val stale = SysError.fromRep ESTALE + val time = SysError.fromRep ETIME + val timedout = SysError.fromRep ETIMEDOUT + val toobig = SysError.fromRep E2BIG + val txtbsy = SysError.fromRep ETXTBSY + val wouldblock = SysError.fromRep EWOULDBLOCK + val xdev = SysError.fromRep EXDEV + + local + infixr 5 ::? + fun (n,s) ::? l = + if n = SysError.fromRep ~1 + then l + else (n,s) :: l + in + val errorNames = + (acces,"acces") ::? + (addrinuse,"addrinuse") ::? + (addrnotavail,"addrnotavail") ::? + (afnosupport,"afnosupport") ::? + (again,"again") ::? + (already,"already") ::? + (badf,"badf") ::? + (badmsg,"badmsg") ::? + (busy,"busy") ::? + (canceled,"canceled") ::? + (child,"child") ::? + (connaborted,"connaborted") ::? + (connrefused,"connrefused") ::? + (connreset,"connreset") ::? + (deadlk,"deadlk") ::? + (destaddrreq,"destaddrreq") ::? + (dom,"dom") ::? + (dquot,"dquot") ::? + (exist,"exist") ::? + (fault,"fault") ::? + (fbig,"fbig") ::? + (hostunreach,"hostunreach") ::? + (idrm,"idrm") ::? + (ilseq,"ilseq") ::? + (inprogress,"inprogress") ::? + (intr,"intr") ::? + (inval,"inval") ::? + (io,"io") ::? + (isconn,"isconn") ::? + (isdir,"isdir") ::? + (loop,"loop") ::? + (mfile,"mfile") ::? + (mlink,"mlink") ::? + (msgsize,"msgsize") ::? + (multihop,"multihop") ::? + (nametoolong,"nametoolong") ::? + (netdown,"netdown") ::? + (netreset,"netreset") ::? + (netunreach,"netunreach") ::? + (nfile,"nfile") ::? + (nobufs,"nobufs") ::? + (nodata,"nodata") ::? + (nodev,"nodev") ::? + (noent,"noent") ::? + (noexec,"noexec") ::? + (nolck,"nolck") ::? + (nolink,"nolink") ::? + (nomem,"nomem") ::? + (nomsg,"nomsg") ::? + (noprotoopt,"noprotoopt") ::? + (nospc,"nospc") ::? + (nosr,"nosr") ::? + (nostr,"nostr") ::? + (nosys,"nosys") ::? + (notconn,"notconn") ::? + (notdir,"notdir") ::? + (notempty,"notempty") ::? + (notsock,"notsock") ::? + (notsup,"notsup") ::? + (notty,"notty") ::? + (nxio,"nxio") ::? + (opnotsupp,"opnotsupp") ::? + (overflow,"overflow") ::? + (perm,"perm") ::? + (pipe,"pipe") ::? + (proto,"proto") ::? + (protonosupport,"protonosupport") ::? + (prototype,"prototype") ::? + (range,"range") ::? + (rofs,"rofs") ::? + (spipe,"spipe") ::? + (srch,"srch") ::? + (stale,"stale") ::? + (time,"time") ::? + (timedout,"timedout") ::? + (toobig,"toobig") ::? + (txtbsy,"txtbsy") ::? + (wouldblock,"wouldblock") ::? + (xdev,"xdev") ::? + [] + end + exception SysErr of string * syserror option + + val toWord = C_Int.castToSysWord o SysError.toRep + val fromWord = SysError.fromRep o C_Int.castFromSysWord + + val cleared : syserror = SysError.fromRep 0 + + fun errorName n = + case List.find (fn (m, _) => n = m) errorNames of + NONE => "" + | SOME (_, s) => s + + val _ = + General.addExnMessager + (fn e => + case e of + SysErr (s, eo) => + SOME (concat ["SysErr: ", s, + case eo of + NONE => "" + | SOME e => concat [" [", errorName e, "]"]]) + | _ => NONE) + + fun syserror s = + case List.find (fn (_, s') => s = s') errorNames of + NONE => NONE + | SOME (n, _) => SOME n + + fun errorMsg (n: syserror) = + let + val cs = strError (SysError.toRep n) + in + if Primitive.MLton.Pointer.isNull + (Primitive.MLton.Pointer.fromWord cs) + then "Unknown error" + else CUtil.C_String.toString cs + end + + fun raiseSys n = raise SysErr (errorMsg n, SOME n) + fun raiseSysWithMsg (n, msg) = raise SysErr ((errorMsg n) ^ ": " ^ msg, SOME n) + + structure SysCall = + struct + structure Thread = Primitive.MLton.Thread + + val blocker: (unit -> (unit -> unit)) ref = + ref (fn () => (fn () => ())) + (* ref (fn () => raise Fail "blocker not installed") *) + val restartFlag = ref true + + val syscallErr: {clear: bool, restart: bool, errVal: ''a} * + (unit -> {return: ''a C_Errno.t, + post: ''a -> 'b, + handlers: (syserror * (unit -> 'b)) list}) -> 'b = + fn ({clear, restart, errVal}, f) => + let + fun call (err: {errno: syserror, + handlers: (syserror * (unit -> 'b)) list} -> 'b): 'b = + let + val () = Thread.atomicBegin () + val () = if clear then clearErrno () else () + val {return, post, handlers} = + f () handle exn => (Thread.atomicEnd (); raise exn) + val return = C_Errno.check return + in + if errVal = return + then + (* Must getErrno () in the critical section. *) + let + val e = SysError.fromRep (getErrno ()) + val () = Thread.atomicEnd () + in + err {errno = e, handlers = handlers} + end + else DynamicWind.wind (fn () => post return , Thread.atomicEnd) + end + fun err {default: unit -> 'b, + errno: syserror, + handlers: (syserror * (unit -> 'b)) list}: 'b = + case List.find (fn (e',_) => errno = e') handlers of + NONE => default () + | SOME (_, handler) => handler () + fun errBlocked {errno: syserror, + handlers: (syserror * (unit -> 'b)) list}: 'b = + err {default = fn () => raiseSys errno, + errno = errno, handlers = handlers} + fun errUnblocked + {errno: syserror, + handlers: (syserror * (unit -> 'b)) list}: 'b = + err {default = fn () => + if restart andalso errno = intr andalso !restartFlag + then if Thread.atomicState () = 0w0 + then call errUnblocked + else let val finish = !blocker () + in + DynamicWind.wind + (fn () => call errBlocked, finish) + end + else raiseSys errno, + errno = errno, handlers = handlers} + in + call errUnblocked + end + + local + val simpleResultAux = fn ({restart, errVal}, f) => + syscallErr + ({clear = false, restart = restart, errVal = errVal}, fn () => + let val return = f () + in {return = return, + post = fn ret => ret, + handlers = []} + end) + in + val simpleResultRestart = fn f => + simpleResultAux ({restart = true, errVal = C_Int.fromInt ~1}, f) + val simpleResult = fn f => + simpleResultAux ({restart = false, errVal = C_Int.fromInt ~1}, f) + + val simpleResultRestart' = fn ({errVal}, f) => + simpleResultAux ({restart = true, errVal = errVal}, f) + val simpleResult' = fn ({errVal}, f) => + simpleResultAux ({restart = false, errVal = errVal}, f) + end + + val simpleRestart = ignore o simpleResultRestart + val simple = ignore o simpleResult + + val simpleRestart' = fn ({errVal}, f) => + ignore (simpleResultRestart' ({errVal = errVal}, f)) + val simple' = fn ({errVal}, f) => + ignore (simpleResult' ({errVal = errVal}, f)) + + val syscallRestart' = fn ({errVal}, f) => + syscallErr + ({clear = false, restart = true, errVal = errVal}, fn () => + let val (return, post) = f () + in {return = return, post = post, handlers = []} + end) + val syscall' = fn ({errVal}, f) => + syscallErr + ({clear = false, restart = false, errVal = errVal}, fn () => + let val (return, post) = f () + in {return = return, post = post, handlers = []} + end) + val syscallRestart = fn f => + syscallRestart' ({errVal = C_Int.fromInt ~1}, f) + val syscall = fn f => + syscall' ({errVal = C_Int.fromInt ~1}, f) + end + end diff --git a/basis-library/posix/file-sys.sig b/basis-library/posix/file-sys.sig new file mode 100644 index 0000000..5f3ef1f --- /dev/null +++ b/basis-library/posix/file-sys.sig @@ -0,0 +1,128 @@ +signature POSIX_FILE_SYS = + sig + eqtype uid + eqtype gid + + eqtype file_desc + val fdToWord: file_desc -> SysWord.word + val wordToFD: SysWord.word -> file_desc + + (* identity functions *) + val fdToIOD: file_desc -> OS.IO.iodesc + val iodToFD: OS.IO.iodesc -> file_desc option + + type dirstream + val opendir: string -> dirstream + val readdir: dirstream -> string option + val rewinddir: dirstream -> unit + val closedir: dirstream -> unit + + val chdir: string -> unit + val getcwd: unit -> string + + val stdin: file_desc + val stdout: file_desc + val stderr: file_desc + + structure S: + sig + eqtype mode + include BIT_FLAGS where type flags = mode + + val irwxu: mode + val irusr: mode + val iwusr: mode + val ixusr: mode + val irwxg: mode + val irgrp: mode + val iwgrp: mode + val ixgrp: mode + val irwxo: mode + val iroth: mode + val iwoth: mode + val ixoth: mode + val isuid: mode + val isgid: mode + end + + structure O: + sig + include BIT_FLAGS + + val append: flags + val excl: flags + val noctty: flags + val nonblock: flags + val sync: flags + val trunc: flags + end + + datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR + + val openf: string * open_mode * O.flags -> file_desc + val createf: string * open_mode * O.flags * S.mode -> file_desc + val creat: string * S.mode -> file_desc + val umask: S.mode -> S.mode + val link: {old: string, new: string} -> unit + val mkdir: string * S.mode -> unit + val mkfifo: string * S.mode -> unit + val unlink: string -> unit + val rmdir: string -> unit + val rename: {old: string, new: string} -> unit + val symlink: {old: string, new: string} -> unit + val readlink: string -> string + + eqtype dev + val wordToDev: SysWord.word -> dev + val devToWord: dev -> SysWord.word + + eqtype ino + val wordToIno: SysWord.word -> ino + val inoToWord: ino -> SysWord.word + + structure ST: + sig + type stat + + val isDir: stat -> bool + val isChr: stat -> bool + val isBlk: stat -> bool + val isReg: stat -> bool + val isFIFO: stat -> bool + val isLink: stat -> bool + val isSock: stat -> bool + val mode: stat -> S.mode + val ino: stat -> ino + val dev: stat -> dev + val nlink: stat -> int + val uid: stat -> uid + val gid: stat -> gid + val size: stat -> Position.int + val atime: stat -> Time.time + val mtime: stat -> Time.time + val ctime: stat -> Time.time + end + + val stat: string -> ST.stat + val lstat: string -> ST.stat + val fstat: file_desc -> ST.stat + + datatype access_mode = A_READ | A_WRITE | A_EXEC + + val access: string * access_mode list -> bool + val chmod: string * S.mode -> unit + val fchmod: file_desc * S.mode -> unit + val chown: string * uid * gid -> unit + val fchown: file_desc * uid * gid -> unit + val utime: string * {actime: Time.time, modtime: Time.time} option -> unit + val ftruncate: file_desc * Position.int -> unit + val pathconf: string * string -> SysWord.word option + val fpathconf: file_desc * string -> SysWord.word option + end + +signature POSIX_FILE_SYS_EXTRA = + sig + include POSIX_FILE_SYS + + val flagsToOpenMode: O.flags -> open_mode + end diff --git a/basis-library/posix/file-sys.sml b/basis-library/posix/file-sys.sml new file mode 100644 index 0000000..044fffa --- /dev/null +++ b/basis-library/posix/file-sys.sml @@ -0,0 +1,473 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PosixFileSys: POSIX_FILE_SYS_EXTRA = + struct + structure Prim = PrimitiveFFI.Posix.FileSys + open Prim + structure FileDesc = PrePosix.FileDesc + structure GId = PrePosix.GId + structure PId = PrePosix.PId + structure Stat = Prim.Stat + structure UId = PrePosix.UId + + structure Error = PosixError + structure SysCall = Error.SysCall + + (* Patch to make Time look like it deals with C_Time.t + * instead of LargeInt.int. + *) + structure Time = + struct + open Time + + val fromSeconds = fromSeconds o C_Time.toLargeInt + + fun toSeconds t = + C_Time.fromLargeInt (Time.toSeconds t) + handle Overflow => Error.raiseSys Error.inval + end + + type file_desc = FileDesc.t + type gid = GId.t + type uid = UId.t + + val fdToWord = C_Fd.castToSysWord o FileDesc.toRep + val wordToFD = FileDesc.fromRep o C_Fd.castFromSysWord + + val fdToIOD = PreOS.IODesc.fromRep o FileDesc.toRep + val iodToFD = SOME o FileDesc.fromRep o PreOS.IODesc.toRep + + (*------------------------------------*) + (* dirstream *) + (*------------------------------------*) + + local + structure Prim = Prim.Dirstream + datatype dirstream = DS of C_DirP.t option ref + + fun get (DS r) = + case !r of + NONE => Error.raiseSys Error.badf + | SOME d => d + in + type dirstream = dirstream + + fun opendir s = + let + val s = NullString.nullTerm s + in + SysCall.syscall' + ({errVal = C_DirP.castFromSysWord 0w0}, fn () => + (Prim.openDir s, fn d => + DS (ref (SOME d)))) + end + + fun readdir d = + let + val d = get d + fun loop () = + let + val res = + SysCall.syscallErr + ({clear = true, restart = false, + errVal = CUtil.C_Pointer.null}, fn () => + {return = Prim.readDir d, + post = fn cs => SOME cs, + handlers = [(Error.cleared, fn () => NONE), + (* MinGW sets errno to ENOENT when it + * returns NULL. + *) + (Error.noent, fn () => NONE)]}) + in + case res of + NONE => NONE + | SOME cs => + let + val s = CUtil.C_String.toString cs + in + if s = "." orelse s = ".." + then loop () + else SOME s + end + end + in loop () + end + + fun rewinddir d = + let val d = get d + in Prim.rewindDir d + end + + fun closedir (DS r) = + case !r of + NONE => () + | SOME d => (SysCall.simple (fn () => Prim.closeDir d); r := NONE) + end + + fun chdir s = + SysCall.simple (fn () => Prim.chdir (NullString.nullTerm s)) + + local + val size: int ref = ref 1 + fun make () = Array.alloc (!size) + val buffer = ref (make ()) + + fun extractToChar (a, c) = + let + val n = Array.length a + (* find the null terminator *) + fun loop i = + if i >= n + then raise Fail "extractToChar didn't find terminator" + else if c = Array.sub (a, i) + then i + else loop (i + 1) + in + ArraySlice.vector (ArraySlice.slice (a, 0, SOME (loop 0))) + end + + fun extract a = extractToChar (a, #"\000") + in + fun getcwd () = + let + val res = + SysCall.syscallErr + ({clear = false, restart = false, + errVal = CUtil.C_Pointer.null}, fn () => + {return = Prim.getcwd (!buffer, C_Size.fromInt (!size)), + post = fn _ => true, + handlers = [(Error.range, fn _ => false)]}) + in + if res + then extract (!buffer) + else (size := 2 * !size + ; buffer := make () + ; getcwd ()) + end + end + + val stdin : file_desc = FileDesc.fromRep 0 + val stdout : file_desc = FileDesc.fromRep 1 + val stderr : file_desc = FileDesc.fromRep 2 + + structure S = + struct + structure Flags = BitFlags(structure S = C_Mode) + open S Flags + type mode = C_Mode.t + val ifblk = IFBLK + val ifchr = IFCHR + val ifdir = IFDIR + val ififo = IFIFO + val iflnk = IFLNK + val ifmt = IFMT + val ifreg = IFREG + val ifsock = IFSOCK + val irgrp = IRGRP + val iroth = IROTH + val irusr = IRUSR + val irwxg = IRWXG + val irwxo = IRWXO + val irwxu = IRWXU + val isgid = ISGID + val isuid = ISUID + val isvtx = ISVTX + val iwgrp = IWGRP + val iwoth = IWOTH + val iwusr = IWUSR + val ixgrp = IXGRP + val ixoth = IXOTH + val ixusr = IXUSR + end + + structure O = + struct + structure Flags = BitFlags(structure S = C_Int) + open O Flags + val append = APPEND + val binary = BINARY + val creat = CREAT + val dsync = DSYNC + val excl = EXCL + val noctty = NOCTTY + val nonblock = NONBLOCK + val rdonly = RDONLY + val rdwr = RDWR + val rsync = RSYNC + val sync = SYNC + val text = TEXT + val trunc = TRUNC + val wronly = WRONLY + end + + datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR + + fun flagsToOpenMode f = + if f = O.rdonly then O_RDONLY + else if f = O.wronly then O_WRONLY + else if f = O.rdwr then O_RDWR + else raise Fail "flagsToOpenMode: unknown flag" + + val openModeToFlags = + fn O_RDONLY => O.rdonly + | O_WRONLY => O.wronly + | O_RDWR => O.rdwr + + fun createf (pathname, openMode, flags, mode) = + let + val pathname = NullString.nullTerm pathname + val flags = O.Flags.flags [openModeToFlags openMode, + flags, + O.creat] + val flags = C_Int.castFromSysWord (O.Flags.toWord flags) + val fd = + SysCall.simpleResult + (fn () => Prim.open3 (pathname, flags, mode)) + in + FileDesc.fromRep fd + end + + fun openf (pathname, openMode, flags) = + let + val pathname = NullString.nullTerm pathname + val flags = O.Flags.flags [openModeToFlags openMode, flags] + val flags = C_Int.castFromSysWord (O.Flags.toWord flags) + val fd = + SysCall.simpleResult + (fn () => Prim.open3 (pathname, flags, C_Mode.castFromSysWord 0wx0)) + in + FileDesc.fromRep fd + end + + fun creat (s, m) = createf (s, O_WRONLY, O.trunc, m) + + val umask = Prim.umask + + + local + fun wrap p arg = (SysCall.simple (fn () => p arg); ()) + fun wrapRestart p arg = (SysCall.simpleRestart (fn () => p arg); ()) + fun wrapOldNew p = + wrap (fn {old,new} => p (NullString.nullTerm old, + NullString.nullTerm new)) + in + val link = wrapOldNew Prim.link + val mkdir = wrap (fn (p, m) => Prim.mkdir (NullString.nullTerm p, m)) + val mkfifo = wrap (fn (p, m) => Prim.mkfifo (NullString.nullTerm p, m)) + val unlink = wrap (Prim.unlink o NullString.nullTerm) + val rmdir = wrap (Prim.rmdir o NullString.nullTerm) + val rename = wrapOldNew Prim.rename + val symlink = wrapOldNew Prim.symlink + val chmod = + wrap + (fn (p, m) => + Prim.chmod (NullString.nullTerm p, m)) + val fchmod = + wrap + (fn (fd, m) => + Prim.fchmod (FileDesc.toRep fd, m)) + val chown = + wrap + (fn (s, uid, gid) => + Prim.chown (NullString.nullTerm s, UId.toRep uid, GId.toRep gid)) + val fchown = + wrap + (fn (fd, uid, gid) => + Prim.fchown (FileDesc.toRep fd, UId.toRep uid, GId.toRep gid)) + val ftruncate = + wrapRestart + (fn (fd, n) => + Prim.ftruncate (FileDesc.toRep fd, n)) + end + + local + val size: int = 1024 + val buf : char array = Array.array (size, #"\000") + in + fun readlink (path: string): string = + let + val path = NullString.nullTerm path + in + SysCall.syscall' + ({errVal = C_SSize.castFromFixedInt ~1}, fn () => + (Prim.readlink (path, buf, C_Size.fromInt size), fn len => + ArraySlice.vector (ArraySlice.slice (buf, 0, SOME (C_SSize.toInt len))))) + end + end + + type dev = C_Dev.t + val wordToDev = C_Dev.castFromSysWord + val devToWord = C_Dev.castToSysWord + + type ino = C_INo.t + val wordToIno = C_INo.castFromSysWord + val inoToWord = C_INo.castToSysWord + + structure ST = + struct + datatype stat = + T of {dev: dev, + ino: ino, + mode: S.mode, + nlink: int, + uid: uid, + gid: gid, + size: Position.int, + atime: Time.time, + mtime: Time.time, + ctime: Time.time} + + fun fromC (): stat = + T {dev = Stat.getDev (), + ino = Stat.getINo (), + mode = Stat.getMode (), + nlink = C_NLink.toInt (Stat.getNLink ()), + uid = UId.fromRep (Stat.getUId ()), + gid = GId.fromRep (Stat.getGId ()), + size = Stat.getSize (), + atime = Time.fromSeconds (Stat.getATime ()), + mtime = Time.fromSeconds (Stat.getMTime ()), + ctime = Time.fromSeconds (Stat.getCTime ())} + + local + fun make sel (T r) = sel r + in + val mode = make #mode + val ino = make #ino + val dev = make #dev + val nlink = make #nlink + val uid = make #uid + val gid = make #gid + val size = make #size + val atime = make #atime + val mtime = make #mtime + val ctime = make #ctime + end + + local + fun make prim s = prim (mode s) <> C_Int.zero + in + val isDir = make Prim.ST.isDir + val isChr = make Prim.ST.isChr + val isBlk = make Prim.ST.isBlk + val isReg = make Prim.ST.isReg + val isFIFO = make Prim.ST.isFIFO + val isLink = make Prim.ST.isLink + val isSock = make Prim.ST.isSock + end + end + + local + fun make prim arg = + SysCall.syscall (fn () => (prim arg, fn _ => ST.fromC ())) + in + val stat = (make Prim.Stat.stat) o NullString.nullTerm + val lstat = (make Prim.Stat.lstat) o NullString.nullTerm + val fstat = (make Prim.Stat.fstat) o FileDesc.toRep + end + + datatype access_mode = A_READ | A_WRITE | A_EXEC + + val conv_access_mode = + fn A_READ => A.R_OK + | A_WRITE => A.W_OK + | A_EXEC => A.X_OK + + fun access (path: string, mode: access_mode list): bool = + let + val mode = List.foldl C_Int.orb 0 (A.F_OK :: (map conv_access_mode mode)) + val path = NullString.nullTerm path + in + SysCall.syscallErr + ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () => + {return = Prim.access (path, mode), + post = fn _ => true, + handlers = [(Error.acces, fn () => false), + (Error.loop, fn () => false), + (Error.nametoolong, fn () => false), + (Error.noent, fn () => false), + (Error.notdir, fn () => false), + (Error.rofs, fn () => false)]}) + end + + local + structure U = Prim.Utimbuf + in + fun utime (f: string, opt: {actime: Time.time, + modtime: Time.time} option): unit = + let + val (a, m) = + case opt of + NONE => let val t = Time.now () + in (t, t) + end + | SOME {actime = a, modtime = m} => (a, m) + val a = Time.toSeconds a + val m = Time.toSeconds m + val f = NullString.nullTerm f + in + SysCall.syscallRestart + (fn () => + (U.setAcTime a + ; U.setModTime m + ; (U.utime f, fn _ => + ()))) + end + end + + local + local + open Prim.PC + infixr 5 ::? + fun (n,s) ::? l = + if n = C_Int.fromInt ~1 + then l + else (n,s) :: l + in + val properties = + (TWO_SYMLINKS,"2_SYMLINKS") ::? + (ALLOC_SIZE_MIN,"ALLOC_SIZE_MIN") ::? + (ASYNC_IO,"ASYNC_IO") ::? + (CHOWN_RESTRICTED,"CHOWN_RESTRICTED") ::? + (FILESIZEBITS,"FILESIZEBITS") ::? + (LINK_MAX,"LINK_MAX") ::? + (MAX_CANON,"MAX_CANON") ::? + (MAX_INPUT,"MAX_INPUT") ::? + (NAME_MAX,"NAME_MAX") ::? + (NO_TRUNC,"NO_TRUNC") ::? + (PATH_MAX,"PATH_MAX") ::? + (PIPE_BUF,"PIPE_BUF") ::? + (PRIO_IO,"PRIO_IO") ::? + (REC_INCR_XFER_SIZE,"REC_INCR_XFER_SIZE") ::? + (REC_MAX_XFER_SIZE,"REC_MAX_XFER_SIZE") ::? + (REC_MIN_XFER_SIZE,"REC_MIN_XFER_SIZE") ::? + (REC_XFER_ALIGN,"REC_XFER_ALIGN") ::? + (SYMLINK_MAX,"SYMLINK_MAX") ::? + (SYNC_IO,"SYNC_IO") ::? + (VDISABLE,"VDISABLE") ::? + [] + end + + fun convertProperty s = + case List.find (fn (_, s') => s = s') properties of + NONE => Error.raiseSys Error.inval + | SOME (n, _) => n + + fun make prim (f, s) = + SysCall.syscallErr + ({clear = true, restart = false, errVal = C_Long.fromInt ~1}, fn () => + {return = prim (f, convertProperty s), + post = fn ret => SOME (SysWord.fromLargeInt (C_Long.toLarge ret)), + handlers = [(Error.cleared, fn () => NONE)]}) + in + val pathconf = make (fn (path, s) => Prim.pathconf (NullString.nullTerm path, s)) + val fpathconf = make (fn (fd, s) => Prim.fpathconf (FileDesc.toRep fd, s)) + end + end diff --git a/basis-library/posix/flags.sig b/basis-library/posix/flags.sig new file mode 100644 index 0000000..b3ab9ef --- /dev/null +++ b/basis-library/posix/flags.sig @@ -0,0 +1,28 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature BIT_FLAGS = + sig + eqtype flags + + val all: flags + val allSet: flags * flags -> bool + val anySet: flags * flags -> bool + val clear: flags * flags -> flags + val flags: flags list -> flags + val fromWord: SysWord.word -> flags + val intersect: flags list -> flags + val toWord: flags -> SysWord.word + end + +signature BIT_FLAGS_EXTRA = + sig + include BIT_FLAGS + + val empty: flags + end diff --git a/basis-library/posix/flags.sml b/basis-library/posix/flags.sml new file mode 100644 index 0000000..abba2a8 --- /dev/null +++ b/basis-library/posix/flags.sml @@ -0,0 +1,35 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor BitFlags(structure S : sig + eqtype t + val castToSysWord: t -> SysWord.word + val castFromSysWord: SysWord.word -> t + val andb: t * t -> t + val notb: t -> t + val orb: t * t -> t + end): BIT_FLAGS_EXTRA = + struct + type flags = S.t + + val all: flags = S.castFromSysWord (SysWord.~ 0w1) + val empty: flags = S.castFromSysWord 0w0 + + fun toWord f = S.castToSysWord f + fun fromWord w = S.castFromSysWord (SysWord.andb (w, toWord all)) + + val flags: flags list -> flags = List.foldl S.orb empty + + val intersect: flags list -> flags = List.foldl S.andb all + + fun clear (f, f') = S.andb (S.notb f, f') + + fun allSet (f, f') = S.andb (f, f') = f' + + fun anySet (f, f') = S.andb (f, f') <> empty + end diff --git a/basis-library/posix/io.sig b/basis-library/posix/io.sig new file mode 100644 index 0000000..0be5089 --- /dev/null +++ b/basis-library/posix/io.sig @@ -0,0 +1,81 @@ +signature POSIX_IO = + sig + eqtype file_desc + eqtype pid + + val pipe: unit -> {infd: file_desc, outfd: file_desc} + val dup: file_desc -> file_desc + val dup2: {old: file_desc, new: file_desc} -> unit + + val close: file_desc -> unit + val readVec: file_desc * int -> Word8Vector.vector + val readArr: file_desc * Word8ArraySlice.slice -> int + val writeVec: file_desc * Word8VectorSlice.slice -> int + val writeArr: file_desc * Word8ArraySlice.slice -> int + + datatype whence = SEEK_SET | SEEK_CUR | SEEK_END + + structure FD: + sig + include BIT_FLAGS + + val cloexec: flags + end + + structure O: + sig + include BIT_FLAGS + + val append: flags + val nonblock: flags + val sync: flags + end + + datatype open_mode = O_RDONLY | O_WRONLY | O_RDWR + + val dupfd: {old: file_desc, base: file_desc} -> file_desc + val getfd: file_desc -> FD.flags + val setfd: file_desc * FD.flags -> unit + val getfl: file_desc -> O.flags * open_mode + val setfl: file_desc * O.flags -> unit + val lseek: file_desc * Position.int * whence -> Position.int + val fsync: file_desc -> unit + + datatype lock_type = F_RDLCK | F_WRLCK | F_UNLCK + + structure FLock: + sig + type flock + val flock: {ltype: lock_type, + whence: whence, + start: Position.int, + len: Position.int, + pid: pid option} -> flock + val ltype: flock -> lock_type + val whence: flock -> whence + val start: flock -> Position.int + val len: flock -> Position.int + val pid: flock -> pid option + end + + val getlk: file_desc * FLock.flock -> FLock.flock + val setlk: file_desc * FLock.flock -> FLock.flock + val setlkw: file_desc * FLock.flock -> FLock.flock + + val mkBinReader: {fd: file_desc, + name: string, + initBlkMode: bool} -> BinPrimIO.reader + val mkTextReader: {fd: file_desc, + name: string, + initBlkMode: bool} -> TextPrimIO.reader + val mkBinWriter: {fd: file_desc, + name: string, + appendMode: bool, + initBlkMode: bool, + chunkSize: int} -> BinPrimIO.writer + val mkTextWriter: {fd: file_desc, + name: string, + appendMode: bool, + initBlkMode: bool, + chunkSize: int} -> TextPrimIO.writer + end diff --git a/basis-library/posix/io.sml b/basis-library/posix/io.sml new file mode 100644 index 0000000..09ba161 --- /dev/null +++ b/basis-library/posix/io.sml @@ -0,0 +1,427 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PosixIO: POSIX_IO = +struct + +structure Prim = PrimitiveFFI.Posix.IO +open Prim +structure FileDesc = PrePosix.FileDesc +structure PId = PrePosix.PId + +structure Error = PosixError +structure SysCall = Error.SysCall +structure FS = PosixFileSys + +type file_desc = FileDesc.t +type pid = PId.t + +local + val a: C_Fd.t array = Array.array (2, C_Fd.fromInt 0) + val get = fn i => FileDesc.fromRep (Array.sub (a, i)) +in + fun pipe () = + SysCall.syscall + (fn () => + (Prim.pipe a, + fn _ => {infd = get 0, + outfd = get 1})) +end + +fun dup fd = + (FileDesc.fromRep o SysCall.simpleResult) + (fn () => Prim.dup (FileDesc.toRep fd)) + +fun dup2 {new, old} = + SysCall.simple + (fn () => Prim.dup2 (FileDesc.toRep old, FileDesc.toRep new)) + +fun close fd = + SysCall.simpleRestart + (fn () => Prim.close (FileDesc.toRep fd)) + +structure FD = + struct + structure Flags = BitFlags(structure S = C_Int) + open FD Flags + val cloexec = CLOEXEC + end + +structure O = PosixFileSys.O + +datatype open_mode = datatype PosixFileSys.open_mode + +fun dupfd {base, old} = + (FileDesc.fromRep o SysCall.simpleResultRestart) + (fn () => Prim.fcntl3 (FileDesc.toRep old, F_DUPFD, FileDesc.toRep base)) + +fun getfd fd = + SysCall.simpleResultRestart + (fn () => Prim.fcntl2 (FileDesc.toRep fd, F_GETFD)) + +fun setfd (fd, flags): unit = + SysCall.simpleRestart + (fn () => Prim.fcntl3 (FileDesc.toRep fd, F_SETFD, flags)) + +fun getfl fd : O.flags * open_mode = + let + val n = SysCall.simpleResultRestart + (fn () => Prim.fcntl2 (FileDesc.toRep fd, F_GETFL)) + val flags = C_Int.andb (n, C_Int.notb O_ACCMODE) + val mode = C_Int.andb (n, O_ACCMODE) + in (flags, PosixFileSys.flagsToOpenMode mode) + end + +fun setfl (fd, flags: O.flags): unit = + SysCall.simpleRestart + (fn () => Prim.fcntl3 (FileDesc.toRep fd, F_SETFL, flags)) + +datatype whence = SEEK_SET | SEEK_CUR | SEEK_END + +val whenceToInt = + fn SEEK_SET => Prim.SEEK_SET + | SEEK_CUR => Prim.SEEK_CUR + | SEEK_END => Prim.SEEK_END + +fun lseek (fd, n: Position.int, w: whence): Position.int = + SysCall.simpleResult' + ({errVal = C_Off.fromInt ~1}, fn () => + Prim.lseek (FileDesc.toRep fd, n, whenceToInt w)) + +fun fsync fd : unit = + SysCall.simple + (fn () => Prim.fsync (FileDesc.toRep fd)) + +val whenceToInt = + fn SEEK_SET => Prim.FLock.SEEK_SET + | SEEK_CUR => Prim.FLock.SEEK_CUR + | SEEK_END => Prim.FLock.SEEK_END + +fun intToWhence n = + if n = Prim.FLock.SEEK_SET + then SEEK_SET + else if n = Prim.FLock.SEEK_CUR + then SEEK_CUR + else if n = Prim.FLock.SEEK_END + then SEEK_END + else raise Fail "Posix.IO.intToWhence" + +datatype lock_type = F_RDLCK | F_WRLCK | F_UNLCK + +val lockTypeToInt = + fn F_RDLCK => Prim.FLock.F_RDLCK + | F_WRLCK => Prim.FLock.F_WRLCK + | F_UNLCK => Prim.FLock.F_UNLCK + +fun intToLockType n = + if n = Prim.FLock.F_RDLCK + then F_RDLCK + else if n = Prim.FLock.F_WRLCK + then F_WRLCK + else if n = Prim.FLock.F_UNLCK + then F_UNLCK + else raise Fail "Posix.IO.intToLockType" + +structure FLock = + struct + open FLock + + type flock = {ltype: lock_type, + whence: whence, + start: Position.int, + len: Position.int, + pid: pid option} + + fun flock l = l + val ltype: flock -> lock_type = #ltype + val whence: flock -> whence = #whence + val start: flock -> Position.int = #start + val len: flock -> Position.int = #len + val pid: flock -> pid option = #pid + end + +local + structure P = Prim.FLock + fun make + (cmd, usepid) + (fd, {ltype, whence, start, len, ...}: FLock.flock) + : FLock.flock = + SysCall.syscallRestart + (fn () => + ((P.setType (lockTypeToInt ltype) + ; P.setWhence (whenceToInt whence) + ; P.setStart start + ; P.setLen len + ; P.fcntl (FileDesc.toRep fd, cmd)), fn _ => + {ltype = intToLockType (P.getType ()), + whence = intToWhence (P.getWhence ()), + start = P.getStart (), + len = P.getLen (), + pid = if usepid then SOME (PId.fromRep (P.getPId ())) + else NONE})) +in + val getlk = make (FLock.F_GETLK, true) + val setlk = make (FLock.F_SETLK, false) + val setlkw = make (FLock.F_SETLKW, false) +end + +(* Adapted from SML/NJ sources. *) +(* posix-bin-prim-io.sml + * + * COPYRIGHT (c) 1995 AT&T Bell Laboratories. + * + * This implements the UNIX version of the OS specific binary primitive + * IO structure. The Text IO version is implemented by a trivial translation + * of these operations (see posix-text-prim-io.sml). + * + *) +local + val pos0 = Position.fromInt 0 + fun isReg fd = FS.ST.isReg(FS.fstat fd) + fun posFns (closed, fd) = + if (isReg fd) + then let + val pos = ref pos0 + fun getPos () = !pos + fun setPos p = (if !closed + then raise IO.ClosedStream + else (); + pos := lseek(fd,p,SEEK_SET)) + fun endPos () = (if !closed + then raise IO.ClosedStream + else (); + FS.ST.size(FS.fstat fd)) + fun verifyPos () = let + val curPos = lseek(fd, pos0, SEEK_CUR) + in + pos := curPos; curPos + end + val _ = verifyPos () + in + {pos = pos, + getPos = SOME getPos, + setPos = SOME setPos, + endPos = SOME endPos, + verifyPos = SOME verifyPos} + end + else {pos = ref pos0, + getPos = NONE, + setPos = NONE, + endPos = NONE, + verifyPos = NONE} + + fun make {RD, WR, fromVector, readArr, setMode, toArraySlice, toVectorSlice, + vectorLength, writeArr, writeVec} = + let + val primReadArr = fn (fd, buf, i, sz) => + readArr (FileDesc.toRep fd, buf, C_Int.fromInt i, C_Size.fromInt sz) + val primWriteArr = fn (fd, buf, i, sz) => + writeArr (FileDesc.toRep fd, buf, C_Int.fromInt i, C_Size.fromInt sz) + val primWriteVec = fn (fd, buf, i, sz) => + writeVec (FileDesc.toRep fd, buf, C_Int.fromInt i, C_Size.fromInt sz) + val setMode = + fn fd => + if let + open Primitive.MLton.Platform.OS + in + case host of + MinGW => true + | _ => false + end + then setMode (FileDesc.toRep fd) + else () + fun readArr (fd, sl): int = + let + val (buf, i, sz) = ArraySlice.base (toArraySlice sl) + val bytesRead = + SysCall.simpleResultRestart' + ({errVal = C_SSize.castFromFixedInt ~1}, fn () => + primReadArr (fd, buf, i, sz)) + val bytesRead = C_SSize.toInt bytesRead + in + bytesRead + end + fun readVec (fd, n) = + let + val buf = Array.alloc n + val bytesRead = + SysCall.simpleResultRestart' + ({errVal = C_SSize.castFromFixedInt ~1}, fn () => + primReadArr (fd, buf, 0, n)) + val bytesRead = C_SSize.toInt bytesRead + in + fromVector + (if n = bytesRead + then Vector.unsafeFromArray buf + else ArraySlice.vector (ArraySlice.slice (buf, 0, SOME bytesRead))) + end + fun writeArr (fd, sl): int = + let + val (buf, i, sz) = ArraySlice.base (toArraySlice sl) + val bytesWrote = + SysCall.simpleResultRestart' + ({errVal = C_SSize.castFromFixedInt ~1}, fn () => + primWriteArr (fd, buf, i, sz)) + val bytesWrote = C_SSize.toInt bytesWrote + in + bytesWrote + end + fun writeVec (fd, sl): int = + let + val (buf, i, sz) = VectorSlice.base (toVectorSlice sl) + val bytesWrote = + SysCall.simpleResultRestart' + ({errVal = C_SSize.castFromFixedInt ~1}, fn () => + primWriteVec (fd, buf, i, sz)) + val bytesWrote = C_SSize.toInt bytesWrote + in + bytesWrote + end + fun mkReader {fd, name, initBlkMode} = + let + val closed = ref false + val {pos, getPos, setPos, endPos, verifyPos} = + posFns (closed, fd) + val blocking = ref initBlkMode + fun blockingOn () = + (setfl(fd, O.flags[]); blocking := true) + fun blockingOff () = + (setfl(fd, O.nonblock); blocking := false) + fun ensureOpen () = + if !closed then raise IO.ClosedStream else () + fun incPos k = pos := Position.+ (!pos, Position.fromInt k) + val readVec = fn n => + let val v = readVec (fd, n) + in incPos (vectorLength v); v + end + val readArr = fn x => + let val k = readArr (fd, x) + in incPos k; k + end + fun blockWrap f x = + (ensureOpen (); + if !blocking then () else blockingOn (); + f x) + fun noBlockWrap f x = + (ensureOpen (); + if !blocking then blockingOff () else (); + (SOME (f x) + handle (e as PosixError.SysErr (_, cause)) => + if cause = SOME PosixError.again then NONE else raise e)) + val close = + fn () => if !closed then () else (closed := true; close fd) + val avail = + if isReg fd + then fn () => if !closed + then SOME 0 + else SOME (Position.toInt + (Position.- + (FS.ST.size (FS.fstat fd), + !pos))) + else fn () => if !closed then SOME 0 else NONE + val () = setMode fd + in + RD {avail = avail, + block = NONE, + canInput = NONE, + chunkSize = Int32.toInt Primitive.Controls.bufSize, + close = close, + endPos = endPos, + getPos = getPos, + ioDesc = SOME (FS.fdToIOD fd), + name = name, + readArr = SOME (blockWrap readArr), + readArrNB = SOME (noBlockWrap readArr), + readVec = SOME (blockWrap readVec), + readVecNB = SOME (noBlockWrap readVec), + setPos = setPos, + verifyPos = verifyPos} + end + fun mkWriter {fd, name, initBlkMode, appendMode, chunkSize} = + let + val closed = ref false + val {pos, getPos, setPos, endPos, verifyPos} = + posFns (closed, fd) + fun incPos k = (pos := Position.+ (!pos, Position.fromInt k); k) + val blocking = ref initBlkMode + val appendFlgs = O.flags(if appendMode then [O.append] else []) + fun updateStatus () = + let + val flgs = if !blocking + then appendFlgs + else O.flags [O.nonblock, appendFlgs] + in + setfl(fd, flgs) + end + fun ensureOpen () = + if !closed then raise IO.ClosedStream else () + fun ensureBlock x = + if !blocking then () else (blocking := x; updateStatus ()) + fun putV x = incPos (writeVec x) + fun putA x = incPos (writeArr x) + fun write (put, block) arg = + (ensureOpen (); ensureBlock block; put (fd, arg)) + fun handleBlock writer arg = + SOME(writer arg) + handle (e as PosixError.SysErr (_, cause)) => + if cause = SOME PosixError.again then NONE else raise e + val close = + fn () => if !closed then () else (closed := true; close fd) + val () = setMode fd + in + WR {block = NONE, + canOutput = NONE, + chunkSize = chunkSize, + close = close, + endPos = endPos, + getPos = getPos, + ioDesc = SOME (FS.fdToIOD fd), + name = name, + setPos = setPos, + verifyPos = verifyPos, + writeArr = SOME (write (putA, true)), + writeArrNB = SOME (handleBlock (write (putA, false))), + writeVec = SOME (write (putV, true)), + writeVecNB = SOME (handleBlock (write (putV, false)))} + end + in + {mkReader = mkReader, + mkWriter = mkWriter, + readArr = readArr, + readVec = readVec, + writeArr = writeArr, + writeVec = writeVec} + end +in + val {mkReader = mkBinReader, mkWriter = mkBinWriter, + readArr, readVec, writeArr, writeVec} = + make {RD = BinPrimIO.RD, + WR = BinPrimIO.WR, + fromVector = Word8Vector.fromPoly, + readArr = readWord8, + setMode = Prim.setbin, + toArraySlice = Word8ArraySlice.toPoly, + toVectorSlice = Word8VectorSlice.toPoly, + vectorLength = Word8Vector.length, + writeArr = writeWord8Arr, + writeVec = writeWord8Vec} + val {mkReader = mkTextReader, mkWriter = mkTextWriter, ...} = + make {RD = TextPrimIO.RD, + WR = TextPrimIO.WR, + fromVector = fn v => v, + readArr = readChar8, + setMode = Prim.settext, + toArraySlice = CharArraySlice.toPoly, + toVectorSlice = CharVectorSlice.toPoly, + vectorLength = CharVector.length, + writeArr = writeChar8Arr, + writeVec = writeChar8Vec} +end + +end diff --git a/basis-library/posix/posix.sig b/basis-library/posix/posix.sig new file mode 100644 index 0000000..65bf4b4 --- /dev/null +++ b/basis-library/posix/posix.sig @@ -0,0 +1,37 @@ +signature POSIX = + sig + structure Error: POSIX_ERROR + structure FileSys: POSIX_FILE_SYS + structure IO: POSIX_IO + structure ProcEnv: POSIX_PROC_ENV + structure Process: POSIX_PROCESS + structure Signal: POSIX_SIGNAL + structure SysDB: POSIX_SYS_DB + structure TTY: POSIX_TTY + + sharing type FileSys.file_desc = ProcEnv.file_desc = IO.file_desc = TTY.file_desc + sharing type ProcEnv.gid = FileSys.gid = SysDB.gid + sharing type FileSys.open_mode = IO.open_mode + sharing type Process.pid = ProcEnv.pid = IO.pid = TTY.pid + sharing type Process.signal = Signal.signal + sharing type ProcEnv.uid = FileSys.uid = SysDB.uid + end + +signature POSIX_EXTRA = + sig + structure Error: POSIX_ERROR_EXTRA + structure FileSys: POSIX_FILE_SYS_EXTRA + structure IO: POSIX_IO + structure ProcEnv: POSIX_PROC_ENV + structure Process: POSIX_PROCESS_EXTRA + structure Signal: POSIX_SIGNAL_EXTRA + structure SysDB: POSIX_SYS_DB + structure TTY: POSIX_TTY + + sharing type FileSys.file_desc = ProcEnv.file_desc = IO.file_desc = TTY.file_desc + sharing type ProcEnv.gid = FileSys.gid = SysDB.gid + sharing type FileSys.open_mode = IO.open_mode + sharing type Process.pid = ProcEnv.pid = IO.pid = TTY.pid + sharing type Process.signal = Signal.signal + sharing type ProcEnv.uid = FileSys.uid = SysDB.uid + end diff --git a/basis-library/posix/posix.sml b/basis-library/posix/posix.sml new file mode 100644 index 0000000..4262d3d --- /dev/null +++ b/basis-library/posix/posix.sml @@ -0,0 +1,26 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Posix: POSIX_EXTRA = + struct + structure Error = PosixError + + structure Signal = PosixSignal + + structure Process = PosixProcess + + structure ProcEnv = PosixProcEnv + + structure FileSys = PosixFileSys + + structure IO = PosixIO + + structure SysDB = PosixSysDB + + structure TTY = PosixTTY + end diff --git a/basis-library/posix/pre-posix.sml b/basis-library/posix/pre-posix.sml new file mode 100644 index 0000000..0675285 --- /dev/null +++ b/basis-library/posix/pre-posix.sml @@ -0,0 +1,16 @@ +(* Copyright (C) 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PrePosix = + struct + structure FileDesc = MkAbsRepEq(type rep = C_Fd.t) + structure GId = MkAbsRepEq(type rep = C_GId.t) + structure PId = MkAbsRepEq(type rep = C_PId.t) + structure Signal = MkAbsRepEq(type rep = C_Signal.t) + structure SysError = MkAbsRepEq(type rep = C_Int.t) + structure UId = MkAbsRepEq(type rep = C_UId.t) + end diff --git a/basis-library/posix/proc-env.sig b/basis-library/posix/proc-env.sig new file mode 100644 index 0000000..c8d2af5 --- /dev/null +++ b/basis-library/posix/proc-env.sig @@ -0,0 +1,38 @@ +signature POSIX_PROC_ENV = + sig + eqtype pid + eqtype uid + eqtype gid + eqtype file_desc + + val uidToWord: uid -> SysWord.word + val wordToUid: SysWord.word -> uid + val gidToWord: gid -> SysWord.word + val wordToGid: SysWord.word -> gid + val getpid : unit -> pid + val getppid: unit -> pid + val getuid : unit -> uid + val geteuid: unit -> uid + val getgid : unit -> gid + val getegid: unit -> gid + val setuid: uid -> unit + val setgid: gid -> unit + val getgroups: unit -> gid list + val getlogin: unit -> string + val getpgrp: unit -> pid + val setsid: unit -> pid + val setpgid: {pid: pid option, pgid: pid option} -> unit + val uname: unit -> (string * string) list + val time: unit -> Time.time + val times: unit -> {elapsed: Time.time, + utime: Time.time, + stime: Time.time, + cutime: Time.time, + cstime: Time.time} + val getenv: string -> string option + val environ: unit -> string list + val ctermid: unit -> string + val ttyname: file_desc -> string + val isatty: file_desc -> bool + val sysconf: string -> SysWord.word + end diff --git a/basis-library/posix/proc-env.sml b/basis-library/posix/proc-env.sml new file mode 100644 index 0000000..dbc8c90 --- /dev/null +++ b/basis-library/posix/proc-env.sml @@ -0,0 +1,289 @@ +(* Copyright (C) 2011,2017 Matthew Fluet. + * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PosixProcEnv: POSIX_PROC_ENV = + struct + structure Prim = PrimitiveFFI.Posix.ProcEnv + structure FileDesc = PrePosix.FileDesc + structure GId = PrePosix.GId + structure PId = PrePosix.PId + structure UId = PrePosix.UId + + structure Error = PosixError + structure SysCall = Error.SysCall + structure CS = CUtil.C_String + structure CSS = CUtil.C_StringArray + + type file_desc = FileDesc.t + type gid = GId.t + type pid = PId.t + type uid = UId.t + + val uidToWord = C_UId.castToSysWord o UId.toRep + val wordToUid = UId.fromRep o C_UId.castFromSysWord + val gidToWord = C_GId.castToSysWord o GId.toRep + val wordToGid = GId.fromRep o C_GId.castFromSysWord + + local + open Prim + in + val getpgrp = PId.fromRep o getpgrp (* No error checking required *) + val getegid = GId.fromRep o getegid (* No error checking required *) + val geteuid = UId.fromRep o geteuid (* No error checking required *) + val getgid = GId.fromRep o getgid (* No error checking required *) + val getpid = PId.fromRep o getpid (* No error checking required *) + val getppid = PId.fromRep o getppid (* No error checking required *) + val getuid = UId.fromRep o getuid (* No error checking required *) + val setgid = fn gid => let val gid = GId.toRep gid + in SysCall.simple (fn () => setgid gid) + end + val setuid = fn uid => let val uid = UId.toRep uid + in SysCall.simple (fn () => setuid uid) + end + end + + fun setsid () = + (PId.fromRep o SysCall.simpleResult') + ({errVal = C_PId.castFromFixedInt ~1}, Prim.setsid) + + fun getgroups () = + SysCall.syscall + (fn () => + let + val n = Prim.getgroupsN () + val a: C_GId.t array = Array.alloc (C_Int.toInt n) + in + (Prim.getgroups (n, a), fn n => + (GId.listFromRep o ArraySlice.toList) + (ArraySlice.slice (a, 0, SOME (C_Int.toInt n)))) + end) + + fun getlogin () = + SysCall.syscall' + ({errVal = CUtil.C_Pointer.null}, fn () => + (Prim.getlogin (), fn cs => + CS.toString cs)) + + fun setpgid {pid, pgid} = + let + val pid = case pid of NONE => 0 | SOME pid => PId.toRep pid + val pgid = case pgid of NONE => 0 | SOME pgid => PId.toRep pgid + in + SysCall.simple + (fn () => Prim.setpgid (pid, pgid)) + end + + fun uname () = + SysCall.syscall + (fn () => + (Prim.uname (), fn _ => + [("sysname", CS.toString (Prim.Uname.getSysName ())), + ("nodename", CS.toString (Prim.Uname.getNodeName ())), + ("release", CS.toString (Prim.Uname.getRelease ())), + ("version", CS.toString (Prim.Uname.getVersion ())), + ("machine", CS.toString (Prim.Uname.getMachine ()))])) + + val time = Time.now + + local + local + infixr 5 ::? + fun (n,s) ::? l = + if n = C_Int.fromInt ~1 + then l + else (n,s) :: l + in + val sysconfNames = + (Prim.SC_2_CHAR_TERM,"2_CHAR_TERM") ::? + (Prim.SC_2_C_BIND,"2_C_BIND") ::? + (Prim.SC_2_C_DEV,"2_C_DEV") ::? + (Prim.SC_2_FORT_DEV,"2_FORT_DEV") ::? + (Prim.SC_2_FORT_RUN,"2_FORT_RUN") ::? + (Prim.SC_2_LOCALEDEF,"2_LOCALEDEF") ::? + (Prim.SC_2_PBS,"2_PBS") ::? + (Prim.SC_2_PBS_ACCOUNTING,"2_PBS_ACCOUNTING") ::? + (Prim.SC_2_PBS_CHECKPOINT,"2_PBS_CHECKPOINT") ::? + (Prim.SC_2_PBS_LOCATE,"2_PBS_LOCATE") ::? + (Prim.SC_2_PBS_MESSAGE,"2_PBS_MESSAGE") ::? + (Prim.SC_2_PBS_TRACK,"2_PBS_TRACK") ::? + (Prim.SC_2_SW_DEV,"2_SW_DEV") ::? + (Prim.SC_2_UPE,"2_UPE") ::? + (Prim.SC_2_VERSION,"2_VERSION") ::? + (Prim.SC_ADVISORY_INFO,"ADVISORY_INFO") ::? + (Prim.SC_AIO_LISTIO_MAX,"AIO_LISTIO_MAX") ::? + (Prim.SC_AIO_MAX,"AIO_MAX") ::? + (Prim.SC_AIO_PRIO_DELTA_MAX,"AIO_PRIO_DELTA_MAX") ::? + (Prim.SC_ARG_MAX,"ARG_MAX") ::? + (Prim.SC_ASYNCHRONOUS_IO,"ASYNCHRONOUS_IO") ::? + (Prim.SC_ATEXIT_MAX,"ATEXIT_MAX") ::? + (Prim.SC_AVPHYS_PAGES,"AVPHYS_PAGES") ::? + (Prim.SC_BARRIERS,"BARRIERS") ::? + (Prim.SC_BC_BASE_MAX,"BC_BASE_MAX") ::? + (Prim.SC_BC_DIM_MAX,"BC_DIM_MAX") ::? + (Prim.SC_BC_SCALE_MAX,"BC_SCALE_MAX") ::? + (Prim.SC_BC_STRING_MAX,"BC_STRING_MAX") ::? + (Prim.SC_CHILD_MAX,"CHILD_MAX") ::? + (Prim.SC_CLK_TCK,"CLK_TCK") ::? + (Prim.SC_CLOCK_SELECTION,"CLOCK_SELECTION") ::? + (Prim.SC_COLL_WEIGHTS_MAX,"COLL_WEIGHTS_MAX") ::? + (Prim.SC_CPUTIME,"CPUTIME") ::? + (Prim.SC_DELAYTIMER_MAX,"DELAYTIMER_MAX") ::? + (Prim.SC_EXPR_NEST_MAX,"EXPR_NEST_MAX") ::? + (Prim.SC_FSYNC,"FSYNC") ::? + (Prim.SC_GETGR_R_SIZE_MAX,"GETGR_R_SIZE_MAX") ::? + (Prim.SC_GETPW_R_SIZE_MAX,"GETPW_R_SIZE_MAX") ::? + (Prim.SC_HOST_NAME_MAX,"HOST_NAME_MAX") ::? + (Prim.SC_IOV_MAX,"IOV_MAX") ::? + (Prim.SC_IPV6,"IPV6") ::? + (Prim.SC_JOB_CONTROL,"JOB_CONTROL") ::? + (Prim.SC_LINE_MAX,"LINE_MAX") ::? + (Prim.SC_LOGIN_NAME_MAX,"LOGIN_NAME_MAX") ::? + (Prim.SC_MAPPED_FILES,"MAPPED_FILES") ::? + (Prim.SC_MEMLOCK,"MEMLOCK") ::? + (Prim.SC_MEMLOCK_RANGE,"MEMLOCK_RANGE") ::? + (Prim.SC_MEMORY_PROTECTION,"MEMORY_PROTECTION") ::? + (Prim.SC_MESSAGE_PASSING,"MESSAGE_PASSING") ::? + (Prim.SC_MONOTONIC_CLOCK,"MONOTONIC_CLOCK") ::? + (Prim.SC_MQ_OPEN_MAX,"MQ_OPEN_MAX") ::? + (Prim.SC_MQ_PRIO_MAX,"MQ_PRIO_MAX") ::? + (Prim.SC_NGROUPS_MAX,"NGROUPS_MAX") ::? + (Prim.SC_NPROCESSORS_CONF,"NPROCESSORS_CONF") ::? + (Prim.SC_NPROCESSORS_ONLN,"NPROCESSORS_ONLN") ::? + (Prim.SC_OPEN_MAX,"OPEN_MAX") ::? + (Prim.SC_PAGESIZE,"PAGESIZE") ::? + (Prim.SC_PAGE_SIZE,"PAGE_SIZE") ::? + (Prim.SC_PHYS_PAGES,"PHYS_PAGES") ::? + (Prim.SC_PRIORITIZED_IO,"PRIORITIZED_IO") ::? + (Prim.SC_PRIORITY_SCHEDULING,"PRIORITY_SCHEDULING") ::? + (Prim.SC_RAW_SOCKETS,"RAW_SOCKETS") ::? + (Prim.SC_READER_WRITER_LOCKS,"READER_WRITER_LOCKS") ::? + (Prim.SC_REALTIME_SIGNALS,"REALTIME_SIGNALS") ::? + (Prim.SC_REGEXP,"REGEXP") ::? + (Prim.SC_RE_DUP_MAX,"RE_DUP_MAX") ::? + (Prim.SC_RTSIG_MAX,"RTSIG_MAX") ::? + (Prim.SC_SAVED_IDS,"SAVED_IDS") ::? + (Prim.SC_SEMAPHORES,"SEMAPHORES") ::? + (Prim.SC_SEM_NSEMS_MAX,"SEM_NSEMS_MAX") ::? + (Prim.SC_SEM_VALUE_MAX,"SEM_VALUE_MAX") ::? + (Prim.SC_SHARED_MEMORY_OBJECTS,"SHARED_MEMORY_OBJECTS") ::? + (Prim.SC_SHELL,"SHELL") ::? + (Prim.SC_SIGQUEUE_MAX,"SIGQUEUE_MAX") ::? + (Prim.SC_SPAWN,"SPAWN") ::? + (Prim.SC_SPIN_LOCKS,"SPIN_LOCKS") ::? + (Prim.SC_SPORADIC_SERVER,"SPORADIC_SERVER") ::? + (Prim.SC_SS_REPL_MAX,"SS_REPL_MAX") ::? + (Prim.SC_STREAM_MAX,"STREAM_MAX") ::? + (Prim.SC_SYMLOOP_MAX,"SYMLOOP_MAX") ::? + (Prim.SC_SYNCHRONIZED_IO,"SYNCHRONIZED_IO") ::? + (Prim.SC_THREADS,"THREADS") ::? + (Prim.SC_THREAD_ATTR_STACKADDR,"THREAD_ATTR_STACKADDR") ::? + (Prim.SC_THREAD_ATTR_STACKSIZE,"THREAD_ATTR_STACKSIZE") ::? + (Prim.SC_THREAD_CPUTIME,"THREAD_CPUTIME") ::? + (Prim.SC_THREAD_DESTRUCTOR_ITERATIONS,"THREAD_DESTRUCTOR_ITERATIONS") ::? + (Prim.SC_THREAD_KEYS_MAX,"THREAD_KEYS_MAX") ::? + (Prim.SC_THREAD_PRIORITY_SCHEDULING,"THREAD_PRIORITY_SCHEDULING") ::? + (Prim.SC_THREAD_PRIO_INHERIT,"THREAD_PRIO_INHERIT") ::? + (Prim.SC_THREAD_PRIO_PROTECT,"THREAD_PRIO_PROTECT") ::? + (Prim.SC_THREAD_PROCESS_SHARED,"THREAD_PROCESS_SHARED") ::? + (Prim.SC_THREAD_SAFE_FUNCTIONS,"THREAD_SAFE_FUNCTIONS") ::? + (Prim.SC_THREAD_SPORADIC_SERVER,"THREAD_SPORADIC_SERVER") ::? + (Prim.SC_THREAD_STACK_MIN,"THREAD_STACK_MIN") ::? + (Prim.SC_THREAD_THREADS_MAX,"THREAD_THREADS_MAX") ::? + (Prim.SC_TIMEOUTS,"TIMEOUTS") ::? + (Prim.SC_TIMERS,"TIMERS") ::? + (Prim.SC_TIMER_MAX,"TIMER_MAX") ::? + (Prim.SC_TRACE,"TRACE") ::? + (Prim.SC_TRACE_EVENT_FILTER,"TRACE_EVENT_FILTER") ::? + (Prim.SC_TRACE_EVENT_NAME_MAX,"TRACE_EVENT_NAME_MAX") ::? + (Prim.SC_TRACE_INHERIT,"TRACE_INHERIT") ::? + (Prim.SC_TRACE_LOG,"TRACE_LOG") ::? + (Prim.SC_TRACE_NAME_MAX,"TRACE_NAME_MAX") ::? + (Prim.SC_TRACE_SYS_MAX,"TRACE_SYS_MAX") ::? + (Prim.SC_TRACE_USER_EVENT_MAX,"TRACE_USER_EVENT_MAX") ::? + (Prim.SC_TTY_NAME_MAX,"TTY_NAME_MAX") ::? + (Prim.SC_TYPED_MEMORY_OBJECTS,"TYPED_MEMORY_OBJECTS") ::? + (Prim.SC_TZNAME_MAX,"TZNAME_MAX") ::? + (Prim.SC_V6_ILP32_OFF32,"V6_ILP32_OFF32") ::? + (Prim.SC_V6_ILP32_OFFBIG,"V6_ILP32_OFFBIG") ::? + (Prim.SC_V6_LP64_OFF64,"V6_LP64_OFF64") ::? + (Prim.SC_V6_LPBIG_OFFBIG,"V6_LPBIG_OFFBIG") ::? + (Prim.SC_VERSION,"VERSION") ::? + (Prim.SC_XBS5_ILP32_OFF32,"XBS5_ILP32_OFF32") ::? + (Prim.SC_XBS5_ILP32_OFFBIG,"XBS5_ILP32_OFFBIG") ::? + (Prim.SC_XBS5_LP64_OFF64,"XBS5_LP64_OFF64") ::? + (Prim.SC_XBS5_LPBIG_OFFBIG,"XBS5_LPBIG_OFFBIG") ::? + (Prim.SC_XOPEN_CRYPT,"XOPEN_CRYPT") ::? + (Prim.SC_XOPEN_ENH_I18N,"XOPEN_ENH_I18N") ::? + (Prim.SC_XOPEN_LEGACY,"XOPEN_LEGACY") ::? + (Prim.SC_XOPEN_REALTIME,"XOPEN_REALTIME") ::? + (Prim.SC_XOPEN_REALTIME_THREADS,"XOPEN_REALTIME_THREADS") ::? + (Prim.SC_XOPEN_SHM,"XOPEN_SHM") ::? + (Prim.SC_XOPEN_STREAMS,"XOPEN_STREAMS") ::? + (Prim.SC_XOPEN_UNIX,"XOPEN_UNIX") ::? + (Prim.SC_XOPEN_VERSION,"XOPEN_VERSION") ::? + [] + end + in + fun sysconf s = + case List.find (fn (_, s') => s = s') sysconfNames of + NONE => Error.raiseSys Error.inval + | SOME (n, _) => + (SysWord.fromLargeInt o C_Long.toLarge o SysCall.simpleResult') + ({errVal = C_Long.fromInt ~1}, fn () => Prim.sysconf n) + end + + local + structure Times = Prim.Times + + val clocksPerSec = + (* syconf is not implemented on MinGW; + * we don't want a SysErr during Basis Library initialization. + *) + if (let open Primitive.MLton.Platform.OS in host = MinGW end) + then LargeInt.zero + else SysWord.toLargeIntX (sysconf "CLK_TCK") + + fun cvt (clocks: C_Clock.t) = + Time.fromTicks (LargeInt.quot + (LargeInt.* (C_Clock.toLargeInt clocks, + Time.ticksPerSecond), + clocksPerSec)) + in + fun times () = + SysCall.syscall' + ({errVal = C_Clock.castFromFixedInt ~1}, fn () => + (Prim.times (), fn elapsed => + {elapsed = cvt elapsed, + utime = cvt (Times.getUTime ()), + stime = cvt (Times.getSTime ()), + cutime = cvt (Times.getCUTime ()), + cstime = cvt (Times.getCSTime ())})) + end + + fun environ () = CSS.toList (Prim.environGet ()) + + fun getenv name = + let + val cs = Prim.getenv (NullString.nullTerm name) + in + if CUtil.C_Pointer.isNull cs + then NONE + else SOME (CS.toString cs) + end + + fun ctermid () = CS.toString (Prim.ctermid ()) + + fun isatty fd = (Prim.isatty (FileDesc.toRep fd)) <> C_Int.zero + + fun ttyname fd = + SysCall.syscall' + ({errVal = CUtil.C_Pointer.null}, fn () => + (Prim.ttyname (FileDesc.toRep fd), fn cs => + CS.toString cs)) + end diff --git a/basis-library/posix/process.sig b/basis-library/posix/process.sig new file mode 100644 index 0000000..1427b96 --- /dev/null +++ b/basis-library/posix/process.sig @@ -0,0 +1,50 @@ +signature POSIX_PROCESS = + sig + eqtype signal + eqtype pid + + structure W: + sig + include BIT_FLAGS + val untraced: flags + end + + datatype exit_status = + W_EXITED + | W_EXITSTATUS of Word8.word + | W_SIGNALED of signal + | W_STOPPED of signal + + datatype killpid_arg = + K_PROC of pid + | K_SAME_GROUP + | K_GROUP of pid + + datatype waitpid_arg = + W_ANY_CHILD + | W_CHILD of pid + | W_SAME_GROUP + | W_GROUP of pid + + val alarm: Time.time -> Time.time + val exec: string * string list -> 'a + val exece: string * string list * string list -> 'a + val execp: string * string list -> 'a + val exit: Word8.word -> 'a + val fork: unit -> pid option + val fromStatus: OS.Process.status -> exit_status + val kill: killpid_arg * signal -> unit + val pause: unit -> unit + val pidToWord: pid -> SysWord.word + val sleep: Time.time -> Time.time + val wait: unit -> pid * exit_status + val waitpid: waitpid_arg * W.flags list -> pid * exit_status + val waitpid_nh: waitpid_arg * W.flags list -> (pid * exit_status) option + val wordToPid: SysWord.word -> pid + end + +signature POSIX_PROCESS_EXTRA = + sig + include POSIX_PROCESS + val fromStatus': C_Status.t -> exit_status + end diff --git a/basis-library/posix/process.sml b/basis-library/posix/process.sml new file mode 100644 index 0000000..bd403c0 --- /dev/null +++ b/basis-library/posix/process.sml @@ -0,0 +1,207 @@ +(* Copyright (C) 2009 Matthew Fluet. + * Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PosixProcess: POSIX_PROCESS_EXTRA = + struct + structure Prim = PrimitiveFFI.Posix.Process + open Prim + structure FileDesc = PrePosix.FileDesc + structure PId = PrePosix.PId + structure Signal = PrePosix.Signal + + structure Error = PosixError + structure SysCall = Error.SysCall + + type signal = Signal.t + type pid = PId.t + + val pidToWord = C_PId.castToSysWord o PId.toRep + val wordToPid = PId.fromRep o C_PId.castFromSysWord + + fun fork () = + SysCall.syscall' + ({errVal = C_PId.castFromFixedInt ~1}, fn () => + (Prim.fork (), fn p => + if p = C_PId.castFromFixedInt 0 + then NONE + else SOME (PId.fromRep p))) + + val fork = + if Primitive.MLton.Platform.OS.forkIsEnabled + then fork + else fn () => Error.raiseSys Error.nosys + + val conv = NullString.nullTerm + val convs = CUtil.C_StringArray.fromList + + fun exece (path, args, env): 'a = + let + val path = conv path + val args = convs args + val env = convs env + in + (SysCall.simple + (fn () => Prim.exece (path, args, env)) + ; raise Fail "Posix.Process.exece") + end + + fun exec (path, args): 'a = + exece (path, args, PosixProcEnv.environ ()) + + fun execp (file, args): 'a = + let + val file = conv file + val args = convs args + in + (SysCall.simple + (fn () => Prim.execp (file, args)) + ; raise Fail "Posix.Process.execp") + end + + datatype waitpid_arg = + W_ANY_CHILD + | W_CHILD of pid + | W_SAME_GROUP + | W_GROUP of pid + + datatype exit_status = + W_EXITED + | W_EXITSTATUS of Word8.word + | W_SIGNALED of signal + | W_STOPPED of signal + + fun fromStatus' (status : C_Status.t) = + if Prim.ifExited status <> C_Int.zero + then (case Prim.exitStatus status of + 0 => W_EXITED + | n => W_EXITSTATUS (Word8.castFromSysWord (C_Int.castToSysWord n))) + else if Prim.ifSignaled status <> C_Int.zero + then W_SIGNALED (PosixSignal.fromRep (Prim.termSig status)) + else if Prim.ifStopped status <> C_Int.zero + then W_STOPPED (PosixSignal.fromRep (Prim.stopSig status)) + else raise Fail "Posix.Process.fromStatus" + fun fromStatus status = + fromStatus' (PreOS.Status.toRep status) + + structure W = + struct + structure Flags = BitFlags(structure S = C_Int) + open W Flags + (* val continued = CONTINUED *) + val nohang = NOHANG + val untraced = UNTRACED + end + + local + val status: C_Status.t ref = ref (C_Status.fromInt 0) + fun wait (wa, status, flags) = + let + val pid = + case wa of + W_ANY_CHILD => C_PId.castFromFixedInt ~1 + | W_CHILD pid => PId.toRep pid + | W_SAME_GROUP => C_PId.castFromFixedInt 0 + | W_GROUP pid => C_PId.~ (PId.toRep pid) + val flags = W.flags flags + in + (PId.fromRep o SysCall.simpleResultRestart') + ({errVal = C_PId.castFromFixedInt ~1}, fn () => + let + val pid = Prim.waitpid (pid, status, flags) + in + pid + end) + end + fun getStatus () = fromStatus' (!status) + in + fun waitpid (wa, flags) = + let + val pid = wait (wa, status, flags) + in + (pid, getStatus ()) + end + + fun waitpid_nh (wa, flags) = + let + val pid = wait (wa, status, W.nohang :: flags) + in + if PId.fromRep (C_PId.castFromFixedInt 0) = pid + then NONE + else SOME (pid, getStatus ()) + end + end + + fun wait () = waitpid (W_ANY_CHILD, []) + + fun exit (w: Word8.word): 'a = + (* Posix.Process.exit does not call atExit cleaners, as per the basis + * library spec. + *) + (Prim.exit (C_Status.castFromSysWord (Word8.castToSysWord w)) + ; raise Fail "Posix.Process.exit") + + datatype killpid_arg = + K_PROC of pid + | K_SAME_GROUP + | K_GROUP of pid + + fun kill (ka: killpid_arg, s: signal): unit = + let + val pid = + case ka of + K_PROC pid => PId.toRep pid + | K_SAME_GROUP => C_PId.castFromFixedInt ~1 + | K_GROUP pid => C_PId.~ (PId.toRep pid) + val s = PosixSignal.toRep s + in + SysCall.simple (fn () => Prim.kill (pid, s)) + end + + local + fun wrap prim (t: Time.time): Time.time = + Time.fromSeconds + (C_UInt.toLargeInt + (prim + ((C_UInt.fromLargeInt (Time.toSeconds t)) + handle Overflow => Error.raiseSys Error.inval))) + in + val alarm = wrap Prim.alarm + (* val sleep = wrap Prim.sleep *) + end + + fun sleep (t: Time.time): Time.time = + let + val t = Time.toNanoseconds t + val sec = LargeInt.quot (t, 1000000000) + val nsec = LargeInt.rem (t, 1000000000) + val (sec, nsec) = + (C_Time.fromLargeInt sec, C_Long.fromLargeInt nsec) + handle Overflow => Error.raiseSys Error.inval + val secRem = ref sec + val nsecRem = ref nsec + fun remaining _ = + Time.+ (Time.fromSeconds (C_Time.toLargeInt (!secRem)), + Time.fromNanoseconds (C_Long.toLargeInt (!nsecRem))) + in + SysCall.syscallErr + ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, fn () => + {handlers = [(Error.intr, remaining)], + post = remaining, + return = Prim.nanosleep (secRem, nsecRem)}) + end + + (* FIXME: pause *) + fun pause () = + SysCall.syscallErr + ({clear = false, restart = false, errVal = C_Int.fromInt ~1}, + fn () => + {return = Prim.pause (), + post = fn _ => (), + handlers = [(Error.intr, fn () => ())]}) + end diff --git a/basis-library/posix/signal.sig b/basis-library/posix/signal.sig new file mode 100644 index 0000000..2824b29 --- /dev/null +++ b/basis-library/posix/signal.sig @@ -0,0 +1,45 @@ +signature POSIX_SIGNAL = + sig + eqtype signal + + val toWord: signal -> SysWord.word + val fromWord: SysWord.word -> signal + + val abrt: signal + val alrm: signal + val bus: signal + val fpe: signal + val hup: signal + val ill: signal + val int: signal + val kill: signal + val pipe: signal + val quit: signal + val segv: signal + val term: signal + val usr1: signal + val usr2: signal + val chld: signal + val cont: signal + val stop: signal + val tstp: signal + val ttin: signal + val ttou: signal + end + +signature POSIX_SIGNAL_EXTRA = + sig + include POSIX_SIGNAL + + val prof: signal + val vtalrm: signal + + val fromRep: C_Int.t -> signal + val toRep: signal -> C_Int.t + + val repFromInt: int -> C_Int.t + val repToInt: C_Int.t -> int + + val fromInt: int -> signal + val toInt: signal -> int + end diff --git a/basis-library/posix/signal.sml b/basis-library/posix/signal.sml new file mode 100644 index 0000000..8af41ad --- /dev/null +++ b/basis-library/posix/signal.sml @@ -0,0 +1,59 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PosixSignal: POSIX_SIGNAL_EXTRA = + struct + open PrimitiveFFI.Posix.Signal + structure Signal = PrePosix.Signal + + type signal = Signal.t + + val abrt = Signal.fromRep SIGABRT + val alrm = Signal.fromRep SIGALRM + val bus = Signal.fromRep SIGBUS + val chld = Signal.fromRep SIGCHLD + val cont = Signal.fromRep SIGCONT + val fpe = Signal.fromRep SIGFPE + val hup = Signal.fromRep SIGHUP + val ill = Signal.fromRep SIGILL + val int = Signal.fromRep SIGINT + val kill = Signal.fromRep SIGKILL + val pipe = Signal.fromRep SIGPIPE + val poll = Signal.fromRep SIGPOLL + val prof = Signal.fromRep SIGPROF + val quit = Signal.fromRep SIGQUIT + val segv = Signal.fromRep SIGSEGV + val stop = Signal.fromRep SIGSTOP + val sys = Signal.fromRep SIGSYS + val term = Signal.fromRep SIGTERM + val trap = Signal.fromRep SIGTRAP + val tstp = Signal.fromRep SIGTSTP + val ttin = Signal.fromRep SIGTTIN + val ttou = Signal.fromRep SIGTTOU + val urg = Signal.fromRep SIGURG + val usr1 = Signal.fromRep SIGUSR1 + val usr2 = Signal.fromRep SIGUSR2 + val vtalrm = Signal.fromRep SIGVTALRM + val xcpu = Signal.fromRep SIGXCPU + val xfsz = Signal.fromRep SIGXFSZ + + val fromRep = Signal.fromRep + val toRep = Signal.toRep + + val repToInt = C_Int.toInt + val repFromInt = C_Int.fromInt + + val toInt = repToInt o toRep + val fromInt = fromRep o repFromInt + + val repToWord = C_Int.castToSysWord + val repFromWord = C_Int.castFromSysWord + + val toWord = repToWord o toRep + val fromWord = fromRep o repFromWord + end diff --git a/basis-library/posix/stub-mingw.sml b/basis-library/posix/stub-mingw.sml new file mode 100644 index 0000000..35aba39 --- /dev/null +++ b/basis-library/posix/stub-mingw.sml @@ -0,0 +1,142 @@ +(* Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Stub out functions that are not implemented on MinGW. *) +local + structure Error = PosixError + val stub: string * ('a -> 'b) -> ('a -> 'b) = + fn (msg, f) => + if let open Primitive.MLton.Platform.OS in MinGW = host end + then fn _ => (if true + then () + else (PrimitiveFFI.Stdio.print msg + ; PrimitiveFFI.Stdio.print "\n") + ; Error.raiseSysWithMsg (Error.nosys, msg)) + else f +in + structure PrimitiveFFI = + struct + open PrimitiveFFI + + structure OS = + struct + open OS + + structure IO = + struct + open IO + + val poll = stub ("poll", poll) + end + end + + structure Posix = + struct + open Posix + + structure FileSys = + struct + open FileSys + + val chown = stub ("chown", chown) + val fchown = stub ("fchown", fchown) + val fpathconf = stub ("fpathconf", fpathconf) + val link = stub ("link", link) + val mkfifo = stub ("mkfifo", mkfifo) + val pathconf = stub ("pathconf", pathconf) + val readlink = stub ("readlink", readlink) + val symlink = stub ("symlink", symlink) + end + + structure IO = + struct + open IO + + val fcntl2 = stub ("fcntl2", fcntl2) + val fcntl3 = stub ("fcntl3", fcntl3) + end + + structure ProcEnv = + struct + open ProcEnv + + val ctermid = stub ("ctermid", ctermid) + val getegid = stub ("getegid", getegid) + val geteuid = stub ("geteuid", geteuid) + val getgid = stub ("getgid", getgid) + val getgroups = stub ("getgroups", getgroups) + val getlogin = stub ("getlogin", getlogin) + val getpgrp = stub ("getpgrp", getpgrp) + val getppid = stub ("getppid", getppid) + val getuid = stub ("getuid", getuid) + val setgid = stub ("setgid", setgid) + val setgroups = stub ("stegroups", setgroups) + val setpgid = stub ("setpgid", setpgid) + val setsid = stub ("setsid", setsid) + val setuid = stub ("setuid", setuid) + val sysconf = stub ("sysconf", sysconf) + val times = stub ("times", times) + val ttyname = stub ("ttyname", ttyname) + end + + structure Process = + struct + open Process + + val exece = stub ("exece", exece) + val execp = stub ("execp", execp) + val fork = stub ("fork", fork) + val pause = stub ("pause", pause) + val waitpid = fn (args as (pid, _, _)) => + if C_PId.<= (pid, 0) + then stub ("waitpid", waitpid) args + else waitpid args + end + + structure SysDB = + struct + open SysDB + + val getgrgid = stub ("getgrgid", getgrgid) + val getgrnam = stub ("getgrnam", getgrnam) + val getpwuid = stub ("getpwuid", getpwuid) + end + + structure TTY = + struct + open TTY + + structure TC = + struct + open TC + + val drain = stub ("drain", drain) + val flow = stub ("flow", flow) + val flush = stub ("flush", flush) + val getattr = stub ("getattr", getattr) + val getpgrp = stub ("getpgrp", getpgrp) + val sendbreak = stub ("sendbreak", sendbreak) + val setattr = stub ("setattr", setattr) + val setpgrp = stub ("setpgrp", setpgrp) + end + end + end + + structure Socket = + struct + open Socket + + structure UnixSock = + struct + open UnixSock + + val toAddr = stub ("toAddr", toAddr) + val fromAddr = stub ("fromAddr", fromAddr) + end + end + end +end diff --git a/basis-library/posix/sys-db.sig b/basis-library/posix/sys-db.sig new file mode 100644 index 0000000..9ee2f25 --- /dev/null +++ b/basis-library/posix/sys-db.sig @@ -0,0 +1,28 @@ +signature POSIX_SYS_DB = + sig + eqtype uid + eqtype gid + + structure Passwd: + sig + type passwd + val name: passwd -> string + val uid: passwd -> uid + val gid: passwd -> gid + val home: passwd -> string + val shell: passwd -> string + end + + structure Group: + sig + type group + val name: group -> string + val gid: group -> gid + val members: group -> string list + end + + val getgrgid: gid -> Group.group + val getgrnam: string -> Group.group + val getpwuid: uid -> Passwd.passwd + val getpwnam: string -> Passwd.passwd + end diff --git a/basis-library/posix/sys-db.sml b/basis-library/posix/sys-db.sml new file mode 100644 index 0000000..194c3f6 --- /dev/null +++ b/basis-library/posix/sys-db.sml @@ -0,0 +1,98 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PosixSysDB: POSIX_SYS_DB = + struct + structure Prim = PrimitiveFFI.Posix.SysDB + structure GId = PrePosix.GId + structure UId = PrePosix.UId + + structure Error = PosixError + structure SysCall = Error.SysCall + + type gid = GId.t + type uid = UId.t + + structure Passwd = + struct + type passwd = {name: string, + uid: uid, + gid: gid, + home: string, + shell: string} + + structure Passwd = Prim.Passwd + + fun fromC (f: unit -> C_Int.t C_Errno.t, fname, fitem): passwd = + SysCall.syscallErr + ({clear = true, restart = false, errVal = C_Int.zero}, fn () => + {return = f (), + post = fn _ => {name = CUtil.C_String.toString (Passwd.getName ()), + uid = UId.fromRep (Passwd.getUId ()), + gid = GId.fromRep (Passwd.getGId ()), + home = CUtil.C_String.toString (Passwd.getDir ()), + shell = CUtil.C_String.toString (Passwd.getShell ())}, + handlers = [(Error.cleared, fn () => + raise Error.SysErr (concat ["Posix.SysDB.", + fname, + ": no group with ", + fitem], NONE))]}) + + val name: passwd -> string = #name + val uid: passwd -> uid = #uid + val gid: passwd -> gid = #gid + val home: passwd -> string = #home + val shell: passwd -> string = #shell + end + + fun getpwnam name = + let val name = NullString.nullTerm name + in Passwd.fromC (fn () => Prim.getpwnam name, "getpwnam", "name") + end + + fun getpwuid uid = + let val uid = UId.toRep uid + in Passwd.fromC (fn () => Prim.getpwuid uid, "getpwuid", "user id") + end + + structure Group = + struct + type group = {name: string, + gid: gid, + members: string list} + + structure Group = Prim.Group + + fun fromC (f: unit -> C_Int.t C_Errno.t, fname, fitem): group = + SysCall.syscallErr + ({clear = true, restart = false, errVal = C_Int.zero}, fn () => + {return = f (), + post = fn _ => {name = CUtil.C_String.toString (Group.getName ()), + gid = GId.fromRep (Group.getGId ()), + members = CUtil.C_StringArray.toList (Group.getMem ())}, + handlers = [(Error.cleared, fn () => + raise Error.SysErr (concat ["Posix.SysDB.", + fname, + ": no group with ", + fitem], NONE))]}) + + val name: group -> string = #name + val gid: group -> gid = #gid + val members: group -> string list = #members + end + + fun getgrnam name = + let val name = NullString.nullTerm name + in Group.fromC (fn () => Prim.getgrnam name, "getgrnam", "name") + end + + fun getgrgid gid = + let val gid = GId.toRep gid + in Group.fromC (fn () => Prim.getgrgid gid, "getgrgid", "group id") + end + end diff --git a/basis-library/posix/tty.sig b/basis-library/posix/tty.sig new file mode 100644 index 0000000..66b441c --- /dev/null +++ b/basis-library/posix/tty.sig @@ -0,0 +1,165 @@ +signature POSIX_TTY = + sig + eqtype pid + eqtype file_desc + + structure V: + sig + val eof: int + val eol: int + val erase: int + val intr: int + val kill: int + val min: int + val quit: int + val susp: int + val time: int + val start: int + val stop: int + val nccs: int + + type cc + val cc: (int * char) list -> cc + val update: cc * (int * char) list -> cc + val sub: cc * int -> char + end + + structure I: + sig + include BIT_FLAGS + val brkint: flags + val icrnl: flags + val ignbrk: flags + val igncr: flags + val ignpar: flags + val inlcr: flags + val inpck: flags + val istrip: flags + val ixoff: flags + val ixon: flags + val parmrk: flags + end + + structure O: + sig + include BIT_FLAGS + val opost: flags + end + + structure C: + sig + include BIT_FLAGS + val clocal: flags + val cread: flags + val cs5: flags + val cs6: flags + val cs7: flags + val cs8: flags + val csize: flags + val cstopb: flags + val hupcl: flags + val parenb: flags + val parodd: flags + end + + structure L: + sig + include BIT_FLAGS + val echo: flags + val echoe: flags + val echok: flags + val echonl: flags + val icanon: flags + val iexten: flags + val isig: flags + val noflsh: flags + val tostop: flags + end + + eqtype speed + + val compareSpeed: speed * speed -> order + val speedToWord: speed -> SysWord.word + val wordToSpeed: SysWord.word -> speed + + val b0: speed + val b50: speed + val b75: speed + val b110: speed + val b134: speed + val b150: speed + val b200: speed + val b300: speed + val b600: speed + val b1200: speed + val b1800: speed + val b2400: speed + val b4800: speed + val b9600: speed + val b19200: speed + val b38400: speed + + type termios + + val termios: {iflag: I.flags, + oflag: O.flags, + cflag: C.flags, + lflag: L.flags, + cc: V.cc, + ispeed: speed, + ospeed: speed} -> termios + + val fieldsOf: termios -> {iflag: I.flags, + oflag: O.flags, + cflag: C.flags, + lflag: L.flags, + cc: V.cc, + ispeed: speed, + ospeed: speed} + val getiflag: termios -> I.flags + val getoflag: termios -> O.flags + val getcflag: termios -> C.flags + val getlflag: termios -> L.flags + val getcc: termios -> V.cc + + structure CF: + sig + val getospeed: termios -> speed + val setospeed: termios * speed -> termios + val getispeed: termios -> speed + val setispeed: termios * speed -> termios + end + + structure TC: + sig + eqtype set_action + + val sanow: set_action + val sadrain: set_action + val saflush: set_action + + eqtype flow_action + + val ooff: flow_action + val oon: flow_action + val ioff: flow_action + val ion: flow_action + + eqtype queue_sel + + val iflush: queue_sel + val oflush: queue_sel + val ioflush: queue_sel + + val getattr: file_desc -> termios + val setattr: file_desc * set_action * termios -> unit + + val sendbreak: file_desc * int -> unit + val drain: file_desc -> unit + val flush: file_desc * queue_sel -> unit + val flow: file_desc * flow_action -> unit + + val getpgrp: file_desc -> pid + val setpgrp: file_desc * pid -> unit + end + end diff --git a/basis-library/posix/tty.sml b/basis-library/posix/tty.sml new file mode 100644 index 0000000..d7f08c8 --- /dev/null +++ b/basis-library/posix/tty.sml @@ -0,0 +1,286 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PosixTTY: POSIX_TTY = + struct + structure Prim = PrimitiveFFI.Posix.TTY + open Prim + structure FileDesc = PrePosix.FileDesc + structure PId = PrePosix.PId + + structure Error = PosixError + structure SysCall = Error.SysCall + + type file_desc = FileDesc.t + type pid = PId.t + + structure V = + struct + open V + val nccs = C_Int.toInt NCCS + val eof = C_Int.toInt VEOF + val eol = C_Int.toInt VEOL + val erase = C_Int.toInt VERASE + val intr = C_Int.toInt VINTR + val kill = C_Int.toInt VKILL + val min = C_Int.toInt VMIN + val quit = C_Int.toInt VQUIT + val susp = C_Int.toInt VSUSP + val time = C_Int.toInt VTIME + val start = C_Int.toInt VSTART + val stop = C_Int.toInt VSTOP + + type cc = C_CC.t array + + val default = C_CC.castFromSysWord 0w0 + + fun new () = Array.array (nccs, default) + + fun updates (a, l) = + List.app (fn (i, cc) => + Array.update (a, i, (C_CC.castFromSysWord o Word8.castToSysWord o Byte.charToByte) cc)) + l + + fun cc l = let val a = new () + in updates (a, l) + ; a + end + + fun update (a, l) = + let val a' = new () + in Array.copy {src = a, dst = a', di = 0} + ; updates (a', l) + ; a' + end + + val sub = (Byte.byteToChar o Word8.castFromSysWord o C_CC.castToSysWord) o Array.sub + end + + structure Flags = BitFlags(structure S = C_TCFlag) + structure I = + struct + open I Flags + val brkint = BRKINT + val icrnl = ICRNL + val ignbrk = IGNBRK + val igncr = IGNCR + val ignpar = IGNPAR + val inlcr = INLCR + val inpck = INPCK + val istrip = ISTRIP + val ixany = IXANY + val ixoff = IXOFF + val ixon = IXON + val parmrk = PARMRK + end + + structure O = + struct + open O Flags + val bs0 = BS0 + val bs1 = BS1 + val bsdly = BSDLY + val cr0 = CR0 + val cr1 = CR1 + val cr2 = CR2 + val cr3 = CR3 + val crdly = CRDLY + val ff0 = FF0 + val ff1 = FF1 + val ffdly = FFDLY + val nl0 = NL0 + val nl1 = NL1 + val onldly = NLDLY + val ocrnl = OCRNL + val ofill = OFILL + val onlcr = ONLCR + val onlret = ONLRET + val onocr = ONOCR + val opost = OPOST + val tab0 = TAB0 + val tab1 = TAB1 + val tab2 = TAB2 + val tab3 = TAB3 + val tabdly = TABDLY + val vt0 = VT0 + val vt1 = VT1 + val vtdly = VTDLY + end + + structure C = + struct + open C Flags + val clocal = CLOCAL + val cread = CREAD + val cs5 = CS5 + val cs6 = CS6 + val cs7 = CS7 + val cs8 = CS8 + val csize = CSIZE + val cstopb = CSTOPB + val hupcl = HUPCL + val parenb = PARENB + val parodd = PARODD + end + + structure L = + struct + open L Flags + val echo = ECHO + val echoe = ECHOE + val echok = ECHOK + val echonl = ECHONL + val icanon = ICANON + val iexten = IEXTEN + val isig = ISIG + val noflsh = NOFLSH + val tostop = TOSTOP + end + + type speed = C_Speed.t + + val b0 = B0 + val b110 = B110 + val b1200 = B1200 + val b134 = B134 + val b150 = B150 + val b1800 = B1800 + val b19200 = B19200 + val b200 = B200 + val b2400 = B2400 + val b300 = B300 + val b38400 = B38400 + val b4800 = B4800 + val b50 = B50 + val b600 = B600 + val b75 = B75 + val b9600 = B9600 + + val compareSpeed = C_Speed.compare + val speedToWord = C_Speed.castToSysWord + val wordToSpeed = C_Speed.castFromSysWord + + type termios = {iflag: I.flags, + oflag: O.flags, + cflag: C.flags, + lflag: L.flags, + cc: V.cc, + ispeed: speed, + ospeed: speed} + + val id = fn x => x + val termios = id + val fieldsOf = id + + val getiflag: termios -> I.flags = #iflag + val getoflag: termios -> O.flags = #oflag + val getcflag: termios -> C.flags = #cflag + val getlflag: termios -> L.flags = #oflag + val getcc: termios -> V.cc = #cc + + structure CF = + struct + val getospeed: termios -> speed = #ospeed + fun setospeed ({iflag, oflag, cflag, lflag, cc, ispeed, ...}: termios, + ospeed: speed): termios = + {iflag = iflag, + oflag = oflag, + cflag = cflag, + lflag = lflag, + cc = cc, + ispeed = ispeed, + ospeed = ospeed} + + val getispeed: termios -> speed = #ispeed + + fun setispeed ({iflag, oflag, cflag, lflag, cc, ospeed, ...}: termios, + ispeed: speed): termios = + {iflag = iflag, + oflag = oflag, + cflag = cflag, + lflag = lflag, + cc = cc, + ispeed = ispeed, + ospeed = ospeed} + end + + structure Termios = Prim.Termios + + structure TC = + struct + open Prim.TC + + type set_action = C_Int.t + val sadrain = TCSADRAIN + val saflush = TCSAFLUSH + val sanow = TCSANOW + + type flow_action = C_Int.t + val ioff = TCIOFF + val ion = TCION + val ooff = TCOOFF + val oon = TCOON + + type queue_sel = C_Int.t + val iflush = TCIFLUSH + val oflush = TCOFLUSH + val ioflush = TCIOFLUSH + + fun getattr fd = + SysCall.syscallRestart + (fn () => + (Prim.TC.getattr (FileDesc.toRep fd), fn _ => + {iflag = Termios.getIFlag (), + oflag = Termios.getOFlag (), + cflag = Termios.getCFlag (), + lflag = Termios.getLFlag (), + cc = let val a = V.new () + in Termios.getCC (a); a + end, + ispeed = Termios.cfGetISpeed (), + ospeed = Termios.cfGetOSpeed ()})) + + fun setattr (fd, a, + {iflag, oflag, cflag, lflag, cc, ispeed, ospeed}) = + SysCall.syscallRestart + (fn () => + (Termios.setIFlag iflag + ; Termios.setOFlag oflag + ; Termios.setCFlag cflag + ; Termios.setLFlag lflag + ; SysCall.simple (fn () => Termios.cfSetOSpeed ospeed) + ; SysCall.simple (fn () => Termios.cfSetISpeed ispeed) + ; Termios.setCC cc + ; (Prim.TC.setattr (FileDesc.toRep fd, a), fn _ => ()))) + + fun sendbreak (fd, n) = + SysCall.simpleRestart + (fn () => Prim.TC.sendbreak (FileDesc.toRep fd, C_Int.fromInt n)) + + fun drain fd = + SysCall.simpleRestart + (fn () => Prim.TC.drain (FileDesc.toRep fd)) + + fun flush (fd, n) = + SysCall.simpleRestart + (fn () => Prim.TC.flush (FileDesc.toRep fd, n)) + + fun flow (fd, n) = + SysCall.simpleRestart + (fn () => Prim.TC.flow (FileDesc.toRep fd, n)) + + fun getpgrp fd = + (PId.fromRep o SysCall.simpleResultRestart') + ({errVal = C_PId.castFromFixedInt ~1}, fn () => + Prim.TC.getpgrp (FileDesc.toRep fd)) + + fun setpgrp (fd, pid) = + SysCall.simpleRestart + (fn () => Prim.TC.setpgrp (FileDesc.toRep fd, PId.toRep pid)) + end + end diff --git a/basis-library/primitive/basis-ffi.sml b/basis-library/primitive/basis-ffi.sml new file mode 100644 index 0000000..53a3b44 --- /dev/null +++ b/basis-library/primitive/basis-ffi.sml @@ -0,0 +1,1369 @@ +(* This file is automatically generated. Do not edit. *) + +local open Primitive in +structure PrimitiveFFI = +struct +structure CommandLine = +struct +val (argcGet, argcSet) = _symbol "CommandLine_argc" private : (unit -> (C_Int.t)) * ((C_Int.t) -> unit); +val (argvGet, argvSet) = _symbol "CommandLine_argv" private : (unit -> (C_StringArray.t)) * ((C_StringArray.t) -> unit); +val (commandNameGet, commandNameSet) = _symbol "CommandLine_commandName" private : (unit -> (C_String.t)) * ((C_String.t) -> unit); +end +structure Cygwin = +struct +val toFullWindowsPath = _import "Cygwin_toFullWindowsPath" private : NullString8.t -> C_String.t; +end +structure Date = +struct +val gmTime = _import "Date_gmTime" private : (C_Time.t) ref -> (C_Int.t) C_Errno.t; +val localOffset = _import "Date_localOffset" private : unit -> C_Double.t; +val localTime = _import "Date_localTime" private : (C_Time.t) ref -> (C_Int.t) C_Errno.t; +val mkTime = _import "Date_mkTime" private : unit -> (C_Time.t) C_Errno.t; +val strfTime = _import "Date_strfTime" private : (Char8.t) array * C_Size.t * NullString8.t -> C_Size.t; +structure Tm = +struct +val getHour = _import "Date_Tm_getHour" private : unit -> C_Int.t; +val getIsDst = _import "Date_Tm_getIsDst" private : unit -> C_Int.t; +val getMDay = _import "Date_Tm_getMDay" private : unit -> C_Int.t; +val getMin = _import "Date_Tm_getMin" private : unit -> C_Int.t; +val getMon = _import "Date_Tm_getMon" private : unit -> C_Int.t; +val getSec = _import "Date_Tm_getSec" private : unit -> C_Int.t; +val getWDay = _import "Date_Tm_getWDay" private : unit -> C_Int.t; +val getYDay = _import "Date_Tm_getYDay" private : unit -> C_Int.t; +val getYear = _import "Date_Tm_getYear" private : unit -> C_Int.t; +val setHour = _import "Date_Tm_setHour" private : C_Int.t -> unit; +val setIsDst = _import "Date_Tm_setIsDst" private : C_Int.t -> unit; +val setMDay = _import "Date_Tm_setMDay" private : C_Int.t -> unit; +val setMin = _import "Date_Tm_setMin" private : C_Int.t -> unit; +val setMon = _import "Date_Tm_setMon" private : C_Int.t -> unit; +val setSec = _import "Date_Tm_setSec" private : C_Int.t -> unit; +val setWDay = _import "Date_Tm_setWDay" private : C_Int.t -> unit; +val setYDay = _import "Date_Tm_setYDay" private : C_Int.t -> unit; +val setYear = _import "Date_Tm_setYear" private : C_Int.t -> unit; +end +end +structure IEEEReal = +struct +val getRoundingMode = _import "IEEEReal_getRoundingMode" private : unit -> C_Int.t; +structure RoundingMode = +struct +val FE_DOWNWARD = _const "IEEEReal_RoundingMode_FE_DOWNWARD" : C_Int.t; +val FE_NOSUPPORT = _const "IEEEReal_RoundingMode_FE_NOSUPPORT" : C_Int.t; +val FE_TONEAREST = _const "IEEEReal_RoundingMode_FE_TONEAREST" : C_Int.t; +val FE_TOWARDZERO = _const "IEEEReal_RoundingMode_FE_TOWARDZERO" : C_Int.t; +val FE_UPWARD = _const "IEEEReal_RoundingMode_FE_UPWARD" : C_Int.t; +end +val setRoundingMode = _import "IEEEReal_setRoundingMode" private : C_Int.t -> C_Int.t; +end +structure MinGW = +struct +val clearNonBlock = _import "MinGW_clearNonBlock" private : C_Fd.t -> unit; +val getTempPath = _import "MinGW_getTempPath" private : C_Size.t * (Char8.t) array -> C_Size.t; +val setNonBlock = _import "MinGW_setNonBlock" private : C_Fd.t -> unit; +end +structure MLton = +struct +val bug = _import "MLton_bug" private : String8.t -> unit; +structure Itimer = +struct +val PROF = _const "MLton_Itimer_PROF" : C_Int.t; +val REAL = _const "MLton_Itimer_REAL" : C_Int.t; +val set = _import "MLton_Itimer_set" private : C_Int.t * C_Time.t * C_SUSeconds.t * C_Time.t * C_SUSeconds.t -> (C_Int.t) C_Errno.t; +val VIRTUAL = _const "MLton_Itimer_VIRTUAL" : C_Int.t; +end +structure Process = +struct +val spawne = _import "MLton_Process_spawne" private : NullString8.t * (NullString8.t) array * (NullString8.t) array -> (C_PId.t) C_Errno.t; +val spawnp = _import "MLton_Process_spawnp" private : NullString8.t * (NullString8.t) array -> (C_PId.t) C_Errno.t; +end +structure Rlimit = +struct +val AS = _const "MLton_Rlimit_AS" : C_Int.t; +val CORE = _const "MLton_Rlimit_CORE" : C_Int.t; +val CPU = _const "MLton_Rlimit_CPU" : C_Int.t; +val DATA = _const "MLton_Rlimit_DATA" : C_Int.t; +val FSIZE = _const "MLton_Rlimit_FSIZE" : C_Int.t; +val get = _import "MLton_Rlimit_get" private : C_Int.t -> (C_Int.t) C_Errno.t; +val getHard = _import "MLton_Rlimit_getHard" private : unit -> C_RLim.t; +val getSoft = _import "MLton_Rlimit_getSoft" private : unit -> C_RLim.t; +val INFINITY = _const "MLton_Rlimit_INFINITY" : C_RLim.t; +val MEMLOCK = _const "MLton_Rlimit_MEMLOCK" : C_Int.t; +val NOFILE = _const "MLton_Rlimit_NOFILE" : C_Int.t; +val NPROC = _const "MLton_Rlimit_NPROC" : C_Int.t; +val RSS = _const "MLton_Rlimit_RSS" : C_Int.t; +val set = _import "MLton_Rlimit_set" private : C_Int.t * C_RLim.t * C_RLim.t -> (C_Int.t) C_Errno.t; +val STACK = _const "MLton_Rlimit_STACK" : C_Int.t; +end +structure Rusage = +struct +val children_stime_sec = _import "MLton_Rusage_children_stime_sec" private : unit -> C_Time.t; +val children_stime_usec = _import "MLton_Rusage_children_stime_usec" private : unit -> C_SUSeconds.t; +val children_utime_sec = _import "MLton_Rusage_children_utime_sec" private : unit -> C_Time.t; +val children_utime_usec = _import "MLton_Rusage_children_utime_usec" private : unit -> C_SUSeconds.t; +val gc_stime_sec = _import "MLton_Rusage_gc_stime_sec" private : unit -> C_Time.t; +val gc_stime_usec = _import "MLton_Rusage_gc_stime_usec" private : unit -> C_SUSeconds.t; +val gc_utime_sec = _import "MLton_Rusage_gc_utime_sec" private : unit -> C_Time.t; +val gc_utime_usec = _import "MLton_Rusage_gc_utime_usec" private : unit -> C_SUSeconds.t; +val getrusage = _import "MLton_Rusage_getrusage" private : unit -> unit; +val self_stime_sec = _import "MLton_Rusage_self_stime_sec" private : unit -> C_Time.t; +val self_stime_usec = _import "MLton_Rusage_self_stime_usec" private : unit -> C_SUSeconds.t; +val self_utime_sec = _import "MLton_Rusage_self_utime_sec" private : unit -> C_Time.t; +val self_utime_usec = _import "MLton_Rusage_self_utime_usec" private : unit -> C_SUSeconds.t; +end +structure Syslog = +struct +val closelog = _import "MLton_Syslog_closelog" private : unit -> unit; +structure Facility = +struct +val LOG_AUTH = _const "MLton_Syslog_Facility_LOG_AUTH" : C_Int.t; +val LOG_CRON = _const "MLton_Syslog_Facility_LOG_CRON" : C_Int.t; +val LOG_DAEMON = _const "MLton_Syslog_Facility_LOG_DAEMON" : C_Int.t; +val LOG_KERN = _const "MLton_Syslog_Facility_LOG_KERN" : C_Int.t; +val LOG_LOCAL0 = _const "MLton_Syslog_Facility_LOG_LOCAL0" : C_Int.t; +val LOG_LOCAL1 = _const "MLton_Syslog_Facility_LOG_LOCAL1" : C_Int.t; +val LOG_LOCAL2 = _const "MLton_Syslog_Facility_LOG_LOCAL2" : C_Int.t; +val LOG_LOCAL3 = _const "MLton_Syslog_Facility_LOG_LOCAL3" : C_Int.t; +val LOG_LOCAL4 = _const "MLton_Syslog_Facility_LOG_LOCAL4" : C_Int.t; +val LOG_LOCAL5 = _const "MLton_Syslog_Facility_LOG_LOCAL5" : C_Int.t; +val LOG_LOCAL6 = _const "MLton_Syslog_Facility_LOG_LOCAL6" : C_Int.t; +val LOG_LOCAL7 = _const "MLton_Syslog_Facility_LOG_LOCAL7" : C_Int.t; +val LOG_LPR = _const "MLton_Syslog_Facility_LOG_LPR" : C_Int.t; +val LOG_MAIL = _const "MLton_Syslog_Facility_LOG_MAIL" : C_Int.t; +val LOG_NEWS = _const "MLton_Syslog_Facility_LOG_NEWS" : C_Int.t; +val LOG_SYSLOG = _const "MLton_Syslog_Facility_LOG_SYSLOG" : C_Int.t; +val LOG_USER = _const "MLton_Syslog_Facility_LOG_USER" : C_Int.t; +val LOG_UUCP = _const "MLton_Syslog_Facility_LOG_UUCP" : C_Int.t; +end +structure Logopt = +struct +val LOG_CONS = _const "MLton_Syslog_Logopt_LOG_CONS" : C_Int.t; +val LOG_NDELAY = _const "MLton_Syslog_Logopt_LOG_NDELAY" : C_Int.t; +val LOG_NOWAIT = _const "MLton_Syslog_Logopt_LOG_NOWAIT" : C_Int.t; +val LOG_ODELAY = _const "MLton_Syslog_Logopt_LOG_ODELAY" : C_Int.t; +val LOG_PERROR = _const "MLton_Syslog_Logopt_LOG_PERROR" : C_Int.t; +val LOG_PID = _const "MLton_Syslog_Logopt_LOG_PID" : C_Int.t; +end +val openlog = _import "MLton_Syslog_openlog" private : NullString8.t * C_Int.t * C_Int.t -> unit; +structure Severity = +struct +val LOG_ALERT = _const "MLton_Syslog_Severity_LOG_ALERT" : C_Int.t; +val LOG_CRIT = _const "MLton_Syslog_Severity_LOG_CRIT" : C_Int.t; +val LOG_DEBUG = _const "MLton_Syslog_Severity_LOG_DEBUG" : C_Int.t; +val LOG_EMERG = _const "MLton_Syslog_Severity_LOG_EMERG" : C_Int.t; +val LOG_ERR = _const "MLton_Syslog_Severity_LOG_ERR" : C_Int.t; +val LOG_INFO = _const "MLton_Syslog_Severity_LOG_INFO" : C_Int.t; +val LOG_NOTICE = _const "MLton_Syslog_Severity_LOG_NOTICE" : C_Int.t; +val LOG_WARNING = _const "MLton_Syslog_Severity_LOG_WARNING" : C_Int.t; +end +val syslog = _import "MLton_Syslog_syslog" private : C_Int.t * NullString8.t -> unit; +end +end +structure Net = +struct +val htonl = _import "Net_htonl" private : Word32.t -> Word32.t; +val htons = _import "Net_htons" private : Word16.t -> Word16.t; +val ntohl = _import "Net_ntohl" private : Word32.t -> Word32.t; +val ntohs = _import "Net_ntohs" private : Word16.t -> Word16.t; +end +structure NetHostDB = +struct +val getByAddress = _import "NetHostDB_getByAddress" private : (Word8.t) vector * C_Socklen.t -> C_Int.t; +val getByName = _import "NetHostDB_getByName" private : NullString8.t -> C_Int.t; +val getEntryAddrsN = _import "NetHostDB_getEntryAddrsN" private : C_Int.t * (Word8.t) array -> unit; +val getEntryAddrsNum = _import "NetHostDB_getEntryAddrsNum" private : unit -> C_Int.t; +val getEntryAddrType = _import "NetHostDB_getEntryAddrType" private : unit -> C_Int.t; +val getEntryAliasesN = _import "NetHostDB_getEntryAliasesN" private : C_Int.t -> C_String.t; +val getEntryAliasesNum = _import "NetHostDB_getEntryAliasesNum" private : unit -> C_Int.t; +val getEntryLength = _import "NetHostDB_getEntryLength" private : unit -> C_Int.t; +val getEntryName = _import "NetHostDB_getEntryName" private : unit -> C_String.t; +val getHostName = _import "NetHostDB_getHostName" private : (Char8.t) array * C_Size.t -> (C_Int.t) C_Errno.t; +val INADDR_ANY = _const "NetHostDB_INADDR_ANY" : C_Int.t; +val inAddrSize = _const "NetHostDB_inAddrSize" : C_Size.t; +end +structure NetProtDB = +struct +val getByName = _import "NetProtDB_getByName" private : NullString8.t -> C_Int.t; +val getByNumber = _import "NetProtDB_getByNumber" private : C_Int.t -> C_Int.t; +val getEntryAliasesN = _import "NetProtDB_getEntryAliasesN" private : C_Int.t -> C_String.t; +val getEntryAliasesNum = _import "NetProtDB_getEntryAliasesNum" private : unit -> C_Int.t; +val getEntryName = _import "NetProtDB_getEntryName" private : unit -> C_String.t; +val getEntryProto = _import "NetProtDB_getEntryProto" private : unit -> C_Int.t; +end +structure NetServDB = +struct +val getByName = _import "NetServDB_getByName" private : NullString8.t * NullString8.t -> C_Int.t; +val getByNameNull = _import "NetServDB_getByNameNull" private : NullString8.t -> C_Int.t; +val getByPort = _import "NetServDB_getByPort" private : C_Int.t * NullString8.t -> C_Int.t; +val getByPortNull = _import "NetServDB_getByPortNull" private : C_Int.t -> C_Int.t; +val getEntryAliasesN = _import "NetServDB_getEntryAliasesN" private : C_Int.t -> C_String.t; +val getEntryAliasesNum = _import "NetServDB_getEntryAliasesNum" private : unit -> C_Int.t; +val getEntryName = _import "NetServDB_getEntryName" private : unit -> C_String.t; +val getEntryPort = _import "NetServDB_getEntryPort" private : unit -> C_Int.t; +val getEntryProto = _import "NetServDB_getEntryProto" private : unit -> C_String.t; +end +structure OS = +struct +structure IO = +struct +val poll = _import "OS_IO_poll" private : (C_Fd.t) vector * (C_Short.t) vector * C_NFds.t * C_Int.t * (C_Short.t) array -> (C_Int.t) C_Errno.t; +val POLLIN = _const "OS_IO_POLLIN" : C_Short.t; +val POLLOUT = _const "OS_IO_POLLOUT" : C_Short.t; +val POLLPRI = _const "OS_IO_POLLPRI" : C_Short.t; +end +end +structure Posix = +struct +structure Error = +struct +val clearErrno = _import "Posix_Error_clearErrno" private : unit -> unit; +val E2BIG = _const "Posix_Error_E2BIG" : C_Int.t; +val EACCES = _const "Posix_Error_EACCES" : C_Int.t; +val EADDRINUSE = _const "Posix_Error_EADDRINUSE" : C_Int.t; +val EADDRNOTAVAIL = _const "Posix_Error_EADDRNOTAVAIL" : C_Int.t; +val EAFNOSUPPORT = _const "Posix_Error_EAFNOSUPPORT" : C_Int.t; +val EAGAIN = _const "Posix_Error_EAGAIN" : C_Int.t; +val EALREADY = _const "Posix_Error_EALREADY" : C_Int.t; +val EBADF = _const "Posix_Error_EBADF" : C_Int.t; +val EBADMSG = _const "Posix_Error_EBADMSG" : C_Int.t; +val EBUSY = _const "Posix_Error_EBUSY" : C_Int.t; +val ECANCELED = _const "Posix_Error_ECANCELED" : C_Int.t; +val ECHILD = _const "Posix_Error_ECHILD" : C_Int.t; +val ECONNABORTED = _const "Posix_Error_ECONNABORTED" : C_Int.t; +val ECONNREFUSED = _const "Posix_Error_ECONNREFUSED" : C_Int.t; +val ECONNRESET = _const "Posix_Error_ECONNRESET" : C_Int.t; +val EDEADLK = _const "Posix_Error_EDEADLK" : C_Int.t; +val EDESTADDRREQ = _const "Posix_Error_EDESTADDRREQ" : C_Int.t; +val EDOM = _const "Posix_Error_EDOM" : C_Int.t; +val EDQUOT = _const "Posix_Error_EDQUOT" : C_Int.t; +val EEXIST = _const "Posix_Error_EEXIST" : C_Int.t; +val EFAULT = _const "Posix_Error_EFAULT" : C_Int.t; +val EFBIG = _const "Posix_Error_EFBIG" : C_Int.t; +val EHOSTUNREACH = _const "Posix_Error_EHOSTUNREACH" : C_Int.t; +val EIDRM = _const "Posix_Error_EIDRM" : C_Int.t; +val EILSEQ = _const "Posix_Error_EILSEQ" : C_Int.t; +val EINPROGRESS = _const "Posix_Error_EINPROGRESS" : C_Int.t; +val EINTR = _const "Posix_Error_EINTR" : C_Int.t; +val EINVAL = _const "Posix_Error_EINVAL" : C_Int.t; +val EIO = _const "Posix_Error_EIO" : C_Int.t; +val EISCONN = _const "Posix_Error_EISCONN" : C_Int.t; +val EISDIR = _const "Posix_Error_EISDIR" : C_Int.t; +val ELOOP = _const "Posix_Error_ELOOP" : C_Int.t; +val EMFILE = _const "Posix_Error_EMFILE" : C_Int.t; +val EMLINK = _const "Posix_Error_EMLINK" : C_Int.t; +val EMSGSIZE = _const "Posix_Error_EMSGSIZE" : C_Int.t; +val EMULTIHOP = _const "Posix_Error_EMULTIHOP" : C_Int.t; +val ENAMETOOLONG = _const "Posix_Error_ENAMETOOLONG" : C_Int.t; +val ENETDOWN = _const "Posix_Error_ENETDOWN" : C_Int.t; +val ENETRESET = _const "Posix_Error_ENETRESET" : C_Int.t; +val ENETUNREACH = _const "Posix_Error_ENETUNREACH" : C_Int.t; +val ENFILE = _const "Posix_Error_ENFILE" : C_Int.t; +val ENOBUFS = _const "Posix_Error_ENOBUFS" : C_Int.t; +val ENODATA = _const "Posix_Error_ENODATA" : C_Int.t; +val ENODEV = _const "Posix_Error_ENODEV" : C_Int.t; +val ENOENT = _const "Posix_Error_ENOENT" : C_Int.t; +val ENOEXEC = _const "Posix_Error_ENOEXEC" : C_Int.t; +val ENOLCK = _const "Posix_Error_ENOLCK" : C_Int.t; +val ENOLINK = _const "Posix_Error_ENOLINK" : C_Int.t; +val ENOMEM = _const "Posix_Error_ENOMEM" : C_Int.t; +val ENOMSG = _const "Posix_Error_ENOMSG" : C_Int.t; +val ENOPROTOOPT = _const "Posix_Error_ENOPROTOOPT" : C_Int.t; +val ENOSPC = _const "Posix_Error_ENOSPC" : C_Int.t; +val ENOSR = _const "Posix_Error_ENOSR" : C_Int.t; +val ENOSTR = _const "Posix_Error_ENOSTR" : C_Int.t; +val ENOSYS = _const "Posix_Error_ENOSYS" : C_Int.t; +val ENOTCONN = _const "Posix_Error_ENOTCONN" : C_Int.t; +val ENOTDIR = _const "Posix_Error_ENOTDIR" : C_Int.t; +val ENOTEMPTY = _const "Posix_Error_ENOTEMPTY" : C_Int.t; +val ENOTSOCK = _const "Posix_Error_ENOTSOCK" : C_Int.t; +val ENOTSUP = _const "Posix_Error_ENOTSUP" : C_Int.t; +val ENOTTY = _const "Posix_Error_ENOTTY" : C_Int.t; +val ENXIO = _const "Posix_Error_ENXIO" : C_Int.t; +val EOPNOTSUPP = _const "Posix_Error_EOPNOTSUPP" : C_Int.t; +val EOVERFLOW = _const "Posix_Error_EOVERFLOW" : C_Int.t; +val EPERM = _const "Posix_Error_EPERM" : C_Int.t; +val EPIPE = _const "Posix_Error_EPIPE" : C_Int.t; +val EPROTO = _const "Posix_Error_EPROTO" : C_Int.t; +val EPROTONOSUPPORT = _const "Posix_Error_EPROTONOSUPPORT" : C_Int.t; +val EPROTOTYPE = _const "Posix_Error_EPROTOTYPE" : C_Int.t; +val ERANGE = _const "Posix_Error_ERANGE" : C_Int.t; +val EROFS = _const "Posix_Error_EROFS" : C_Int.t; +val ESPIPE = _const "Posix_Error_ESPIPE" : C_Int.t; +val ESRCH = _const "Posix_Error_ESRCH" : C_Int.t; +val ESTALE = _const "Posix_Error_ESTALE" : C_Int.t; +val ETIME = _const "Posix_Error_ETIME" : C_Int.t; +val ETIMEDOUT = _const "Posix_Error_ETIMEDOUT" : C_Int.t; +val ETXTBSY = _const "Posix_Error_ETXTBSY" : C_Int.t; +val EWOULDBLOCK = _const "Posix_Error_EWOULDBLOCK" : C_Int.t; +val EXDEV = _const "Posix_Error_EXDEV" : C_Int.t; +val getErrno = _import "Posix_Error_getErrno" private : unit -> C_Int.t; +val strError = _import "Posix_Error_strError" private : C_Int.t -> C_String.t; +end +structure FileSys = +struct +structure A = +struct +val F_OK = _const "Posix_FileSys_A_F_OK" : C_Int.t; +val R_OK = _const "Posix_FileSys_A_R_OK" : C_Int.t; +val W_OK = _const "Posix_FileSys_A_W_OK" : C_Int.t; +val X_OK = _const "Posix_FileSys_A_X_OK" : C_Int.t; +end +val access = _import "Posix_FileSys_access" private : NullString8.t * C_Int.t -> (C_Int.t) C_Errno.t; +val chdir = _import "Posix_FileSys_chdir" private : NullString8.t -> (C_Int.t) C_Errno.t; +val chmod = _import "Posix_FileSys_chmod" private : NullString8.t * C_Mode.t -> (C_Int.t) C_Errno.t; +val chown = _import "Posix_FileSys_chown" private : NullString8.t * C_UId.t * C_GId.t -> (C_Int.t) C_Errno.t; +structure Dirstream = +struct +val closeDir = _import "Posix_FileSys_Dirstream_closeDir" private : C_DirP.t -> (C_Int.t) C_Errno.t; +val openDir = _import "Posix_FileSys_Dirstream_openDir" private : NullString8.t -> (C_DirP.t) C_Errno.t; +val readDir = _import "Posix_FileSys_Dirstream_readDir" private : C_DirP.t -> (C_String.t) C_Errno.t; +val rewindDir = _import "Posix_FileSys_Dirstream_rewindDir" private : C_DirP.t -> unit; +end +val fchdir = _import "Posix_FileSys_fchdir" private : C_Fd.t -> (C_Int.t) C_Errno.t; +val fchmod = _import "Posix_FileSys_fchmod" private : C_Fd.t * C_Mode.t -> (C_Int.t) C_Errno.t; +val fchown = _import "Posix_FileSys_fchown" private : C_Fd.t * C_UId.t * C_GId.t -> (C_Int.t) C_Errno.t; +val fpathconf = _import "Posix_FileSys_fpathconf" private : C_Fd.t * C_Int.t -> (C_Long.t) C_Errno.t; +val ftruncate = _import "Posix_FileSys_ftruncate" private : C_Fd.t * C_Off.t -> (C_Int.t) C_Errno.t; +val getcwd = _import "Posix_FileSys_getcwd" private : (Char8.t) array * C_Size.t -> (C_String.t) C_Errno.t; +val link = _import "Posix_FileSys_link" private : NullString8.t * NullString8.t -> (C_Int.t) C_Errno.t; +val mkdir = _import "Posix_FileSys_mkdir" private : NullString8.t * C_Mode.t -> (C_Int.t) C_Errno.t; +val mkfifo = _import "Posix_FileSys_mkfifo" private : NullString8.t * C_Mode.t -> (C_Int.t) C_Errno.t; +structure O = +struct +val APPEND = _const "Posix_FileSys_O_APPEND" : C_Int.t; +val BINARY = _const "Posix_FileSys_O_BINARY" : C_Int.t; +val CREAT = _const "Posix_FileSys_O_CREAT" : C_Int.t; +val DSYNC = _const "Posix_FileSys_O_DSYNC" : C_Int.t; +val EXCL = _const "Posix_FileSys_O_EXCL" : C_Int.t; +val NOCTTY = _const "Posix_FileSys_O_NOCTTY" : C_Int.t; +val NONBLOCK = _const "Posix_FileSys_O_NONBLOCK" : C_Int.t; +val RDONLY = _const "Posix_FileSys_O_RDONLY" : C_Int.t; +val RDWR = _const "Posix_FileSys_O_RDWR" : C_Int.t; +val RSYNC = _const "Posix_FileSys_O_RSYNC" : C_Int.t; +val SYNC = _const "Posix_FileSys_O_SYNC" : C_Int.t; +val TEXT = _const "Posix_FileSys_O_TEXT" : C_Int.t; +val TRUNC = _const "Posix_FileSys_O_TRUNC" : C_Int.t; +val WRONLY = _const "Posix_FileSys_O_WRONLY" : C_Int.t; +end +val open2 = _import "Posix_FileSys_open2" private : NullString8.t * C_Int.t -> (C_Fd.t) C_Errno.t; +val open3 = _import "Posix_FileSys_open3" private : NullString8.t * C_Int.t * C_Mode.t -> (C_Fd.t) C_Errno.t; +val pathconf = _import "Posix_FileSys_pathconf" private : NullString8.t * C_Int.t -> (C_Long.t) C_Errno.t; +structure PC = +struct +val ALLOC_SIZE_MIN = _const "Posix_FileSys_PC_ALLOC_SIZE_MIN" : C_Int.t; +val ASYNC_IO = _const "Posix_FileSys_PC_ASYNC_IO" : C_Int.t; +val CHOWN_RESTRICTED = _const "Posix_FileSys_PC_CHOWN_RESTRICTED" : C_Int.t; +val FILESIZEBITS = _const "Posix_FileSys_PC_FILESIZEBITS" : C_Int.t; +val LINK_MAX = _const "Posix_FileSys_PC_LINK_MAX" : C_Int.t; +val MAX_CANON = _const "Posix_FileSys_PC_MAX_CANON" : C_Int.t; +val MAX_INPUT = _const "Posix_FileSys_PC_MAX_INPUT" : C_Int.t; +val NAME_MAX = _const "Posix_FileSys_PC_NAME_MAX" : C_Int.t; +val NO_TRUNC = _const "Posix_FileSys_PC_NO_TRUNC" : C_Int.t; +val PATH_MAX = _const "Posix_FileSys_PC_PATH_MAX" : C_Int.t; +val PIPE_BUF = _const "Posix_FileSys_PC_PIPE_BUF" : C_Int.t; +val PRIO_IO = _const "Posix_FileSys_PC_PRIO_IO" : C_Int.t; +val REC_INCR_XFER_SIZE = _const "Posix_FileSys_PC_REC_INCR_XFER_SIZE" : C_Int.t; +val REC_MAX_XFER_SIZE = _const "Posix_FileSys_PC_REC_MAX_XFER_SIZE" : C_Int.t; +val REC_MIN_XFER_SIZE = _const "Posix_FileSys_PC_REC_MIN_XFER_SIZE" : C_Int.t; +val REC_XFER_ALIGN = _const "Posix_FileSys_PC_REC_XFER_ALIGN" : C_Int.t; +val SYMLINK_MAX = _const "Posix_FileSys_PC_SYMLINK_MAX" : C_Int.t; +val SYNC_IO = _const "Posix_FileSys_PC_SYNC_IO" : C_Int.t; +val TWO_SYMLINKS = _const "Posix_FileSys_PC_TWO_SYMLINKS" : C_Int.t; +val VDISABLE = _const "Posix_FileSys_PC_VDISABLE" : C_Int.t; +end +val readlink = _import "Posix_FileSys_readlink" private : NullString8.t * (Char8.t) array * C_Size.t -> (C_SSize.t) C_Errno.t; +val rename = _import "Posix_FileSys_rename" private : NullString8.t * NullString8.t -> (C_Int.t) C_Errno.t; +val rmdir = _import "Posix_FileSys_rmdir" private : NullString8.t -> (C_Int.t) C_Errno.t; +structure S = +struct +val IFBLK = _const "Posix_FileSys_S_IFBLK" : C_Mode.t; +val IFCHR = _const "Posix_FileSys_S_IFCHR" : C_Mode.t; +val IFDIR = _const "Posix_FileSys_S_IFDIR" : C_Mode.t; +val IFIFO = _const "Posix_FileSys_S_IFIFO" : C_Mode.t; +val IFLNK = _const "Posix_FileSys_S_IFLNK" : C_Mode.t; +val IFMT = _const "Posix_FileSys_S_IFMT" : C_Mode.t; +val IFREG = _const "Posix_FileSys_S_IFREG" : C_Mode.t; +val IFSOCK = _const "Posix_FileSys_S_IFSOCK" : C_Mode.t; +val IRGRP = _const "Posix_FileSys_S_IRGRP" : C_Mode.t; +val IROTH = _const "Posix_FileSys_S_IROTH" : C_Mode.t; +val IRUSR = _const "Posix_FileSys_S_IRUSR" : C_Mode.t; +val IRWXG = _const "Posix_FileSys_S_IRWXG" : C_Mode.t; +val IRWXO = _const "Posix_FileSys_S_IRWXO" : C_Mode.t; +val IRWXU = _const "Posix_FileSys_S_IRWXU" : C_Mode.t; +val ISGID = _const "Posix_FileSys_S_ISGID" : C_Mode.t; +val ISUID = _const "Posix_FileSys_S_ISUID" : C_Mode.t; +val ISVTX = _const "Posix_FileSys_S_ISVTX" : C_Mode.t; +val IWGRP = _const "Posix_FileSys_S_IWGRP" : C_Mode.t; +val IWOTH = _const "Posix_FileSys_S_IWOTH" : C_Mode.t; +val IWUSR = _const "Posix_FileSys_S_IWUSR" : C_Mode.t; +val IXGRP = _const "Posix_FileSys_S_IXGRP" : C_Mode.t; +val IXOTH = _const "Posix_FileSys_S_IXOTH" : C_Mode.t; +val IXUSR = _const "Posix_FileSys_S_IXUSR" : C_Mode.t; +end +structure ST = +struct +val isBlk = _import "Posix_FileSys_ST_isBlk" private : C_Mode.t -> C_Int.t; +val isChr = _import "Posix_FileSys_ST_isChr" private : C_Mode.t -> C_Int.t; +val isDir = _import "Posix_FileSys_ST_isDir" private : C_Mode.t -> C_Int.t; +val isFIFO = _import "Posix_FileSys_ST_isFIFO" private : C_Mode.t -> C_Int.t; +val isLink = _import "Posix_FileSys_ST_isLink" private : C_Mode.t -> C_Int.t; +val isReg = _import "Posix_FileSys_ST_isReg" private : C_Mode.t -> C_Int.t; +val isSock = _import "Posix_FileSys_ST_isSock" private : C_Mode.t -> C_Int.t; +end +structure Stat = +struct +val fstat = _import "Posix_FileSys_Stat_fstat" private : C_Fd.t -> (C_Int.t) C_Errno.t; +val getATime = _import "Posix_FileSys_Stat_getATime" private : unit -> C_Time.t; +val getCTime = _import "Posix_FileSys_Stat_getCTime" private : unit -> C_Time.t; +val getDev = _import "Posix_FileSys_Stat_getDev" private : unit -> C_Dev.t; +val getGId = _import "Posix_FileSys_Stat_getGId" private : unit -> C_GId.t; +val getINo = _import "Posix_FileSys_Stat_getINo" private : unit -> C_INo.t; +val getMode = _import "Posix_FileSys_Stat_getMode" private : unit -> C_Mode.t; +val getMTime = _import "Posix_FileSys_Stat_getMTime" private : unit -> C_Time.t; +val getNLink = _import "Posix_FileSys_Stat_getNLink" private : unit -> C_NLink.t; +val getRDev = _import "Posix_FileSys_Stat_getRDev" private : unit -> C_Dev.t; +val getSize = _import "Posix_FileSys_Stat_getSize" private : unit -> C_Off.t; +val getUId = _import "Posix_FileSys_Stat_getUId" private : unit -> C_UId.t; +val lstat = _import "Posix_FileSys_Stat_lstat" private : NullString8.t -> (C_Int.t) C_Errno.t; +val stat = _import "Posix_FileSys_Stat_stat" private : NullString8.t -> (C_Int.t) C_Errno.t; +end +val symlink = _import "Posix_FileSys_symlink" private : NullString8.t * NullString8.t -> (C_Int.t) C_Errno.t; +val truncate = _import "Posix_FileSys_truncate" private : NullString8.t * C_Off.t -> (C_Int.t) C_Errno.t; +val umask = _import "Posix_FileSys_umask" private : C_Mode.t -> C_Mode.t; +val unlink = _import "Posix_FileSys_unlink" private : NullString8.t -> (C_Int.t) C_Errno.t; +structure Utimbuf = +struct +val setAcTime = _import "Posix_FileSys_Utimbuf_setAcTime" private : C_Time.t -> unit; +val setModTime = _import "Posix_FileSys_Utimbuf_setModTime" private : C_Time.t -> unit; +val utime = _import "Posix_FileSys_Utimbuf_utime" private : NullString8.t -> (C_Int.t) C_Errno.t; +end +end +structure IO = +struct +val close = _import "Posix_IO_close" private : C_Fd.t -> (C_Int.t) C_Errno.t; +val dup = _import "Posix_IO_dup" private : C_Fd.t -> (C_Fd.t) C_Errno.t; +val dup2 = _import "Posix_IO_dup2" private : C_Fd.t * C_Fd.t -> (C_Fd.t) C_Errno.t; +val F_DUPFD = _const "Posix_IO_F_DUPFD" : C_Int.t; +val F_GETFD = _const "Posix_IO_F_GETFD" : C_Int.t; +val F_GETFL = _const "Posix_IO_F_GETFL" : C_Int.t; +val F_GETOWN = _const "Posix_IO_F_GETOWN" : C_Int.t; +val F_SETFD = _const "Posix_IO_F_SETFD" : C_Int.t; +val F_SETFL = _const "Posix_IO_F_SETFL" : C_Int.t; +val F_SETOWN = _const "Posix_IO_F_SETOWN" : C_Int.t; +val fcntl2 = _import "Posix_IO_fcntl2" private : C_Fd.t * C_Int.t -> (C_Int.t) C_Errno.t; +val fcntl3 = _import "Posix_IO_fcntl3" private : C_Fd.t * C_Int.t * C_Int.t -> (C_Int.t) C_Errno.t; +structure FD = +struct +val CLOEXEC = _const "Posix_IO_FD_CLOEXEC" : C_Int.t; +end +structure FLock = +struct +val F_GETLK = _const "Posix_IO_FLock_F_GETLK" : C_Int.t; +val F_RDLCK = _const "Posix_IO_FLock_F_RDLCK" : C_Short.t; +val F_SETLK = _const "Posix_IO_FLock_F_SETLK" : C_Int.t; +val F_SETLKW = _const "Posix_IO_FLock_F_SETLKW" : C_Int.t; +val F_UNLCK = _const "Posix_IO_FLock_F_UNLCK" : C_Short.t; +val F_WRLCK = _const "Posix_IO_FLock_F_WRLCK" : C_Short.t; +val fcntl = _import "Posix_IO_FLock_fcntl" private : C_Fd.t * C_Int.t -> (C_Int.t) C_Errno.t; +val getLen = _import "Posix_IO_FLock_getLen" private : unit -> C_Off.t; +val getPId = _import "Posix_IO_FLock_getPId" private : unit -> C_PId.t; +val getStart = _import "Posix_IO_FLock_getStart" private : unit -> C_Off.t; +val getType = _import "Posix_IO_FLock_getType" private : unit -> C_Short.t; +val getWhence = _import "Posix_IO_FLock_getWhence" private : unit -> C_Short.t; +val SEEK_CUR = _const "Posix_IO_FLock_SEEK_CUR" : C_Short.t; +val SEEK_END = _const "Posix_IO_FLock_SEEK_END" : C_Short.t; +val SEEK_SET = _const "Posix_IO_FLock_SEEK_SET" : C_Short.t; +val setLen = _import "Posix_IO_FLock_setLen" private : C_Off.t -> unit; +val setPId = _import "Posix_IO_FLock_setPId" private : C_PId.t -> unit; +val setStart = _import "Posix_IO_FLock_setStart" private : C_Off.t -> unit; +val setType = _import "Posix_IO_FLock_setType" private : C_Short.t -> unit; +val setWhence = _import "Posix_IO_FLock_setWhence" private : C_Short.t -> unit; +end +val fsync = _import "Posix_IO_fsync" private : C_Fd.t -> (C_Int.t) C_Errno.t; +val lseek = _import "Posix_IO_lseek" private : C_Fd.t * C_Off.t * C_Int.t -> (C_Off.t) C_Errno.t; +val O_ACCMODE = _const "Posix_IO_O_ACCMODE" : C_Int.t; +val pipe = _import "Posix_IO_pipe" private : (C_Fd.t) array -> (C_Int.t) C_Errno.t; +val readChar8 = _import "Posix_IO_readChar8" private : C_Fd.t * (Char8.t) array * C_Int.t * C_Size.t -> (C_SSize.t) C_Errno.t; +val readWord8 = _import "Posix_IO_readWord8" private : C_Fd.t * (Word8.t) array * C_Int.t * C_Size.t -> (C_SSize.t) C_Errno.t; +val SEEK_CUR = _const "Posix_IO_SEEK_CUR" : C_Int.t; +val SEEK_END = _const "Posix_IO_SEEK_END" : C_Int.t; +val SEEK_SET = _const "Posix_IO_SEEK_SET" : C_Int.t; +val setbin = _import "Posix_IO_setbin" private : C_Fd.t -> unit; +val settext = _import "Posix_IO_settext" private : C_Fd.t -> unit; +val writeChar8Arr = _import "Posix_IO_writeChar8Arr" private : C_Fd.t * (Char8.t) array * C_Int.t * C_Size.t -> (C_SSize.t) C_Errno.t; +val writeChar8Vec = _import "Posix_IO_writeChar8Vec" private : C_Fd.t * (Char8.t) vector * C_Int.t * C_Size.t -> (C_SSize.t) C_Errno.t; +val writeWord8Arr = _import "Posix_IO_writeWord8Arr" private : C_Fd.t * (Word8.t) array * C_Int.t * C_Size.t -> (C_SSize.t) C_Errno.t; +val writeWord8Vec = _import "Posix_IO_writeWord8Vec" private : C_Fd.t * (Word8.t) vector * C_Int.t * C_Size.t -> (C_SSize.t) C_Errno.t; +end +structure ProcEnv = +struct +val ctermid = _import "Posix_ProcEnv_ctermid" private : unit -> C_String.t; +val (environGet, environSet) = _symbol "Posix_ProcEnv_environ" private : (unit -> (C_StringArray.t)) * ((C_StringArray.t) -> unit); +val getegid = _import "Posix_ProcEnv_getegid" private : unit -> C_GId.t; +val getenv = _import "Posix_ProcEnv_getenv" private : NullString8.t -> C_String.t; +val geteuid = _import "Posix_ProcEnv_geteuid" private : unit -> C_UId.t; +val getgid = _import "Posix_ProcEnv_getgid" private : unit -> C_GId.t; +val getgroups = _import "Posix_ProcEnv_getgroups" private : C_Int.t * (C_GId.t) array -> (C_Int.t) C_Errno.t; +val getgroupsN = _import "Posix_ProcEnv_getgroupsN" private : unit -> C_Int.t; +val getlogin = _import "Posix_ProcEnv_getlogin" private : unit -> (C_String.t) C_Errno.t; +val getpgrp = _import "Posix_ProcEnv_getpgrp" private : unit -> C_PId.t; +val getpid = _import "Posix_ProcEnv_getpid" private : unit -> C_PId.t; +val getppid = _import "Posix_ProcEnv_getppid" private : unit -> C_PId.t; +val getuid = _import "Posix_ProcEnv_getuid" private : unit -> C_UId.t; +val isatty = _import "Posix_ProcEnv_isatty" private : C_Fd.t -> C_Int.t; +val SC_2_C_BIND = _const "Posix_ProcEnv_SC_2_C_BIND" : C_Int.t; +val SC_2_C_DEV = _const "Posix_ProcEnv_SC_2_C_DEV" : C_Int.t; +val SC_2_CHAR_TERM = _const "Posix_ProcEnv_SC_2_CHAR_TERM" : C_Int.t; +val SC_2_FORT_DEV = _const "Posix_ProcEnv_SC_2_FORT_DEV" : C_Int.t; +val SC_2_FORT_RUN = _const "Posix_ProcEnv_SC_2_FORT_RUN" : C_Int.t; +val SC_2_LOCALEDEF = _const "Posix_ProcEnv_SC_2_LOCALEDEF" : C_Int.t; +val SC_2_PBS = _const "Posix_ProcEnv_SC_2_PBS" : C_Int.t; +val SC_2_PBS_ACCOUNTING = _const "Posix_ProcEnv_SC_2_PBS_ACCOUNTING" : C_Int.t; +val SC_2_PBS_CHECKPOINT = _const "Posix_ProcEnv_SC_2_PBS_CHECKPOINT" : C_Int.t; +val SC_2_PBS_LOCATE = _const "Posix_ProcEnv_SC_2_PBS_LOCATE" : C_Int.t; +val SC_2_PBS_MESSAGE = _const "Posix_ProcEnv_SC_2_PBS_MESSAGE" : C_Int.t; +val SC_2_PBS_TRACK = _const "Posix_ProcEnv_SC_2_PBS_TRACK" : C_Int.t; +val SC_2_SW_DEV = _const "Posix_ProcEnv_SC_2_SW_DEV" : C_Int.t; +val SC_2_UPE = _const "Posix_ProcEnv_SC_2_UPE" : C_Int.t; +val SC_2_VERSION = _const "Posix_ProcEnv_SC_2_VERSION" : C_Int.t; +val SC_ADVISORY_INFO = _const "Posix_ProcEnv_SC_ADVISORY_INFO" : C_Int.t; +val SC_AIO_LISTIO_MAX = _const "Posix_ProcEnv_SC_AIO_LISTIO_MAX" : C_Int.t; +val SC_AIO_MAX = _const "Posix_ProcEnv_SC_AIO_MAX" : C_Int.t; +val SC_AIO_PRIO_DELTA_MAX = _const "Posix_ProcEnv_SC_AIO_PRIO_DELTA_MAX" : C_Int.t; +val SC_ARG_MAX = _const "Posix_ProcEnv_SC_ARG_MAX" : C_Int.t; +val SC_ASYNCHRONOUS_IO = _const "Posix_ProcEnv_SC_ASYNCHRONOUS_IO" : C_Int.t; +val SC_ATEXIT_MAX = _const "Posix_ProcEnv_SC_ATEXIT_MAX" : C_Int.t; +val SC_AVPHYS_PAGES = _const "Posix_ProcEnv_SC_AVPHYS_PAGES" : C_Int.t; +val SC_BARRIERS = _const "Posix_ProcEnv_SC_BARRIERS" : C_Int.t; +val SC_BC_BASE_MAX = _const "Posix_ProcEnv_SC_BC_BASE_MAX" : C_Int.t; +val SC_BC_DIM_MAX = _const "Posix_ProcEnv_SC_BC_DIM_MAX" : C_Int.t; +val SC_BC_SCALE_MAX = _const "Posix_ProcEnv_SC_BC_SCALE_MAX" : C_Int.t; +val SC_BC_STRING_MAX = _const "Posix_ProcEnv_SC_BC_STRING_MAX" : C_Int.t; +val SC_CHILD_MAX = _const "Posix_ProcEnv_SC_CHILD_MAX" : C_Int.t; +val SC_CLK_TCK = _const "Posix_ProcEnv_SC_CLK_TCK" : C_Int.t; +val SC_CLOCK_SELECTION = _const "Posix_ProcEnv_SC_CLOCK_SELECTION" : C_Int.t; +val SC_COLL_WEIGHTS_MAX = _const "Posix_ProcEnv_SC_COLL_WEIGHTS_MAX" : C_Int.t; +val SC_CPUTIME = _const "Posix_ProcEnv_SC_CPUTIME" : C_Int.t; +val SC_DELAYTIMER_MAX = _const "Posix_ProcEnv_SC_DELAYTIMER_MAX" : C_Int.t; +val SC_EXPR_NEST_MAX = _const "Posix_ProcEnv_SC_EXPR_NEST_MAX" : C_Int.t; +val SC_FSYNC = _const "Posix_ProcEnv_SC_FSYNC" : C_Int.t; +val SC_GETGR_R_SIZE_MAX = _const "Posix_ProcEnv_SC_GETGR_R_SIZE_MAX" : C_Int.t; +val SC_GETPW_R_SIZE_MAX = _const "Posix_ProcEnv_SC_GETPW_R_SIZE_MAX" : C_Int.t; +val SC_HOST_NAME_MAX = _const "Posix_ProcEnv_SC_HOST_NAME_MAX" : C_Int.t; +val SC_IOV_MAX = _const "Posix_ProcEnv_SC_IOV_MAX" : C_Int.t; +val SC_IPV6 = _const "Posix_ProcEnv_SC_IPV6" : C_Int.t; +val SC_JOB_CONTROL = _const "Posix_ProcEnv_SC_JOB_CONTROL" : C_Int.t; +val SC_LINE_MAX = _const "Posix_ProcEnv_SC_LINE_MAX" : C_Int.t; +val SC_LOGIN_NAME_MAX = _const "Posix_ProcEnv_SC_LOGIN_NAME_MAX" : C_Int.t; +val SC_MAPPED_FILES = _const "Posix_ProcEnv_SC_MAPPED_FILES" : C_Int.t; +val SC_MEMLOCK = _const "Posix_ProcEnv_SC_MEMLOCK" : C_Int.t; +val SC_MEMLOCK_RANGE = _const "Posix_ProcEnv_SC_MEMLOCK_RANGE" : C_Int.t; +val SC_MEMORY_PROTECTION = _const "Posix_ProcEnv_SC_MEMORY_PROTECTION" : C_Int.t; +val SC_MESSAGE_PASSING = _const "Posix_ProcEnv_SC_MESSAGE_PASSING" : C_Int.t; +val SC_MONOTONIC_CLOCK = _const "Posix_ProcEnv_SC_MONOTONIC_CLOCK" : C_Int.t; +val SC_MQ_OPEN_MAX = _const "Posix_ProcEnv_SC_MQ_OPEN_MAX" : C_Int.t; +val SC_MQ_PRIO_MAX = _const "Posix_ProcEnv_SC_MQ_PRIO_MAX" : C_Int.t; +val SC_NGROUPS_MAX = _const "Posix_ProcEnv_SC_NGROUPS_MAX" : C_Int.t; +val SC_NPROCESSORS_CONF = _const "Posix_ProcEnv_SC_NPROCESSORS_CONF" : C_Int.t; +val SC_NPROCESSORS_ONLN = _const "Posix_ProcEnv_SC_NPROCESSORS_ONLN" : C_Int.t; +val SC_OPEN_MAX = _const "Posix_ProcEnv_SC_OPEN_MAX" : C_Int.t; +val SC_PAGE_SIZE = _const "Posix_ProcEnv_SC_PAGE_SIZE" : C_Int.t; +val SC_PAGESIZE = _const "Posix_ProcEnv_SC_PAGESIZE" : C_Int.t; +val SC_PHYS_PAGES = _const "Posix_ProcEnv_SC_PHYS_PAGES" : C_Int.t; +val SC_PRIORITIZED_IO = _const "Posix_ProcEnv_SC_PRIORITIZED_IO" : C_Int.t; +val SC_PRIORITY_SCHEDULING = _const "Posix_ProcEnv_SC_PRIORITY_SCHEDULING" : C_Int.t; +val SC_RAW_SOCKETS = _const "Posix_ProcEnv_SC_RAW_SOCKETS" : C_Int.t; +val SC_RE_DUP_MAX = _const "Posix_ProcEnv_SC_RE_DUP_MAX" : C_Int.t; +val SC_READER_WRITER_LOCKS = _const "Posix_ProcEnv_SC_READER_WRITER_LOCKS" : C_Int.t; +val SC_REALTIME_SIGNALS = _const "Posix_ProcEnv_SC_REALTIME_SIGNALS" : C_Int.t; +val SC_REGEXP = _const "Posix_ProcEnv_SC_REGEXP" : C_Int.t; +val SC_RTSIG_MAX = _const "Posix_ProcEnv_SC_RTSIG_MAX" : C_Int.t; +val SC_SAVED_IDS = _const "Posix_ProcEnv_SC_SAVED_IDS" : C_Int.t; +val SC_SEM_NSEMS_MAX = _const "Posix_ProcEnv_SC_SEM_NSEMS_MAX" : C_Int.t; +val SC_SEM_VALUE_MAX = _const "Posix_ProcEnv_SC_SEM_VALUE_MAX" : C_Int.t; +val SC_SEMAPHORES = _const "Posix_ProcEnv_SC_SEMAPHORES" : C_Int.t; +val SC_SHARED_MEMORY_OBJECTS = _const "Posix_ProcEnv_SC_SHARED_MEMORY_OBJECTS" : C_Int.t; +val SC_SHELL = _const "Posix_ProcEnv_SC_SHELL" : C_Int.t; +val SC_SIGQUEUE_MAX = _const "Posix_ProcEnv_SC_SIGQUEUE_MAX" : C_Int.t; +val SC_SPAWN = _const "Posix_ProcEnv_SC_SPAWN" : C_Int.t; +val SC_SPIN_LOCKS = _const "Posix_ProcEnv_SC_SPIN_LOCKS" : C_Int.t; +val SC_SPORADIC_SERVER = _const "Posix_ProcEnv_SC_SPORADIC_SERVER" : C_Int.t; +val SC_SS_REPL_MAX = _const "Posix_ProcEnv_SC_SS_REPL_MAX" : C_Int.t; +val SC_STREAM_MAX = _const "Posix_ProcEnv_SC_STREAM_MAX" : C_Int.t; +val SC_SYMLOOP_MAX = _const "Posix_ProcEnv_SC_SYMLOOP_MAX" : C_Int.t; +val SC_SYNCHRONIZED_IO = _const "Posix_ProcEnv_SC_SYNCHRONIZED_IO" : C_Int.t; +val SC_THREAD_ATTR_STACKADDR = _const "Posix_ProcEnv_SC_THREAD_ATTR_STACKADDR" : C_Int.t; +val SC_THREAD_ATTR_STACKSIZE = _const "Posix_ProcEnv_SC_THREAD_ATTR_STACKSIZE" : C_Int.t; +val SC_THREAD_CPUTIME = _const "Posix_ProcEnv_SC_THREAD_CPUTIME" : C_Int.t; +val SC_THREAD_DESTRUCTOR_ITERATIONS = _const "Posix_ProcEnv_SC_THREAD_DESTRUCTOR_ITERATIONS" : C_Int.t; +val SC_THREAD_KEYS_MAX = _const "Posix_ProcEnv_SC_THREAD_KEYS_MAX" : C_Int.t; +val SC_THREAD_PRIO_INHERIT = _const "Posix_ProcEnv_SC_THREAD_PRIO_INHERIT" : C_Int.t; +val SC_THREAD_PRIO_PROTECT = _const "Posix_ProcEnv_SC_THREAD_PRIO_PROTECT" : C_Int.t; +val SC_THREAD_PRIORITY_SCHEDULING = _const "Posix_ProcEnv_SC_THREAD_PRIORITY_SCHEDULING" : C_Int.t; +val SC_THREAD_PROCESS_SHARED = _const "Posix_ProcEnv_SC_THREAD_PROCESS_SHARED" : C_Int.t; +val SC_THREAD_SAFE_FUNCTIONS = _const "Posix_ProcEnv_SC_THREAD_SAFE_FUNCTIONS" : C_Int.t; +val SC_THREAD_SPORADIC_SERVER = _const "Posix_ProcEnv_SC_THREAD_SPORADIC_SERVER" : C_Int.t; +val SC_THREAD_STACK_MIN = _const "Posix_ProcEnv_SC_THREAD_STACK_MIN" : C_Int.t; +val SC_THREAD_THREADS_MAX = _const "Posix_ProcEnv_SC_THREAD_THREADS_MAX" : C_Int.t; +val SC_THREADS = _const "Posix_ProcEnv_SC_THREADS" : C_Int.t; +val SC_TIMEOUTS = _const "Posix_ProcEnv_SC_TIMEOUTS" : C_Int.t; +val SC_TIMER_MAX = _const "Posix_ProcEnv_SC_TIMER_MAX" : C_Int.t; +val SC_TIMERS = _const "Posix_ProcEnv_SC_TIMERS" : C_Int.t; +val SC_TRACE = _const "Posix_ProcEnv_SC_TRACE" : C_Int.t; +val SC_TRACE_EVENT_FILTER = _const "Posix_ProcEnv_SC_TRACE_EVENT_FILTER" : C_Int.t; +val SC_TRACE_EVENT_NAME_MAX = _const "Posix_ProcEnv_SC_TRACE_EVENT_NAME_MAX" : C_Int.t; +val SC_TRACE_INHERIT = _const "Posix_ProcEnv_SC_TRACE_INHERIT" : C_Int.t; +val SC_TRACE_LOG = _const "Posix_ProcEnv_SC_TRACE_LOG" : C_Int.t; +val SC_TRACE_NAME_MAX = _const "Posix_ProcEnv_SC_TRACE_NAME_MAX" : C_Int.t; +val SC_TRACE_SYS_MAX = _const "Posix_ProcEnv_SC_TRACE_SYS_MAX" : C_Int.t; +val SC_TRACE_USER_EVENT_MAX = _const "Posix_ProcEnv_SC_TRACE_USER_EVENT_MAX" : C_Int.t; +val SC_TTY_NAME_MAX = _const "Posix_ProcEnv_SC_TTY_NAME_MAX" : C_Int.t; +val SC_TYPED_MEMORY_OBJECTS = _const "Posix_ProcEnv_SC_TYPED_MEMORY_OBJECTS" : C_Int.t; +val SC_TZNAME_MAX = _const "Posix_ProcEnv_SC_TZNAME_MAX" : C_Int.t; +val SC_V6_ILP32_OFF32 = _const "Posix_ProcEnv_SC_V6_ILP32_OFF32" : C_Int.t; +val SC_V6_ILP32_OFFBIG = _const "Posix_ProcEnv_SC_V6_ILP32_OFFBIG" : C_Int.t; +val SC_V6_LP64_OFF64 = _const "Posix_ProcEnv_SC_V6_LP64_OFF64" : C_Int.t; +val SC_V6_LPBIG_OFFBIG = _const "Posix_ProcEnv_SC_V6_LPBIG_OFFBIG" : C_Int.t; +val SC_VERSION = _const "Posix_ProcEnv_SC_VERSION" : C_Int.t; +val SC_XBS5_ILP32_OFF32 = _const "Posix_ProcEnv_SC_XBS5_ILP32_OFF32" : C_Int.t; +val SC_XBS5_ILP32_OFFBIG = _const "Posix_ProcEnv_SC_XBS5_ILP32_OFFBIG" : C_Int.t; +val SC_XBS5_LP64_OFF64 = _const "Posix_ProcEnv_SC_XBS5_LP64_OFF64" : C_Int.t; +val SC_XBS5_LPBIG_OFFBIG = _const "Posix_ProcEnv_SC_XBS5_LPBIG_OFFBIG" : C_Int.t; +val SC_XOPEN_CRYPT = _const "Posix_ProcEnv_SC_XOPEN_CRYPT" : C_Int.t; +val SC_XOPEN_ENH_I18N = _const "Posix_ProcEnv_SC_XOPEN_ENH_I18N" : C_Int.t; +val SC_XOPEN_LEGACY = _const "Posix_ProcEnv_SC_XOPEN_LEGACY" : C_Int.t; +val SC_XOPEN_REALTIME = _const "Posix_ProcEnv_SC_XOPEN_REALTIME" : C_Int.t; +val SC_XOPEN_REALTIME_THREADS = _const "Posix_ProcEnv_SC_XOPEN_REALTIME_THREADS" : C_Int.t; +val SC_XOPEN_SHM = _const "Posix_ProcEnv_SC_XOPEN_SHM" : C_Int.t; +val SC_XOPEN_STREAMS = _const "Posix_ProcEnv_SC_XOPEN_STREAMS" : C_Int.t; +val SC_XOPEN_UNIX = _const "Posix_ProcEnv_SC_XOPEN_UNIX" : C_Int.t; +val SC_XOPEN_VERSION = _const "Posix_ProcEnv_SC_XOPEN_VERSION" : C_Int.t; +val setenv = _import "Posix_ProcEnv_setenv" private : NullString8.t * NullString8.t -> (C_Int.t) C_Errno.t; +val setgid = _import "Posix_ProcEnv_setgid" private : C_GId.t -> (C_Int.t) C_Errno.t; +val setgroups = _import "Posix_ProcEnv_setgroups" private : C_Int.t * (C_GId.t) vector -> (C_Int.t) C_Errno.t; +val setpgid = _import "Posix_ProcEnv_setpgid" private : C_PId.t * C_PId.t -> (C_Int.t) C_Errno.t; +val setsid = _import "Posix_ProcEnv_setsid" private : unit -> (C_PId.t) C_Errno.t; +val setuid = _import "Posix_ProcEnv_setuid" private : C_UId.t -> (C_Int.t) C_Errno.t; +val sysconf = _import "Posix_ProcEnv_sysconf" private : C_Int.t -> (C_Long.t) C_Errno.t; +val times = _import "Posix_ProcEnv_times" private : unit -> (C_Clock.t) C_Errno.t; +structure Times = +struct +val getCSTime = _import "Posix_ProcEnv_Times_getCSTime" private : unit -> C_Clock.t; +val getCUTime = _import "Posix_ProcEnv_Times_getCUTime" private : unit -> C_Clock.t; +val getSTime = _import "Posix_ProcEnv_Times_getSTime" private : unit -> C_Clock.t; +val getUTime = _import "Posix_ProcEnv_Times_getUTime" private : unit -> C_Clock.t; +end +val ttyname = _import "Posix_ProcEnv_ttyname" private : C_Fd.t -> (C_String.t) C_Errno.t; +val uname = _import "Posix_ProcEnv_uname" private : unit -> (C_Int.t) C_Errno.t; +structure Uname = +struct +val getMachine = _import "Posix_ProcEnv_Uname_getMachine" private : unit -> C_String.t; +val getNodeName = _import "Posix_ProcEnv_Uname_getNodeName" private : unit -> C_String.t; +val getRelease = _import "Posix_ProcEnv_Uname_getRelease" private : unit -> C_String.t; +val getSysName = _import "Posix_ProcEnv_Uname_getSysName" private : unit -> C_String.t; +val getVersion = _import "Posix_ProcEnv_Uname_getVersion" private : unit -> C_String.t; +end +end +structure Process = +struct +val alarm = _import "Posix_Process_alarm" private : C_UInt.t -> C_UInt.t; +val exece = _import "Posix_Process_exece" private : NullString8.t * (NullString8.t) array * (NullString8.t) array -> (C_Int.t) C_Errno.t; +val execp = _import "Posix_Process_execp" private : NullString8.t * (NullString8.t) array -> (C_Int.t) C_Errno.t; +val exit = _import "Posix_Process_exit" private : C_Status.t -> unit; +val exitStatus = _import "Posix_Process_exitStatus" private : C_Status.t -> C_Int.t; +val fork = _import "Posix_Process_fork" private : unit -> (C_PId.t) C_Errno.t; +val ifExited = _import "Posix_Process_ifExited" private : C_Status.t -> C_Int.t; +val ifSignaled = _import "Posix_Process_ifSignaled" private : C_Status.t -> C_Int.t; +val ifStopped = _import "Posix_Process_ifStopped" private : C_Status.t -> C_Int.t; +val kill = _import "Posix_Process_kill" private : C_PId.t * C_Signal.t -> (C_Int.t) C_Errno.t; +val nanosleep = _import "Posix_Process_nanosleep" private : (C_Time.t) ref * (C_Long.t) ref -> (C_Int.t) C_Errno.t; +val pause = _import "Posix_Process_pause" private : unit -> (C_Int.t) C_Errno.t; +val sleep = _import "Posix_Process_sleep" private : C_UInt.t -> C_UInt.t; +val stopSig = _import "Posix_Process_stopSig" private : C_Status.t -> C_Signal.t; +val system = _import "Posix_Process_system" private : NullString8.t -> (C_Status.t) C_Errno.t; +val termSig = _import "Posix_Process_termSig" private : C_Status.t -> C_Signal.t; +structure W = +struct +val NOHANG = _const "Posix_Process_W_NOHANG" : C_Int.t; +val UNTRACED = _const "Posix_Process_W_UNTRACED" : C_Int.t; +end +val waitpid = _import "Posix_Process_waitpid" private : C_PId.t * (C_Status.t) ref * C_Int.t -> (C_PId.t) C_Errno.t; +end +structure Signal = +struct +val default = _import "Posix_Signal_default" private : C_Signal.t -> (C_Int.t) C_Errno.t; +val handlee = _import "Posix_Signal_handlee" private : C_Signal.t -> (C_Int.t) C_Errno.t; +val handleGC = _import "Posix_Signal_handleGC" private : unit -> unit; +val ignore = _import "Posix_Signal_ignore" private : C_Signal.t -> (C_Int.t) C_Errno.t; +val isDefault = _import "Posix_Signal_isDefault" private : C_Signal.t * (C_Int.t) ref -> (C_Int.t) C_Errno.t; +val isIgnore = _import "Posix_Signal_isIgnore" private : C_Signal.t * (C_Int.t) ref -> (C_Int.t) C_Errno.t; +val isPending = _import "Posix_Signal_isPending" private : C_Signal.t -> C_Int.t; +val isPendingGC = _import "Posix_Signal_isPendingGC" private : unit -> C_Int.t; +val NSIG = _const "Posix_Signal_NSIG" : C_Int.t; +val resetPending = _import "Posix_Signal_resetPending" private : unit -> unit; +val SIG_BLOCK = _const "Posix_Signal_SIG_BLOCK" : C_Int.t; +val SIG_SETMASK = _const "Posix_Signal_SIG_SETMASK" : C_Int.t; +val SIG_UNBLOCK = _const "Posix_Signal_SIG_UNBLOCK" : C_Int.t; +val SIGABRT = _const "Posix_Signal_SIGABRT" : C_Signal.t; +val sigaddset = _import "Posix_Signal_sigaddset" private : (Word8.t) array * C_Signal.t -> (C_Int.t) C_Errno.t; +val SIGALRM = _const "Posix_Signal_SIGALRM" : C_Signal.t; +val SIGBUS = _const "Posix_Signal_SIGBUS" : C_Signal.t; +val SIGCHLD = _const "Posix_Signal_SIGCHLD" : C_Signal.t; +val SIGCONT = _const "Posix_Signal_SIGCONT" : C_Signal.t; +val sigdelset = _import "Posix_Signal_sigdelset" private : (Word8.t) array * C_Signal.t -> (C_Int.t) C_Errno.t; +val sigemptyset = _import "Posix_Signal_sigemptyset" private : (Word8.t) array -> (C_Int.t) C_Errno.t; +val sigfillset = _import "Posix_Signal_sigfillset" private : (Word8.t) array -> (C_Int.t) C_Errno.t; +val SIGFPE = _const "Posix_Signal_SIGFPE" : C_Signal.t; +val SIGHUP = _const "Posix_Signal_SIGHUP" : C_Signal.t; +val SIGILL = _const "Posix_Signal_SIGILL" : C_Signal.t; +val SIGINT = _const "Posix_Signal_SIGINT" : C_Signal.t; +val sigismember = _import "Posix_Signal_sigismember" private : (Word8.t) vector * C_Signal.t -> (C_Int.t) C_Errno.t; +val SIGKILL = _const "Posix_Signal_SIGKILL" : C_Signal.t; +val SIGPIPE = _const "Posix_Signal_SIGPIPE" : C_Signal.t; +val SIGPOLL = _const "Posix_Signal_SIGPOLL" : C_Signal.t; +val sigprocmask = _import "Posix_Signal_sigprocmask" private : C_Int.t * (Word8.t) vector * (Word8.t) array -> (C_Int.t) C_Errno.t; +val SIGPROF = _const "Posix_Signal_SIGPROF" : C_Signal.t; +val SIGQUIT = _const "Posix_Signal_SIGQUIT" : C_Signal.t; +val SIGSEGV = _const "Posix_Signal_SIGSEGV" : C_Signal.t; +val sigSetLen = _const "Posix_Signal_sigSetLen" : C_Size.t; +val SIGSTOP = _const "Posix_Signal_SIGSTOP" : C_Signal.t; +val sigsuspend = _import "Posix_Signal_sigsuspend" private : (Word8.t) vector -> unit; +val SIGSYS = _const "Posix_Signal_SIGSYS" : C_Signal.t; +val SIGTERM = _const "Posix_Signal_SIGTERM" : C_Signal.t; +val SIGTRAP = _const "Posix_Signal_SIGTRAP" : C_Signal.t; +val SIGTSTP = _const "Posix_Signal_SIGTSTP" : C_Signal.t; +val SIGTTIN = _const "Posix_Signal_SIGTTIN" : C_Signal.t; +val SIGTTOU = _const "Posix_Signal_SIGTTOU" : C_Signal.t; +val SIGURG = _const "Posix_Signal_SIGURG" : C_Signal.t; +val SIGUSR1 = _const "Posix_Signal_SIGUSR1" : C_Signal.t; +val SIGUSR2 = _const "Posix_Signal_SIGUSR2" : C_Signal.t; +val SIGVTALRM = _const "Posix_Signal_SIGVTALRM" : C_Signal.t; +val SIGXCPU = _const "Posix_Signal_SIGXCPU" : C_Signal.t; +val SIGXFSZ = _const "Posix_Signal_SIGXFSZ" : C_Signal.t; +end +structure SysDB = +struct +val getgrgid = _import "Posix_SysDB_getgrgid" private : C_GId.t -> (C_Int.t) C_Errno.t; +val getgrnam = _import "Posix_SysDB_getgrnam" private : NullString8.t -> (C_Int.t) C_Errno.t; +val getpwnam = _import "Posix_SysDB_getpwnam" private : NullString8.t -> (C_Int.t) C_Errno.t; +val getpwuid = _import "Posix_SysDB_getpwuid" private : C_GId.t -> (C_Int.t) C_Errno.t; +structure Group = +struct +val getGId = _import "Posix_SysDB_Group_getGId" private : unit -> C_GId.t; +val getMem = _import "Posix_SysDB_Group_getMem" private : unit -> C_StringArray.t; +val getName = _import "Posix_SysDB_Group_getName" private : unit -> C_String.t; +end +structure Passwd = +struct +val getDir = _import "Posix_SysDB_Passwd_getDir" private : unit -> C_String.t; +val getGId = _import "Posix_SysDB_Passwd_getGId" private : unit -> C_GId.t; +val getName = _import "Posix_SysDB_Passwd_getName" private : unit -> C_String.t; +val getShell = _import "Posix_SysDB_Passwd_getShell" private : unit -> C_String.t; +val getUId = _import "Posix_SysDB_Passwd_getUId" private : unit -> C_UId.t; +end +end +structure TTY = +struct +val B0 = _const "Posix_TTY_B0" : C_Speed.t; +val B110 = _const "Posix_TTY_B110" : C_Speed.t; +val B1200 = _const "Posix_TTY_B1200" : C_Speed.t; +val B134 = _const "Posix_TTY_B134" : C_Speed.t; +val B150 = _const "Posix_TTY_B150" : C_Speed.t; +val B1800 = _const "Posix_TTY_B1800" : C_Speed.t; +val B19200 = _const "Posix_TTY_B19200" : C_Speed.t; +val B200 = _const "Posix_TTY_B200" : C_Speed.t; +val B2400 = _const "Posix_TTY_B2400" : C_Speed.t; +val B300 = _const "Posix_TTY_B300" : C_Speed.t; +val B38400 = _const "Posix_TTY_B38400" : C_Speed.t; +val B4800 = _const "Posix_TTY_B4800" : C_Speed.t; +val B50 = _const "Posix_TTY_B50" : C_Speed.t; +val B600 = _const "Posix_TTY_B600" : C_Speed.t; +val B75 = _const "Posix_TTY_B75" : C_Speed.t; +val B9600 = _const "Posix_TTY_B9600" : C_Speed.t; +structure C = +struct +val CLOCAL = _const "Posix_TTY_C_CLOCAL" : C_TCFlag.t; +val CREAD = _const "Posix_TTY_C_CREAD" : C_TCFlag.t; +val CS5 = _const "Posix_TTY_C_CS5" : C_TCFlag.t; +val CS6 = _const "Posix_TTY_C_CS6" : C_TCFlag.t; +val CS7 = _const "Posix_TTY_C_CS7" : C_TCFlag.t; +val CS8 = _const "Posix_TTY_C_CS8" : C_TCFlag.t; +val CSIZE = _const "Posix_TTY_C_CSIZE" : C_TCFlag.t; +val CSTOPB = _const "Posix_TTY_C_CSTOPB" : C_TCFlag.t; +val HUPCL = _const "Posix_TTY_C_HUPCL" : C_TCFlag.t; +val PARENB = _const "Posix_TTY_C_PARENB" : C_TCFlag.t; +val PARODD = _const "Posix_TTY_C_PARODD" : C_TCFlag.t; +end +structure I = +struct +val BRKINT = _const "Posix_TTY_I_BRKINT" : C_TCFlag.t; +val ICRNL = _const "Posix_TTY_I_ICRNL" : C_TCFlag.t; +val IGNBRK = _const "Posix_TTY_I_IGNBRK" : C_TCFlag.t; +val IGNCR = _const "Posix_TTY_I_IGNCR" : C_TCFlag.t; +val IGNPAR = _const "Posix_TTY_I_IGNPAR" : C_TCFlag.t; +val INLCR = _const "Posix_TTY_I_INLCR" : C_TCFlag.t; +val INPCK = _const "Posix_TTY_I_INPCK" : C_TCFlag.t; +val ISTRIP = _const "Posix_TTY_I_ISTRIP" : C_TCFlag.t; +val IXANY = _const "Posix_TTY_I_IXANY" : C_TCFlag.t; +val IXOFF = _const "Posix_TTY_I_IXOFF" : C_TCFlag.t; +val IXON = _const "Posix_TTY_I_IXON" : C_TCFlag.t; +val PARMRK = _const "Posix_TTY_I_PARMRK" : C_TCFlag.t; +end +structure L = +struct +val ECHO = _const "Posix_TTY_L_ECHO" : C_TCFlag.t; +val ECHOE = _const "Posix_TTY_L_ECHOE" : C_TCFlag.t; +val ECHOK = _const "Posix_TTY_L_ECHOK" : C_TCFlag.t; +val ECHONL = _const "Posix_TTY_L_ECHONL" : C_TCFlag.t; +val ICANON = _const "Posix_TTY_L_ICANON" : C_TCFlag.t; +val IEXTEN = _const "Posix_TTY_L_IEXTEN" : C_TCFlag.t; +val ISIG = _const "Posix_TTY_L_ISIG" : C_TCFlag.t; +val NOFLSH = _const "Posix_TTY_L_NOFLSH" : C_TCFlag.t; +val TOSTOP = _const "Posix_TTY_L_TOSTOP" : C_TCFlag.t; +end +structure O = +struct +val BS0 = _const "Posix_TTY_O_BS0" : C_TCFlag.t; +val BS1 = _const "Posix_TTY_O_BS1" : C_TCFlag.t; +val BSDLY = _const "Posix_TTY_O_BSDLY" : C_TCFlag.t; +val CR0 = _const "Posix_TTY_O_CR0" : C_TCFlag.t; +val CR1 = _const "Posix_TTY_O_CR1" : C_TCFlag.t; +val CR2 = _const "Posix_TTY_O_CR2" : C_TCFlag.t; +val CR3 = _const "Posix_TTY_O_CR3" : C_TCFlag.t; +val CRDLY = _const "Posix_TTY_O_CRDLY" : C_TCFlag.t; +val FF0 = _const "Posix_TTY_O_FF0" : C_TCFlag.t; +val FF1 = _const "Posix_TTY_O_FF1" : C_TCFlag.t; +val FFDLY = _const "Posix_TTY_O_FFDLY" : C_TCFlag.t; +val NL0 = _const "Posix_TTY_O_NL0" : C_TCFlag.t; +val NL1 = _const "Posix_TTY_O_NL1" : C_TCFlag.t; +val NLDLY = _const "Posix_TTY_O_NLDLY" : C_TCFlag.t; +val OCRNL = _const "Posix_TTY_O_OCRNL" : C_TCFlag.t; +val OFILL = _const "Posix_TTY_O_OFILL" : C_TCFlag.t; +val ONLCR = _const "Posix_TTY_O_ONLCR" : C_TCFlag.t; +val ONLRET = _const "Posix_TTY_O_ONLRET" : C_TCFlag.t; +val ONOCR = _const "Posix_TTY_O_ONOCR" : C_TCFlag.t; +val OPOST = _const "Posix_TTY_O_OPOST" : C_TCFlag.t; +val TAB0 = _const "Posix_TTY_O_TAB0" : C_TCFlag.t; +val TAB1 = _const "Posix_TTY_O_TAB1" : C_TCFlag.t; +val TAB2 = _const "Posix_TTY_O_TAB2" : C_TCFlag.t; +val TAB3 = _const "Posix_TTY_O_TAB3" : C_TCFlag.t; +val TABDLY = _const "Posix_TTY_O_TABDLY" : C_TCFlag.t; +val VT0 = _const "Posix_TTY_O_VT0" : C_TCFlag.t; +val VT1 = _const "Posix_TTY_O_VT1" : C_TCFlag.t; +val VTDLY = _const "Posix_TTY_O_VTDLY" : C_TCFlag.t; +end +structure TC = +struct +val drain = _import "Posix_TTY_TC_drain" private : C_Fd.t -> (C_Int.t) C_Errno.t; +val flow = _import "Posix_TTY_TC_flow" private : C_Fd.t * C_Int.t -> (C_Int.t) C_Errno.t; +val flush = _import "Posix_TTY_TC_flush" private : C_Fd.t * C_Int.t -> (C_Int.t) C_Errno.t; +val getattr = _import "Posix_TTY_TC_getattr" private : C_Fd.t -> (C_Int.t) C_Errno.t; +val getpgrp = _import "Posix_TTY_TC_getpgrp" private : C_Fd.t -> (C_PId.t) C_Errno.t; +val sendbreak = _import "Posix_TTY_TC_sendbreak" private : C_Fd.t * C_Int.t -> (C_Int.t) C_Errno.t; +val setattr = _import "Posix_TTY_TC_setattr" private : C_Fd.t * C_Int.t -> (C_Int.t) C_Errno.t; +val setpgrp = _import "Posix_TTY_TC_setpgrp" private : C_Fd.t * C_PId.t -> (C_Int.t) C_Errno.t; +val TCIFLUSH = _const "Posix_TTY_TC_TCIFLUSH" : C_Int.t; +val TCIOFF = _const "Posix_TTY_TC_TCIOFF" : C_Int.t; +val TCIOFLUSH = _const "Posix_TTY_TC_TCIOFLUSH" : C_Int.t; +val TCION = _const "Posix_TTY_TC_TCION" : C_Int.t; +val TCOFLUSH = _const "Posix_TTY_TC_TCOFLUSH" : C_Int.t; +val TCOOFF = _const "Posix_TTY_TC_TCOOFF" : C_Int.t; +val TCOON = _const "Posix_TTY_TC_TCOON" : C_Int.t; +val TCSADRAIN = _const "Posix_TTY_TC_TCSADRAIN" : C_Int.t; +val TCSAFLUSH = _const "Posix_TTY_TC_TCSAFLUSH" : C_Int.t; +val TCSANOW = _const "Posix_TTY_TC_TCSANOW" : C_Int.t; +end +structure Termios = +struct +val cfGetISpeed = _import "Posix_TTY_Termios_cfGetISpeed" private : unit -> C_Speed.t; +val cfGetOSpeed = _import "Posix_TTY_Termios_cfGetOSpeed" private : unit -> C_Speed.t; +val cfSetISpeed = _import "Posix_TTY_Termios_cfSetISpeed" private : C_Speed.t -> (C_Int.t) C_Errno.t; +val cfSetOSpeed = _import "Posix_TTY_Termios_cfSetOSpeed" private : C_Speed.t -> (C_Int.t) C_Errno.t; +val getCC = _import "Posix_TTY_Termios_getCC" private : (C_CC.t) array -> unit; +val getCFlag = _import "Posix_TTY_Termios_getCFlag" private : unit -> C_TCFlag.t; +val getIFlag = _import "Posix_TTY_Termios_getIFlag" private : unit -> C_TCFlag.t; +val getLFlag = _import "Posix_TTY_Termios_getLFlag" private : unit -> C_TCFlag.t; +val getOFlag = _import "Posix_TTY_Termios_getOFlag" private : unit -> C_TCFlag.t; +val setCC = _import "Posix_TTY_Termios_setCC" private : (C_CC.t) array -> unit; +val setCFlag = _import "Posix_TTY_Termios_setCFlag" private : C_TCFlag.t -> unit; +val setIFlag = _import "Posix_TTY_Termios_setIFlag" private : C_TCFlag.t -> unit; +val setLFlag = _import "Posix_TTY_Termios_setLFlag" private : C_TCFlag.t -> unit; +val setOFlag = _import "Posix_TTY_Termios_setOFlag" private : C_TCFlag.t -> unit; +end +structure V = +struct +val NCCS = _const "Posix_TTY_V_NCCS" : C_Int.t; +val VEOF = _const "Posix_TTY_V_VEOF" : C_Int.t; +val VEOL = _const "Posix_TTY_V_VEOL" : C_Int.t; +val VERASE = _const "Posix_TTY_V_VERASE" : C_Int.t; +val VINTR = _const "Posix_TTY_V_VINTR" : C_Int.t; +val VKILL = _const "Posix_TTY_V_VKILL" : C_Int.t; +val VMIN = _const "Posix_TTY_V_VMIN" : C_Int.t; +val VQUIT = _const "Posix_TTY_V_VQUIT" : C_Int.t; +val VSTART = _const "Posix_TTY_V_VSTART" : C_Int.t; +val VSTOP = _const "Posix_TTY_V_VSTOP" : C_Int.t; +val VSUSP = _const "Posix_TTY_V_VSUSP" : C_Int.t; +val VTIME = _const "Posix_TTY_V_VTIME" : C_Int.t; +end +end +end +structure Real32 = +struct +type t = Real32.t +val abs = _import "Real32_abs" private : Real32.t -> Real32.t; +val add = _import "Real32_add" private : Real32.t * Real32.t -> Real32.t; +val castToWord32 = _import "Real32_castToWord32" private : Real32.t -> Word32.t; +val div = _import "Real32_div" private : Real32.t * Real32.t -> Real32.t; +val equal = _import "Real32_equal" private : Real32.t * Real32.t -> Bool.t; +val fetch = _import "Real32_fetch" private : (Real32.t) ref -> Real32.t; +val frexp = _import "Real32_frexp" private : Real32.t * (C_Int.t) ref -> Real32.t; +val gdtoa = _import "Real32_gdtoa" private : Real32.t * C_Int.t * C_Int.t * C_Int.t * (C_Int.t) ref -> C_String.t; +val ldexp = _import "Real32_ldexp" private : Real32.t * C_Int.t -> Real32.t; +val le = _import "Real32_le" private : Real32.t * Real32.t -> Bool.t; +val lt = _import "Real32_lt" private : Real32.t * Real32.t -> Bool.t; +structure Math = +struct +val acos = _import "Real32_Math_acos" private : Real32.t -> Real32.t; +val asin = _import "Real32_Math_asin" private : Real32.t -> Real32.t; +val atan = _import "Real32_Math_atan" private : Real32.t -> Real32.t; +val atan2 = _import "Real32_Math_atan2" private : Real32.t * Real32.t -> Real32.t; +val cos = _import "Real32_Math_cos" private : Real32.t -> Real32.t; +val cosh = _import "Real32_Math_cosh" private : Real32.t -> Real32.t; +val (eGet, eSet) = _symbol "Real32_Math_e" private : (unit -> (Real32.t)) * ((Real32.t) -> unit); +val exp = _import "Real32_Math_exp" private : Real32.t -> Real32.t; +val ln = _import "Real32_Math_ln" private : Real32.t -> Real32.t; +val log10 = _import "Real32_Math_log10" private : Real32.t -> Real32.t; +val (piGet, piSet) = _symbol "Real32_Math_pi" private : (unit -> (Real32.t)) * ((Real32.t) -> unit); +val pow = _import "Real32_Math_pow" private : Real32.t * Real32.t -> Real32.t; +val sin = _import "Real32_Math_sin" private : Real32.t -> Real32.t; +val sinh = _import "Real32_Math_sinh" private : Real32.t -> Real32.t; +val sqrt = _import "Real32_Math_sqrt" private : Real32.t -> Real32.t; +val tan = _import "Real32_Math_tan" private : Real32.t -> Real32.t; +val tanh = _import "Real32_Math_tanh" private : Real32.t -> Real32.t; +end +val modf = _import "Real32_modf" private : Real32.t * (Real32.t) ref -> Real32.t; +val move = _import "Real32_move" private : (Real32.t) ref * (Real32.t) ref -> unit; +val mul = _import "Real32_mul" private : Real32.t * Real32.t -> Real32.t; +val muladd = _import "Real32_muladd" private : Real32.t * Real32.t * Real32.t -> Real32.t; +val mulsub = _import "Real32_mulsub" private : Real32.t * Real32.t * Real32.t -> Real32.t; +val neg = _import "Real32_neg" private : Real32.t -> Real32.t; +val realCeil = _import "Real32_realCeil" private : Real32.t -> Real32.t; +val realFloor = _import "Real32_realFloor" private : Real32.t -> Real32.t; +val realTrunc = _import "Real32_realTrunc" private : Real32.t -> Real32.t; +val rndToReal32 = _import "Real32_rndToReal32" private : Real32.t -> Real32.t; +val rndToReal64 = _import "Real32_rndToReal64" private : Real32.t -> Real64.t; +val rndToWordS16 = _import "Real32_rndToWordS16" private : Real32.t -> Int16.t; +val rndToWordS32 = _import "Real32_rndToWordS32" private : Real32.t -> Int32.t; +val rndToWordS64 = _import "Real32_rndToWordS64" private : Real32.t -> Int64.t; +val rndToWordS8 = _import "Real32_rndToWordS8" private : Real32.t -> Int8.t; +val rndToWordU16 = _import "Real32_rndToWordU16" private : Real32.t -> Word16.t; +val rndToWordU32 = _import "Real32_rndToWordU32" private : Real32.t -> Word32.t; +val rndToWordU64 = _import "Real32_rndToWordU64" private : Real32.t -> Word64.t; +val rndToWordU8 = _import "Real32_rndToWordU8" private : Real32.t -> Word8.t; +val round = _import "Real32_round" private : Real32.t -> Real32.t; +val store = _import "Real32_store" private : (Real32.t) ref * Real32.t -> unit; +val strtor = _import "Real32_strtor" private : NullString8.t * C_Int.t -> Real32.t; +val sub = _import "Real32_sub" private : Real32.t * Real32.t -> Real32.t; +end +structure Real64 = +struct +type t = Real64.t +val abs = _import "Real64_abs" private : Real64.t -> Real64.t; +val add = _import "Real64_add" private : Real64.t * Real64.t -> Real64.t; +val castToWord64 = _import "Real64_castToWord64" private : Real64.t -> Word64.t; +val div = _import "Real64_div" private : Real64.t * Real64.t -> Real64.t; +val equal = _import "Real64_equal" private : Real64.t * Real64.t -> Bool.t; +val fetch = _import "Real64_fetch" private : (Real64.t) ref -> Real64.t; +val frexp = _import "Real64_frexp" private : Real64.t * (C_Int.t) ref -> Real64.t; +val gdtoa = _import "Real64_gdtoa" private : Real64.t * C_Int.t * C_Int.t * C_Int.t * (C_Int.t) ref -> C_String.t; +val ldexp = _import "Real64_ldexp" private : Real64.t * C_Int.t -> Real64.t; +val le = _import "Real64_le" private : Real64.t * Real64.t -> Bool.t; +val lt = _import "Real64_lt" private : Real64.t * Real64.t -> Bool.t; +structure Math = +struct +val acos = _import "Real64_Math_acos" private : Real64.t -> Real64.t; +val asin = _import "Real64_Math_asin" private : Real64.t -> Real64.t; +val atan = _import "Real64_Math_atan" private : Real64.t -> Real64.t; +val atan2 = _import "Real64_Math_atan2" private : Real64.t * Real64.t -> Real64.t; +val cos = _import "Real64_Math_cos" private : Real64.t -> Real64.t; +val cosh = _import "Real64_Math_cosh" private : Real64.t -> Real64.t; +val (eGet, eSet) = _symbol "Real64_Math_e" private : (unit -> (Real64.t)) * ((Real64.t) -> unit); +val exp = _import "Real64_Math_exp" private : Real64.t -> Real64.t; +val ln = _import "Real64_Math_ln" private : Real64.t -> Real64.t; +val log10 = _import "Real64_Math_log10" private : Real64.t -> Real64.t; +val (piGet, piSet) = _symbol "Real64_Math_pi" private : (unit -> (Real64.t)) * ((Real64.t) -> unit); +val pow = _import "Real64_Math_pow" private : Real64.t * Real64.t -> Real64.t; +val sin = _import "Real64_Math_sin" private : Real64.t -> Real64.t; +val sinh = _import "Real64_Math_sinh" private : Real64.t -> Real64.t; +val sqrt = _import "Real64_Math_sqrt" private : Real64.t -> Real64.t; +val tan = _import "Real64_Math_tan" private : Real64.t -> Real64.t; +val tanh = _import "Real64_Math_tanh" private : Real64.t -> Real64.t; +end +val modf = _import "Real64_modf" private : Real64.t * (Real64.t) ref -> Real64.t; +val move = _import "Real64_move" private : (Real64.t) ref * (Real64.t) ref -> unit; +val mul = _import "Real64_mul" private : Real64.t * Real64.t -> Real64.t; +val muladd = _import "Real64_muladd" private : Real64.t * Real64.t * Real64.t -> Real64.t; +val mulsub = _import "Real64_mulsub" private : Real64.t * Real64.t * Real64.t -> Real64.t; +val neg = _import "Real64_neg" private : Real64.t -> Real64.t; +val realCeil = _import "Real64_realCeil" private : Real64.t -> Real64.t; +val realFloor = _import "Real64_realFloor" private : Real64.t -> Real64.t; +val realTrunc = _import "Real64_realTrunc" private : Real64.t -> Real64.t; +val rndToReal32 = _import "Real64_rndToReal32" private : Real64.t -> Real32.t; +val rndToReal64 = _import "Real64_rndToReal64" private : Real64.t -> Real64.t; +val rndToWordS16 = _import "Real64_rndToWordS16" private : Real64.t -> Int16.t; +val rndToWordS32 = _import "Real64_rndToWordS32" private : Real64.t -> Int32.t; +val rndToWordS64 = _import "Real64_rndToWordS64" private : Real64.t -> Int64.t; +val rndToWordS8 = _import "Real64_rndToWordS8" private : Real64.t -> Int8.t; +val rndToWordU16 = _import "Real64_rndToWordU16" private : Real64.t -> Word16.t; +val rndToWordU32 = _import "Real64_rndToWordU32" private : Real64.t -> Word32.t; +val rndToWordU64 = _import "Real64_rndToWordU64" private : Real64.t -> Word64.t; +val rndToWordU8 = _import "Real64_rndToWordU8" private : Real64.t -> Word8.t; +val round = _import "Real64_round" private : Real64.t -> Real64.t; +val store = _import "Real64_store" private : (Real64.t) ref * Real64.t -> unit; +val strtor = _import "Real64_strtor" private : NullString8.t * C_Int.t -> Real64.t; +val sub = _import "Real64_sub" private : Real64.t * Real64.t -> Real64.t; +end +structure Socket = +struct +val accept = _import "Socket_accept" private : C_Sock.t * (Word8.t) array * (C_Socklen.t) ref -> (C_Int.t) C_Errno.t; +structure AF = +struct +val INET = _const "Socket_AF_INET" : C_Int.t; +val INET6 = _const "Socket_AF_INET6" : C_Int.t; +val UNIX = _const "Socket_AF_UNIX" : C_Int.t; +val UNSPEC = _const "Socket_AF_UNSPEC" : C_Int.t; +end +val bind = _import "Socket_bind" private : C_Sock.t * (Word8.t) vector * C_Socklen.t -> (C_Int.t) C_Errno.t; +val close = _import "Socket_close" private : C_Sock.t -> (C_Int.t) C_Errno.t; +val connect = _import "Socket_connect" private : C_Sock.t * (Word8.t) vector * C_Socklen.t -> (C_Int.t) C_Errno.t; +structure Ctl = +struct +val getATMARK = _import "Socket_Ctl_getATMARK" private : C_Sock.t * (C_Int.t) ref -> (C_Int.t) C_Errno.t; +val getNREAD = _import "Socket_Ctl_getNREAD" private : C_Sock.t * (C_Int.t) ref -> (C_Int.t) C_Errno.t; +val getPeerName = _import "Socket_Ctl_getPeerName" private : C_Sock.t * (Word8.t) array * (C_Socklen.t) ref -> (C_Int.t) C_Errno.t; +val getSockName = _import "Socket_Ctl_getSockName" private : C_Sock.t * (Word8.t) array * (C_Socklen.t) ref -> (C_Int.t) C_Errno.t; +val getSockOptC_Int = _import "Socket_Ctl_getSockOptC_Int" private : C_Sock.t * C_Int.t * C_Int.t * (C_Int.t) ref -> (C_Int.t) C_Errno.t; +val getSockOptC_Linger = _import "Socket_Ctl_getSockOptC_Linger" private : C_Sock.t * C_Int.t * C_Int.t * (C_Int.t) ref * (C_Int.t) ref -> (C_Int.t) C_Errno.t; +val setSockOptC_Int = _import "Socket_Ctl_setSockOptC_Int" private : C_Sock.t * C_Int.t * C_Int.t * C_Int.t -> (C_Int.t) C_Errno.t; +val setSockOptC_Linger = _import "Socket_Ctl_setSockOptC_Linger" private : C_Sock.t * C_Int.t * C_Int.t * C_Int.t * C_Int.t -> (C_Int.t) C_Errno.t; +val SO_ACCEPTCONN = _const "Socket_Ctl_SO_ACCEPTCONN" : C_Int.t; +val SO_BROADCAST = _const "Socket_Ctl_SO_BROADCAST" : C_Int.t; +val SO_DEBUG = _const "Socket_Ctl_SO_DEBUG" : C_Int.t; +val SO_DONTROUTE = _const "Socket_Ctl_SO_DONTROUTE" : C_Int.t; +val SO_ERROR = _const "Socket_Ctl_SO_ERROR" : C_Int.t; +val SO_KEEPALIVE = _const "Socket_Ctl_SO_KEEPALIVE" : C_Int.t; +val SO_LINGER = _const "Socket_Ctl_SO_LINGER" : C_Int.t; +val SO_OOBINLINE = _const "Socket_Ctl_SO_OOBINLINE" : C_Int.t; +val SO_RCVBUF = _const "Socket_Ctl_SO_RCVBUF" : C_Int.t; +val SO_RCVLOWAT = _const "Socket_Ctl_SO_RCVLOWAT" : C_Int.t; +val SO_RCVTIMEO = _const "Socket_Ctl_SO_RCVTIMEO" : C_Int.t; +val SO_REUSEADDR = _const "Socket_Ctl_SO_REUSEADDR" : C_Int.t; +val SO_SNDBUF = _const "Socket_Ctl_SO_SNDBUF" : C_Int.t; +val SO_SNDLOWAT = _const "Socket_Ctl_SO_SNDLOWAT" : C_Int.t; +val SO_SNDTIMEO = _const "Socket_Ctl_SO_SNDTIMEO" : C_Int.t; +val SO_TYPE = _const "Socket_Ctl_SO_TYPE" : C_Int.t; +val SOL_SOCKET = _const "Socket_Ctl_SOL_SOCKET" : C_Int.t; +end +val familyOfAddr = _import "Socket_familyOfAddr" private : (Word8.t) vector -> C_Int.t; +structure GenericSock = +struct +val socket = _import "Socket_GenericSock_socket" private : C_Int.t * C_Int.t * C_Int.t -> (C_Int.t) C_Errno.t; +val socketPair = _import "Socket_GenericSock_socketPair" private : C_Int.t * C_Int.t * C_Int.t * (C_Int.t) array -> (C_Int.t) C_Errno.t; +end +val getTimeout_sec = _import "Socket_getTimeout_sec" private : unit -> C_Time.t; +val getTimeout_usec = _import "Socket_getTimeout_usec" private : unit -> C_SUSeconds.t; +structure INetSock = +struct +structure Ctl = +struct +val IPPROTO_TCP = _const "Socket_INetSock_Ctl_IPPROTO_TCP" : C_Int.t; +val TCP_NODELAY = _const "Socket_INetSock_Ctl_TCP_NODELAY" : C_Int.t; +end +val fromAddr = _import "Socket_INetSock_fromAddr" private : (Word8.t) vector -> unit; +val getInAddr = _import "Socket_INetSock_getInAddr" private : (Word8.t) array -> unit; +val getPort = _import "Socket_INetSock_getPort" private : unit -> Word16.t; +val toAddr = _import "Socket_INetSock_toAddr" private : (Word8.t) vector * Word16.t * (Word8.t) array * (C_Socklen.t) ref -> unit; +end +val listen = _import "Socket_listen" private : C_Sock.t * C_Int.t -> (C_Int.t) C_Errno.t; +val MSG_CTRUNC = _const "Socket_MSG_CTRUNC" : C_Int.t; +val MSG_DONTROUTE = _const "Socket_MSG_DONTROUTE" : C_Int.t; +val MSG_DONTWAIT = _const "Socket_MSG_DONTWAIT" : C_Int.t; +val MSG_EOR = _const "Socket_MSG_EOR" : C_Int.t; +val MSG_OOB = _const "Socket_MSG_OOB" : C_Int.t; +val MSG_PEEK = _const "Socket_MSG_PEEK" : C_Int.t; +val MSG_TRUNC = _const "Socket_MSG_TRUNC" : C_Int.t; +val MSG_WAITALL = _const "Socket_MSG_WAITALL" : C_Int.t; +val recv = _import "Socket_recv" private : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t -> (C_SSize.t) C_Errno.t; +val recvFrom = _import "Socket_recvFrom" private : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t * (Word8.t) array * (C_Socklen.t) ref -> (C_SSize.t) C_Errno.t; +val select = _import "Socket_select" private : (C_Fd.t) vector * (C_Fd.t) vector * (C_Fd.t) vector * (C_Int.t) array * (C_Int.t) array * (C_Int.t) array -> (C_Int.t) C_Errno.t; +val sendArr = _import "Socket_sendArr" private : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t -> (C_SSize.t) C_Errno.t; +val sendArrTo = _import "Socket_sendArrTo" private : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t * (Word8.t) vector * C_Socklen.t -> (C_SSize.t) C_Errno.t; +val sendVec = _import "Socket_sendVec" private : C_Sock.t * (Word8.t) vector * C_Int.t * C_Size.t * C_Int.t -> (C_SSize.t) C_Errno.t; +val sendVecTo = _import "Socket_sendVecTo" private : C_Sock.t * (Word8.t) vector * C_Int.t * C_Size.t * C_Int.t * (Word8.t) vector * C_Socklen.t -> (C_SSize.t) C_Errno.t; +val setTimeout = _import "Socket_setTimeout" private : C_Time.t * C_SUSeconds.t -> unit; +val setTimeoutNull = _import "Socket_setTimeoutNull" private : unit -> unit; +val SHUT_RD = _const "Socket_SHUT_RD" : C_Int.t; +val SHUT_RDWR = _const "Socket_SHUT_RDWR" : C_Int.t; +val SHUT_WR = _const "Socket_SHUT_WR" : C_Int.t; +val shutdown = _import "Socket_shutdown" private : C_Sock.t * C_Int.t -> (C_Int.t) C_Errno.t; +structure SOCK = +struct +val DGRAM = _const "Socket_SOCK_DGRAM" : C_Int.t; +val RAW = _const "Socket_SOCK_RAW" : C_Int.t; +val SEQPACKET = _const "Socket_SOCK_SEQPACKET" : C_Int.t; +val STREAM = _const "Socket_SOCK_STREAM" : C_Int.t; +end +val sockAddrStorageLen = _const "Socket_sockAddrStorageLen" : C_Size.t; +structure UnixSock = +struct +val fromAddr = _import "Socket_UnixSock_fromAddr" private : (Word8.t) vector * (Char8.t) array * C_Size.t -> unit; +val pathLen = _import "Socket_UnixSock_pathLen" private : (Word8.t) vector -> C_Size.t; +val toAddr = _import "Socket_UnixSock_toAddr" private : NullString8.t * C_Size.t * (Word8.t) array * (C_Socklen.t) ref -> unit; +end +end +structure Stdio = +struct +val print = _import "Stdio_print" private : String8.t -> unit; +val printStderr = _import "Stdio_printStderr" private : String8.t -> unit; +val printStdout = _import "Stdio_printStdout" private : String8.t -> unit; +end +structure Time = +struct +val getTimeOfDay = _import "Time_getTimeOfDay" private : (C_Time.t) ref * (C_SUSeconds.t) ref -> C_Int.t; +end +structure Windows = +struct +structure Process = +struct +val create = _import "Windows_Process_create" private : NullString8.t * NullString8.t * NullString8.t * C_Fd.t * C_Fd.t * C_Fd.t -> (C_PId.t) C_Errno.t; +val createNull = _import "Windows_Process_createNull" private : NullString8.t * NullString8.t * C_Fd.t * C_Fd.t * C_Fd.t -> (C_PId.t) C_Errno.t; +val getexitcode = _import "Windows_Process_getexitcode" private : C_PId.t * (C_Status.t) ref -> (C_Int.t) C_Errno.t; +val terminate = _import "Windows_Process_terminate" private : C_PId.t * C_Signal.t -> (C_Int.t) C_Errno.t; +end +end +structure Word16 = +struct +type t = Word16.t +val add = _import "Word16_add" private : Word16.t * Word16.t -> Word16.t; +val andb = _import "Word16_andb" private : Word16.t * Word16.t -> Word16.t; +val equal = _import "Word16_equal" private : Word16.t * Word16.t -> Bool.t; +val lshift = _import "Word16_lshift" private : Word16.t * Word32.t -> Word16.t; +val neg = _import "Word16_neg" private : Word16.t -> Word16.t; +val notb = _import "Word16_notb" private : Word16.t -> Word16.t; +val orb = _import "Word16_orb" private : Word16.t * Word16.t -> Word16.t; +val rol = _import "Word16_rol" private : Word16.t * Word32.t -> Word16.t; +val ror = _import "Word16_ror" private : Word16.t * Word32.t -> Word16.t; +val sub = _import "Word16_sub" private : Word16.t * Word16.t -> Word16.t; +val xorb = _import "Word16_xorb" private : Word16.t * Word16.t -> Word16.t; +end +structure Word32 = +struct +type t = Word32.t +val add = _import "Word32_add" private : Word32.t * Word32.t -> Word32.t; +val andb = _import "Word32_andb" private : Word32.t * Word32.t -> Word32.t; +val castToReal32 = _import "Word32_castToReal32" private : Word32.t -> Real32.t; +val equal = _import "Word32_equal" private : Word32.t * Word32.t -> Bool.t; +val lshift = _import "Word32_lshift" private : Word32.t * Word32.t -> Word32.t; +val neg = _import "Word32_neg" private : Word32.t -> Word32.t; +val notb = _import "Word32_notb" private : Word32.t -> Word32.t; +val orb = _import "Word32_orb" private : Word32.t * Word32.t -> Word32.t; +val rol = _import "Word32_rol" private : Word32.t * Word32.t -> Word32.t; +val ror = _import "Word32_ror" private : Word32.t * Word32.t -> Word32.t; +val sub = _import "Word32_sub" private : Word32.t * Word32.t -> Word32.t; +val xorb = _import "Word32_xorb" private : Word32.t * Word32.t -> Word32.t; +end +structure Word64 = +struct +type t = Word64.t +val add = _import "Word64_add" private : Word64.t * Word64.t -> Word64.t; +val andb = _import "Word64_andb" private : Word64.t * Word64.t -> Word64.t; +val castToReal64 = _import "Word64_castToReal64" private : Word64.t -> Real64.t; +val equal = _import "Word64_equal" private : Word64.t * Word64.t -> Bool.t; +val fetch = _import "Word64_fetch" private : (Word64.t) ref -> Word64.t; +val lshift = _import "Word64_lshift" private : Word64.t * Word32.t -> Word64.t; +val move = _import "Word64_move" private : (Word64.t) ref * (Word64.t) ref -> unit; +val neg = _import "Word64_neg" private : Word64.t -> Word64.t; +val notb = _import "Word64_notb" private : Word64.t -> Word64.t; +val orb = _import "Word64_orb" private : Word64.t * Word64.t -> Word64.t; +val rol = _import "Word64_rol" private : Word64.t * Word32.t -> Word64.t; +val ror = _import "Word64_ror" private : Word64.t * Word32.t -> Word64.t; +val store = _import "Word64_store" private : (Word64.t) ref * Word64.t -> unit; +val sub = _import "Word64_sub" private : Word64.t * Word64.t -> Word64.t; +val xorb = _import "Word64_xorb" private : Word64.t * Word64.t -> Word64.t; +end +structure Word8 = +struct +type t = Word8.t +val add = _import "Word8_add" private : Word8.t * Word8.t -> Word8.t; +val andb = _import "Word8_andb" private : Word8.t * Word8.t -> Word8.t; +val equal = _import "Word8_equal" private : Word8.t * Word8.t -> Bool.t; +val lshift = _import "Word8_lshift" private : Word8.t * Word32.t -> Word8.t; +val neg = _import "Word8_neg" private : Word8.t -> Word8.t; +val notb = _import "Word8_notb" private : Word8.t -> Word8.t; +val orb = _import "Word8_orb" private : Word8.t * Word8.t -> Word8.t; +val rol = _import "Word8_rol" private : Word8.t * Word32.t -> Word8.t; +val ror = _import "Word8_ror" private : Word8.t * Word32.t -> Word8.t; +val sub = _import "Word8_sub" private : Word8.t * Word8.t -> Word8.t; +val xorb = _import "Word8_xorb" private : Word8.t * Word8.t -> Word8.t; +end +structure WordS16 = +struct +val addCheckOverflows = _import "WordS16_addCheckOverflows" private : Int16.t * Int16.t -> Bool.t; +val extdToWord16 = _import "WordS16_extdToWord16" private : Int16.t -> Word16.t; +val extdToWord32 = _import "WordS16_extdToWord32" private : Int16.t -> Word32.t; +val extdToWord64 = _import "WordS16_extdToWord64" private : Int16.t -> Word64.t; +val extdToWord8 = _import "WordS16_extdToWord8" private : Int16.t -> Word8.t; +val ge = _import "WordS16_ge" private : Int16.t * Int16.t -> Bool.t; +val gt = _import "WordS16_gt" private : Int16.t * Int16.t -> Bool.t; +val le = _import "WordS16_le" private : Int16.t * Int16.t -> Bool.t; +val lt = _import "WordS16_lt" private : Int16.t * Int16.t -> Bool.t; +val mul = _import "WordS16_mul" private : Int16.t * Int16.t -> Int16.t; +val mulCheckOverflows = _import "WordS16_mulCheckOverflows" private : Int16.t * Int16.t -> Bool.t; +val negCheckOverflows = _import "WordS16_negCheckOverflows" private : Int16.t -> Bool.t; +val quot = _import "WordS16_quot" private : Int16.t * Int16.t -> Int16.t; +val rem = _import "WordS16_rem" private : Int16.t * Int16.t -> Int16.t; +val rndToReal32 = _import "WordS16_rndToReal32" private : Int16.t -> Real32.t; +val rndToReal64 = _import "WordS16_rndToReal64" private : Int16.t -> Real64.t; +val rshift = _import "WordS16_rshift" private : Int16.t * Word32.t -> Int16.t; +val subCheckOverflows = _import "WordS16_subCheckOverflows" private : Int16.t * Int16.t -> Bool.t; +end +structure WordS32 = +struct +val addCheckOverflows = _import "WordS32_addCheckOverflows" private : Int32.t * Int32.t -> Bool.t; +val extdToWord16 = _import "WordS32_extdToWord16" private : Int32.t -> Word16.t; +val extdToWord32 = _import "WordS32_extdToWord32" private : Int32.t -> Word32.t; +val extdToWord64 = _import "WordS32_extdToWord64" private : Int32.t -> Word64.t; +val extdToWord8 = _import "WordS32_extdToWord8" private : Int32.t -> Word8.t; +val ge = _import "WordS32_ge" private : Int32.t * Int32.t -> Bool.t; +val gt = _import "WordS32_gt" private : Int32.t * Int32.t -> Bool.t; +val le = _import "WordS32_le" private : Int32.t * Int32.t -> Bool.t; +val lt = _import "WordS32_lt" private : Int32.t * Int32.t -> Bool.t; +val mul = _import "WordS32_mul" private : Int32.t * Int32.t -> Int32.t; +val mulCheckOverflows = _import "WordS32_mulCheckOverflows" private : Int32.t * Int32.t -> Bool.t; +val negCheckOverflows = _import "WordS32_negCheckOverflows" private : Int32.t -> Bool.t; +val quot = _import "WordS32_quot" private : Int32.t * Int32.t -> Int32.t; +val rem = _import "WordS32_rem" private : Int32.t * Int32.t -> Int32.t; +val rndToReal32 = _import "WordS32_rndToReal32" private : Int32.t -> Real32.t; +val rndToReal64 = _import "WordS32_rndToReal64" private : Int32.t -> Real64.t; +val rshift = _import "WordS32_rshift" private : Int32.t * Word32.t -> Int32.t; +val subCheckOverflows = _import "WordS32_subCheckOverflows" private : Int32.t * Int32.t -> Bool.t; +end +structure WordS64 = +struct +val addCheckOverflows = _import "WordS64_addCheckOverflows" private : Int64.t * Int64.t -> Bool.t; +val extdToWord16 = _import "WordS64_extdToWord16" private : Int64.t -> Word16.t; +val extdToWord32 = _import "WordS64_extdToWord32" private : Int64.t -> Word32.t; +val extdToWord64 = _import "WordS64_extdToWord64" private : Int64.t -> Word64.t; +val extdToWord8 = _import "WordS64_extdToWord8" private : Int64.t -> Word8.t; +val ge = _import "WordS64_ge" private : Int64.t * Int64.t -> Bool.t; +val gt = _import "WordS64_gt" private : Int64.t * Int64.t -> Bool.t; +val le = _import "WordS64_le" private : Int64.t * Int64.t -> Bool.t; +val lt = _import "WordS64_lt" private : Int64.t * Int64.t -> Bool.t; +val mul = _import "WordS64_mul" private : Int64.t * Int64.t -> Int64.t; +val mulCheckOverflows = _import "WordS64_mulCheckOverflows" private : Int64.t * Int64.t -> Bool.t; +val negCheckOverflows = _import "WordS64_negCheckOverflows" private : Int64.t -> Bool.t; +val quot = _import "WordS64_quot" private : Int64.t * Int64.t -> Int64.t; +val rem = _import "WordS64_rem" private : Int64.t * Int64.t -> Int64.t; +val rndToReal32 = _import "WordS64_rndToReal32" private : Int64.t -> Real32.t; +val rndToReal64 = _import "WordS64_rndToReal64" private : Int64.t -> Real64.t; +val rshift = _import "WordS64_rshift" private : Int64.t * Word32.t -> Int64.t; +val subCheckOverflows = _import "WordS64_subCheckOverflows" private : Int64.t * Int64.t -> Bool.t; +end +structure WordS8 = +struct +val addCheckOverflows = _import "WordS8_addCheckOverflows" private : Int8.t * Int8.t -> Bool.t; +val extdToWord16 = _import "WordS8_extdToWord16" private : Int8.t -> Word16.t; +val extdToWord32 = _import "WordS8_extdToWord32" private : Int8.t -> Word32.t; +val extdToWord64 = _import "WordS8_extdToWord64" private : Int8.t -> Word64.t; +val extdToWord8 = _import "WordS8_extdToWord8" private : Int8.t -> Word8.t; +val ge = _import "WordS8_ge" private : Int8.t * Int8.t -> Bool.t; +val gt = _import "WordS8_gt" private : Int8.t * Int8.t -> Bool.t; +val le = _import "WordS8_le" private : Int8.t * Int8.t -> Bool.t; +val lt = _import "WordS8_lt" private : Int8.t * Int8.t -> Bool.t; +val mul = _import "WordS8_mul" private : Int8.t * Int8.t -> Int8.t; +val mulCheckOverflows = _import "WordS8_mulCheckOverflows" private : Int8.t * Int8.t -> Bool.t; +val negCheckOverflows = _import "WordS8_negCheckOverflows" private : Int8.t -> Bool.t; +val quot = _import "WordS8_quot" private : Int8.t * Int8.t -> Int8.t; +val rem = _import "WordS8_rem" private : Int8.t * Int8.t -> Int8.t; +val rndToReal32 = _import "WordS8_rndToReal32" private : Int8.t -> Real32.t; +val rndToReal64 = _import "WordS8_rndToReal64" private : Int8.t -> Real64.t; +val rshift = _import "WordS8_rshift" private : Int8.t * Word32.t -> Int8.t; +val subCheckOverflows = _import "WordS8_subCheckOverflows" private : Int8.t * Int8.t -> Bool.t; +end +structure WordU16 = +struct +val addCheckOverflows = _import "WordU16_addCheckOverflows" private : Word16.t * Word16.t -> Bool.t; +val extdToWord16 = _import "WordU16_extdToWord16" private : Word16.t -> Word16.t; +val extdToWord32 = _import "WordU16_extdToWord32" private : Word16.t -> Word32.t; +val extdToWord64 = _import "WordU16_extdToWord64" private : Word16.t -> Word64.t; +val extdToWord8 = _import "WordU16_extdToWord8" private : Word16.t -> Word8.t; +val ge = _import "WordU16_ge" private : Word16.t * Word16.t -> Bool.t; +val gt = _import "WordU16_gt" private : Word16.t * Word16.t -> Bool.t; +val le = _import "WordU16_le" private : Word16.t * Word16.t -> Bool.t; +val lt = _import "WordU16_lt" private : Word16.t * Word16.t -> Bool.t; +val mul = _import "WordU16_mul" private : Word16.t * Word16.t -> Word16.t; +val mulCheckOverflows = _import "WordU16_mulCheckOverflows" private : Word16.t * Word16.t -> Bool.t; +val quot = _import "WordU16_quot" private : Word16.t * Word16.t -> Word16.t; +val rem = _import "WordU16_rem" private : Word16.t * Word16.t -> Word16.t; +val rndToReal32 = _import "WordU16_rndToReal32" private : Word16.t -> Real32.t; +val rndToReal64 = _import "WordU16_rndToReal64" private : Word16.t -> Real64.t; +val rshift = _import "WordU16_rshift" private : Word16.t * Word32.t -> Word16.t; +end +structure WordU32 = +struct +val addCheckOverflows = _import "WordU32_addCheckOverflows" private : Word32.t * Word32.t -> Bool.t; +val extdToWord16 = _import "WordU32_extdToWord16" private : Word32.t -> Word16.t; +val extdToWord32 = _import "WordU32_extdToWord32" private : Word32.t -> Word32.t; +val extdToWord64 = _import "WordU32_extdToWord64" private : Word32.t -> Word64.t; +val extdToWord8 = _import "WordU32_extdToWord8" private : Word32.t -> Word8.t; +val ge = _import "WordU32_ge" private : Word32.t * Word32.t -> Bool.t; +val gt = _import "WordU32_gt" private : Word32.t * Word32.t -> Bool.t; +val le = _import "WordU32_le" private : Word32.t * Word32.t -> Bool.t; +val lt = _import "WordU32_lt" private : Word32.t * Word32.t -> Bool.t; +val mul = _import "WordU32_mul" private : Word32.t * Word32.t -> Word32.t; +val mulCheckOverflows = _import "WordU32_mulCheckOverflows" private : Word32.t * Word32.t -> Bool.t; +val quot = _import "WordU32_quot" private : Word32.t * Word32.t -> Word32.t; +val rem = _import "WordU32_rem" private : Word32.t * Word32.t -> Word32.t; +val rndToReal32 = _import "WordU32_rndToReal32" private : Word32.t -> Real32.t; +val rndToReal64 = _import "WordU32_rndToReal64" private : Word32.t -> Real64.t; +val rshift = _import "WordU32_rshift" private : Word32.t * Word32.t -> Word32.t; +end +structure WordU64 = +struct +val addCheckOverflows = _import "WordU64_addCheckOverflows" private : Word64.t * Word64.t -> Bool.t; +val extdToWord16 = _import "WordU64_extdToWord16" private : Word64.t -> Word16.t; +val extdToWord32 = _import "WordU64_extdToWord32" private : Word64.t -> Word32.t; +val extdToWord64 = _import "WordU64_extdToWord64" private : Word64.t -> Word64.t; +val extdToWord8 = _import "WordU64_extdToWord8" private : Word64.t -> Word8.t; +val ge = _import "WordU64_ge" private : Word64.t * Word64.t -> Bool.t; +val gt = _import "WordU64_gt" private : Word64.t * Word64.t -> Bool.t; +val le = _import "WordU64_le" private : Word64.t * Word64.t -> Bool.t; +val lt = _import "WordU64_lt" private : Word64.t * Word64.t -> Bool.t; +val mul = _import "WordU64_mul" private : Word64.t * Word64.t -> Word64.t; +val mulCheckOverflows = _import "WordU64_mulCheckOverflows" private : Word64.t * Word64.t -> Bool.t; +val quot = _import "WordU64_quot" private : Word64.t * Word64.t -> Word64.t; +val rem = _import "WordU64_rem" private : Word64.t * Word64.t -> Word64.t; +val rndToReal32 = _import "WordU64_rndToReal32" private : Word64.t -> Real32.t; +val rndToReal64 = _import "WordU64_rndToReal64" private : Word64.t -> Real64.t; +val rshift = _import "WordU64_rshift" private : Word64.t * Word32.t -> Word64.t; +end +structure WordU8 = +struct +val addCheckOverflows = _import "WordU8_addCheckOverflows" private : Word8.t * Word8.t -> Bool.t; +val extdToWord16 = _import "WordU8_extdToWord16" private : Word8.t -> Word16.t; +val extdToWord32 = _import "WordU8_extdToWord32" private : Word8.t -> Word32.t; +val extdToWord64 = _import "WordU8_extdToWord64" private : Word8.t -> Word64.t; +val extdToWord8 = _import "WordU8_extdToWord8" private : Word8.t -> Word8.t; +val ge = _import "WordU8_ge" private : Word8.t * Word8.t -> Bool.t; +val gt = _import "WordU8_gt" private : Word8.t * Word8.t -> Bool.t; +val le = _import "WordU8_le" private : Word8.t * Word8.t -> Bool.t; +val lt = _import "WordU8_lt" private : Word8.t * Word8.t -> Bool.t; +val mul = _import "WordU8_mul" private : Word8.t * Word8.t -> Word8.t; +val mulCheckOverflows = _import "WordU8_mulCheckOverflows" private : Word8.t * Word8.t -> Bool.t; +val quot = _import "WordU8_quot" private : Word8.t * Word8.t -> Word8.t; +val rem = _import "WordU8_rem" private : Word8.t * Word8.t -> Word8.t; +val rndToReal32 = _import "WordU8_rndToReal32" private : Word8.t -> Real32.t; +val rndToReal64 = _import "WordU8_rndToReal64" private : Word8.t -> Real64.t; +val rshift = _import "WordU8_rshift" private : Word8.t * Word32.t -> Word8.t; +end +end +end diff --git a/basis-library/primitive/check-real.sml b/basis-library/primitive/check-real.sml new file mode 100644 index 0000000..b386812 --- /dev/null +++ b/basis-library/primitive/check-real.sml @@ -0,0 +1,97 @@ +(* Copyright (C) 2012,2013 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + fun 'a check (_: 'a, _: 'a) : unit = () + + local + structure R1 = Primitive.Real32 + structure R2 = PrimitiveFFI.Real32 + in + val () = check (R1.Math.acos, R2.Math.acos) + val () = check (R1.Math.asin, R2.Math.asin) + val () = check (R1.Math.atan, R2.Math.atan) + val () = check (R1.Math.atan2, R2.Math.atan2) + val () = check (R1.Math.cos, R2.Math.cos) + val () = check (R1.Math.cosh, R2.Math.cosh) + val () = check (fn () => R1.Math.e, R2.Math.eGet) + val () = check (R1.Math.exp, R2.Math.exp) + val () = check (R1.Math.ln, R2.Math.ln) + val () = check (R1.Math.log10, R2.Math.log10) + val () = check (fn () => R1.Math.pi, R2.Math.piGet) + val () = check (R1.Math.pow, R2.Math.pow) + val () = check (R1.Math.sin, R2.Math.sin) + val () = check (R1.Math.sinh, R2.Math.sinh) + val () = check (R1.Math.sqrt, R2.Math.sqrt) + val () = check (R1.Math.tan, R2.Math.tan) + val () = check (R1.Math.tanh, R2.Math.tanh) + + val () = check (R1.abs, R2.abs) + val () = check (R1.+, R2.add) + val () = check (R1./, R2.div) + val () = check (R1.==, R2.equal) + val () = check (R1.frexp, R2.frexp) + val () = check (R1.gdtoa, R2.gdtoa) + val () = check (R1.ldexp, R2.ldexp) + val () = check (R1.<=, R2.le) + val () = check (R1.<, R2.lt) + val () = check (R1.modf, R2.modf) + val () = check (R1.*, R2.mul) + val () = check (R1.*+, R2.muladd) + val () = check (R1.*-, R2.mulsub) + val () = check (R1.~, R2.neg) + val () = check (R1.round, R2.round) + val () = check (R1.strtor, R2.strtor) + val () = check (R1.-, R2.sub) + end + + local + structure R1 = Primitive.Real64 + structure R2 = PrimitiveFFI.Real64 + in + val () = check (R1.Math.acos, R2.Math.acos) + val () = check (R1.Math.asin, R2.Math.asin) + val () = check (R1.Math.atan, R2.Math.atan) + val () = check (R1.Math.atan2, R2.Math.atan2) + val () = check (R1.Math.cos, R2.Math.cos) + val () = check (R1.Math.cosh, R2.Math.cosh) + val () = check (fn () => R1.Math.e, R2.Math.eGet) + val () = check (R1.Math.exp, R2.Math.exp) + val () = check (R1.Math.ln, R2.Math.ln) + val () = check (R1.Math.log10, R2.Math.log10) + val () = check (fn () => R1.Math.pi, R2.Math.piGet) + val () = check (R1.Math.pow, R2.Math.pow) + val () = check (R1.Math.sin, R2.Math.sin) + val () = check (R1.Math.sinh, R2.Math.sinh) + val () = check (R1.Math.sqrt, R2.Math.sqrt) + val () = check (R1.Math.tan, R2.Math.tan) + val () = check (R1.Math.tanh, R2.Math.tanh) + + val () = check (R1.abs, R2.abs) + val () = check (R1.+, R2.add) + val () = check (R1./, R2.div) + val () = check (R1.==, R2.equal) + val () = check (R1.frexp, R2.frexp) + val () = check (R1.gdtoa, R2.gdtoa) + val () = check (R1.ldexp, R2.ldexp) + val () = check (R1.<=, R2.le) + val () = check (R1.<, R2.lt) + val () = check (R1.modf, R2.modf) + val () = check (R1.*, R2.mul) + val () = check (R1.*+, R2.muladd) + val () = check (R1.*-, R2.mulsub) + val () = check (R1.~, R2.neg) + val () = check (R1.round, R2.round) + val () = check (R1.strtor, R2.strtor) + val () = check (R1.-, R2.sub) + end + +in + +end diff --git a/basis-library/primitive/prim-basis.mlb b/basis-library/primitive/prim-basis.mlb new file mode 100644 index 0000000..898eb7c --- /dev/null +++ b/basis-library/primitive/prim-basis.mlb @@ -0,0 +1,21 @@ +(* Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "allowPrim true" + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" +in + local + _prim + in + prim-basis.sml + end +end diff --git a/basis-library/primitive/prim-basis.sml b/basis-library/primitive/prim-basis.sml new file mode 100644 index 0000000..735c9de --- /dev/null +++ b/basis-library/primitive/prim-basis.sml @@ -0,0 +1,457 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Primitive = struct + +(* Primitive Basis (Definition) *) +structure Bool = + struct + datatype t = datatype bool + datatype bool = datatype t + end +structure Exn = + struct + type t = exn + type exn = t + exception Bind = Bind + exception Match = Match + exception PrimOverflow = Overflow + end +structure List = + struct + datatype t = datatype list + datatype list = datatype t + end +structure Ref = + struct + datatype t = datatype ref + datatype ref = datatype t + end +structure Unit = + struct + type t = unit + type unit = t + end + +(* Primitive Basis (Basis Library) *) +structure Array = + struct + type 'a t = 'a array + type 'a array = 'a t + end +structure Vector = + struct + type 'a t = 'a vector + type 'a vector = 'a t + end + +(* Primitive Basis (Primitive Types) *) +structure Char8 = + struct + type t = char8 + type char = t + end +structure Char16 = + struct + type t = char16 + type char = t + end +structure Char32 = + struct + type t = char32 + type char = t + end + +structure Int1 = + struct + type t = int1 + type int = t + end +structure Int2 = + struct + type t = int2 + type int = t + end +structure Int3 = + struct + type t = int3 + type int = t + end +structure Int4 = + struct + type t = int4 + type int = t + end +structure Int5 = + struct + type t = int5 + type int = t + end +structure Int6 = + struct + type t = int6 + type int = t + end +structure Int7 = + struct + type t = int7 + type int = t + end +structure Int8 = + struct + type t = int8 + type int = t + end +structure Int9 = + struct + type t = int9 + type int = t + end +structure Int10 = + struct + type t = int10 + type int = t + end +structure Int11 = + struct + type t = int11 + type int = t + end +structure Int12 = + struct + type t = int12 + type int = t + end +structure Int13 = + struct + type t = int13 + type int = t + end +structure Int14 = + struct + type t = int14 + type int = t + end +structure Int15 = + struct + type t = int15 + type int = t + end +structure Int16 = + struct + type t = int16 + type int = t + end +structure Int17 = + struct + type t = int17 + type int = t + end +structure Int18 = + struct + type t = int18 + type int = t + end +structure Int19 = + struct + type t = int19 + type int = t + end +structure Int20 = + struct + type t = int20 + type int = t + end +structure Int21 = + struct + type t = int21 + type int = t + end +structure Int22 = + struct + type t = int22 + type int = t + end +structure Int23 = + struct + type t = int23 + type int = t + end +structure Int24 = + struct + type t = int24 + type int = t + end +structure Int25 = + struct + type t = int25 + type int = t + end +structure Int26 = + struct + type t = int26 + type int = t + end +structure Int27 = + struct + type t = int27 + type int = t + end +structure Int28 = + struct + type t = int28 + type int = t + end +structure Int29 = + struct + type t = int29 + type int = t + end +structure Int30 = + struct + type t = int30 + type int = t + end +structure Int31 = + struct + type t = int31 + type int = t + end +structure Int32 = + struct + type t = int32 + type int = t + end +structure Int64 = + struct + type t = int64 + type int = t + end +structure IntInf = + struct + type t = intInf + type int = t + end + +structure Real32 = + struct + type t = real32 + type real = t + end +structure Real64 = + struct + type t = real64 + type real = t + end + +structure String8 = + struct + type t = Char8.t vector + type string = t + end +structure String16 = + struct + type t = Char16.t vector + type string = t + end +structure String32 = + struct + type t = Char32.t vector + type string = t + end + +structure Word1 = + struct + type t = word1 + type word = t + end +structure Word2 = + struct + type t = word2 + type word = t + end +structure Word3 = + struct + type t = word3 + type word = t + end +structure Word4 = + struct + type t = word4 + type word = t + end +structure Word5 = + struct + type t = word5 + type word = t + end +structure Word6 = + struct + type t = word6 + type word = t + end +structure Word7 = + struct + type t = word7 + type word = t + end +structure Word8 = + struct + type t = word8 + type word = t + end +structure Word9 = + struct + type t = word9 + type word = t + end +structure Word10 = + struct + type t = word10 + type word = t + end +structure Word11 = + struct + type t = word11 + type word = t + end +structure Word12 = + struct + type t = word12 + type word = t + end +structure Word13 = + struct + type t = word13 + type word = t + end +structure Word14 = + struct + type t = word14 + type word = t + end +structure Word15 = + struct + type t = word15 + type word = t + end +structure Word16 = + struct + type t = word16 + type word = t + end +structure Word17 = + struct + type t = word17 + type word = t + end +structure Word18 = + struct + type t = word18 + type word = t + end +structure Word19 = + struct + type t = word19 + type word = t + end +structure Word20 = + struct + type t = word20 + type word = t + end +structure Word21 = + struct + type t = word21 + type word = t + end +structure Word22 = + struct + type t = word22 + type word = t + end +structure Word23 = + struct + type t = word23 + type word = t + end +structure Word24 = + struct + type t = word24 + type word = t + end +structure Word25 = + struct + type t = word25 + type word = t + end +structure Word26 = + struct + type t = word26 + type word = t + end +structure Word27 = + struct + type t = word27 + type word = t + end +structure Word28 = + struct + type t = word28 + type word = t + end +structure Word29 = + struct + type t = word29 + type word = t + end +structure Word30 = + struct + type t = word30 + type word = t + end +structure Word31 = + struct + type t = word31 + type word = t + end +structure Word32 = + struct + type t = word32 + type word = t + end +structure Word64 = + struct + type t = word64 + type word = t + end + +(* Primitive Basis (MLton Extensions) *) +structure Pointer = + struct + type t = cpointer + end +structure Thread = + struct + type t = thread + end +structure Weak = + struct + type 'a t = 'a weak + end + +end + +(* Top-level bindings *) +datatype bool = datatype Primitive.Bool.bool +type exn = Primitive.Exn.exn +datatype list = datatype Primitive.List.list +datatype ref = datatype Primitive.Ref.ref +type unit = Primitive.Unit.unit +type 'a array = 'a Primitive.Array.array +type 'a vector = 'a Primitive.Vector.vector diff --git a/basis-library/primitive/prim-char.sml b/basis-library/primitive/prim-char.sml new file mode 100644 index 0000000..07031a4 --- /dev/null +++ b/basis-library/primitive/prim-char.sml @@ -0,0 +1,78 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +structure Primitive = struct + +open Primitive + +structure Char8 = + struct + open Char8 + + val < = _prim "WordU8_lt": char * char -> bool; + + val idToWord8 = _prim "WordU8_extdToWord8": char -> Word8.word; + val idFromWord8 = _prim "WordU8_extdToWord8": Word8.word -> char; + val idToInt8 = _prim "WordS8_extdToWord8": char -> Int8.int; + val idFromInt8 = _prim "WordS8_extdToWord8": Int8.int -> char; + end +structure Char8 = + struct + open Char8 + local + structure S = IntegralComparisons(Char8) + in + open S + end + end + +structure Char16 = + struct + open Char16 + + val < = _prim "WordU16_lt": char * char -> bool; + + val idToWord16 = _prim "WordU16_extdToWord16": char -> Word16.word; + val idFromWord16 = _prim "WordU16_extdToWord16": Word16.word -> char; + val idToInt16 = _prim "WordS16_extdToWord16": char -> Int16.int; + val idFromInt16 = _prim "WordS16_extdToWord16": Int16.int -> char; + end +structure Char16 = + struct + open Char16 + local + structure S = IntegralComparisons(Char16) + in + open S + end + end + +structure Char32 = + struct + open Char32 + + val < = _prim "WordU32_lt": char * char -> bool; + + val idToWord32 = _prim "WordU32_extdToWord32": char -> Word32.word; + val idFromWord32 = _prim "WordU32_extdToWord32": Word32.word -> char; + val idToInt32 = _prim "WordS32_extdToWord32": char -> Int32.int; + val idFromInt32 = _prim "WordS32_extdToWord32": Int32.int -> char; + end +structure Char32 = + struct + open Char32 + local + structure S = IntegralComparisons(Char32) + in + open S + end + end + +end diff --git a/basis-library/primitive/prim-int-inf.sml b/basis-library/primitive/prim-int-inf.sml new file mode 100644 index 0000000..2cec8df --- /dev/null +++ b/basis-library/primitive/prim-int-inf.sml @@ -0,0 +1,41 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +structure Primitive = struct + +open Primitive + +structure IntInf = + struct + open IntInf + + val + = _prim "IntInf_add": int * int * C_Size.t -> int; + val andb = _prim "IntInf_andb": int * int * C_Size.t -> int; + val ~>> = _prim "IntInf_arshift": int * Word32.word * C_Size.t -> int; + val compare = _prim "IntInf_compare": int * int -> Int32.int; + val fromVector = _prim "WordVector_toIntInf": C_MPLimb.t vector -> int; + val fromWord = _prim "Word_toIntInf": ObjptrWord.word -> int; + val gcd = _prim "IntInf_gcd": int * int * C_Size.t -> int; + val << = _prim "IntInf_lshift": int * Word32.word * C_Size.t -> int; + val * = _prim "IntInf_mul": int * int * C_Size.t -> int; + val ~ = _prim "IntInf_neg": int * C_Size.t -> int; + val notb = _prim "IntInf_notb": int * C_Size.t -> int; + val orb = _prim "IntInf_orb": int * int * C_Size.t -> int; + val quot = _prim "IntInf_quot": int * int * C_Size.t -> int; + val rem = _prim "IntInf_rem": int * int * C_Size.t -> int; + val - = _prim "IntInf_sub": int * int * C_Size.t -> int; + val toString = + _prim "IntInf_toString": int * Int32.int * C_Size.t -> String8.string; + val toVector = _prim "IntInf_toVector": int -> C_MPLimb.t vector; + val toWord = _prim "IntInf_toWord": int -> ObjptrWord.word; + val xorb = _prim "IntInf_xorb": int * int * C_Size.t -> int; + end + +end diff --git a/basis-library/primitive/prim-int.sml b/basis-library/primitive/prim-int.sml new file mode 100644 index 0000000..69b8ca1 --- /dev/null +++ b/basis-library/primitive/prim-int.sml @@ -0,0 +1,469 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +signature PRIM_INTEGER = + sig + eqtype int + type t = int + + val sizeInBits: Primitive.Int32.int + val sizeInBitsWord: Primitive.Word32.word + val precision: Primitive.Int32.int option + + val +! : int * int -> int + val +? : int * int -> int + val + : int * int -> int + val *! : int * int -> int + val *? : int * int -> int + val * : int * int -> int + val ~! : int -> int + val ~? : int -> int + val ~ : int -> int + val quotUnsafe: int * int -> int + val -! : int * int -> int + val -? : int * int -> int + val - : int * int -> int + val remUnsafe: int * int -> int + + val < : int * int -> bool + val <= : int * int -> bool + val > : int * int -> bool + val >= : int * int -> bool + val compare: int * int -> Primitive.Order.order + val min: int * int -> int + val max: int * int -> int + end + +structure Primitive = struct + +open Primitive + +structure Int1 = + struct + open Int1 + type big = Int8.int + val fromBigUnsafe = _prim "WordU8_extdToWord1": big -> int; + val sizeInBits: Int32.int = 1 + val toBig = _prim "WordU1_extdToWord8": int -> big; + end +structure Int2 = + struct + open Int2 + type big = Int8.int + val fromBigUnsafe = _prim "WordU8_extdToWord2": big -> int; + val sizeInBits: Int32.int = 2 + val toBig = _prim "WordU2_extdToWord8": int -> big; + end +structure Int3 = + struct + open Int3 + type big = Int8.int + val fromBigUnsafe = _prim "WordU8_extdToWord3": big -> int; + val sizeInBits: Int32.int = 3 + val toBig = _prim "WordU3_extdToWord8": int -> big; + end +structure Int4 = + struct + open Int4 + type big = Int8.int + val fromBigUnsafe = _prim "WordU8_extdToWord4": big -> int; + val sizeInBits: Int32.int = 4 + val toBig = _prim "WordU4_extdToWord8": int -> big; + end +structure Int5 = + struct + open Int5 + type big = Int8.int + val fromBigUnsafe = _prim "WordU8_extdToWord5": big -> int; + val sizeInBits: Int32.int = 5 + val toBig = _prim "WordU5_extdToWord8": int -> big; + end +structure Int6 = + struct + open Int6 + type big = Int8.int + val fromBigUnsafe = _prim "WordU8_extdToWord6": big -> int; + val sizeInBits: Int32.int = 6 + val toBig = _prim "WordU6_extdToWord8": int -> big; + end +structure Int7 = + struct + open Int7 + type big = Int8.int + val fromBigUnsafe = _prim "WordU8_extdToWord7": big -> int; + val sizeInBits: Int32.int = 7 + val toBig = _prim "WordU7_extdToWord8": int -> big; + end +structure Int8 = + struct + open Int8 + + val sizeInBits: Int32.int = 8 + val sizeInBitsWord: Word32.word = + IntWordConv.zextdFromInt32ToWord32 sizeInBits + val precision = SOME sizeInBits + + val +! = Exn.wrapOverflow (_prim "WordS8_addCheck": int * int -> int;) + val +? = _prim "Word8_add": int * int -> int; + val + = + if Controls.detectOverflow + then +! + else +? + val *! = Exn.wrapOverflow (_prim "WordS8_mulCheck": int * int -> int;) + val *? = _prim "WordS8_mul": int * int -> int; + val * = + if Controls.detectOverflow + then *! + else *? + val ~! = Exn.wrapOverflow (_prim "Word8_negCheck": int -> int;) + val ~? = _prim "Word8_neg": int -> int; + val ~ = + if Controls.detectOverflow + then ~! + else ~? + val quotUnsafe = _prim "WordS8_quot": int * int -> int; + val -! = Exn.wrapOverflow (_prim "WordS8_subCheck": int * int -> int;) + val -? = _prim "Word8_sub": int * int -> int; + val - = + if Controls.detectOverflow + then -! + else -? + val remUnsafe = _prim "WordS8_rem": int * int -> int; + + val < = _prim "WordS8_lt": int * int -> bool; + end +structure Int8 : PRIM_INTEGER = + struct + open Int8 + local + structure S = IntegralComparisons(Int8) + in + open S + end + end +structure Int9 = + struct + open Int9 + type big = Int16.int + val fromBigUnsafe = _prim "WordU16_extdToWord9": big -> int; + val sizeInBits: Int32.int = 9 + val toBig = _prim "WordU9_extdToWord16": int -> big; + end +structure Int10 = + struct + open Int10 + type big = Int16.int + val fromBigUnsafe = _prim "WordU16_extdToWord10": big -> int; + val sizeInBits: Int32.int = 10 + val toBig = _prim "WordU10_extdToWord16": int -> big; + end +structure Int11 = + struct + open Int11 + type big = Int16.int + val fromBigUnsafe = _prim "WordU16_extdToWord11": big -> int; + val sizeInBits: Int32.int = 11 + val toBig = _prim "WordU11_extdToWord16": int -> big; + end +structure Int12 = + struct + open Int12 + type big = Int16.int + val fromBigUnsafe = _prim "WordU16_extdToWord12": big -> int; + val sizeInBits: Int32.int = 12 + val toBig = _prim "WordU12_extdToWord16": int -> big; + end +structure Int13 = + struct + open Int13 + type big = Int16.int + val fromBigUnsafe = _prim "WordU16_extdToWord13": big -> int; + val sizeInBits: Int32.int = 13 + val toBig = _prim "WordU13_extdToWord16": int -> big; + end +structure Int14 = + struct + open Int14 + type big = Int16.int + val fromBigUnsafe = _prim "WordU16_extdToWord14": big -> int; + val sizeInBits: Int32.int = 14 + val toBig = _prim "WordU14_extdToWord16": int -> big; + end +structure Int15 = + struct + open Int15 + type big = Int16.int + val fromBigUnsafe = _prim "WordU16_extdToWord15": big -> int; + val sizeInBits: Int32.int = 15 + val toBig = _prim "WordU15_extdToWord16": int -> big; + end +structure Int16 = + struct + open Int16 + + val sizeInBits: Int32.int = 16 + val sizeInBitsWord: Word32.word = + IntWordConv.zextdFromInt32ToWord32 sizeInBits + val precision = SOME sizeInBits + + val +! = Exn.wrapOverflow (_prim "WordS16_addCheck": int * int -> int;) + val +? = _prim "Word16_add": int * int -> int; + val + = + if Controls.detectOverflow + then +! + else +? + val *! = Exn.wrapOverflow (_prim "WordS16_mulCheck": int * int -> int;) + val *? = _prim "WordS16_mul": int * int -> int; + val * = + if Controls.detectOverflow + then *! + else *? + val ~! = Exn.wrapOverflow (_prim "Word16_negCheck": int -> int;) + val ~? = _prim "Word16_neg": int -> int; + val ~ = + if Controls.detectOverflow + then ~! + else ~? + val quotUnsafe = _prim "WordS16_quot": int * int -> int; + val -! = Exn.wrapOverflow (_prim "WordS16_subCheck": int * int -> int;) + val -? = _prim "Word16_sub": int * int -> int; + val - = + if Controls.detectOverflow + then -! + else -? + val remUnsafe = _prim "WordS16_rem": int * int -> int; + + val < = _prim "WordS16_lt": int * int -> bool; + end +structure Int16 : PRIM_INTEGER = + struct + open Int16 + local + structure S = IntegralComparisons(Int16) + in + open S + end + end +structure Int17 = + struct + open Int17 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord17": big -> int; + val sizeInBits: Int32.int = 17 + val toBig = _prim "WordU17_extdToWord32": int -> big; + end +structure Int18 = + struct + open Int18 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord18": big -> int; + val sizeInBits: Int32.int = 18 + val toBig = _prim "WordU18_extdToWord32": int -> big; + end +structure Int19 = + struct + open Int19 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord19": big -> int; + val sizeInBits: Int32.int = 19 + val toBig = _prim "WordU19_extdToWord32": int -> big; + end +structure Int20 = + struct + open Int20 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord20": big -> int; + val sizeInBits: Int32.int = 20 + val toBig = _prim "WordU20_extdToWord32": int -> big; + end +structure Int21 = + struct + open Int21 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord21": big -> int; + val sizeInBits: Int32.int = 21 + val toBig = _prim "WordU21_extdToWord32": int -> big; + end +structure Int22 = + struct + open Int22 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord22": big -> int; + val sizeInBits: Int32.int = 22 + val toBig = _prim "WordU22_extdToWord32": int -> big; + end +structure Int23 = + struct + open Int23 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord23": big -> int; + val sizeInBits: Int32.int = 23 + val toBig = _prim "WordU23_extdToWord32": int -> big; + end +structure Int24 = + struct + open Int24 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord24": big -> int; + val sizeInBits: Int32.int = 24 + val toBig = _prim "WordU24_extdToWord32": int -> big; + end +structure Int25 = + struct + open Int25 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord25": big -> int; + val sizeInBits: Int32.int = 25 + val toBig = _prim "WordU25_extdToWord32": int -> big; + end +structure Int26 = + struct + open Int26 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord26": big -> int; + val sizeInBits: Int32.int = 26 + val toBig = _prim "WordU26_extdToWord32": int -> big; + end +structure Int27 = + struct + open Int27 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord27": big -> int; + val sizeInBits: Int32.int = 27 + val toBig = _prim "WordU27_extdToWord32": int -> big; + end +structure Int28 = + struct + open Int28 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord28": big -> int; + val sizeInBits: Int32.int = 28 + val toBig = _prim "WordU28_extdToWord32": int -> big; + end +structure Int29 = + struct + open Int29 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord29": big -> int; + val sizeInBits: Int32.int = 29 + val toBig = _prim "WordU29_extdToWord32": int -> big; + end +structure Int30 = + struct + open Int30 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord30": big -> int; + val sizeInBits: Int32.int = 30 + val toBig = _prim "WordU30_extdToWord32": int -> big; + end +structure Int31 = + struct + open Int31 + type big = Int32.int + val fromBigUnsafe = _prim "WordU32_extdToWord31": big -> int; + val sizeInBits: Int32.int = 31 + val toBig = _prim "WordU31_extdToWord32": int -> big; + end +structure Int32 = + struct + open Int32 + + val sizeInBits: Int32.int = 32 + val sizeInBitsWord: Word32.word = + IntWordConv.zextdFromInt32ToWord32 sizeInBits + val precision = SOME sizeInBits + + val +! = Exn.wrapOverflow (_prim "WordS32_addCheck": int * int -> int;) + val +? = _prim "Word32_add": int * int -> int; + val + = + if Controls.detectOverflow + then +! + else +? + val *! = Exn.wrapOverflow (_prim "WordS32_mulCheck": int * int -> int;) + val *? = _prim "WordS32_mul": int * int -> int; + val * = + if Controls.detectOverflow + then *! + else *? + val ~! = Exn.wrapOverflow (_prim "Word32_negCheck": int -> int;) + val ~? = _prim "Word32_neg": int -> int; + val ~ = + if Controls.detectOverflow + then ~! + else ~? + val quotUnsafe = _prim "WordS32_quot": int * int -> int; + val -! = Exn.wrapOverflow (_prim "WordS32_subCheck": int * int -> int;) + val -? = _prim "Word32_sub": int * int -> int; + val - = + if Controls.detectOverflow + then -! + else -? + val remUnsafe = _prim "WordS32_rem": int * int -> int; + + val < = _prim "WordS32_lt": int * int -> bool; + end +structure Int32 : PRIM_INTEGER = + struct + open Int32 + local + structure S = IntegralComparisons(Int32) + in + open S + end + end +structure Int64 = + struct + open Int64 + + val sizeInBits: Int32.int = 64 + val sizeInBitsWord: Word32.word = + IntWordConv.zextdFromInt32ToWord32 sizeInBits + val precision = SOME sizeInBits + + val +! = Exn.wrapOverflow (_prim "WordS64_addCheck": int * int -> int;) + val +? = _prim "Word64_add": int * int -> int; + val + = + if Controls.detectOverflow + then +! + else +? + val *! = Exn.wrapOverflow (_prim "WordS64_mulCheck": int * int -> int;) + val *? = _prim "WordS64_mul": int * int -> int; + val * = + if Controls.detectOverflow + then *! + else *? + val ~! = Exn.wrapOverflow (_prim "Word64_negCheck": int -> int;) + val ~? = _prim "Word64_neg": int -> int; + val ~ = + if Controls.detectOverflow + then ~! + else ~? + val quotUnsafe = _prim "WordS64_quot": int * int -> int; + val -! = Exn.wrapOverflow (_prim "WordS64_subCheck": int * int -> int;) + val -? = _prim "Word64_sub": int * int -> int; + val - = + if Controls.detectOverflow + then -! + else -? + val remUnsafe = _prim "WordS64_rem": int * int -> int; + + val < = _prim "WordS64_lt": int * int -> bool; + end +structure Int64 : PRIM_INTEGER = + struct + open Int64 + local + structure S = IntegralComparisons(Int64) + in + open S + end + end + +end diff --git a/basis-library/primitive/prim-iwconv.sml b/basis-library/primitive/prim-iwconv.sml new file mode 100644 index 0000000..00f937e --- /dev/null +++ b/basis-library/primitive/prim-iwconv.sml @@ -0,0 +1,493 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +signature PRIM_INTWORD_CONV = + sig + (* identity *) + val idFromInt8ToInt8: Primitive.Int8.int -> Primitive.Int8.int + val idFromInt8ToWord8: Primitive.Int8.int -> Primitive.Word8.word + val idFromInt16ToInt16: Primitive.Int16.int -> Primitive.Int16.int + val idFromInt16ToWord16: Primitive.Int16.int -> Primitive.Word16.word + val idFromInt32ToInt32: Primitive.Int32.int -> Primitive.Int32.int + val idFromInt32ToWord32: Primitive.Int32.int -> Primitive.Word32.word + val idFromInt64ToInt64: Primitive.Int64.int -> Primitive.Int64.int + val idFromInt64ToWord64: Primitive.Int64.int -> Primitive.Word64.word + val idFromWord8ToInt8: Primitive.Word8.word -> Primitive.Int8.int + val idFromWord8ToWord8: Primitive.Word8.word -> Primitive.Word8.word + val idFromWord16ToInt16: Primitive.Word16.word -> Primitive.Int16.int + val idFromWord16ToWord16: Primitive.Word16.word -> Primitive.Word16.word + val idFromWord32ToInt32: Primitive.Word32.word -> Primitive.Int32.int + val idFromWord32ToWord32: Primitive.Word32.word -> Primitive.Word32.word + val idFromWord64ToInt64: Primitive.Word64.word -> Primitive.Int64.int + val idFromWord64ToWord64: Primitive.Word64.word -> Primitive.Word64.word + + (* zero-extend or low-bits *) + val zextdFromInt8ToInt8: Primitive.Int8.int -> Primitive.Int8.int + val zextdFromInt8ToInt16: Primitive.Int8.int -> Primitive.Int16.int + val zextdFromInt8ToInt32: Primitive.Int8.int -> Primitive.Int32.int + val zextdFromInt8ToInt64: Primitive.Int8.int -> Primitive.Int64.int + val zextdFromInt8ToWord8: Primitive.Int8.int -> Primitive.Word8.word + val zextdFromInt8ToWord16: Primitive.Int8.int -> Primitive.Word16.word + val zextdFromInt8ToWord32: Primitive.Int8.int -> Primitive.Word32.word + val zextdFromInt8ToWord64: Primitive.Int8.int -> Primitive.Word64.word + + val zextdFromInt16ToInt8: Primitive.Int16.int -> Primitive.Int8.int + val zextdFromInt16ToInt16: Primitive.Int16.int -> Primitive.Int16.int + val zextdFromInt16ToInt32: Primitive.Int16.int -> Primitive.Int32.int + val zextdFromInt16ToInt64: Primitive.Int16.int -> Primitive.Int64.int + val zextdFromInt16ToWord8: Primitive.Int16.int -> Primitive.Word8.word + val zextdFromInt16ToWord16: Primitive.Int16.int -> Primitive.Word16.word + val zextdFromInt16ToWord32: Primitive.Int16.int -> Primitive.Word32.word + val zextdFromInt16ToWord64: Primitive.Int16.int -> Primitive.Word64.word + + val zextdFromInt32ToInt8: Primitive.Int32.int -> Primitive.Int8.int + val zextdFromInt32ToInt16: Primitive.Int32.int -> Primitive.Int16.int + val zextdFromInt32ToInt32: Primitive.Int32.int -> Primitive.Int32.int + val zextdFromInt32ToInt64: Primitive.Int32.int -> Primitive.Int64.int + val zextdFromInt32ToWord8: Primitive.Int32.int -> Primitive.Word8.word + val zextdFromInt32ToWord16: Primitive.Int32.int -> Primitive.Word16.word + val zextdFromInt32ToWord32: Primitive.Int32.int -> Primitive.Word32.word + val zextdFromInt32ToWord64: Primitive.Int32.int -> Primitive.Word64.word + + val zextdFromInt64ToInt8: Primitive.Int64.int -> Primitive.Int8.int + val zextdFromInt64ToInt16: Primitive.Int64.int -> Primitive.Int16.int + val zextdFromInt64ToInt32: Primitive.Int64.int -> Primitive.Int32.int + val zextdFromInt64ToInt64: Primitive.Int64.int -> Primitive.Int64.int + val zextdFromInt64ToWord8: Primitive.Int64.int -> Primitive.Word8.word + val zextdFromInt64ToWord16: Primitive.Int64.int -> Primitive.Word16.word + val zextdFromInt64ToWord32: Primitive.Int64.int -> Primitive.Word32.word + val zextdFromInt64ToWord64: Primitive.Int64.int -> Primitive.Word64.word + + val zextdFromWord8ToInt8: Primitive.Word8.word -> Primitive.Int8.int + val zextdFromWord8ToInt16: Primitive.Word8.word -> Primitive.Int16.int + val zextdFromWord8ToInt32: Primitive.Word8.word -> Primitive.Int32.int + val zextdFromWord8ToInt64: Primitive.Word8.word -> Primitive.Int64.int + val zextdFromWord8ToWord8: Primitive.Word8.word -> Primitive.Word8.word + val zextdFromWord8ToWord16: Primitive.Word8.word -> Primitive.Word16.word + val zextdFromWord8ToWord32: Primitive.Word8.word -> Primitive.Word32.word + val zextdFromWord8ToWord64: Primitive.Word8.word -> Primitive.Word64.word + + val zextdFromWord16ToInt8: Primitive.Word16.word -> Primitive.Int8.int + val zextdFromWord16ToInt16: Primitive.Word16.word -> Primitive.Int16.int + val zextdFromWord16ToInt32: Primitive.Word16.word -> Primitive.Int32.int + val zextdFromWord16ToInt64: Primitive.Word16.word -> Primitive.Int64.int + val zextdFromWord16ToWord8: Primitive.Word16.word -> Primitive.Word8.word + val zextdFromWord16ToWord16: Primitive.Word16.word -> Primitive.Word16.word + val zextdFromWord16ToWord32: Primitive.Word16.word -> Primitive.Word32.word + val zextdFromWord16ToWord64: Primitive.Word16.word -> Primitive.Word64.word + + val zextdFromWord32ToInt8: Primitive.Word32.word -> Primitive.Int8.int + val zextdFromWord32ToInt16: Primitive.Word32.word -> Primitive.Int16.int + val zextdFromWord32ToInt32: Primitive.Word32.word -> Primitive.Int32.int + val zextdFromWord32ToInt64: Primitive.Word32.word -> Primitive.Int64.int + val zextdFromWord32ToWord8: Primitive.Word32.word -> Primitive.Word8.word + val zextdFromWord32ToWord16: Primitive.Word32.word -> Primitive.Word16.word + val zextdFromWord32ToWord32: Primitive.Word32.word -> Primitive.Word32.word + val zextdFromWord32ToWord64: Primitive.Word32.word -> Primitive.Word64.word + + val zextdFromWord64ToInt8: Primitive.Word64.word -> Primitive.Int8.int + val zextdFromWord64ToInt16: Primitive.Word64.word -> Primitive.Int16.int + val zextdFromWord64ToInt32: Primitive.Word64.word -> Primitive.Int32.int + val zextdFromWord64ToInt64: Primitive.Word64.word -> Primitive.Int64.int + val zextdFromWord64ToWord8: Primitive.Word64.word -> Primitive.Word8.word + val zextdFromWord64ToWord16: Primitive.Word64.word -> Primitive.Word16.word + val zextdFromWord64ToWord32: Primitive.Word64.word -> Primitive.Word32.word + val zextdFromWord64ToWord64: Primitive.Word64.word -> Primitive.Word64.word + + (* sign-extend or low-bits *) + val sextdFromInt8ToInt8: Primitive.Int8.int -> Primitive.Int8.int + val sextdFromInt8ToInt16: Primitive.Int8.int -> Primitive.Int16.int + val sextdFromInt8ToInt32: Primitive.Int8.int -> Primitive.Int32.int + val sextdFromInt8ToInt64: Primitive.Int8.int -> Primitive.Int64.int + val sextdFromInt8ToWord8: Primitive.Int8.int -> Primitive.Word8.word + val sextdFromInt8ToWord16: Primitive.Int8.int -> Primitive.Word16.word + val sextdFromInt8ToWord32: Primitive.Int8.int -> Primitive.Word32.word + val sextdFromInt8ToWord64: Primitive.Int8.int -> Primitive.Word64.word + + val sextdFromInt16ToInt8: Primitive.Int16.int -> Primitive.Int8.int + val sextdFromInt16ToInt16: Primitive.Int16.int -> Primitive.Int16.int + val sextdFromInt16ToInt32: Primitive.Int16.int -> Primitive.Int32.int + val sextdFromInt16ToInt64: Primitive.Int16.int -> Primitive.Int64.int + val sextdFromInt16ToWord8: Primitive.Int16.int -> Primitive.Word8.word + val sextdFromInt16ToWord16: Primitive.Int16.int -> Primitive.Word16.word + val sextdFromInt16ToWord32: Primitive.Int16.int -> Primitive.Word32.word + val sextdFromInt16ToWord64: Primitive.Int16.int -> Primitive.Word64.word + + val sextdFromInt32ToInt8: Primitive.Int32.int -> Primitive.Int8.int + val sextdFromInt32ToInt16: Primitive.Int32.int -> Primitive.Int16.int + val sextdFromInt32ToInt32: Primitive.Int32.int -> Primitive.Int32.int + val sextdFromInt32ToInt64: Primitive.Int32.int -> Primitive.Int64.int + val sextdFromInt32ToWord8: Primitive.Int32.int -> Primitive.Word8.word + val sextdFromInt32ToWord16: Primitive.Int32.int -> Primitive.Word16.word + val sextdFromInt32ToWord32: Primitive.Int32.int -> Primitive.Word32.word + val sextdFromInt32ToWord64: Primitive.Int32.int -> Primitive.Word64.word + + val sextdFromInt64ToInt8: Primitive.Int64.int -> Primitive.Int8.int + val sextdFromInt64ToInt16: Primitive.Int64.int -> Primitive.Int16.int + val sextdFromInt64ToInt32: Primitive.Int64.int -> Primitive.Int32.int + val sextdFromInt64ToInt64: Primitive.Int64.int -> Primitive.Int64.int + val sextdFromInt64ToWord8: Primitive.Int64.int -> Primitive.Word8.word + val sextdFromInt64ToWord16: Primitive.Int64.int -> Primitive.Word16.word + val sextdFromInt64ToWord32: Primitive.Int64.int -> Primitive.Word32.word + val sextdFromInt64ToWord64: Primitive.Int64.int -> Primitive.Word64.word + + val sextdFromWord8ToInt8: Primitive.Word8.word -> Primitive.Int8.int + val sextdFromWord8ToInt16: Primitive.Word8.word -> Primitive.Int16.int + val sextdFromWord8ToInt32: Primitive.Word8.word -> Primitive.Int32.int + val sextdFromWord8ToInt64: Primitive.Word8.word -> Primitive.Int64.int + val sextdFromWord8ToWord8: Primitive.Word8.word -> Primitive.Word8.word + val sextdFromWord8ToWord16: Primitive.Word8.word -> Primitive.Word16.word + val sextdFromWord8ToWord32: Primitive.Word8.word -> Primitive.Word32.word + val sextdFromWord8ToWord64: Primitive.Word8.word -> Primitive.Word64.word + + val sextdFromWord16ToInt8: Primitive.Word16.word -> Primitive.Int8.int + val sextdFromWord16ToInt16: Primitive.Word16.word -> Primitive.Int16.int + val sextdFromWord16ToInt32: Primitive.Word16.word -> Primitive.Int32.int + val sextdFromWord16ToInt64: Primitive.Word16.word -> Primitive.Int64.int + val sextdFromWord16ToWord8: Primitive.Word16.word -> Primitive.Word8.word + val sextdFromWord16ToWord16: Primitive.Word16.word -> Primitive.Word16.word + val sextdFromWord16ToWord32: Primitive.Word16.word -> Primitive.Word32.word + val sextdFromWord16ToWord64: Primitive.Word16.word -> Primitive.Word64.word + + val sextdFromWord32ToInt8: Primitive.Word32.word -> Primitive.Int8.int + val sextdFromWord32ToInt16: Primitive.Word32.word -> Primitive.Int16.int + val sextdFromWord32ToInt32: Primitive.Word32.word -> Primitive.Int32.int + val sextdFromWord32ToInt64: Primitive.Word32.word -> Primitive.Int64.int + val sextdFromWord32ToWord8: Primitive.Word32.word -> Primitive.Word8.word + val sextdFromWord32ToWord16: Primitive.Word32.word -> Primitive.Word16.word + val sextdFromWord32ToWord32: Primitive.Word32.word -> Primitive.Word32.word + val sextdFromWord32ToWord64: Primitive.Word32.word -> Primitive.Word64.word + + val sextdFromWord64ToInt8: Primitive.Word64.word -> Primitive.Int8.int + val sextdFromWord64ToInt16: Primitive.Word64.word -> Primitive.Int16.int + val sextdFromWord64ToInt32: Primitive.Word64.word -> Primitive.Int32.int + val sextdFromWord64ToInt64: Primitive.Word64.word -> Primitive.Int64.int + val sextdFromWord64ToWord8: Primitive.Word64.word -> Primitive.Word8.word + val sextdFromWord64ToWord16: Primitive.Word64.word -> Primitive.Word16.word + val sextdFromWord64ToWord32: Primitive.Word64.word -> Primitive.Word32.word + val sextdFromWord64ToWord64: Primitive.Word64.word -> Primitive.Word64.word + end + +structure Primitive = struct + +open Primitive + +structure IntWordConv : PRIM_INTWORD_CONV = + struct + (* identity *) + val idFromInt8ToInt8 = + _prim "WordU8_extdToWord8": Int8.int -> Int8.int; + val idFromInt8ToWord8 = + _prim "WordU8_extdToWord8": Int8.int -> Word8.word; + val idFromInt16ToInt16 = + _prim "WordU16_extdToWord16": Int16.int -> Int16.int; + val idFromInt16ToWord16 = + _prim "WordU16_extdToWord16": Int16.int -> Word16.word; + val idFromInt32ToInt32 = + _prim "WordU32_extdToWord32": Int32.int -> Int32.int; + val idFromInt32ToWord32 = + _prim "WordU32_extdToWord32": Int32.int -> Word32.word; + val idFromInt64ToInt64 = + _prim "WordU64_extdToWord64": Int64.int -> Int64.int; + val idFromInt64ToWord64 = + _prim "WordU64_extdToWord64": Int64.int -> Word64.word; + val idFromWord8ToInt8 = + _prim "WordU8_extdToWord8": Word8.word -> Int8.int; + val idFromWord8ToWord8 = + _prim "WordU8_extdToWord8": Word8.word -> Word8.word; + val idFromWord16ToInt16 = + _prim "WordU16_extdToWord16": Word16.word -> Int16.int; + val idFromWord16ToWord16 = + _prim "WordU16_extdToWord16": Word16.word -> Word16.word; + val idFromWord32ToInt32 = + _prim "WordU32_extdToWord32": Word32.word -> Int32.int; + val idFromWord32ToWord32 = + _prim "WordU32_extdToWord32": Word32.word -> Word32.word; + val idFromWord64ToInt64 = + _prim "WordU64_extdToWord64": Word64.word -> Int64.int; + val idFromWord64ToWord64 = + _prim "WordU64_extdToWord64": Word64.word -> Word64.word; + + (* zero-extend or low-bits *) + val zextdFromInt8ToInt8 = + _prim "WordU8_extdToWord8": Int8.int -> Int8.int; + val zextdFromInt8ToInt16 = + _prim "WordU8_extdToWord16": Int8.int -> Int16.int; + val zextdFromInt8ToInt32 = + _prim "WordU8_extdToWord32": Int8.int -> Int32.int; + val zextdFromInt8ToInt64 = + _prim "WordU8_extdToWord64": Int8.int -> Int64.int; + val zextdFromInt8ToWord8 = + _prim "WordU8_extdToWord8": Int8.int -> Word8.word; + val zextdFromInt8ToWord16 = + _prim "WordU8_extdToWord16": Int8.int -> Word16.word; + val zextdFromInt8ToWord32 = + _prim "WordU8_extdToWord32": Int8.int -> Word32.word; + val zextdFromInt8ToWord64 = + _prim "WordU8_extdToWord64": Int8.int -> Word64.word; + + val zextdFromInt16ToInt8 = + _prim "WordU16_extdToWord8": Int16.int -> Int8.int; + val zextdFromInt16ToInt16 = + _prim "WordU16_extdToWord16": Int16.int -> Int16.int; + val zextdFromInt16ToInt32 = + _prim "WordU16_extdToWord32": Int16.int -> Int32.int; + val zextdFromInt16ToInt64 = + _prim "WordU16_extdToWord64": Int16.int -> Int64.int; + val zextdFromInt16ToWord8 = + _prim "WordU16_extdToWord8": Int16.int -> Word8.word; + val zextdFromInt16ToWord16 = + _prim "WordU16_extdToWord16": Int16.int -> Word16.word; + val zextdFromInt16ToWord32 = + _prim "WordU16_extdToWord32": Int16.int -> Word32.word; + val zextdFromInt16ToWord64 = + _prim "WordU16_extdToWord64": Int16.int -> Word64.word; + + val zextdFromInt32ToInt8 = + _prim "WordU32_extdToWord8": Int32.int -> Int8.int; + val zextdFromInt32ToInt16 = + _prim "WordU32_extdToWord16": Int32.int -> Int16.int; + val zextdFromInt32ToInt32 = + _prim "WordU32_extdToWord32": Int32.int -> Int32.int; + val zextdFromInt32ToInt64 = + _prim "WordU32_extdToWord64": Int32.int -> Int64.int; + val zextdFromInt32ToWord8 = + _prim "WordU32_extdToWord8": Int32.int -> Word8.word; + val zextdFromInt32ToWord16 = + _prim "WordU32_extdToWord16": Int32.int -> Word16.word; + val zextdFromInt32ToWord32 = + _prim "WordU32_extdToWord32": Int32.int -> Word32.word; + val zextdFromInt32ToWord64 = + _prim "WordU32_extdToWord64": Int32.int -> Word64.word; + + val zextdFromInt64ToInt8 = + _prim "WordU64_extdToWord8": Int64.int -> Int8.int; + val zextdFromInt64ToInt16 = + _prim "WordU64_extdToWord16": Int64.int -> Int16.int; + val zextdFromInt64ToInt32 = + _prim "WordU64_extdToWord32": Int64.int -> Int32.int; + val zextdFromInt64ToInt64 = + _prim "WordU64_extdToWord64": Int64.int -> Int64.int; + val zextdFromInt64ToWord8 = + _prim "WordU64_extdToWord8": Int64.int -> Word8.word; + val zextdFromInt64ToWord16 = + _prim "WordU64_extdToWord16": Int64.int -> Word16.word; + val zextdFromInt64ToWord32 = + _prim "WordU64_extdToWord32": Int64.int -> Word32.word; + val zextdFromInt64ToWord64 = + _prim "WordU64_extdToWord64": Int64.int -> Word64.word; + + val zextdFromWord8ToInt8 = + _prim "WordU8_extdToWord8": Word8.word -> Int8.int; + val zextdFromWord8ToInt16 = + _prim "WordU8_extdToWord16": Word8.word -> Int16.int; + val zextdFromWord8ToInt32 = + _prim "WordU8_extdToWord32": Word8.word -> Int32.int; + val zextdFromWord8ToInt64 = + _prim "WordU8_extdToWord64": Word8.word -> Int64.int; + val zextdFromWord8ToWord8 = + _prim "WordU8_extdToWord8": Word8.word -> Word8.word; + val zextdFromWord8ToWord16 = + _prim "WordU8_extdToWord16": Word8.word -> Word16.word; + val zextdFromWord8ToWord32 = + _prim "WordU8_extdToWord32": Word8.word -> Word32.word; + val zextdFromWord8ToWord64 = + _prim "WordU8_extdToWord64": Word8.word -> Word64.word; + + val zextdFromWord16ToInt8 = + _prim "WordU16_extdToWord8": Word16.word -> Int8.int; + val zextdFromWord16ToInt16 = + _prim "WordU16_extdToWord16": Word16.word -> Int16.int; + val zextdFromWord16ToInt32 = + _prim "WordU16_extdToWord32": Word16.word -> Int32.int; + val zextdFromWord16ToInt64 = + _prim "WordU16_extdToWord64": Word16.word -> Int64.int; + val zextdFromWord16ToWord8 = + _prim "WordU16_extdToWord8": Word16.word -> Word8.word; + val zextdFromWord16ToWord16 = + _prim "WordU16_extdToWord16": Word16.word -> Word16.word; + val zextdFromWord16ToWord32 = + _prim "WordU16_extdToWord32": Word16.word -> Word32.word; + val zextdFromWord16ToWord64 = + _prim "WordU16_extdToWord64": Word16.word -> Word64.word; + + val zextdFromWord32ToInt8 = + _prim "WordU32_extdToWord8": Word32.word -> Int8.int; + val zextdFromWord32ToInt16 = + _prim "WordU32_extdToWord16": Word32.word -> Int16.int; + val zextdFromWord32ToInt32 = + _prim "WordU32_extdToWord32": Word32.word -> Int32.int; + val zextdFromWord32ToInt64 = + _prim "WordU32_extdToWord64": Word32.word -> Int64.int; + val zextdFromWord32ToWord8 = + _prim "WordU32_extdToWord8": Word32.word -> Word8.word; + val zextdFromWord32ToWord16 = + _prim "WordU32_extdToWord16": Word32.word -> Word16.word; + val zextdFromWord32ToWord32 = + _prim "WordU32_extdToWord32": Word32.word -> Word32.word; + val zextdFromWord32ToWord64 = + _prim "WordU32_extdToWord64": Word32.word -> Word64.word; + + val zextdFromWord64ToInt8 = + _prim "WordU64_extdToWord8": Word64.word -> Int8.int; + val zextdFromWord64ToInt16 = + _prim "WordU64_extdToWord16": Word64.word -> Int16.int; + val zextdFromWord64ToInt32 = + _prim "WordU64_extdToWord32": Word64.word -> Int32.int; + val zextdFromWord64ToInt64 = + _prim "WordU64_extdToWord64": Word64.word -> Int64.int; + val zextdFromWord64ToWord8 = + _prim "WordU64_extdToWord8": Word64.word -> Word8.word; + val zextdFromWord64ToWord16 = + _prim "WordU64_extdToWord16": Word64.word -> Word16.word; + val zextdFromWord64ToWord32 = + _prim "WordU64_extdToWord32": Word64.word -> Word32.word; + val zextdFromWord64ToWord64 = + _prim "WordU64_extdToWord64": Word64.word -> Word64.word; + + (* sign-extend or low-bits *) + val sextdFromInt8ToInt8 = + _prim "WordS8_extdToWord8": Int8.int -> Int8.int; + val sextdFromInt8ToInt16 = + _prim "WordS8_extdToWord16": Int8.int -> Int16.int; + val sextdFromInt8ToInt32 = + _prim "WordS8_extdToWord32": Int8.int -> Int32.int; + val sextdFromInt8ToInt64 = + _prim "WordS8_extdToWord64": Int8.int -> Int64.int; + val sextdFromInt8ToWord8 = + _prim "WordS8_extdToWord8": Int8.int -> Word8.word; + val sextdFromInt8ToWord16 = + _prim "WordS8_extdToWord16": Int8.int -> Word16.word; + val sextdFromInt8ToWord32 = + _prim "WordS8_extdToWord32": Int8.int -> Word32.word; + val sextdFromInt8ToWord64 = + _prim "WordS8_extdToWord64": Int8.int -> Word64.word; + + val sextdFromInt16ToInt8 = + _prim "WordS16_extdToWord8": Int16.int -> Int8.int; + val sextdFromInt16ToInt16 = + _prim "WordS16_extdToWord16": Int16.int -> Int16.int; + val sextdFromInt16ToInt32 = + _prim "WordS16_extdToWord32": Int16.int -> Int32.int; + val sextdFromInt16ToInt64 = + _prim "WordS16_extdToWord64": Int16.int -> Int64.int; + val sextdFromInt16ToWord8 = + _prim "WordS16_extdToWord8": Int16.int -> Word8.word; + val sextdFromInt16ToWord16 = + _prim "WordS16_extdToWord16": Int16.int -> Word16.word; + val sextdFromInt16ToWord32 = + _prim "WordS16_extdToWord32": Int16.int -> Word32.word; + val sextdFromInt16ToWord64 = + _prim "WordS16_extdToWord64": Int16.int -> Word64.word; + + val sextdFromInt32ToInt8 = + _prim "WordS32_extdToWord8": Int32.int -> Int8.int; + val sextdFromInt32ToInt16 = + _prim "WordS32_extdToWord16": Int32.int -> Int16.int; + val sextdFromInt32ToInt32 = + _prim "WordS32_extdToWord32": Int32.int -> Int32.int; + val sextdFromInt32ToInt64 = + _prim "WordS32_extdToWord64": Int32.int -> Int64.int; + val sextdFromInt32ToWord8 = + _prim "WordS32_extdToWord8": Int32.int -> Word8.word; + val sextdFromInt32ToWord16 = + _prim "WordS32_extdToWord16": Int32.int -> Word16.word; + val sextdFromInt32ToWord32 = + _prim "WordS32_extdToWord32": Int32.int -> Word32.word; + val sextdFromInt32ToWord64 = + _prim "WordS32_extdToWord64": Int32.int -> Word64.word; + + val sextdFromInt64ToInt8 = + _prim "WordS64_extdToWord8": Int64.int -> Int8.int; + val sextdFromInt64ToInt16 = + _prim "WordS64_extdToWord16": Int64.int -> Int16.int; + val sextdFromInt64ToInt32 = + _prim "WordS64_extdToWord32": Int64.int -> Int32.int; + val sextdFromInt64ToInt64 = + _prim "WordS64_extdToWord64": Int64.int -> Int64.int; + val sextdFromInt64ToWord8 = + _prim "WordS64_extdToWord8": Int64.int -> Word8.word; + val sextdFromInt64ToWord16 = + _prim "WordS64_extdToWord16": Int64.int -> Word16.word; + val sextdFromInt64ToWord32 = + _prim "WordS64_extdToWord32": Int64.int -> Word32.word; + val sextdFromInt64ToWord64 = + _prim "WordS64_extdToWord64": Int64.int -> Word64.word; + + val sextdFromWord8ToInt8 = + _prim "WordS8_extdToWord8": Word8.word -> Int8.int; + val sextdFromWord8ToInt16 = + _prim "WordS8_extdToWord16": Word8.word -> Int16.int; + val sextdFromWord8ToInt32 = + _prim "WordS8_extdToWord32": Word8.word -> Int32.int; + val sextdFromWord8ToInt64 = + _prim "WordS8_extdToWord64": Word8.word -> Int64.int; + val sextdFromWord8ToWord8 = + _prim "WordS8_extdToWord8": Word8.word -> Word8.word; + val sextdFromWord8ToWord16 = + _prim "WordS8_extdToWord16": Word8.word -> Word16.word; + val sextdFromWord8ToWord32 = + _prim "WordS8_extdToWord32": Word8.word -> Word32.word; + val sextdFromWord8ToWord64 = + _prim "WordS8_extdToWord64": Word8.word -> Word64.word; + + val sextdFromWord16ToInt8 = + _prim "WordS16_extdToWord8": Word16.word -> Int8.int; + val sextdFromWord16ToInt16 = + _prim "WordS16_extdToWord16": Word16.word -> Int16.int; + val sextdFromWord16ToInt32 = + _prim "WordS16_extdToWord32": Word16.word -> Int32.int; + val sextdFromWord16ToInt64 = + _prim "WordS16_extdToWord64": Word16.word -> Int64.int; + val sextdFromWord16ToWord8 = + _prim "WordS16_extdToWord8": Word16.word -> Word8.word; + val sextdFromWord16ToWord16 = + _prim "WordS16_extdToWord16": Word16.word -> Word16.word; + val sextdFromWord16ToWord32 = + _prim "WordS16_extdToWord32": Word16.word -> Word32.word; + val sextdFromWord16ToWord64 = + _prim "WordS16_extdToWord64": Word16.word -> Word64.word; + + val sextdFromWord32ToInt8 = + _prim "WordS32_extdToWord8": Word32.word -> Int8.int; + val sextdFromWord32ToInt16 = + _prim "WordS32_extdToWord16": Word32.word -> Int16.int; + val sextdFromWord32ToInt32 = + _prim "WordS32_extdToWord32": Word32.word -> Int32.int; + val sextdFromWord32ToInt64 = + _prim "WordS32_extdToWord64": Word32.word -> Int64.int; + val sextdFromWord32ToWord8 = + _prim "WordS32_extdToWord8": Word32.word -> Word8.word; + val sextdFromWord32ToWord16 = + _prim "WordS32_extdToWord16": Word32.word -> Word16.word; + val sextdFromWord32ToWord32 = + _prim "WordS32_extdToWord32": Word32.word -> Word32.word; + val sextdFromWord32ToWord64 = + _prim "WordS32_extdToWord64": Word32.word -> Word64.word; + + val sextdFromWord64ToInt8 = + _prim "WordS64_extdToWord8": Word64.word -> Int8.int; + val sextdFromWord64ToInt16 = + _prim "WordS64_extdToWord16": Word64.word -> Int16.int; + val sextdFromWord64ToInt32 = + _prim "WordS64_extdToWord32": Word64.word -> Int32.int; + val sextdFromWord64ToInt64 = + _prim "WordS64_extdToWord64": Word64.word -> Int64.int; + val sextdFromWord64ToWord8 = + _prim "WordS64_extdToWord8": Word64.word -> Word8.word; + val sextdFromWord64ToWord16 = + _prim "WordS64_extdToWord16": Word64.word -> Word16.word; + val sextdFromWord64ToWord32 = + _prim "WordS64_extdToWord32": Word64.word -> Word32.word; + val sextdFromWord64ToWord64 = + _prim "WordS64_extdToWord64": Word64.word -> Word64.word; + end + +end diff --git a/basis-library/primitive/prim-mlton.sml b/basis-library/primitive/prim-mlton.sml new file mode 100644 index 0000000..7b30f41 --- /dev/null +++ b/basis-library/primitive/prim-mlton.sml @@ -0,0 +1,384 @@ +(* Copyright (C) 2010-2011,2013-2014,2017 Matthew Fluet. + * Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +structure Primitive = struct + +open Primitive + +structure MLton = struct + +val eq = _prim "MLton_eq": 'a * 'a -> bool; +val equal = _prim "MLton_equal": 'a * 'a -> bool; +(* val deserialize = _prim "MLton_deserialize": Word8Vector.vector -> 'a ref; *) +val halt = _prim "MLton_halt": C_Status.t -> unit; +val hash = _prim "MLton_hash": 'a -> Word32.word; +(* val serialize = _prim "MLton_serialize": 'a ref -> Word8Vector.vector; *) +val share = _prim "MLton_share": 'a -> unit; +val size = _prim "MLton_size": 'a -> C_Size.t; + +val installSignalHandler = + _prim "MLton_installSignalHandler": unit -> unit; + +structure GCState = + struct + type t = Pointer.t + + val gcState = #1 _symbol "gcStateAddress" private: t GetSet.t; () + end + +structure Align = + struct + datatype t = Align4 | Align8 + + val align = + case _build_const "MLton_Align_align": Int32.int; of + 4 => Align4 + | 8 => Align8 + | _ => raise Primitive.Exn.Fail8 "MLton_Align_align" + end + +structure CallStack = + struct + (* The most recent caller is at index 0 in the array. *) + datatype t = T of Word32.word array + + val callStack = + _import "GC_callStack" runtime private: GCState.t * Word32.word array -> unit; + val frameIndexSourceSeq = + _import "GC_frameIndexSourceSeq" runtime private: GCState.t * Word32.word -> Pointer.t; + val keep = _command_line_const "CallStack.keep": bool = false; + val numStackFrames = + _import "GC_numStackFrames" runtime private: GCState.t -> Word32.word; + val sourceName = _import "GC_sourceName" runtime private: GCState.t * Word32.word -> C_String.t; + end + +structure Codegen = + struct + datatype t = AMD64 | C | LLVM | X86 + + val codegen = + case _build_const "MLton_Codegen_codegen": Int32.int; of + 0 => C + | 1 => X86 + | 2 => AMD64 + | 3 => LLVM + | _ => raise Primitive.Exn.Fail8 "MLton_Codegen_codegen" + + val isC = codegen = C + val isAMD64 = codegen = AMD64 + val isLLVM = codegen = LLVM + val isX86 = codegen = X86 + end + +structure Exn = + struct + (* The polymorphism with extra and setInitExtra is because primitives + * are only supposed to deal with basic types. The polymorphism + * allows the various passes like monomorphisation to translate + * the types appropriately. + *) + type extra = CallStack.t option + + val extra = _prim "Exn_extra": exn -> 'a; + val extra: exn -> extra = extra + val keepHistory = _command_line_const "Exn.keepHistory": bool = false; + val setExtendExtra = _prim "Exn_setExtendExtra": ('a -> 'a) -> unit; + val setExtendExtra: (extra -> extra) -> unit = setExtendExtra + + (* Ensure that setExtendExtra is initialized. + * Important for -const 'Exn.keepHistory true', so that + * exceptions can be raised (and handled) during Basis Library + * initialization. + *) + val setExtendExtra : (extra -> extra) -> unit = + if keepHistory + then (setExtendExtra (fn _ => NONE) + ; setExtendExtra) + else fn _ => () + end + +structure FFI = + struct + val getOpArgsResPtr = #1 _symbol "MLton_FFI_opArgsResPtr" private: Pointer.t GetSet.t; + val numExports = _build_const "MLton_FFI_numExports": Int32.int; + end + +structure Finalizable = + struct + val touch = _prim "MLton_touch": 'a -> unit; + end + +structure GC = + struct + val collect = _prim "GC_collect": unit -> unit; + val pack = _import "GC_pack" runtime private: GCState.t -> unit; + val getBytesAllocated = + _import "GC_getCumulativeStatisticsBytesAllocated" runtime private: GCState.t -> C_UIntmax.t; + val getNumCopyingGCs = + _import "GC_getCumulativeStatisticsNumCopyingGCs" runtime private: GCState.t -> C_UIntmax.t; + val getNumMarkCompactGCs = + _import "GC_getCumulativeStatisticsNumMarkCompactGCs" runtime private: GCState.t -> C_UIntmax.t; + val getNumMinorGCs = + _import "GC_getCumulativeStatisticsNumMinorGCs" runtime private: GCState.t -> C_UIntmax.t; + val getLastBytesLive = + _import "GC_getLastMajorStatisticsBytesLive" runtime private: GCState.t -> C_Size.t; + val getMaxBytesLive = + _import "GC_getCumulativeStatisticsMaxBytesLive" runtime private: GCState.t -> C_Size.t; + val setHashConsDuringGC = + _import "GC_setHashConsDuringGC" runtime private: GCState.t * bool -> unit; + val setMessages = _import "GC_setControlsMessages" runtime private: GCState.t * bool -> unit; + val setRusageMeasureGC = + _import "GC_setControlsRusageMeasureGC" runtime private: GCState.t * bool -> unit; + val setSummary = _import "GC_setControlsSummary" runtime private: GCState.t * bool -> unit; + val unpack = _import "GC_unpack" runtime private: GCState.t -> unit; + end + +structure Platform = + struct + structure Arch = + struct + datatype t = + Alpha + | AMD64 + | ARM + | ARM64 + | HPPA + | IA64 + | m68k + | MIPS + | PowerPC + | PowerPC64 + | S390 + | Sparc + | X86 + + val host: t = + case _const "MLton_Platform_Arch_host": String8.string; of + "alpha" => Alpha + | "amd64" => AMD64 + | "arm" => ARM + | "arm64" => ARM64 + | "hppa" => HPPA + | "ia64" => IA64 + | "m68k" => m68k + | "mips" => MIPS + | "powerpc" => PowerPC + | "powerpc64" => PowerPC64 + | "s390" => S390 + | "sparc" => Sparc + | "x86" => X86 + | _ => raise Primitive.Exn.Fail8 "strange MLton_Platform_Arch_host" + + val hostIsBigEndian = _const "MLton_Platform_Arch_bigendian": bool; + end + + structure Format = + struct + datatype t = + Archive + | Executable + | LibArchive + | Library + + val host: t = + case _build_const "MLton_Platform_Format": String8.string; of + "archive" => Archive + | "executable" => Executable + | "libarchive" => LibArchive + | "library" => Library + | _ => raise Primitive.Exn.Fail8 "strange MLton_Platform_Format" + end + + structure OS = + struct + datatype t = + AIX + | Cygwin + | Darwin + | FreeBSD + | Hurd + | HPUX + | Linux + | MinGW + | NetBSD + | OpenBSD + | Solaris + + val host: t = + case _const "MLton_Platform_OS_host": String8.string; of + "aix" => AIX + | "cygwin" => Cygwin + | "darwin" => Darwin + | "freebsd" => FreeBSD + | "hurd" => Hurd + | "hpux" => HPUX + | "linux" => Linux + | "mingw" => MinGW + | "netbsd" => NetBSD + | "openbsd" => OpenBSD + | "solaris" => Solaris + | _ => raise Primitive.Exn.Fail8 "strange MLton_Platform_OS_host" + + val forkIsEnabled = + case host of + Cygwin => + #1 _symbol "MLton_Platform_CygwinUseMmap" private: bool GetSet.t; () + | MinGW => false + | _ => true + + val useWindowsProcess = not forkIsEnabled + end + end + +structure Pointer = + struct + open Pointer + type pointer = t + + val add = + _prim "CPointer_add": t * C_Ptrdiff.t -> t; + val sub = + _prim "CPointer_sub": t * C_Ptrdiff.t -> t; + val diff = + _prim "CPointer_diff": t * t -> C_Ptrdiff.t; + val < = _prim "CPointer_lt": t * t -> bool; + local + structure S = IntegralComparisons(type t = t + val < = <) + in + open S + end + + val fromWord = + _prim "CPointer_fromWord": C_Size.t -> t; + val toWord = + _prim "CPointer_toWord": t -> C_Size.t; + + val null: t = fromWord 0w0 + + fun isNull p = p = null + + val getCPointer = _prim "CPointer_getCPointer": t * C_Ptrdiff.t -> t; + val getInt8 = _prim "CPointer_getWord8": t * C_Ptrdiff.t -> Int8.int; + val getInt16 = _prim "CPointer_getWord16": t * C_Ptrdiff.t -> Int16.int; + val getInt32 = _prim "CPointer_getWord32": t * C_Ptrdiff.t -> Int32.int; + val getInt64 = _prim "CPointer_getWord64": t * C_Ptrdiff.t -> Int64.int; + val getObjptr = _prim "CPointer_getObjptr": t * C_Ptrdiff.t -> 'a; + val getReal32 = _prim "CPointer_getReal32": t * C_Ptrdiff.t -> Real32.real; + val getReal64 = _prim "CPointer_getReal64": t * C_Ptrdiff.t -> Real64.real; + val getWord8 = _prim "CPointer_getWord8": t * C_Ptrdiff.t -> Word8.word; + val getWord16 = _prim "CPointer_getWord16": t * C_Ptrdiff.t -> Word16.word; + val getWord32 = _prim "CPointer_getWord32": t * C_Ptrdiff.t -> Word32.word; + val getWord64 = _prim "CPointer_getWord64": t * C_Ptrdiff.t -> Word64.word; + val setCPointer = _prim "CPointer_setCPointer": t * C_Ptrdiff.t * t -> unit; + val setInt8 = _prim "CPointer_setWord8": t * C_Ptrdiff.t * Int8.int -> unit; + val setInt16 = _prim "CPointer_setWord16": t * C_Ptrdiff.t * Int16.int -> unit; + val setInt32 = _prim "CPointer_setWord32": t * C_Ptrdiff.t * Int32.int -> unit; + val setInt64 = _prim "CPointer_setWord64": t * C_Ptrdiff.t * Int64.int -> unit; + val setObjptr = _prim "CPointer_setObjptr": t * C_Ptrdiff.t * 'a -> unit; + val setReal32 = _prim "CPointer_setReal32": t * C_Ptrdiff.t * Real32.real -> unit; + val setReal64 = _prim "CPointer_setReal64": t * C_Ptrdiff.t * Real64.real -> unit; + val setWord8 = _prim "CPointer_setWord8": t * C_Ptrdiff.t * Word8.word -> unit; + val setWord16 = _prim "CPointer_setWord16": t * C_Ptrdiff.t * Word16.word -> unit; + val setWord32 = _prim "CPointer_setWord32": t * C_Ptrdiff.t * Word32.word -> unit; + val setWord64 = _prim "CPointer_setWord64": t * C_Ptrdiff.t * Word64.word -> unit; + end + +structure Profile = + struct + val isOn = _build_const "MLton_Profile_isOn": bool; + structure Data = + struct + type t = Pointer.t + + val dummy = Pointer.null + val free = _import "GC_profileFree" runtime private: GCState.t * t -> unit; + val malloc = _import "GC_profileMalloc" runtime private: GCState.t -> t; + val write = + _import "GC_profileWrite" runtime private: GCState.t * t * NullString8.t -> unit; + end + val done = _import "GC_profileDone" runtime private: GCState.t -> unit; + val getCurrent = _import "GC_getProfileCurrent" runtime private: GCState.t -> Data.t; + val setCurrent = _import "GC_setProfileCurrent" runtime private : GCState.t * Data.t -> unit; + end + +structure Thread = + struct + type preThread = PreThread.t + type thread = Thread.t + + val atomicState = _prim "Thread_atomicState": unit -> Word32.word; + val atomicBegin = _prim "Thread_atomicBegin": unit -> unit; + fun atomicEnd () = + if atomicState () = 0w0 + then raise Primitive.Exn.Fail8 "Thread.atomicEnd" + else _prim "Thread_atomicEnd": unit -> unit; () + val copy = _prim "Thread_copy": preThread -> thread; + (* copyCurrent's result is accesible via savedPre (). + * It is not possible to have the type of copyCurrent as + * unit -> preThread, because there are two different ways to + * return from the call to copyCurrent. One way is the direct + * obvious way, in the thread that called copyCurrent. That one, + * of course, wants to call savedPre (). However, another way to + * return is by making a copy of the preThread and then switching + * to it. In that case, there is no preThread to return. Making + * copyCurrent return a preThread creates nasty bugs where the + * return code from the CCall expects to see a preThread result + * according to the C return convention, but there isn't one when + * switching to a copy. + *) + val copyCurrent = _prim "Thread_copyCurrent": unit -> unit; + val current = _import "GC_getCurrentThread" runtime private: GCState.t -> thread; + val finishSignalHandler = _import "GC_finishSignalHandler" runtime private: GCState.t -> unit; + val returnToC = _prim "Thread_returnToC": unit -> unit; + val saved = _import "GC_getSavedThread" runtime private: GCState.t -> thread; + val savedPre = _import "GC_getSavedThread" runtime private: GCState.t -> preThread; + val setCallFromCHandler = + _import "GC_setCallFromCHandlerThread" runtime private: GCState.t * thread -> unit; + val setSignalHandler = + _import "GC_setSignalHandlerThread" runtime private: GCState.t * thread -> unit; + val setSaved = _import "GC_setSavedThread" runtime private: GCState.t * thread -> unit; + val startSignalHandler = _import "GC_startSignalHandler" runtime private: GCState.t -> unit; + val switchTo = _prim "Thread_switchTo": thread -> unit; + end + +structure Weak = + struct + open Weak + + val canGet = _prim "Weak_canGet": 'a t -> bool; + val get = _prim "Weak_get": 'a t -> 'a; + val new = _prim "Weak_new": 'a -> 'a t; + end + +structure World = + struct + val getAmOriginal = _import "GC_getAmOriginal" runtime private: GCState.t -> bool; + val setAmOriginal = _import "GC_setAmOriginal" runtime private: GCState.t * bool -> unit; + val getSaveStatus = _import "GC_getSaveWorldStatus" runtime private: GCState.t -> bool C_Errno.t; + (* save's result status is accesible via getSaveStatus (). + * It is not possible to have the type of save as + * NullString8.t -> bool C_Errno.t, because there are two + * different ways to return from the call to save. One way is + * the direct obvious way, in the program instance that called + * save. However, another way to return is in the program + * instance that loads the world. Making save return a bool + * creates nasty bugs where the return code from the CCall + * expects to see a bool result according to the C return + * convention, but there isn't one when returning in the load + * world. + *) + val save = _prim "World_save": NullString8.t -> unit; + end + +end + +end diff --git a/basis-library/primitive/prim-nullstring.sml b/basis-library/primitive/prim-nullstring.sml new file mode 100644 index 0000000..42b8a76 --- /dev/null +++ b/basis-library/primitive/prim-nullstring.sml @@ -0,0 +1,37 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +structure Primitive = struct + +open Primitive + +(* NullString is used for strings that must be passed to C and hence must be + * null terminated. + *) +structure NullString8 :> + sig + type t + + val empty: t + val fromString: String8.string -> t + end = + struct + type t = String8.string + + fun fromString s = + if #"\000" = Vector.subUnsafe (s, SeqIndex.- (Vector.length s, 1)) + then s + else raise Exn.Fail8 "NullString.fromString" + + val empty = fromString "\000" + end +structure NullString8Array = struct type t = NullString8.t array end + +end diff --git a/basis-library/primitive/prim-pack-real.sml b/basis-library/primitive/prim-pack-real.sml new file mode 100644 index 0000000..d3a2f96 --- /dev/null +++ b/basis-library/primitive/prim-pack-real.sml @@ -0,0 +1,33 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +structure Primitive = struct + +open Primitive + +structure PackReal32 = + struct + type real = Real32.real + type word = Word32.word + + val castFromWord = _prim "Word32_castToReal32": word -> real; + val castToWord = _prim "Real32_castToWord32": real -> word; + end + +structure PackReal64 = + struct + type real = Real64.real + type word = Word64.word + + val castFromWord = _prim "Word64_castToReal64": word -> real; + val castToWord = _prim "Real64_castToWord64": real -> word; + end + +end diff --git a/basis-library/primitive/prim-pack-word.sml b/basis-library/primitive/prim-pack-word.sml new file mode 100644 index 0000000..f9fd083 --- /dev/null +++ b/basis-library/primitive/prim-pack-word.sml @@ -0,0 +1,63 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +structure Primitive = struct + +open Primitive + +structure PackWord8 = + struct + type word = Word8.word + + val subArr = + _prim "Word8Array_subWord8": Word8.word array * SeqIndex.int -> word; + val subVec = + _prim "Word8Vector_subWord8": Word8.word vector * SeqIndex.int -> word; + val update = + _prim "Word8Array_updateWord8": Word8.word array * SeqIndex.int * word -> unit; + end + +structure PackWord16 = + struct + type word = Word16.word + + val subArr = + _prim "Word8Array_subWord16": Word8.word array * SeqIndex.int -> word; + val subVec = + _prim "Word8Vector_subWord16": Word8.word vector * SeqIndex.int -> word; + val update = + _prim "Word8Array_updateWord16": Word8.word array * SeqIndex.int * word -> unit; + end + +structure PackWord32 = + struct + type word = Word32.word + + val subArr = + _prim "Word8Array_subWord32": Word8.word array * SeqIndex.int -> word; + val subVec = + _prim "Word8Vector_subWord32": Word8.word vector * SeqIndex.int -> word; + val update = + _prim "Word8Array_updateWord32": Word8.word array * SeqIndex.int * word -> unit; + end + +structure PackWord64 = + struct + type word = Word64.word + + val subArr = + _prim "Word8Array_subWord64": Word8.word array * SeqIndex.int -> word; + val subVec = + _prim "Word8Vector_subWord64": Word8.word vector * SeqIndex.int -> word; + val update = + _prim "Word8Array_updateWord64": Word8.word array * SeqIndex.int * word -> unit; + end + +end diff --git a/basis-library/primitive/prim-real.sml b/basis-library/primitive/prim-real.sml new file mode 100644 index 0000000..958121a --- /dev/null +++ b/basis-library/primitive/prim-real.sml @@ -0,0 +1,284 @@ +(* Copyright (C) 2012,2013 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +signature PRIM_REAL = + sig + type real + type t = real + + val realSize: Primitive.Int32.int + val exponentBias : Primitive.Int32.int + val precision: Primitive.Int32.int + val radix: Primitive.Int32.int + + structure Math : + sig + type real + + val acos: real -> real + val asin: real -> real + val atan: real -> real + val atan2: real * real -> real + val cos: real -> real + val cosh: real -> real + val e: real + val exp: real -> real + val ln: real -> real + val log10: real -> real + val pi: real + val pow: real * real -> real + val sin: real -> real + val sinh: real -> real + val sqrt: real -> real + val tan: real -> real + val tanh: real -> real + end + + val * : real * real -> real + val *+ : real * real * real -> real + val *- : real * real * real -> real + val + : real * real -> real + val - : real * real -> real + val / : real * real -> real + val ~ : real -> real + val < : real * real -> bool + val <= : real * real -> bool + val == : real * real -> bool + val ?= : real * real -> bool + val abs: real -> real + val frexp: real * C_Int.t ref -> real + val gdtoa: real * C_Int.t * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t + val ldexp: real * C_Int.t -> real + val modf: real * real ref -> real + val round: real -> real + val realCeil: real -> real + val realFloor: real -> real + val realTrunc: real -> real + val strtor: Primitive.NullString8.t * C_Int.t -> real + + (* Integer to float; depends on rounding mode. *) + val fromInt8Unsafe: Primitive.Int8.int -> real + val fromInt16Unsafe: Primitive.Int16.int -> real + val fromInt32Unsafe: Primitive.Int32.int -> real + val fromInt64Unsafe: Primitive.Int64.int -> real + + (* Float to float; depends on rounding mode. *) + val fromReal32Unsafe: Primitive.Real32.real -> real + val fromReal64Unsafe: Primitive.Real64.real -> real + + (* Word to float; depends on rounding mode. *) + val fromWord8Unsafe: Primitive.Word8.word -> real + val fromWord16Unsafe: Primitive.Word16.word -> real + val fromWord32Unsafe: Primitive.Word32.word -> real + val fromWord64Unsafe: Primitive.Word64.word -> real + + (* Float to integer, taking lowbits. *) + val toInt8Unsafe: real -> Primitive.Int8.int + val toInt16Unsafe: real -> Primitive.Int16.int + val toInt32Unsafe: real -> Primitive.Int32.int + val toInt64Unsafe: real -> Primitive.Int64.int + + (* Float to float; depends on rounding mode. *) + val toReal32Unsafe: real -> Primitive.Real32.real + val toReal64Unsafe: real -> Primitive.Real64.real + + (* Float to word, taking lowbits. *) + val toWord8Unsafe: real -> Primitive.Word8.word + val toWord16Unsafe: real -> Primitive.Word16.word + val toWord32Unsafe: real -> Primitive.Word32.word + val toWord64Unsafe: real -> Primitive.Word64.word + end + +structure Primitive = struct + +open Primitive + +structure Real32 : PRIM_REAL = + struct + open Real32 + + val realSize : Int32.int = 32 + val exponentBias : Int32.int = 127 + val precision : Int32.int = 24 + val radix : Int32.int = 2 + + structure Math = + struct + type real = real + + val acos = _prim "Real32_Math_acos": real -> real; + val asin = _prim "Real32_Math_asin": real -> real; + val atan = _prim "Real32_Math_atan": real -> real; + val atan2 = _prim "Real32_Math_atan2": real * real -> real; + val cos = _prim "Real32_Math_cos": real -> real; + val cosh = _import "Real32_Math_cosh" private: real -> real; + val e = #1 _symbol "Real32_Math_e" private: real GetSet.t; () + val exp = _prim "Real32_Math_exp": real -> real; + val ln = _prim "Real32_Math_ln": real -> real; + val log10 = _prim "Real32_Math_log10": real -> real; + val pi = #1 _symbol "Real32_Math_pi" private: real GetSet.t; () + val pow = _import "Real32_Math_pow" private: real * real -> real; + val sin = _prim "Real32_Math_sin": real -> real; + val sinh = _import "Real32_Math_sinh" private: real -> real; + val sqrt = _prim "Real32_Math_sqrt": real -> real; + val tan = _prim "Real32_Math_tan": real -> real; + val tanh = _import "Real32_Math_tanh" private: real -> real; + end + + val * = _prim "Real32_mul": real * real -> real; + val *+ = _prim "Real32_muladd": real * real * real -> real; + val *- = _prim "Real32_mulsub": real * real * real -> real; + val + = _prim "Real32_add": real * real -> real; + val - = _prim "Real32_sub": real * real -> real; + val / = _prim "Real32_div": real * real -> real; + val ~ = _prim "Real32_neg": real -> real; + val op < = _prim "Real32_lt": real * real -> bool; + val op <= = _prim "Real32_le": real * real -> bool; + val == = _prim "Real32_equal": real * real -> bool; + val ?= = _prim "Real32_qequal": real * real -> bool; + val abs = _prim "Real32_abs": real -> real; + val frexp = _import "Real32_frexp" private: real * C_Int.t ref -> real; + val gdtoa = _import "Real32_gdtoa" private: real * C_Int.t * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t; + val ldexp = _prim "Real32_ldexp": real * C_Int.t -> real; + val modf = _import "Real32_modf" private: real * real ref -> real; + val round = _prim "Real32_round": real -> real; + val realCeil = _import "Real32_realCeil" private: real -> real; + val realFloor = _import "Real32_realFloor" private: real -> real; + val realTrunc = _import "Real32_realTrunc" private: real -> real; + val strtor = _import "Real32_strtor" private: NullString8.t * C_Int.t -> real; + + val fromInt8Unsafe = _prim "WordS8_rndToReal32": Int8.int -> real; + val fromInt16Unsafe = _prim "WordS16_rndToReal32": Int16.int -> real; + val fromInt32Unsafe = _prim "WordS32_rndToReal32": Int32.int -> real; + val fromInt64Unsafe = _prim "WordS64_rndToReal32": Int64.int -> real; + + val fromReal32Unsafe = _prim "Real32_rndToReal32": Real32.real -> real; + val fromReal64Unsafe = _prim "Real64_rndToReal32": Real64.real -> real; + + val fromWord8Unsafe = _prim "WordU8_rndToReal32": Word8.word -> real; + val fromWord16Unsafe = _prim "WordU16_rndToReal32": Word16.word -> real; + val fromWord32Unsafe = _prim "WordU32_rndToReal32": Word32.word -> real; + val fromWord64Unsafe = _prim "WordU64_rndToReal32": Word64.word -> real; + + val toInt8Unsafe = _prim "Real32_rndToWordS8": real -> Int8.int; + val toInt16Unsafe = _prim "Real32_rndToWordS16": real -> Int16.int; + val toInt32Unsafe = _prim "Real32_rndToWordS32": real -> Int32.int; + val toInt64Unsafe = _prim "Real32_rndToWordS64": real -> Int64.int; + + val toReal32Unsafe = _prim "Real32_rndToReal32": real -> Real32.real; + val toReal64Unsafe = _prim "Real32_rndToReal64": real -> Real64.real; + + val toWord8Unsafe = _prim "Real32_rndToWordU8": real -> Word8.word; + val toWord16Unsafe = _prim "Real32_rndToWordU16": real -> Word16.word; + val toWord32Unsafe = _prim "Real32_rndToWordU32": real -> Word32.word; + val toWord64Unsafe = _prim "Real32_rndToWordU64": real -> Word64.word; + end +structure Real32 = + struct + open Real32 + local + structure S = RealComparisons (Real32) + in + open S + end + end + +structure Real64 : PRIM_REAL = + struct + open Real64 + + val realSize : Int32.int = 64 + val exponentBias : Int32.int = 1023 + val precision : Int32.int = 53 + val radix : Int32.int = 2 + + structure Math = + struct + type real = real + + val acos = _prim "Real64_Math_acos": real -> real; + val asin = _prim "Real64_Math_asin": real -> real; + val atan = _prim "Real64_Math_atan": real -> real; + val atan2 = _prim "Real64_Math_atan2": real * real -> real; + val cos = _prim "Real64_Math_cos": real -> real; + val cosh = _import "Real64_Math_cosh" private: real -> real; + val e = #1 _symbol "Real64_Math_e" private: real GetSet.t; () + val exp = _prim "Real64_Math_exp": real -> real; + val ln = _prim "Real64_Math_ln": real -> real; + val log10 = _prim "Real64_Math_log10": real -> real; + val pi = #1 _symbol "Real64_Math_pi" private: real GetSet.t; () + val pow = _import "Real64_Math_pow" private: real * real -> real; + val sin = _prim "Real64_Math_sin": real -> real; + val sinh = _import "Real64_Math_sinh" private: real -> real; + val sqrt = _prim "Real64_Math_sqrt": real -> real; + val tan = _prim "Real64_Math_tan": real -> real; + val tanh = _import "Real64_Math_tanh" private: real -> real; + end + + val * = _prim "Real64_mul": real * real -> real; + val *+ = _prim "Real64_muladd": real * real * real -> real; + val *- = _prim "Real64_mulsub": real * real * real -> real; + val + = _prim "Real64_add": real * real -> real; + val - = _prim "Real64_sub": real * real -> real; + val / = _prim "Real64_div": real * real -> real; + val ~ = _prim "Real64_neg": real -> real; + val op < = _prim "Real64_lt": real * real -> bool; + val op <= = _prim "Real64_le": real * real -> bool; + val == = _prim "Real64_equal": real * real -> bool; + val ?= = _prim "Real64_qequal": real * real -> bool; + val abs = _prim "Real64_abs": real -> real; + val frexp = _import "Real64_frexp" private: real * C_Int.t ref -> real; + val gdtoa = _import "Real64_gdtoa" private: real * C_Int.t * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t; + val ldexp = _prim "Real64_ldexp": real * C_Int.t -> real; + val modf = _import "Real64_modf" private: real * real ref -> real; + val round = _prim "Real64_round": real -> real; + val realCeil = _import "Real64_realCeil" private: real -> real; + val realFloor = _import "Real64_realFloor" private: real -> real; + val realTrunc = _import "Real64_realTrunc" private: real -> real; + val strtor = _import "Real64_strtor" private: NullString8.t * C_Int.t -> real; + + val fromInt8Unsafe = _prim "WordS8_rndToReal64": Int8.int -> real; + val fromInt16Unsafe = _prim "WordS16_rndToReal64": Int16.int -> real; + val fromInt32Unsafe = _prim "WordS32_rndToReal64": Int32.int -> real; + val fromInt64Unsafe = _prim "WordS64_rndToReal64": Int64.int -> real; + + val fromReal32Unsafe = _prim "Real32_rndToReal64": Real32.real -> real; + val fromReal64Unsafe = _prim "Real64_rndToReal64": Real64.real -> real; + + val fromWord8Unsafe = _prim "WordU8_rndToReal64": Word8.word -> real; + val fromWord16Unsafe = _prim "WordU16_rndToReal64": Word16.word -> real; + val fromWord32Unsafe = _prim "WordU32_rndToReal64": Word32.word -> real; + val fromWord64Unsafe = _prim "WordU64_rndToReal64": Word64.word -> real; + + val toInt8Unsafe = _prim "Real64_rndToWordS8": real -> Int8.int; + val toInt16Unsafe = _prim "Real64_rndToWordS16": real -> Int16.int; + val toInt32Unsafe = _prim "Real64_rndToWordS32": real -> Int32.int; + val toInt64Unsafe = _prim "Real64_rndToWordS64": real -> Int64.int; + + val toReal32Unsafe = _prim "Real64_rndToReal32": real -> Real32.real; + val toReal64Unsafe = _prim "Real64_rndToReal64": real -> Real64.real; + + val toWord8Unsafe = _prim "Real64_rndToWordU8": real -> Word8.word; + val toWord16Unsafe = _prim "Real64_rndToWordU16": real -> Word16.word; + val toWord32Unsafe = _prim "Real64_rndToWordU32": real -> Word32.word; + val toWord64Unsafe = _prim "Real64_rndToWordU64": real -> Word64.word; + end +structure Real64 = + struct + open Real64 + local + structure S = RealComparisons (Real64) + in + open S + end + end + +end diff --git a/basis-library/primitive/prim-seq.sml b/basis-library/primitive/prim-seq.sml new file mode 100644 index 0000000..24e6438 --- /dev/null +++ b/basis-library/primitive/prim-seq.sml @@ -0,0 +1,60 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +structure Primitive = struct + +open Primitive + +structure Array = + struct + open Array + val allocUnsafe = _prim "Array_alloc": SeqIndex.int -> 'a array; + val copyArrayUnsafe = _prim "Array_copyArray": 'a array * SeqIndex.int * 'a array * SeqIndex.int * SeqIndex.int -> unit; + val copyVectorUnsafe = _prim "Array_copyVector": 'a array * SeqIndex.int * 'a vector * SeqIndex.int * SeqIndex.int -> unit; + val length = _prim "Array_length": 'a array -> SeqIndex.int; + (* There is no maximum length on arrays, so maxLen' = SeqIndex.maxInt'. *) + (* val maxLen': SeqIndex.int = SeqIndex.maxInt' *) + val subUnsafe = _prim "Array_sub": 'a array * SeqIndex.int -> 'a; + val uninitIsNop = _prim "Array_uninitIsNop": 'a array -> bool; + val uninitUnsafe = _prim "Array_uninit": 'a array * SeqIndex.int -> unit; + val updateUnsafe = _prim "Array_update": 'a array * SeqIndex.int * 'a -> unit; + + structure Raw :> sig + type 'a rawarr + val allocUnsafe: SeqIndex.int -> 'a rawarr + val length: 'a rawarr -> SeqIndex.int + val toArrayUnsafe: 'a rawarr -> 'a array + val uninitIsNop: 'a rawarr -> bool + val uninitUnsafe: 'a rawarr * SeqIndex.int -> unit + end = + struct + type 'a rawarr = 'a array + val allocUnsafe = _prim "Array_allocRaw": SeqIndex.int -> 'a rawarr; + val length = length + val toArrayUnsafe = _prim "Array_toArray": 'a rawarr -> 'a array; + val uninitIsNop = uninitIsNop + val uninitUnsafe = uninitUnsafe + end + end + +structure Vector = + struct + open Vector + (* Don't mutate the array after you apply fromArray, because vectors + * are supposed to be immutable and the optimizer depends on this. + *) + val fromArrayUnsafe = _prim "Array_toVector": 'a array -> 'a vector; + val length = _prim "Vector_length": 'a vector -> SeqIndex.int; + val subUnsafe = _prim "Vector_sub": 'a vector * SeqIndex.int -> 'a; + val vector0 = _prim "Vector_vector": unit -> 'a vector; + end + +end diff --git a/basis-library/primitive/prim-string.sml b/basis-library/primitive/prim-string.sml new file mode 100644 index 0000000..63f7ad3 --- /dev/null +++ b/basis-library/primitive/prim-string.sml @@ -0,0 +1,25 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +structure Primitive = struct + +open Primitive + +structure String8 = + struct + open String8 + + val idFromWord8Vector = + _prim "Word8Vector_toString": Word8.word vector -> string; + val idToWord8Vector = + _prim "String_toWord8Vector": string -> Word8.word vector; + end + +end diff --git a/basis-library/primitive/prim-word.sml b/basis-library/primitive/prim-word.sml new file mode 100644 index 0000000..f858cd4 --- /dev/null +++ b/basis-library/primitive/prim-word.sml @@ -0,0 +1,421 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +signature PRIM_WORD = + sig + eqtype word + type t = word + + val sizeInBits: Primitive.Int32.int + val sizeInBitsWord: Primitive.Word32.word + + val + : word * word -> word + val andb : word * word -> word + val < word + val * : word * word -> word + val ~ : word -> word + val notb : word -> word + val orb : word * word -> word + val quotUnsafe : word * word -> word + val remUnsafe: word * word -> word + val rolUnsafe: word * Primitive.Word32.word -> word + val rorUnsafe: word * Primitive.Word32.word -> word + val ~>>? : word * Primitive.Word32.word -> word + val >>? : word * Primitive.Word32.word -> word + val - : word * word -> word + val xorb: word * word -> word + + val < : word * word -> bool + val <= : word * word -> bool + val > : word * word -> bool + val >= : word * word -> bool + val compare: word * word -> Primitive.Order.order + val min: word * word -> word + val max: word * word -> word + end + +structure Primitive = struct + +open Primitive + +structure Word1 = + struct + open Word1 + type big = Word8.word + val fromBigUnsafe = _prim "WordU8_extdToWord1": big -> word; + val toBig = _prim "WordU1_extdToWord8": word -> big; + val sizeInBits: Int32.int = 1 + end +structure Word2 = + struct + open Word2 + type big = Word8.word + val fromBigUnsafe = _prim "WordU8_extdToWord2": big -> word; + val toBig = _prim "WordU2_extdToWord8": word -> big; + val sizeInBits: Int32.int = 2 + end +structure Word3 = + struct + open Word3 + type big = Word8.word + val fromBigUnsafe = _prim "WordU8_extdToWord3": big -> word; + val toBig = _prim "WordU3_extdToWord8": word -> big; + val sizeInBits: Int32.int = 3 + end +structure Word4 = + struct + open Word4 + type big = Word8.word + val fromBigUnsafe = _prim "WordU8_extdToWord4": big -> word; + val toBig = _prim "WordU4_extdToWord8": word -> big; + val sizeInBits: Int32.int = 4 + end +structure Word5 = + struct + open Word5 + type big = Word8.word + val fromBigUnsafe = _prim "WordU8_extdToWord5": big -> word; + val toBig = _prim "WordU5_extdToWord8": word -> big; + val sizeInBits: Int32.int = 5 + end +structure Word6 = + struct + open Word6 + type big = Word8.word + val fromBigUnsafe = _prim "WordU8_extdToWord6": big -> word; + val toBig = _prim "WordU6_extdToWord8": word -> big; + val sizeInBits: Int32.int = 6 + end +structure Word7 = + struct + open Word7 + type big = Word8.word + val fromBigUnsafe = _prim "WordU8_extdToWord7": big -> word; + val toBig = _prim "WordU7_extdToWord8": word -> big; + val sizeInBits: Int32.int = 7 + end +structure Word8 = + struct + open Word8 + + val sizeInBits: Int32.int = 8 + val sizeInBitsWord: Word32.word = + IntWordConv.zextdFromInt32ToWord32 sizeInBits + + val + = _prim "Word8_add": word * word -> word; + val andb = _prim "Word8_andb": word * word -> word; + val < word; + val * = _prim "WordU8_mul": word * word -> word; + val ~ = _prim "Word8_neg": word -> word; + val notb = _prim "Word8_notb": word -> word; + val orb = _prim "Word8_orb": word * word -> word; + val quotUnsafe = _prim "WordU8_quot": word * word -> word; + val remUnsafe = _prim "WordU8_rem": word * word -> word; + val rolUnsafe = _prim "Word8_rol": word * Word32.word -> word; + val rorUnsafe = _prim "Word8_ror": word * Word32.word -> word; + val ~>>? = _prim "WordS8_rshift": word * Word32.word -> word; + val >>? = _prim "WordU8_rshift": word * Word32.word -> word; + val - = _prim "Word8_sub": word * word -> word; + val xorb = _prim "Word8_xorb": word * word -> word; + + val < = _prim "WordU8_lt": word * word -> bool; + end +structure Word8 : PRIM_WORD = + struct + open Word8 + local + structure S = IntegralComparisons(Word8) + in + open S + end + end +structure Word9 = + struct + open Word9 + type big = Word16.word + val fromBigUnsafe = _prim "WordU16_extdToWord9": big -> word; + val toBig = _prim "WordU9_extdToWord16": word -> big; + val sizeInBits: Int32.int = 9 + end +structure Word10 = + struct + open Word10 + type big = Word16.word + val fromBigUnsafe = _prim "WordU16_extdToWord10": big -> word; + val toBig = _prim "WordU10_extdToWord16": word -> big; + val sizeInBits: Int32.int = 10 + end +structure Word11 = + struct + open Word11 + type big = Word16.word + val fromBigUnsafe = _prim "WordU16_extdToWord11": big -> word; + val toBig = _prim "WordU11_extdToWord16": word -> big; + val sizeInBits: Int32.int = 11 + end +structure Word12 = + struct + open Word12 + type big = Word16.word + val fromBigUnsafe = _prim "WordU16_extdToWord12": big -> word; + val toBig = _prim "WordU12_extdToWord16": word -> big; + val sizeInBits: Int32.int = 12 + end +structure Word13 = + struct + open Word13 + type big = Word16.word + val fromBigUnsafe = _prim "WordU16_extdToWord13": big -> word; + val toBig = _prim "WordU13_extdToWord16": word -> big; + val sizeInBits: Int32.int = 13 + end +structure Word14 = + struct + open Word14 + type big = Word16.word + val fromBigUnsafe = _prim "WordU16_extdToWord14": big -> word; + val toBig = _prim "WordU14_extdToWord16": word -> big; + val sizeInBits: Int32.int = 14 + end +structure Word15 = + struct + open Word15 + type big = Word16.word + val fromBigUnsafe = _prim "WordU16_extdToWord15": big -> word; + val toBig = _prim "WordU15_extdToWord16": word -> big; + val sizeInBits: Int32.int = 15 + end +structure Word16 = + struct + open Word16 + + val sizeInBits: Int32.int = 16 + val sizeInBitsWord: Word32.word = + IntWordConv.zextdFromInt32ToWord32 sizeInBits + + val + = _prim "Word16_add": word * word -> word; + val andb = _prim "Word16_andb": word * word -> word; + val < word; + val * = _prim "WordU16_mul": word * word -> word; + val ~ = _prim "Word16_neg": word -> word; + val notb = _prim "Word16_notb": word -> word; + val orb = _prim "Word16_orb": word * word -> word; + val quotUnsafe = _prim "WordU16_quot": word * word -> word; + val remUnsafe = _prim "WordU16_rem": word * word -> word; + val rolUnsafe = _prim "Word16_rol": word * Word32.word -> word; + val rorUnsafe = _prim "Word16_ror": word * Word32.word -> word; + val ~>>? = _prim "WordS16_rshift": word * Word32.word -> word; + val >>? = _prim "WordU16_rshift": word * Word32.word -> word; + val - = _prim "Word16_sub": word * word -> word; + val xorb = _prim "Word16_xorb": word * word -> word; + + val < = _prim "WordU16_lt": word * word -> bool; + end +structure Word16 : PRIM_WORD = + struct + open Word16 + local + structure S = IntegralComparisons(Word16) + in + open S + end + end +structure Word17 = + struct + open Word17 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord17": big -> word; + val toBig = _prim "WordU17_extdToWord32": word -> big; + val sizeInBits: Int32.int = 17 + end +structure Word18 = + struct + open Word18 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord18": big -> word; + val toBig = _prim "WordU18_extdToWord32": word -> big; + val sizeInBits: Int32.int = 18 + end +structure Word19 = + struct + open Word19 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord19": big -> word; + val toBig = _prim "WordU19_extdToWord32": word -> big; + val sizeInBits: Int32.int = 19 + end +structure Word20 = + struct + open Word20 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord20": big -> word; + val toBig = _prim "WordU20_extdToWord32": word -> big; + val sizeInBits: Int32.int = 20 + end +structure Word21 = + struct + open Word21 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord21": big -> word; + val toBig = _prim "WordU21_extdToWord32": word -> big; + val sizeInBits: Int32.int = 21 + end +structure Word22 = + struct + open Word22 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord22": big -> word; + val toBig = _prim "WordU22_extdToWord32": word -> big; + val sizeInBits: Int32.int = 22 + end +structure Word23 = + struct + open Word23 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord23": big -> word; + val toBig = _prim "WordU23_extdToWord32": word -> big; + val sizeInBits: Int32.int = 23 + end +structure Word24 = + struct + open Word24 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord24": big -> word; + val toBig = _prim "WordU24_extdToWord32": word -> big; + val sizeInBits: Int32.int = 24 + end +structure Word25 = + struct + open Word25 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord25": big -> word; + val toBig = _prim "WordU25_extdToWord32": word -> big; + val sizeInBits: Int32.int = 25 + end +structure Word26 = + struct + open Word26 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord26": big -> word; + val toBig = _prim "WordU26_extdToWord32": word -> big; + val sizeInBits: Int32.int = 26 + end +structure Word27 = + struct + open Word27 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord27": big -> word; + val toBig = _prim "WordU27_extdToWord32": word -> big; + val sizeInBits: Int32.int = 27 + end +structure Word28 = + struct + open Word28 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord28": big -> word; + val toBig = _prim "WordU28_extdToWord32": word -> big; + val sizeInBits: Int32.int = 28 + end +structure Word29 = + struct + open Word29 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord29": big -> word; + val toBig = _prim "WordU29_extdToWord32": word -> big; + val sizeInBits: Int32.int = 29 + end +structure Word30 = + struct + open Word30 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord30": big -> word; + val toBig = _prim "WordU30_extdToWord32": word -> big; + val sizeInBits: Int32.int = 30 + end +structure Word31 = + struct + open Word31 + type big = Word32.word + val fromBigUnsafe = _prim "WordU32_extdToWord31": big -> word; + val toBig = _prim "WordU31_extdToWord32": word -> big; + val sizeInBits: Int32.int = 31 + end +structure Word32 = + struct + open Word32 + + val sizeInBits: Int32.int = 32 + val sizeInBitsWord: Word32.word = + IntWordConv.zextdFromInt32ToWord32 sizeInBits + + val + = _prim "Word32_add": word * word -> word; + val andb = _prim "Word32_andb": word * word -> word; + val < word; + val * = _prim "WordU32_mul": word * word -> word; + val ~ = _prim "Word32_neg": word -> word; + val notb = _prim "Word32_notb": word -> word; + val orb = _prim "Word32_orb": word * word -> word; + val quotUnsafe = _prim "WordU32_quot": word * word -> word; + val remUnsafe = _prim "WordU32_rem": word * word -> word; + val rolUnsafe = _prim "Word32_rol": word * Word32.word -> word; + val rorUnsafe = _prim "Word32_ror": word * Word32.word -> word; + val ~>>? = _prim "WordS32_rshift": word * Word32.word -> word; + val >>? = _prim "WordU32_rshift": word * Word32.word -> word; + val - = _prim "Word32_sub": word * word -> word; + val xorb = _prim "Word32_xorb": word * word -> word; + + val < = _prim "WordU32_lt": word * word -> bool; + end +structure Word32 : PRIM_WORD = + struct + open Word32 + local + structure S = IntegralComparisons(Word32) + in + open S + end + end +structure Word64 = + struct + open Word64 + + val sizeInBits: Int32.int = 64 + val sizeInBitsWord: Word32.word = + IntWordConv.zextdFromInt32ToWord32 sizeInBits + + val + = _prim "Word64_add": word * word -> word; + val andb = _prim "Word64_andb": word * word -> word; + val < word; + val * = _prim "WordU64_mul": word * word -> word; + val ~ = _prim "Word64_neg": word -> word; + val notb = _prim "Word64_notb": word -> word; + val orb = _prim "Word64_orb": word * word -> word; + val quotUnsafe = _prim "WordU64_quot": word * word -> word; + val remUnsafe = _prim "WordU64_rem": word * word -> word; + val rolUnsafe = _prim "Word64_rol": word * Word32.word -> word; + val rorUnsafe = _prim "Word64_ror": word * Word32.word -> word; + val ~>>? = _prim "WordS64_rshift": word * Word32.word -> word; + val >>? = _prim "WordU64_rshift": word * Word32.word -> word; + val - = _prim "Word64_sub": word * word -> word; + val xorb = _prim "Word64_xorb": word * word -> word; + + val < = _prim "WordU64_lt": word * word -> bool; + end +structure Word64 : PRIM_WORD = + struct + open Word64 + local + structure S = IntegralComparisons(Word64) + in + open S + end + end + +end diff --git a/basis-library/primitive/prim1.sml b/basis-library/primitive/prim1.sml new file mode 100644 index 0000000..2af0fe8 --- /dev/null +++ b/basis-library/primitive/prim1.sml @@ -0,0 +1,104 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Primitive names are special -- see atoms/prim.fun. *) + +structure Primitive = struct + +open Primitive + +structure GetSet = + struct + type 'a t = (unit -> 'a) * ('a -> unit) + end + +structure PreThread :> sig type t end = struct type t = Thread.t end +structure Thread :> sig type t end = struct type t = Thread.t end + +(**************************************************************************) + +structure Bool = + struct + open Bool + fun not b = if b then false else true + end + +structure Controls = + struct + val debug = _command_line_const "MLton.debug": bool = false; + val detectOverflow = _command_line_const "MLton.detectOverflow": bool = true; + val safe = _command_line_const "MLton.safe": bool = true; + val bufSize = _command_line_const "TextIO.bufSize": Int32.int = 4096; + end + +structure Exn = + struct + open Exn + + val name = _prim "Exn_name": exn -> String8.string; + + exception Div + exception Domain + exception Fail8 of String8.string + exception Fail16 of String16.string + exception Fail32 of String32.string + exception Overflow + exception Size + exception Span + exception Subscript + + val wrapOverflow: ('a -> 'b) -> ('a -> 'b) = + fn f => fn a => f a handle PrimOverflow => raise Overflow + end + +structure Order = + struct + datatype t = LESS | EQUAL | GREATER + datatype order = datatype t + end + +structure Option = + struct + datatype 'a t = NONE | SOME of 'a + datatype option = datatype t + end + +structure Ref = + struct + open Ref + val deref = _prim "Ref_deref": 'a ref -> 'a; + val assign = _prim "Ref_assign": 'a ref * 'a -> unit; + end + +structure TopLevel = + struct + val getHandler = _prim "TopLevel_getHandler": unit -> (exn -> unit); + val getSuffix = _prim "TopLevel_getSuffix": unit -> (unit -> unit); + val setHandler = _prim "TopLevel_setHandler": (exn -> unit) -> unit; + val setSuffix = _prim "TopLevel_setSuffix": (unit -> unit) -> unit; + end + +end + +val not = Primitive.Bool.not + +exception Bind = Primitive.Exn.Bind +exception Div = Primitive.Exn.Div +exception Domain = Primitive.Exn.Domain +exception Match = Primitive.Exn.Match +exception Overflow = Primitive.Exn.Overflow +exception Size = Primitive.Exn.Size +exception Span = Primitive.Exn.Span +exception Subscript = Primitive.Exn.Subscript + +datatype option = datatype Primitive.Option.option +datatype order = datatype Primitive.Order.order + +infix 4 = <> +val op = = _prim "MLton_equal": ''a * ''a -> bool; +val op <> = fn (x, y) => not (x = y) diff --git a/basis-library/primitive/prim2.sml b/basis-library/primitive/prim2.sml new file mode 100644 index 0000000..0fc155d --- /dev/null +++ b/basis-library/primitive/prim2.sml @@ -0,0 +1,62 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Primitive = + struct + open Primitive + + structure MLton = + struct + open MLton + val bug = PrimitiveFFI.MLton.bug + end + + val dontInline: (unit -> 'a) -> 'a = + fn f => + let + val rec recur: Int32.int -> 'a = + fn i => + if i = 0 + then f () + else let + val _ = recur (Int32.- (i, 1)) + in + recur (Int32.- (i, 2)) + end + in + recur 0 + end + end + +(* Install an emergency exception handler. *) +local + structure P = Primitive + structure PFFI = PrimitiveFFI + val _ = + P.TopLevel.setHandler + (fn exn => + (PFFI.Stdio.print "unhandled exception: " + ; case exn of + P.Exn.Fail8 msg => (PFFI.Stdio.print "Fail " + ; PFFI.Stdio.print msg) + | _ => PFFI.Stdio.print (P.Exn.name exn) + ; PFFI.Stdio.print "\n" + ; P.MLton.bug ("unhandled exception in Basis Library"))) +in +end + +(* Install an emergency suffix. *) +local + structure P = Primitive + val _ = + P.TopLevel.setSuffix + (fn () => + (P.MLton.halt 0 + ; P.MLton.bug ("missing suffix in Basis Library"))) +in +end diff --git a/basis-library/primitive/primitive.mlb b/basis-library/primitive/primitive.mlb new file mode 100644 index 0000000..fe48cf4 --- /dev/null +++ b/basis-library/primitive/primitive.mlb @@ -0,0 +1,79 @@ +(* Copyright (C) 2016-2017 Matthew Fluet. + * Copyright (C) 2004-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "allowConstant true" + "allowFFI true" + "allowPrim true" + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused false" +in + prim-basis.mlb + ann "allowRedefineSpecialIds true" in + prim1.sml + end + ../util/integral-comparisons.sml + ../util/string-comparisons.sml + ../util/real-comparisons.sml + local + ../config/bind/char-prim.sml + ../config/bind/int-prim.sml + ../config/bind/int-inf-prim.sml + ../config/bind/real-prim.sml + ../config/bind/string-prim.sml + ../config/bind/word-prim.sml + in ann "forceUsed" in + ../config/choose-char.sml + ../config/choose-int.sml + ../config/choose-real.sml + ../config/choose-string.sml + ../config/choose-word.sml + ../config/c/word-to-bool.sml + end end + + prim-iwconv.sml + prim-word.sml + prim-int.sml + + local + ../config/bind/int-prim.sml + ../config/bind/pointer-prim.sml + ../config/bind/real-prim.sml + ../config/bind/word-prim.sml + in ann "forceUsed" in + ../config/objptr/objptr-$(OBJPTR_REP).sml + ../config/seqindex/seqindex-$(SEQINDEX_INT).sml + $(LIB_MLTON_DIR)/targets/$(TARGET)/sml/c-types.sml + ../config/c/errno.sml + ../config/c/position.sml + ../config/c/sys-word.sml + end end + prim-seq.sml + prim-nullstring.sml + + prim-int-inf.sml + + prim-char.sml + prim-string.sml + + prim-real.sml + + prim-pack-word.sml + prim-pack-real.sml + + prim-mlton.sml + + basis-ffi.sml + prim2.sml + + (* Check compatibility between primitives and runtime functions. *) + check-real.sml +end diff --git a/basis-library/real/IEEE-real.sig b/basis-library/real/IEEE-real.sig new file mode 100644 index 0000000..9dee807 --- /dev/null +++ b/basis-library/real/IEEE-real.sig @@ -0,0 +1,38 @@ +signature IEEE_REAL = + sig + exception Unordered + + datatype real_order = LESS | EQUAL | GREATER | UNORDERED + + datatype float_class = + NAN + | INF + | ZERO + | NORMAL + | SUBNORMAL + + datatype rounding_mode = + TO_NEAREST + | TO_NEGINF + | TO_POSINF + | TO_ZERO + + type decimal_approx = {class: float_class, + digits: int list, + exp: int, + sign: bool} + + val fromString: string -> decimal_approx option + val getRoundingMode: unit -> rounding_mode + val scan: (char, 'a) StringCvt.reader + -> (decimal_approx, 'a) StringCvt.reader + val setRoundingMode: rounding_mode -> unit + val toString: decimal_approx -> string + end + +signature IEEE_REAL_EXTRA = + sig + include IEEE_REAL + + val withRoundingMode: rounding_mode * (unit -> 'a) -> 'a + end diff --git a/basis-library/real/IEEE-real.sml b/basis-library/real/IEEE-real.sml new file mode 100644 index 0000000..c3ecbfe --- /dev/null +++ b/basis-library/real/IEEE-real.sml @@ -0,0 +1,376 @@ +(* Copyright (C) 2012 Matthew Fluet. + * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure IEEEReal: IEEE_REAL_EXTRA = + struct + val op + = Int.+ + val op - = Int.- + val op * = Int.* + + exception Unordered + datatype real_order = LESS | EQUAL | GREATER | UNORDERED + + structure Prim = PrimitiveFFI.IEEEReal + + datatype float_class = + INF + | NAN + | NORMAL + | SUBNORMAL + | ZERO + + structure RoundingMode = + struct + datatype t = + TO_NEAREST + | TO_NEGINF + | TO_POSINF + | TO_ZERO + + fun fromInt (i: C_Int.int): t = + let + open Prim.RoundingMode + in + if i = FE_TONEAREST + then TO_NEAREST + else if i = FE_DOWNWARD + then TO_NEGINF + else if i = FE_UPWARD + then TO_POSINF + else if i = FE_TOWARDZERO + then TO_ZERO + else raise Fail "IEEEReal.RoundingMode.fromInt" + end + + fun toInt (m: t): C_Int.int = + let + open Prim.RoundingMode + val i = + case m of + TO_NEAREST => FE_TONEAREST + | TO_NEGINF => FE_DOWNWARD + | TO_POSINF => FE_UPWARD + | TO_ZERO => FE_TOWARDZERO + in + if i = FE_NOSUPPORT + then raise Fail "IEEEReal rounding mode not supported" + else i + end + end + + datatype rounding_mode = datatype RoundingMode.t + + fun setRoundingMode (m: rounding_mode): unit = + if Prim.setRoundingMode (RoundingMode.toInt m) = 0 + then () + else + raise PosixError.raiseSys PosixError.inval + + val getRoundingMode = RoundingMode.fromInt o Prim.getRoundingMode + + fun withRoundingMode (m: rounding_mode, th: unit -> 'a): 'a = + let + val m' = getRoundingMode () + val _ = setRoundingMode m + val res = th () + val _ = setRoundingMode m' + in + res + end + + structure DecimalApprox = + struct + type t = {class: float_class, + digits: int list, + exp: int, + sign: bool} + + val inf: t = {class = INF, + digits = [], + exp = 0, + sign = false} + + val zero: t = {class = ZERO, + digits = [], + exp = 0, + sign = false} + end + + type decimal_approx = DecimalApprox.t + + fun 'a scan reader (state: 'a) = + let + val state = StringCvt.skipWS reader state + fun readc (c, state, f) = + case reader state of + NONE => NONE + | SOME (c', state') => + if c = Char.toLower c' + then f state' + else NONE + fun readString (s, state, failure, success) = + let + val n = String.size s + fun loop (i, state) = + if i = n + then success state + else + case reader state of + NONE => failure () + | SOME (c, state) => + if Char.toLower c = String.sub (s, i) + then loop (i + 1, state) + else failure () + in + loop (0, state) + end + fun charToDigit c = Char.ord c - Char.ord #"0" + fun digitStar (ds: int list, state) = + let + fun done () = (rev ds, state) + in + case reader state of + NONE => done () + | SOME (c, state) => + if Char.isDigit c + then digitStar (charToDigit c :: ds, state) + else done () + end + fun digitPlus (state, failure, success) = + case reader state of + NONE => failure () + | SOME (c, state) => + if Char.isDigit c + then success (digitStar ([charToDigit c], state)) + else failure () + (* [+~-]?[0-9]+ *) + type exp = {digits: int list, negate: bool} + fun 'b afterE (state: 'a, + failure: unit -> 'b, + success: exp * 'a -> 'b) : 'b = + case reader state of + NONE => failure () + | SOME (c, state) => + let + fun neg () = + digitPlus (state, failure, + fn (ds, state) => + success ({digits = ds, negate = true}, + state)) + in + case c of + #"+" => digitPlus (state, failure, + fn (ds, state) => + success ({digits = ds, + negate = false}, + state)) + | #"~" => neg () + | #"-" => neg () + | _ => + if Char.isDigit c + then + let + val (ds, state) = + digitStar ([charToDigit c], state) + in + success ({digits = ds, negate = false}, + state) + end + else failure () + end + (* e[+~-]?[0-9]+)? *) + fun exp (state: 'a, failure, success) = + case reader state of + NONE => failure () + | SOME (c, state) => + case Char.toLower c of + #"e" => afterE (state, failure, success) + | _ => failure () + (* (\.[0-9]+)(e[+~-]?[0-9]+)? *) + fun 'b afterDot (state: 'a, + failure: unit -> 'b, + success: int list * exp * 'a -> 'b) = + digitPlus (state, failure, + fn (frac, state) => + exp (state, + fn () => success (frac, + {digits = [], negate = false}, + state), + fn (e, state) => success (frac, e, state))) + fun stripLeadingZeros (ds: int list): int * int list = + let + fun loop (i, ds) = + case ds of + [] => (i, []) + | d :: ds' => + if d = 0 + then loop (i + 1, ds') + else (i, ds) + in + loop (0, ds) + end + fun stripTrailingZeros ds = + case ds of + [] => [] + | _ => + case List.last ds of + 0 => rev (#2 (stripLeadingZeros (rev ds))) + | _ => ds + fun done (whole: int list, + frac: int list, + {digits: int list, negate: bool}, + state: 'a) = + let + val (_, il) = stripLeadingZeros whole + val fl = stripTrailingZeros frac + datatype exp = + Int of int + | Overflow of DecimalApprox.t + val exp = + case (SOME (let + val i = + List.foldl (fn (d, n) => n * 10 + d) + 0 digits + in + if negate then Int.~ i else i + end) + handle General.Overflow => NONE) of + NONE => Overflow (if negate + then DecimalApprox.zero + else DecimalApprox.inf) + | SOME i => Int i + val da = + case il of + [] => + (case fl of + [] => DecimalApprox.zero + | _ => + case exp of + Int e => + let + val (m, fl) = stripLeadingZeros fl + in + {class = NORMAL, + digits = fl, + exp = e - m, + sign = false} + end + | Overflow da => da) + | _ => + case exp of + Int e => + {class = NORMAL, + digits = stripTrailingZeros (il @ fl), + exp = e + length il, + sign = false} + | Overflow da => da + in + SOME (da, state) + end + fun normal' (c, state) = + case Char.toLower c of + #"i" => readc (#"n", state, fn state => + readc (#"f", state, fn state => + let + fun res state = + SOME ({class = INF, + digits = [], + exp = 0, + sign = false}, + state) + in + readString ("inity", state, + fn () => res state, + res) + end)) + | #"n" => readc (#"a", state, fn state => + readc (#"n", state, fn state => + SOME ({class = NAN, + digits = [], + exp = 0, + sign = false}, + state))) + (* (([0-9]+(\.[0-9]+)?)|(\.[0-9]+))(e[+~-]?[0-9]+)? *) + | #"." => afterDot (state, + fn () => NONE, + fn (frac, exp, state) => + done ([], frac, exp, state)) + | _ => + if Char.isDigit c + then + (* ([0-9]+(\.[0-9]+)?)(e[+~-]?[0-9]+)? *) + let + val (whole, state) = + digitStar ([charToDigit c], state) + fun no () = done (whole, [], + {digits = [], negate = false}, + state) + in + case reader state of + NONE => no () + | SOME (c, state) => + case Char.toLower c of + #"." => + afterDot (state, no, + fn (frac, e, state) => + done (whole, frac, e, state)) + | #"e" => + afterE (state, no, + fn (e, state) => + done (whole, [], e, state)) + | _ => no () + end + else NONE + fun normal state = + case reader state of + NONE => NONE + | SOME z => normal' z + fun negate state = + case normal state of + NONE => NONE + | SOME ({class, digits, exp, ...}, state) => + SOME ({class = class, + digits = digits, + exp = exp, + sign = true}, + state) + in + case reader state of + NONE => NONE + | SOME (c, state) => + case c of + #"~" => negate state + | #"-" => negate state + | #"+" => normal state + | _ => normal' (c, state) + end + + fun fromString s = StringCvt.scanString scan s + + fun toString {class, sign, digits, exp}: string = + let + fun digitStr () = implode (map StringCvt.digitToChar digits) + fun norm () = + let val num = "0." ^ digitStr() + in if exp = 0 + then num + else concat [num, "E", Int.toString exp] + end + val num = + case class of + ZERO => "0.0" + | NORMAL => norm () + | SUBNORMAL => norm () + | INF => "inf" + | NAN => "nan" + in if sign + then "~" ^ num + else num + end + end diff --git a/basis-library/real/math.sig b/basis-library/real/math.sig new file mode 100644 index 0000000..b97856a --- /dev/null +++ b/basis-library/real/math.sig @@ -0,0 +1,22 @@ +signature MATH = + sig + type real + + val acos: real -> real + val asin: real -> real + val atan2: real * real -> real + val atan: real -> real + val cos: real -> real + val cosh: real -> real + val e: real + val exp: real -> real + val ln: real -> real + val log10: real -> real + val pi: real + val pow: real * real -> real + val sin: real -> real + val sinh: real -> real + val sqrt: real -> real + val tan: real -> real + val tanh: real -> real + end diff --git a/basis-library/real/pack-real.sig b/basis-library/real/pack-real.sig new file mode 100644 index 0000000..bca98dc --- /dev/null +++ b/basis-library/real/pack-real.sig @@ -0,0 +1,20 @@ +signature PACK_REAL = + sig + type real + + val bytesPerElem: int + val isBigEndian: bool + val toBytes: real -> Word8Vector.vector + val fromBytes: Word8Vector.vector -> real + val subVec: Word8Vector.vector * int -> real + val subArr: Word8Array.array * int -> real + val update: Word8Array.array * int * real -> unit + end + +signature PACK_REAL_EXTRA = + sig + include PACK_REAL + val unsafeSubVec: Word8Vector.vector * int -> real + val unsafeSubArr: Word8Array.array * int -> real + val unsafeUpdate: Word8Array.array * int * real -> unit + end diff --git a/basis-library/real/pack-real.sml b/basis-library/real/pack-real.sml new file mode 100644 index 0000000..c4828a3 --- /dev/null +++ b/basis-library/real/pack-real.sml @@ -0,0 +1,312 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor PackRealArg (S: sig + type real + type word + val subArr: Word8.word array * SeqIndex.int -> word + val subVec: Word8.word vector * SeqIndex.int -> word + val update: Word8.word array * SeqIndex.int * word -> unit + val bswap: word -> word + val castFromWord: word -> real + val castToWord: real -> word + end) = +struct + +open S + +val subArrRev = castFromWord o bswap o subArr +val subVecRev = castFromWord o bswap o subVec +fun updateRev (a, i, r) = update (a, i, bswap (castToWord r)) + +val subArr = castFromWord o subArr +val subVec = castFromWord o subVec +val update = fn (a, i, r) => update (a, i, castToWord r) + +end + +structure PackReal32Arg = + PackRealArg (open Primitive.PackReal32 + open Primitive.PackWord32 + val bswap = Word32.bswap) +structure PackReal64Arg = + PackRealArg (open Primitive.PackReal64 + open Primitive.PackWord64 + val bswap = Word64.bswap) +structure PackRealArg = + struct + type real = Real.real + local + structure S = + Real_ChooseRealN + (type 'a t = int + val fReal32 = Real32.realSize + val fReal64 = Real64.realSize) + in + val realSize = S.f + end + local + structure S = + Real_ChooseRealN + (type 'a t = Word8.word array * SeqIndex.int -> 'a + val fReal32 = PackReal32Arg.subArr + val fReal64 = PackReal64Arg.subArr) + in + val subArr = S.f + end + local + structure S = + Real_ChooseRealN + (type 'a t = Word8.word vector * SeqIndex.int -> 'a + val fReal32 = PackReal32Arg.subVec + val fReal64 = PackReal64Arg.subVec) + in + val subVec = S.f + end + local + structure S = + Real_ChooseRealN + (type 'a t = Word8.word array * SeqIndex.int * 'a -> unit + val fReal32 = PackReal32Arg.update + val fReal64 = PackReal64Arg.update) + in + val update = S.f + end + local + structure S = + Real_ChooseRealN + (type 'a t = Word8.word array * SeqIndex.int -> 'a + val fReal32 = PackReal32Arg.subArrRev + val fReal64 = PackReal64Arg.subArrRev) + in + val subArrRev = S.f + end + local + structure S = + Real_ChooseRealN + (type 'a t = Word8.word vector * SeqIndex.int -> 'a + val fReal32 = PackReal32Arg.subVecRev + val fReal64 = PackReal64Arg.subVecRev) + in + val subVecRev = S.f + end + local + structure S = + Real_ChooseRealN + (type 'a t = Word8.word array * SeqIndex.int * 'a -> unit + val fReal32 = PackReal32Arg.updateRev + val fReal64 = PackReal64Arg.updateRev) + in + val updateRev = S.f + end + end +structure PackLargeRealArg = + struct + type real = LargeReal.real + local + structure S = + LargeReal_ChooseRealN + (type 'a t = int + val fReal32 = Real32.realSize + val fReal64 = Real64.realSize) + in + val realSize = S.f + end + local + structure S = + LargeReal_ChooseRealN + (type 'a t = Word8.word array * SeqIndex.int -> 'a + val fReal32 = PackReal32Arg.subArr + val fReal64 = PackReal64Arg.subArr) + in + val subArr = S.f + end + local + structure S = + LargeReal_ChooseRealN + (type 'a t = Word8.word vector * SeqIndex.int -> 'a + val fReal32 = PackReal32Arg.subVec + val fReal64 = PackReal64Arg.subVec) + in + val subVec = S.f + end + local + structure S = + LargeReal_ChooseRealN + (type 'a t = Word8.word array * SeqIndex.int * 'a -> unit + val fReal32 = PackReal32Arg.update + val fReal64 = PackReal64Arg.update) + in + val update = S.f + end + local + structure S = + LargeReal_ChooseRealN + (type 'a t = Word8.word array * SeqIndex.int -> 'a + val fReal32 = PackReal32Arg.subArrRev + val fReal64 = PackReal64Arg.subArrRev) + in + val subArrRev = S.f + end + local + structure S = + LargeReal_ChooseRealN + (type 'a t = Word8.word vector * SeqIndex.int -> 'a + val fReal32 = PackReal32Arg.subVecRev + val fReal64 = PackReal64Arg.subVecRev) + in + val subVecRev = S.f + end + local + structure S = + LargeReal_ChooseRealN + (type 'a t = Word8.word array * SeqIndex.int * 'a -> unit + val fReal32 = PackReal32Arg.updateRev + val fReal64 = PackReal64Arg.updateRev) + in + val updateRev = S.f + end + end + +functor PackReal (S: sig + type real + val realSize: int + val isBigEndian: bool + val subArr: Word8.word array * SeqIndex.int -> real + val subVec: Word8.word vector * SeqIndex.int -> real + val update: Word8.word array * SeqIndex.int * real -> unit + val subArrRev: Word8.word array * SeqIndex.int -> real + val subVecRev: Word8.word vector * SeqIndex.int -> real + val updateRev: Word8.word array * SeqIndex.int * real -> unit + end): PACK_REAL_EXTRA = +struct + +open S + +val bytesPerElem = Int.div (realSize, 8) + +fun offset (i, n) = + let + val i' = Int.* (bytesPerElem, i) + val () = + if Primitive.Controls.safe + andalso (Int.geu (Int.+ (i', Int.- (bytesPerElem, 1)), n)) + then raise Subscript + else () + in + SeqIndex.fromInt i + end + handle Overflow => raise Subscript + + +val (subA, subV, updA) = + if isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian + then (subArr, subVec, update) + else (subArrRev, subVecRev, updateRev) + +fun update (a, i, r) = + let + val i = offset (i, Word8Array.length a) + val a = Word8Array.toPoly a + in + updA (a, i, r) + end + +fun unsafeUpdate (a, i, r) = + let + val i = SeqIndex.fromInt i + val a = Word8Array.toPoly a + in + updA (a, i, r) + end + +local + fun make (sub, length, toPoly) (av, i) = + let + val i = offset (i, length av) + in + sub (toPoly av, i) + end +in + val subArr = make (subA, Word8Array.length, Word8Array.toPoly) + val subVec = make (subV, Word8Vector.length, Word8Vector.toPoly) +end + +local + fun make (sub, length, toPoly) (av, i) = + let + val i = SeqIndex.fromInt i + in + sub (toPoly av, i) + end +in + val unsafeSubArr = make (subA, Word8Array.length, Word8Array.toPoly) + val unsafeSubVec = make (subV, Word8Vector.length, Word8Vector.toPoly) +end + +fun toBytes (r: real): Word8Vector.vector = + let + val a = Array.alloc bytesPerElem + in + (updA (a, 0, r) + ; Word8Vector.fromPoly (Array.vector a)) + end + +fun fromBytes v = subVec (v, 0) + +end + +structure PackReal32Big: PACK_REAL_EXTRA = + PackReal (open Real32 + open PackReal32Arg + val isBigEndian = true) +structure PackReal32Little: PACK_REAL_EXTRA = + PackReal (open Real32 + open PackReal32Arg + val isBigEndian = false) +structure PackReal32Host: PACK_REAL_EXTRA = + PackReal (open Real32 + open PackReal32Arg + val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian) +structure PackReal64Big: PACK_REAL_EXTRA = + PackReal (open Real64 + open PackReal64Arg + val isBigEndian = true) +structure PackReal64Little: PACK_REAL_EXTRA = + PackReal (open Real64 + open PackReal64Arg + val isBigEndian = false) +structure PackReal64Host: PACK_REAL_EXTRA = + PackReal (open Real64 + open PackReal64Arg + val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian) +structure PackRealBig: PACK_REAL_EXTRA = + PackReal (open Real + open PackRealArg + val isBigEndian = true) +structure PackRealLittle: PACK_REAL_EXTRA = + PackReal (open Real + open PackRealArg + val isBigEndian = false) +structure PackRealHost: PACK_REAL_EXTRA = + PackReal (open Real + open PackRealArg + val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian) +structure PackLargeRealBig: PACK_REAL_EXTRA = + PackReal (open LargeReal + open PackLargeRealArg + val isBigEndian = true) +structure PackLargeRealLittle: PACK_REAL_EXTRA = + PackReal (open LargeReal + open PackLargeRealArg + val isBigEndian = false) +structure PackLargeRealHost: PACK_REAL_EXTRA = + PackReal (open LargeReal + open PackLargeRealArg + val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian) diff --git a/basis-library/real/real-global.sml b/basis-library/real/real-global.sml new file mode 100644 index 0000000..bda0ab5 --- /dev/null +++ b/basis-library/real/real-global.sml @@ -0,0 +1,11 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +val real = Real.fromInt +structure RealGlobal: REAL_GLOBAL = Real +open RealGlobal diff --git a/basis-library/real/real.sig b/basis-library/real/real.sig new file mode 100644 index 0000000..cad0c4b --- /dev/null +++ b/basis-library/real/real.sig @@ -0,0 +1,153 @@ +signature PRE_REAL_GLOBAL = + sig + type real + structure Math: MATH where type real = real + end + +signature PRE_REAL = + sig + include PRE_REAL_GLOBAL + + val * : real * real -> real + val *+ : real * real * real -> real + val *- : real * real * real -> real + val + : real * real -> real + val - : real * real -> real + val / : real * real -> real + val < : real * real -> bool + val <= : real * real -> bool + val == : real * real -> bool + val > : real * real -> bool + val >= : real * real -> bool + val ?= : real * real -> bool + val ~ : real -> real + val abs: real -> real + + val realSize: Primitive.Int32.int + val exponentBias: Primitive.Int32.int + val precision: Primitive.Int32.int + val radix: Primitive.Int32.int + + val frexp: real * C_Int.int ref -> real + val ldexp: real * C_Int.int -> real + val modf: real * real ref -> real + + val round: real -> real + val realCeil: real -> real + val realFloor: real -> real + val realTrunc: real -> real + + val gdtoa: real * C_Int.t * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t + val strtor: Primitive.NullString8.t * C_Int.t -> real + + val fromInt8Unsafe: Primitive.Int8.int -> real + val fromInt16Unsafe: Primitive.Int16.int -> real + val fromInt32Unsafe: Primitive.Int32.int -> real + val fromInt64Unsafe: Primitive.Int64.int -> real + + val fromReal32Unsafe: Primitive.Real32.real -> real + val fromReal64Unsafe: Primitive.Real64.real -> real + + val fromWord8Unsafe: Primitive.Word8.word -> real + val fromWord16Unsafe: Primitive.Word16.word -> real + val fromWord32Unsafe: Primitive.Word32.word -> real + val fromWord64Unsafe: Primitive.Word64.word -> real + + val toInt8Unsafe: real -> Primitive.Int8.int + val toInt16Unsafe: real -> Primitive.Int16.int + val toInt32Unsafe: real -> Primitive.Int32.int + val toInt64Unsafe: real -> Primitive.Int64.int + + val toReal32Unsafe: real -> Primitive.Real32.real + val toReal64Unsafe: real -> Primitive.Real64.real + + val toWord8Unsafe: real -> Primitive.Word8.word + val toWord16Unsafe: real -> Primitive.Word16.word + val toWord32Unsafe: real -> Primitive.Word32.word + val toWord64Unsafe: real -> Primitive.Word64.word + end + +signature REAL_GLOBAL = + sig + include PRE_REAL_GLOBAL + + val round: real -> Int.int + val trunc: real -> Int.int + val ceil: real -> Int.int + val floor: real -> Int.int + end + +signature REAL = + sig + include REAL_GLOBAL + + val != : real * real -> bool + val * : real * real -> real + val *+ : real * real * real -> real + val *- : real * real * real -> real + val + : real * real -> real + val - : real * real -> real + val / : real * real -> real + val < : real * real -> bool + val <= : real * real -> bool + val == : real * real -> bool + val > : real * real -> bool + val >= : real * real -> bool + val ?= : real * real -> bool + val ~ : real -> real + val abs: real -> real + val checkFloat: real -> real + val class: real -> IEEEReal.float_class + val compare: real * real -> order + val compareReal: real * real -> IEEEReal.real_order + val copySign: real * real -> real + val fmt: StringCvt.realfmt -> real -> string + val fromDecimal: IEEEReal.decimal_approx -> real option + val fromInt: int -> real + val fromLarge: IEEEReal.rounding_mode -> LargeReal.real -> real + val fromLargeInt: LargeInt.int -> real + val fromManExp: {man: real, exp: int} -> real + val fromString: string -> real option + val isFinite: real -> bool + val isNan: real -> bool + val isNormal: real -> bool + val max: real * real -> real + val maxFinite: real + val min: real * real -> real + val minNormalPos: real + val minPos: real + val negInf: real + val nextAfter: real * real -> real + val posInf: real + val precision: int + val radix: int + val realCeil: real -> real + val realFloor: real -> real + val realMod: real -> real + val realRound: real -> real + val realTrunc: real -> real + val rem: real * real -> real + val sameSign: real * real -> bool + val scan: (char, 'a) StringCvt.reader -> (real, 'a) StringCvt.reader + val sign: real -> int + val signBit: real -> bool + val split: real -> {whole: real, frac: real} + val toDecimal: real -> IEEEReal.decimal_approx + val toInt: IEEEReal.rounding_mode -> real -> int + val toLarge: real -> LargeReal.real + val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int + val toManExp: real -> {man: real, exp: int} + val toString: real -> string + val unordered: real * real -> bool + end + +signature REAL_EXTRA = + sig + include REAL + val realSize: Int.int + + val fromWord: word -> real + val fromLargeWord: LargeWord.word -> real + val toWord: IEEEReal.rounding_mode -> real -> word + val toLargeWord: IEEEReal.rounding_mode -> real -> LargeWord.word + end diff --git a/basis-library/real/real.sml b/basis-library/real/real.sml new file mode 100644 index 0000000..6ef1aa9 --- /dev/null +++ b/basis-library/real/real.sml @@ -0,0 +1,1136 @@ +(* Copyright (C) 2011-2014,2017 Matthew Fluet. + * Copyright (C) 2003-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor Real (structure W: WORD_EXTRA + structure R: + sig + include PRE_REAL + val castToWord: real -> W.word + val castFromWord: W.word -> real + end): REAL_EXTRA = + struct + structure MLton = Primitive.MLton + structure Prim = R + local + open IEEEReal + in + datatype float_class = datatype float_class + datatype rounding_mode = datatype rounding_mode + end + infix 4 == != ?= + type real = R.real + + local + open Prim + in + val realSize = Int32.toInt realSize + val exponentBias = Int32.toInt exponentBias + val precision = Int32.toInt precision + val radix = Int32.toInt radix + end + + val signBits = Word.one + val exponentSignificandBits = Word.- (Word.fromInt realSize, signBits) + val significandBits = Word.- (Word.fromInt precision, Word.one) + val exponentBits = Word.- (exponentSignificandBits, significandBits) + + local + val mkMask : Word.word -> W.word = + fn b => W.notb (W.<< (W.notb W.zero, b)) + in + val signMask = + W.<< (mkMask signBits, exponentSignificandBits) + val exponentMask = + W.<< (mkMask exponentBits, significandBits) + val significandMask = + mkMask significandBits + end + + val class : real -> float_class = + fn r => + let + val w = R.castToWord r + in + if W.andb (w, exponentMask) = exponentMask + then if W.andb (w, significandMask) = W.zero + then IEEEReal.INF + else IEEEReal.NAN + else if W.andb (w, exponentMask) = W.zero + then if W.andb (w, significandMask) = W.zero + then IEEEReal.ZERO + else IEEEReal.SUBNORMAL + else IEEEReal.NORMAL + end + + val toBits : real -> {sign: bool, exponent: W.word, significand: W.word} = + fn r => + let + val w = R.castToWord r + val significand = + W.andb (w, significandMask) + val exponent = + W.>> (W.andb (w, exponentMask), significandBits) + val sign = + W.andb (w, signMask) = signMask + in + {sign = sign, + exponent = exponent, + significand = significand} + end + + val fromBits : {sign: bool, exponent: W.word, significand: W.word} -> real = + fn {sign, exponent, significand} => + let + val w = + W.orb (if sign then W.<< (W.one, exponentSignificandBits) else W.zero, + W.orb (W.andb (W.<< (exponent, significandBits), exponentMask), + W.andb (significand, significandMask))) + val r = R.castFromWord w + in + r + end + + local + open Prim + in + val op *+ = op *+ + val op *- = op *- + val op * = op * + val op + = op + + val op - = op - + val op / = op / + val op < = op < + val op <= = op <= + val op > = op > + val op >= = op >= + val ~ = ~ + val abs = abs + end + + local + fun 'a make {fromRealUnsafe: 'a -> real, + toRealUnsafe: real -> 'a, + other : {precision: Primitive.Int32.int}} = + if R.precision = #precision other + then (fn (_: rounding_mode) => fromRealUnsafe, + toRealUnsafe) + else (fn (m: rounding_mode) => fn r => + IEEEReal.withRoundingMode (m, fn () => fromRealUnsafe r), + toRealUnsafe) + in + val (fromReal32,toReal32) = + make {fromRealUnsafe = R.fromReal32Unsafe, + toRealUnsafe = R.toReal32Unsafe, + other = {precision = Primitive.Real32.precision}} + val (fromReal64,toReal64) = + make {fromRealUnsafe = R.fromReal64Unsafe, + toRealUnsafe = R.toReal64Unsafe, + other = {precision = Primitive.Real64.precision}} + end + local + structure S = + LargeReal_ChooseRealN + (type 'a t = real -> 'a + val fReal32 = toReal32 + val fReal64 = toReal64) + in + val toLarge = S.f + end + local + structure S = + LargeReal_ChooseRealN + (type 'a t = rounding_mode -> 'a -> real + val fReal32 = fromReal32 + val fReal64 = fromReal64) + in + val fromLarge = S.f + end + + val negInf = R.castFromWord (W.orb (signMask, exponentMask)) + val negOne = R.castFromWord (W.orb (signMask, W.<< (W.fromInt exponentBias, significandBits))) + val negZero = R.castFromWord signMask + val zero = R.castFromWord W.zero + val minPos = R.castFromWord W.one + val minNormalPos = R.castFromWord (W.<< (W.one, significandBits)) + val half = R.castFromWord (W.<< (W.- (W.fromInt exponentBias, W.one), significandBits)) + val one = R.castFromWord (W.<< (W.fromInt exponentBias, significandBits)) + val two = R.castFromWord (W.<< (W.+ (W.fromInt exponentBias, W.one), significandBits)) + val maxFinite = R.castFromWord (W.- (exponentMask, W.one)) + val posInf = R.castFromWord exponentMask + + val nan = posInf + negInf + val posNan = R.castFromWord (W.andb (R.castToWord nan, W.notb signMask)) + val negNan = R.castFromWord (W.orb (R.castToWord nan, signMask)) + + + fun isFinite r = + abs r <= maxFinite + + val op == = Prim.== + + val op != = not o op == + + fun isNan r = r != r + + fun isNormal r = class r = NORMAL + + val op ?= = + if MLton.Codegen.isAMD64 orelse MLton.Codegen.isLLVM orelse MLton.Codegen.isX86 + then R.?= + else + fn (x, y) => + case (class x, class y) of + (NAN, _) => true + | (_, NAN) => true + | (ZERO, ZERO) => true + | _ => R.== (x, y) + + fun min (x, y) = + if x <= y then x + else if x > y then y + else if isNan y then x + else y + + fun max (x, y) = + if x >= y then x + else if x < y then y + else if isNan y then x + else y + + fun sign (x: real): int = + if x > zero then 1 + else if x < zero then ~1 + else if x == zero then 0 + else raise Domain + + val signBit = #sign o toBits + + fun sameSign (x, y) = signBit x = signBit y + + fun copySign (x, y) = + if sameSign (x, y) + then x + else ~ x + + local + structure I = IEEEReal + in + fun compareReal (x, y) = + if x < y then I.LESS + else if x > y then I.GREATER + else if x == y then I.EQUAL + else I.UNORDERED + end + + local + structure I = IEEEReal + structure G = General + in + fun compare (x, y) = + case compareReal (x, y) of + I.EQUAL => G.EQUAL + | I.GREATER => G.GREATER + | I.LESS => G.LESS + | I.UNORDERED => raise IEEEReal.Unordered + end + + fun unordered (x, y) = isNan x orelse isNan y + + (* nextAfter for subnormal and normal values works by converting + * the real to a word of equivalent size and doing an increment + * or decrement on the word. Because of the way IEEE floating + * point numbers are represented, word {de,in}crement + * automatically does the right thing at the boundary between + * normals and denormals. Also, convienently, + * maxFinite+1 = posInf and minFinite-1 = negInf. + *) + val nextAfter: real * real -> real = + fn (r, t) => + case (class r, class t) of + (NAN, _) => nan + | (_, NAN) => nan + | (INF, _) => r + | (ZERO, ZERO) => t (* want "t", not "r", to get the sign right *) + | (ZERO, _) => if t > zero then minPos else ~minPos + | _ => + if r == t then + r + else if (r > t) = (r > zero) then + R.castFromWord (W.- (R.castToWord r, W.one)) + else + R.castFromWord (W.+ (R.castToWord r, W.one)) + + local + val one = One.make (fn () => ref (0 : C_Int.t)) + in + fun toManExp x = + case class x of + INF => {exp = 0, man = x} + | NAN => {exp = 0, man = nan} + | ZERO => {exp = 0, man = x} + | _ => One.use (one, fn r => + let + val man = R.frexp (x, r) + in + {exp = C_Int.toInt (!r), man = man} + end) + end + + fun fromManExp {exp, man} = + (R.ldexp (man, C_Int.fromInt exp)) + handle Overflow => + man * (if Int.< (exp, 0) then zero else posInf) + + val fromManExp = + if MLton.Codegen.isX86 + then fromManExp + else + fn {exp, man} => + case class man of + INF => man + | NAN => man + | ZERO => man + | _ => fromManExp {exp = exp, man = man} + + local + val one = One.make (fn () => ref zero) + in + fun split x = + case class x of + INF => {frac = if x > zero then zero else ~zero, + whole = x} + | NAN => {frac = nan, whole = nan} + | _ => + let + val (frac, whole) = + One.use (one, fn int => + (R.modf (x, int), !int)) + (* Some platforms' C libraries don't get sign of + * zero right. + *) + fun fix y = + if class y = ZERO andalso not (sameSign (x, y)) + then ~ y + else y + in + {frac = fix frac, + whole = fix whole} + end + end + + val realMod = #frac o split + + fun checkFloat x = + if isFinite x then x + else if isNan x then raise Div + else raise Overflow + + val realCeil = R.realCeil + val realFloor = R.realFloor + val realTrunc = R.realTrunc + + (* Unfortunately, libc round ties to zero instead of even values. *) + (* Fortunately, if any rounding mode is supported, it's TO_NEAREST. *) + val realRound = fn r => IEEEReal.withRoundingMode (TO_NEAREST, fn () => R.round r) + + fun rem (x, y) = + (case class x of + INF => nan + | NAN => nan + | ZERO => zero + | _ => (case class y of + INF => x + | NAN => nan + | ZERO => nan + | _ => x - realTrunc (x/y) * y)) + + (* fromDecimal, scan, fromString: decimal -> binary conversions *) + fun strtor (str: NullString.t, + rounding_mode: IEEEReal.rounding_mode) = + let + val rounding : C_Int.int = + case rounding_mode of + TO_NEAREST => 1 + | TO_NEGINF => 3 + | TO_POSINF => 2 + | TO_ZERO => 0 + in + Prim.strtor (str, rounding) + end + exception Bad + fun fromDecimalWithRoundingMode + ({class, digits, exp, sign}: IEEEReal.decimal_approx, + rounding_mode: IEEEReal.rounding_mode) = + let + fun doit () = + let + val exp = + if Int.< (exp, 0) + then concat ["-", Int.toString (Int.~ exp)] + else Int.toString exp +(* + val str = concat [if sign then "-" else "", + "0.", digits, + "E", exp, "\000"] +*) + val n = Int.+ (if sign then 1 else 0, + Int.+ (4 (* "0." + "E" + "\000" *), + Int.+ (List.length digits, + String.size exp))) + val a = Array.alloc n + fun upd (i, c) = (Array.update (a, i, c); Int.+ (i, 1)) + val i = 0 + val i = if sign then upd (i, #"-") else i + val i = upd (i, #"0") + val i = upd (i, #".") + val i = + List.foldl + (fn (d, i) => + if Int.< (d, 0) orelse Int.> (d, 9) + then raise Bad + else upd (i, Char.chr (Int.+ (d, Char.ord #"0")))) + i digits + val i = upd (i, #"E") + val i = CharVector.foldl (fn (c, i) => upd (i, c)) i exp + val _ = upd (i, #"\000") + val str = Vector.unsafeFromArray a + val x = strtor (NullString.fromString str, rounding_mode) + in + x + end + in + SOME (case class of + INF => if sign then negInf else posInf + | NAN => if sign then negNan else posNan + | NORMAL => doit () + | SUBNORMAL => doit () + | ZERO => if sign then negZero else zero) + handle Bad => NONE + end + + fun fromDecimal da = fromDecimalWithRoundingMode (da, TO_NEAREST) + + fun scan reader state = + case IEEEReal.scan reader state of + NONE => NONE + | SOME (da, state) => + SOME (valOf (fromDecimalWithRoundingMode + (da, IEEEReal.getRoundingMode ())), + state) + + val fromString = StringCvt.scanString scan + + (* toDecimal, fmt, toString: binary -> decimal conversions. *) + datatype mode = Fix | Gen | Sci + local + val one = One.make (fn () => ref (0: C_Int.int)) + in + fun gdtoa (x: real, mode: mode, ndig: int, + rounding_mode: IEEEReal.rounding_mode) = + let + val mode : C_Int.int = + case mode of + Fix => 3 + | Gen => 0 + | Sci => 2 + val ndig : C_Int.int = C_Int.fromInt ndig + val rounding : C_Int.int = + case rounding_mode of + TO_NEAREST => 1 + | TO_NEGINF => 3 + | TO_POSINF => 2 + | TO_ZERO => 0 + in + One.use (one, fn decpt => + (Prim.gdtoa (x, mode, ndig, rounding, decpt), + C_Int.toInt (!decpt))) + end + end + + fun toDecimal (x: real): IEEEReal.decimal_approx = + case class x of + INF => {class = INF, + digits = [], + exp = 0, + sign = x < zero} + | NAN => {class = NAN, + digits = [], + exp = 0, + sign = signBit x} + | ZERO => {class = ZERO, + digits = [], + exp = 0, + sign = signBit x} + | c => + let + val (cs, exp) = gdtoa (x, Gen, 0, TO_NEAREST) + fun loop (i, ac) = + if Int.< (i, 0) + then ac + else loop (Int.- (i, 1), + (Int.- (Char.ord (CUtil.C_String.sub (cs, i)), + Char.ord #"0")) + :: ac) + val digits = loop (Int.- (CUtil.C_String.length cs, 1), []) + in + {class = c, + digits = digits, + exp = exp, + sign = x < zero} + end + + datatype realfmt = datatype StringCvt.realfmt + + local + fun fix (sign: string, cs: CUtil.C_String.t, decpt: int, ndig: int): string = + let + val length = CUtil.C_String.length cs + in + if Int.< (decpt, 0) + then + concat [sign, + "0.", + String.new (Int.~ decpt, #"0"), + CUtil.C_String.toString cs, + String.new (Int.+ (Int.- (ndig, length), + decpt), + #"0")] + else + let + val whole = + if decpt = 0 + then "0" + else + String.tabulate (decpt, fn i => + if Int.< (i, length) + then CUtil.C_String.sub (cs, i) + else #"0") + in + if 0 = ndig + then concat [sign, whole] + else + let + val frac = + String.tabulate + (ndig, fn i => + let + val j = Int.+ (i, decpt) + in + if Int.< (j, length) + then CUtil.C_String.sub (cs, j) + else #"0" + end) + in + concat [sign, whole, ".", frac] + end + end + end + fun sci (x: real, ndig: int): string = + let + val sign = if x < zero then "~" else "" + val (cs, decpt) = + gdtoa (x, Sci, Int.+ (1, ndig), IEEEReal.getRoundingMode ()) + val length = CUtil.C_String.length cs + val whole = String.tabulate (1, fn _ => CUtil.C_String.sub (cs, 0)) + val frac = + if 0 = ndig + then "" + else concat [".", + String.tabulate + (ndig, fn i => + let + val j = Int.+ (i, 1) + in + if Int.< (j, length) + then CUtil.C_String.sub (cs, j) + else #"0" + end)] + val exp = Int.- (decpt, 1) + val exp = + let + val (exp, sign) = + if Int.< (exp, 0) + then (Int.~ exp, "~") + else (exp, "") + in + concat [sign, Int.toString exp] + end + in + concat [sign, whole, frac, "E", exp] + end + fun gen (x: real, n: int): string = + let + val (prefix, x) = + if x < zero + then ("~", ~ x) + else ("", x) + val ss = Substring.full (sci (x, Int.- (n, 1))) + fun isE c = c = #"E" + fun isZero c = c = #"0" + val expS = + Substring.string (Substring.taker (not o isE) ss) + val exp = valOf (Int.fromString expS) + val man = + String.translate + (fn #"." => "" | c => str c) + (Substring.string (Substring.dropr isZero + (Substring.takel (not o isE) ss))) + val manSize = String.size man + fun zeros i = CharVector.tabulate (i, fn _ => #"0") + fun dotAt i = + concat [String.substring (man, 0, i), + ".", String.extract (man, i, NONE)] + fun sci () = concat [prefix, + if manSize = 1 then man else dotAt 1, + "E", expS] + val op - = Int.- + val op + = Int.+ + val ~ = Int.~ + val op >= = Int.>= + in + if exp >= (if manSize = 1 then 3 else manSize + 3) + then sci () + else if exp >= manSize - 1 + then concat [prefix, man, zeros (exp - (manSize - 1))] + else if exp >= 0 + then concat [prefix, dotAt (exp + 1)] + else if exp >= (if manSize = 1 then ~2 else ~3) + then concat [prefix, "0.", zeros (~exp - 1), man] + else sci () + end + in + fun fmt spec = + let + val doit = + case spec of + EXACT => IEEEReal.toString o toDecimal + | FIX opt => + let + val n = + case opt of + NONE => 6 + | SOME n => + if Primitive.Controls.safe andalso Int.< (n, 0) + then raise Size + else n + in + fn x => + let + val sign = if x < zero then "~" else "" + val (cs, decpt) = + gdtoa (x, Fix, n, IEEEReal.getRoundingMode ()) + in + fix (sign, cs, decpt, n) + end + end + | GEN opt => + let + val n = + case opt of + NONE => 12 + | SOME n => + if Primitive.Controls.safe andalso Int.< (n, 1) + then raise Size + else n + in + fn x => gen (x, n) + end + | SCI opt => + let + val n = + case opt of + NONE => 6 + | SOME n => + if Primitive.Controls.safe andalso Int.< (n, 0) + then raise Size + else n + in + fn x => sci (x, n) + end + in + fn x => + case class x of + NAN => (* if signBit x then "~nan" else *) "nan" + | INF => if x > zero then "inf" else "~inf" + | _ => doit x + end + end + + val toString = fmt (StringCvt.GEN NONE) + + (* Not all devices support all rounding modes. + * However, every device has ceil/floor/round/trunc. + *) + fun safeConvert (m, cvt, x) = + case m of + TO_POSINF => cvt (realCeil x) + | TO_NEGINF => cvt (realFloor x) + | TO_NEAREST => cvt (realRound x) + | TO_ZERO => cvt (realTrunc x) + + local + fun 'a make {fromIntUnsafe: 'a -> real, + toIntUnsafe: real -> 'a, + other : {maxInt': Word.word -> 'a, + minInt': 'a, + precision': int}} = + (fromIntUnsafe, + if Int.< (precision, #precision' other) then + let + val trim = Int.- (Int.- (#precision' other, precision), 1) + val maxInt' = (#maxInt' other) (Word.fromInt trim) + val minInt' = #minInt' other + val maxInt = fromIntUnsafe maxInt' + val minInt = fromIntUnsafe minInt' + in + fn (m: rounding_mode) => fn x => + if minInt <= x then + if x <= maxInt then + safeConvert (m, toIntUnsafe, x) + else + raise Overflow + else + if x < minInt then + raise Overflow + else + raise Domain (* NaN *) + end + else + let + val maxInt' = (#maxInt' other) 0w0 + val minInt' = #minInt' other + val maxInt = fromIntUnsafe maxInt' + val minInt = fromIntUnsafe minInt' + in + fn (m: rounding_mode) => fn x => + if minInt <= x then + if x <= maxInt then + safeConvert (m, toIntUnsafe, x) + else + if x < maxInt + one then + (case m of + TO_NEGINF => maxInt' + | TO_POSINF => raise Overflow + | TO_ZERO => maxInt' + | TO_NEAREST => + (* Depends on maxInt being odd. *) + if x - maxInt >= half then + raise Overflow + else + maxInt') + else + raise Overflow + else + if x < minInt then + if minInt - one < x then + (case m of + TO_NEGINF => raise Overflow + | TO_POSINF => minInt' + | TO_ZERO => minInt' + | TO_NEAREST => + (* Depends on minInt being even. *) + if x - minInt < ~half then + raise Overflow + else + minInt') + else + raise Overflow + else + raise Domain (* NaN *) + end) + in + val (fromInt8,toInt8) = + make {fromIntUnsafe = R.fromInt8Unsafe, + toIntUnsafe = R.toInt8Unsafe, + other = {maxInt' = fn w => Int8.<< (Int8.>> (Int8.maxInt', w), w), + minInt' = Int8.minInt', + precision' = Int8.precision'}} + val (fromInt16,toInt16) = + make {fromIntUnsafe = R.fromInt16Unsafe, + toIntUnsafe = R.toInt16Unsafe, + other = {maxInt' = fn w => Int16.<< (Int16.>> (Int16.maxInt', w), w), + minInt' = Int16.minInt', + precision' = Int16.precision'}} + val (fromInt32,toInt32) = + make {fromIntUnsafe = R.fromInt32Unsafe, + toIntUnsafe = R.toInt32Unsafe, + other = {maxInt' = fn w => Int32.<< (Int32.>> (Int32.maxInt', w), w), + minInt' = Int32.minInt', + precision' = Int32.precision'}} + val (fromInt64,toInt64) = + make {fromIntUnsafe = R.fromInt64Unsafe, + toIntUnsafe = R.toInt64Unsafe, + other = {maxInt' = fn w => Int64.<< (Int64.>> (Int64.maxInt', w), w), + minInt' = Int64.minInt', + precision' = Int64.precision'}} + end + + val fromIntInf: IntInf.int -> real = + fn i => + let + val str = + if IntInf.< (i, 0) + then "-" ^ (IntInf.toString (IntInf.~ i)) + else IntInf.toString i + val x = strtor (NullString.nullTerm str, + IEEEReal.getRoundingMode ()) + in + x + end + + val toIntInf: rounding_mode -> real -> LargeInt.int = + fn mode => fn x => + case class x of + INF => raise Overflow + | NAN => raise Domain + | ZERO => (0 : LargeInt.int) + | _ => + let + (* This round may turn x into an INF, so we need to check the + * class again. + *) + val x = + case mode of + TO_POSINF => realCeil x + | TO_NEGINF => realFloor x + | TO_NEAREST => realRound x + | TO_ZERO => realTrunc x + in + case class x of + INF => raise Overflow + | _ => valOf (IntInf.fromString (fmt (StringCvt.FIX (SOME 0)) x)) + end + + local + structure S = + Int_ChooseInt + (type 'a t = 'a -> real + val fInt8 = fromInt8 + val fInt16 = fromInt16 + val fInt32 = fromInt32 + val fInt64 = fromInt64 + val fIntInf = fromIntInf) + in + val fromInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = 'a -> real + val fInt8 = fromInt8 + val fInt16 = fromInt16 + val fInt32 = fromInt32 + val fInt64 = fromInt64 + val fIntInf = fromIntInf) + in + val fromLargeInt = S.f + end + local + structure S = + Int_ChooseInt + (type 'a t = rounding_mode -> real -> 'a + val fInt8 = toInt8 + val fInt16 = toInt16 + val fInt32 = toInt32 + val fInt64 = toInt64 + val fIntInf = toIntInf) + in + val toInt = S.f + end + local + structure S = + LargeInt_ChooseInt + (type 'a t = rounding_mode -> real -> 'a + val fInt8 = toInt8 + val fInt16 = toInt16 + val fInt32 = toInt32 + val fInt64 = toInt64 + val fIntInf = toIntInf) + in + val toLargeInt = S.f + end + + val floor = toInt TO_NEGINF + val ceil = toInt TO_POSINF + val trunc = toInt TO_ZERO + val round = toInt TO_NEAREST + + local + fun 'a make {fromWordUnsafe: 'a -> real, + toWordUnsafe: real -> 'a, + other : {maxWord': Word.word -> 'a, + wordSize: int, + zeroWord: 'a}} = + (fromWordUnsafe, + if Int.<= (precision, #wordSize other) + then let + val trim = Int.- (#wordSize other, precision) + val maxWord' = (#maxWord' other) (Word.fromInt trim) + val maxWord = fromWordUnsafe maxWord' + val zeroWord = #zeroWord other + in + fn (m: rounding_mode) => fn x => + case class x of + INF => raise Overflow + | NAN => raise Domain + | _ => if zero <= x + then if x <= maxWord + then safeConvert (m, toWordUnsafe, x) + else raise Overflow + else if x > ~one + then (case m of + TO_NEGINF => raise Overflow + | TO_POSINF => zeroWord + | TO_ZERO => zeroWord + | TO_NEAREST => + if x < ~half + then raise Overflow + else zeroWord) + else raise Overflow + end + else let + val maxWord' = (#maxWord' other) 0w0 + val maxWord = fromWordUnsafe maxWord' + val zeroWord = #zeroWord other + in + fn (m: rounding_mode) => fn x => + case class x of + INF => raise Overflow + | NAN => raise Domain + | _ => if zero <= x + then if x <= maxWord + then safeConvert (m, toWordUnsafe, x) + else if x < maxWord + one + then (case m of + TO_NEGINF => maxWord' + | TO_POSINF => raise Overflow + | TO_ZERO => maxWord' + | TO_NEAREST => + (* Depends on maxWord being odd. *) + if x - maxWord >= half + then raise Overflow + else maxWord') + else raise Overflow + else if x > ~one + then (case m of + TO_NEGINF => raise Overflow + | TO_POSINF => zeroWord + | TO_ZERO => zeroWord + | TO_NEAREST => + if x < ~half + then raise Overflow + else zeroWord) + else raise Overflow + end) + in + val (fromWord8,toWord8) = + make {fromWordUnsafe = R.fromWord8Unsafe, + toWordUnsafe = R.toWord8Unsafe, + other = {maxWord' = fn w => Word8.<< (Word8.>> (Word8.maxWord', w), w), + wordSize = Word8.wordSize, + zeroWord = Word8.zero}} + val (fromWord16,toWord16) = + make {fromWordUnsafe = R.fromWord16Unsafe, + toWordUnsafe = R.toWord16Unsafe, + other = {maxWord' = fn w => Word16.<< (Word16.>> (Word16.maxWord', w), w), + wordSize = Word16.wordSize, + zeroWord = Word16.zero}} + val (fromWord32,toWord32) = + make {fromWordUnsafe = R.fromWord32Unsafe, + toWordUnsafe = R.toWord32Unsafe, + other = {maxWord' = fn w => Word32.<< (Word32.>> (Word32.maxWord', w), w), + wordSize = Word32.wordSize, + zeroWord = Word32.zero}} + val (fromWord64,toWord64) = + make {fromWordUnsafe = R.fromWord64Unsafe, + toWordUnsafe = R.toWord64Unsafe, + other = {maxWord' = fn w => Word64.<< (Word64.>> (Word64.maxWord', w), w), + wordSize = Word64.wordSize, + zeroWord = Word64.zero}} + end + + local + structure S = + Word_ChooseWordN + (type 'a t = 'a -> real + val fWord8 = fromWord8 + val fWord16 = fromWord16 + val fWord32 = fromWord32 + val fWord64 = fromWord64) + in + val fromWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = 'a -> real + val fWord8 = fromWord8 + val fWord16 = fromWord16 + val fWord32 = fromWord32 + val fWord64 = fromWord64) + in + val fromLargeWord = S.f + end + local + structure S = + Word_ChooseWordN + (type 'a t = rounding_mode -> real -> 'a + val fWord8 = toWord8 + val fWord16 = toWord16 + val fWord32 = toWord32 + val fWord64 = toWord64) + in + val toWord = S.f + end + local + structure S = + LargeWord_ChooseWordN + (type 'a t = rounding_mode -> real -> 'a + val fWord8 = toWord8 + val fWord16 = toWord16 + val fWord32 = toWord32 + val fWord64 = toWord64) + in + val toLargeWord = S.f + end + + structure Math = + struct + open Prim.Math + + (* Patch functions to handle out-of-range args. Many C math + * libraries do not do what the SML Basis Spec requires. + *) + + local + fun patch f x = + if x < ~one orelse x > one + then nan + else f x + in + val acos = patch acos + val asin = patch asin + end + + local + fun patch f x = if x < zero then nan else f x + in + val ln = patch ln + val log10 = patch log10 + end + + (* The x86 doesn't get exp right on infs. *) + val exp = + if MLton.Codegen.isX86 + andalso let open MLton.Platform.Arch in host = X86 end + then (fn x => + case class x of + INF => if x > zero then posInf else zero + | _ => exp x) + else exp + + (* The Cygwin math library doesn't get pow right on some exceptional + * cases. + * + * The Linux math library doesn't get pow (x, y) right when x < 0 + * and y is large (but finite). + * + * So, we define a pow function that gives the correct result on + * exceptional cases, and only calls the C pow with x > 0. + *) + fun isInt (x: real): bool = x == realFloor x + + (* isEven x assumes isInt x. *) + fun isEven (x: real): bool = isInt (x / two) + + fun isOddInt x = isInt x andalso not (isEven x) + + fun isNeg x = x < zero + + fun pow (x, y) = + case class y of + INF => + if class x = NAN + then nan + else if x < negOne orelse x > one + then if isNeg y then zero else posInf + else if negOne < x andalso x < one + then if isNeg y then posInf else zero + else (* x = 1 orelse x = ~1 *) + nan + | NAN => nan + | ZERO => one + | _ => + (case class x of + INF => + if isNeg x + then if isNeg y + then if isOddInt y + then negZero + else zero + else if isOddInt y + then negInf + else posInf + else (* x = posInf *) + if isNeg y then zero else posInf + | NAN => nan + | ZERO => + if isNeg y + then if isOddInt y + then copySign (posInf, x) + else posInf + else if isOddInt y + then x + else zero + | _ => + if isNeg x + then if isInt y + then if isEven y + then Prim.Math.pow (~ x, y) + else negOne * Prim.Math.pow (~ x, y) + else nan + else Prim.Math.pow (x, y)) + + fun cosh x = + case class x of + INF => x + | ZERO => one + | _ => R.Math.cosh x + + fun sinh x = + case class x of + INF => x + | ZERO => x + | _ => R.Math.sinh x + + fun tanh x = + case class x of + INF => if x > zero then one else negOne + | ZERO => x + | _ => R.Math.tanh x + end + end + +structure Real32 = Real (structure W = Word32 + structure R = + struct + open Primitive.Real32 + local open Primitive.PackReal32 in + val castToWord = castToWord + val castFromWord = castFromWord + end + end) +structure Real64 = Real (structure W = Word64 + structure R = + struct + open Primitive.Real64 + local open Primitive.PackReal64 in + val castToWord = castToWord + val castFromWord = castFromWord + end + end) diff --git a/basis-library/sml-nj.mlb b/basis-library/sml-nj.mlb new file mode 100644 index 0000000..d8533d8 --- /dev/null +++ b/basis-library/sml-nj.mlb @@ -0,0 +1,21 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + libs/basis-extra/basis-extra.mlb + in + signature SML_OF_NJ + structure SMLofNJ + end +end diff --git a/basis-library/sml-nj/sml-nj.sig b/basis-library/sml-nj/sml-nj.sig new file mode 100644 index 0000000..e67c741 --- /dev/null +++ b/basis-library/sml-nj/sml-nj.sig @@ -0,0 +1,26 @@ +signature SML_OF_NJ = + sig + structure Cont: + sig + type 'a cont + val callcc: ('a cont -> 'a) -> 'a + val isolate: ('a -> unit) -> 'a cont + val throw: 'a cont -> 'a -> 'b + end + structure SysInfo: + sig + exception UNKNOWN + datatype os_kind = BEOS | MACOS | OS2 | UNIX | WIN32 + + val getHostArch: unit -> string + val getOSKind: unit -> os_kind + val getOSName: unit -> string + end + + val exnHistory: exn -> string list + val exportFn: string * (string * string list -> OS.Process.status) -> unit + val exportML: string -> bool + val getAllArgs: unit -> string list + val getArgs: unit -> string list + val getCmdName: unit -> string + end diff --git a/basis-library/sml-nj/sml-nj.sml b/basis-library/sml-nj/sml-nj.sml new file mode 100644 index 0000000..3939501 --- /dev/null +++ b/basis-library/sml-nj/sml-nj.sml @@ -0,0 +1,74 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure SMLofNJ: SML_OF_NJ = + struct + structure Cont = + struct + structure C = MLton.Cont + + type 'a cont = 'a C.t + val callcc = C.callcc + val isolate = C.isolate + fun throw k v = C.throw (k, v) + end + + structure SysInfo = + struct + exception UNKNOWN + datatype os_kind = BEOS | MACOS | OS2 | UNIX | WIN32 + + fun getHostArch () = + MLton.Platform.Arch.toString MLton.Platform.Arch.host + + fun getOSKind () = + let + open MLton.Platform.OS + in + case host of + AIX => UNIX + | Cygwin => UNIX + | Darwin => MACOS + | FreeBSD => UNIX + | Hurd => UNIX + | HPUX => UNIX + | Linux => UNIX + | MinGW => WIN32 + | NetBSD => UNIX + | OpenBSD => UNIX + | Solaris => UNIX + end + + fun getOSName () = MLton.Platform.OS.toString MLton.Platform.OS.host + end + + val getCmdName = CommandLine.name + val getArgs = CommandLine.arguments + + fun getAllArgs () = getCmdName () :: getArgs () + + val exnHistory = MLton.Exn.history + + fun exportFn (file: string, f) = + let + open MLton.World OS.Process + in + case save (file ^ ".mlton") of + Original => exit success + | Clone => exit (f (getCmdName (), getArgs ()) handle _ => failure) + end + + fun exportML (f: string): bool = + let + open MLton.World + in + case save (f ^ ".mlton") of + Clone => true + | Original => false + end + end diff --git a/basis-library/sml-nj/unsafe.sig b/basis-library/sml-nj/unsafe.sig new file mode 100644 index 0000000..f2f6e75 --- /dev/null +++ b/basis-library/sml-nj/unsafe.sig @@ -0,0 +1,141 @@ +(* A subset of the UNSAFE signature provided by SML/NJ. Modified from SML/NJ + * sources, which are + * + * Copyright (c) 1997 Bell Labs, Lucent Technologies. + * + *) + +signature UNSAFE_MONO_ARRAY = + sig + type array + type elem + + (* omit Size check; + * elements have indeterminate value + *) + val create: int -> array + (* omit Subscript check *) + val sub: array * int -> elem + (* omit Subscript check *) + val update: array * int * elem -> unit + end + +(* SML/NJ provides 'create' and 'update', + * but they are not provided with MLton, + * because vectors are immutable and optimizations may + * break if they are updated. + *) +signature UNSAFE_MONO_VECTOR = + sig + type elem + type vector + + (* omit Size check; + * elements have indeterminate values *) + (* val create: int -> vector *) + (* omit Subscript check *) + val sub: vector * int -> elem + (* omit Subscript check *) + (* val update: vector * int * elem -> unit *) + end + +signature UNSAFE = + sig + structure Array: + sig + (* omit Size check; + * objptr(s) at elements set to bogus non-objptr value; + * non-objptr(s) at elements have indeterminate value + *) + val alloc: int -> 'a array + (* omit Size check; + * elements set to initial value + *) + val create: int * 'a -> 'a array + (* omit Subscript check *) + val sub: 'a array * int -> 'a + val uninitIsNop: 'a array -> bool + (* omit Subscript check; + * objptr(s) at element set to bogus non-objptr value + *) + val uninit: 'a array * int -> unit + (* omit Subscript check *) + val update: 'a array * int * 'a -> unit + + structure Raw: + sig + type 'a rawarr + + (* omit Size check; + * objptr(s) at elements have indeterminate value; + * non-objptr(s) at elements have indeterminate value + *) + val alloc: int -> 'a rawarr + (* prereq: all objptr(s) at elements set to bogus + * non-objptr value (via uninit) + *) + val toArray: 'a rawarr -> 'a array + val uninitIsNop: 'a rawarr -> bool + (* omit Subscript check; + * objptr(s) at element set to bogus non-objptr value + *) + val uninit: 'a rawarr * int -> unit + end + end + structure BoolArray: UNSAFE_MONO_ARRAY + structure BoolVector: UNSAFE_MONO_VECTOR + structure CharArray: UNSAFE_MONO_ARRAY + structure CharVector: UNSAFE_MONO_VECTOR + structure IntArray: UNSAFE_MONO_ARRAY + structure IntVector: UNSAFE_MONO_VECTOR + structure Int8Array: UNSAFE_MONO_ARRAY + structure Int8Vector: UNSAFE_MONO_VECTOR + structure Int16Array: UNSAFE_MONO_ARRAY + structure Int16Vector: UNSAFE_MONO_VECTOR + structure Int32Array: UNSAFE_MONO_ARRAY + structure Int32Vector: UNSAFE_MONO_VECTOR + structure Int64Array: UNSAFE_MONO_ARRAY + structure Int64Vector: UNSAFE_MONO_VECTOR + structure IntInfArray: UNSAFE_MONO_ARRAY + structure IntInfVector: UNSAFE_MONO_VECTOR + structure LargeIntArray: UNSAFE_MONO_ARRAY + structure LargeIntVector: UNSAFE_MONO_VECTOR + structure LargeRealArray: UNSAFE_MONO_ARRAY + structure LargeRealVector: UNSAFE_MONO_VECTOR + structure LargeWordArray: UNSAFE_MONO_ARRAY + structure LargeWordVector: UNSAFE_MONO_VECTOR + structure RealArray: UNSAFE_MONO_ARRAY + structure RealVector: UNSAFE_MONO_VECTOR + structure Real32Array: UNSAFE_MONO_ARRAY + structure Real32Vector: UNSAFE_MONO_VECTOR + structure Real64Array: UNSAFE_MONO_ARRAY + structure Real64Vector: UNSAFE_MONO_VECTOR + structure Vector: + sig + (* val create: int * 'a list -> 'a vector *) + val sub: 'a vector * int -> 'a + end + structure WordArray: UNSAFE_MONO_ARRAY + structure WordVector: UNSAFE_MONO_VECTOR + structure Word8Array: UNSAFE_MONO_ARRAY + structure Word8Vector: UNSAFE_MONO_VECTOR + structure Word16Array: UNSAFE_MONO_ARRAY + structure Word16Vector: UNSAFE_MONO_VECTOR + structure Word32Array: UNSAFE_MONO_ARRAY + structure Word32Vector: UNSAFE_MONO_VECTOR + structure Word64Array: UNSAFE_MONO_ARRAY + structure Word64Vector: UNSAFE_MONO_VECTOR + + structure PackReal32Big : PACK_REAL + structure PackReal32Little : PACK_REAL + structure PackReal64Big : PACK_REAL + structure PackReal64Little : PACK_REAL + structure PackRealBig : PACK_REAL + structure PackRealLittle : PACK_REAL + structure PackWord16Big : PACK_WORD + structure PackWord16Little : PACK_WORD + structure PackWord32Big : PACK_WORD + structure PackWord32Little : PACK_WORD + structure PackWord64Big : PACK_WORD + structure PackWord64Little : PACK_WORD + end diff --git a/basis-library/sml-nj/unsafe.sml b/basis-library/sml-nj/unsafe.sml new file mode 100644 index 0000000..69b12ec --- /dev/null +++ b/basis-library/sml-nj/unsafe.sml @@ -0,0 +1,119 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor UnsafeMonoArray (A: MONO_ARRAY_EXTRA): UNSAFE_MONO_ARRAY = + struct + open A + + val sub = unsafeSub + val update = unsafeUpdate + val create = fromPoly o Array.unsafeAlloc + end + +functor UnsafeMonoVector (V: MONO_VECTOR_EXTRA): UNSAFE_MONO_VECTOR = + struct + open V + + val sub = unsafeSub + end + +functor UnsafePackWord(PW : PACK_WORD_EXTRA) : PACK_WORD = + struct + open PW + val subVec = unsafeSubVec + val subVecX = unsafeSubVecX + val subArr = unsafeSubArr + val subArrX = unsafeSubArrX + val update = unsafeUpdate + end + +functor UnsafePackReal(PW : PACK_REAL_EXTRA) : PACK_REAL = + struct + open PW + val subVec = unsafeSubVec + val subArr = unsafeSubArr + val update = unsafeUpdate + end + +(* This is here so that the code generated by Lex and Yacc will work. *) +structure Unsafe: UNSAFE = + struct + structure Array = + struct + val alloc = Array.unsafeAlloc + val sub = Array.unsafeSub + val uninitIsNop = Array.uninitIsNop + val uninit = Array.unsafeUninit + val update = Array.unsafeUpdate + val create = Array.unsafeArray + structure Raw = Array.Raw + structure Raw = + struct + type 'a rawarr = 'a Raw.rawarr + val alloc = Raw.unsafeAlloc + val toArray = Raw.unsafeToArray + val uninitIsNop = Raw.uninitIsNop + val uninit = Raw.unsafeUninit + end + end + structure BoolArray = UnsafeMonoArray (BoolArray) + structure BoolVector = UnsafeMonoVector (BoolVector) + structure CharArray = UnsafeMonoArray (CharArray) + structure CharVector = UnsafeMonoVector (CharVector) + structure IntArray = UnsafeMonoArray (IntArray) + structure IntVector = UnsafeMonoVector (IntVector) + structure Int8Array = UnsafeMonoArray (Int8Array) + structure Int8Vector = UnsafeMonoVector (Int8Vector) + structure Int16Array = UnsafeMonoArray (Int16Array) + structure Int16Vector = UnsafeMonoVector (Int16Vector) + structure Int32Array = UnsafeMonoArray (Int32Array) + structure Int32Vector = UnsafeMonoVector (Int32Vector) + structure Int64Array = UnsafeMonoArray (Int64Array) + structure Int64Vector = UnsafeMonoVector (Int64Vector) + structure IntInfArray = UnsafeMonoArray (IntInfArray) + structure IntInfVector = UnsafeMonoVector (IntInfVector) + structure LargeIntArray = UnsafeMonoArray (LargeIntArray) + structure LargeIntVector = UnsafeMonoVector (LargeIntVector) + structure LargeRealArray = UnsafeMonoArray (LargeRealArray) + structure LargeRealVector = UnsafeMonoVector (LargeRealVector) + structure LargeWordArray = UnsafeMonoArray (LargeWordArray) + structure LargeWordVector = UnsafeMonoVector (LargeWordVector) + structure RealArray = UnsafeMonoArray (RealArray) + structure RealVector = UnsafeMonoVector (RealVector) + structure Real32Array = UnsafeMonoArray (Real32Array) + structure Real32Vector = UnsafeMonoVector (Real32Vector) + structure Real64Array = UnsafeMonoArray (Real64Array) + structure Real64Vector = UnsafeMonoVector (Real64Vector) + structure Vector = + struct + val sub = Vector.unsafeSub + end + structure WordArray = UnsafeMonoArray (WordArray) + structure WordVector = UnsafeMonoVector (WordVector) + structure Word8Array = UnsafeMonoArray (Word8Array) + structure Word8Vector = UnsafeMonoVector (Word8Vector) + structure Word16Array = UnsafeMonoArray (Word16Array) + structure Word16Vector = UnsafeMonoVector (Word16Vector) + structure Word32Array = UnsafeMonoArray (Word32Array) + structure Word32Vector = UnsafeMonoVector (Word32Vector) + structure Word64Array = UnsafeMonoArray (Word64Array) + structure Word64Vector = UnsafeMonoVector (Word64Vector) + structure PackReal32Big = UnsafePackReal(PackReal32Big) + structure PackReal32Little = UnsafePackReal(PackReal32Little) + structure PackReal64Big = UnsafePackReal(PackReal64Big) + structure PackReal64Little = UnsafePackReal(PackReal64Little) + structure PackRealBig = UnsafePackReal(PackRealBig) + structure PackRealLittle = UnsafePackReal(PackRealLittle) + structure PackWord16Big = UnsafePackWord(PackWord16Big) + structure PackWord16Little = UnsafePackWord(PackWord16Little) + structure PackWord32Big = UnsafePackWord(PackWord32Big) + structure PackWord32Little = UnsafePackWord(PackWord32Little) + structure PackWord64Big = UnsafePackWord(PackWord64Big) + structure PackWord64Little = UnsafePackWord(PackWord64Little) + end diff --git a/basis-library/system/command-line.sig b/basis-library/system/command-line.sig new file mode 100644 index 0000000..fcabe1b --- /dev/null +++ b/basis-library/system/command-line.sig @@ -0,0 +1,5 @@ +signature COMMAND_LINE = + sig + val name: unit -> string + val arguments: unit -> string list + end diff --git a/basis-library/system/command-line.sml b/basis-library/system/command-line.sml new file mode 100644 index 0000000..4a75301 --- /dev/null +++ b/basis-library/system/command-line.sml @@ -0,0 +1,19 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure CommandLine: COMMAND_LINE = + struct + structure Prim = PrimitiveFFI.CommandLine + + fun name () = + CUtil.C_String.toString (Prim.commandNameGet ()) + + fun arguments () = + (Array.toList o CUtil.C_StringArray.toArrayOfLength) + (Prim.argvGet (), C_Int.toInt (Prim.argcGet ())) + end diff --git a/basis-library/system/date.sig b/basis-library/system/date.sig new file mode 100644 index 0000000..24856b1 --- /dev/null +++ b/basis-library/system/date.sig @@ -0,0 +1,40 @@ +signature DATE = + sig + datatype weekday = + Mon | Tue | Wed | Thu | Fri | Sat | Sun + + datatype month = + Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec + + type date + + exception Date + + val date: {year: int, + month: month, + day: int, + hour: int, + minute: int, + second: int, + offset: Time.time option} -> date + + val year: date -> int + val month: date -> month + val day: date -> int + val hour: date -> int + val minute: date -> int + val second: date -> int + val weekDay: date -> weekday + val yearDay: date -> int + val offset: date -> Time.time option + val isDst: date -> bool option + val localOffset: unit -> Time.time + val fromTimeLocal: Time.time -> date + val fromTimeUniv: Time.time -> date + val toTime: date -> Time.time + val toString: date -> string + val fmt: string -> date -> string + val fromString: string -> date option + val scan: (char, 'a) StringCvt.reader -> (date, 'a) StringCvt.reader + val compare: date * date -> order + end diff --git a/basis-library/system/date.sml b/basis-library/system/date.sml new file mode 100644 index 0000000..98b8905 --- /dev/null +++ b/basis-library/system/date.sml @@ -0,0 +1,546 @@ +(* Modified from the ML Kit 4.1.4; basislib/Date.sml + * by mfluet@acm.org on 2017-04-07 + * by mfluet@acm.org on 2006-4-25 + * by mfluet@acm.org on 2005-8-10 based on + * modifications from the ML Kit Version 3; basislib/Date.sml + * by sweeks@research.nj.nec.com on 1999-1-3 and + * by sweeks@acm.org on 2000-1-18. + *) + +(* Date -- 1995-07-03, 1998-04-07 *) + +structure Date :> DATE = + struct + structure Prim = PrimitiveFFI.Date + structure Tm = Prim.Tm + + (* Patch to make Time look like it deals with Int.int + * instead of LargeInt.int. + *) + structure Time = + struct + open Time + val toSeconds = LargeInt.toInt o toSeconds + val fromSeconds = fromSeconds o LargeInt.fromInt + end + + datatype weekday = Mon | Tue | Wed | Thu | Fri | Sat | Sun + + datatype month = Jan | Feb | Mar | Apr | May | Jun + | Jul | Aug | Sep | Oct | Nov | Dec + + datatype t = + T of {day: int, (* 1-31 *) + hour: int, (* 0-23 *) + isDst: bool option, (* daylight savings time in force *) + minute: int, (* 0-59 *) + month: month, + offset: int option, (* signed seconds East of UTC: + * this zone = UTC+t; ~82800 < t <= 82800 *) + second: int, (* 0-61 (allowing for leap seconds) *) + weekDay: weekday, + year: int, (* e.g. 1995 *) + yearDay: int} (* 0-365 *) + type date = t + + local + fun make f (T r) = f r + in + val day = make #day + val hour = make #hour + val isDst = make #isDst + val minute = make #minute + val month = make #month + val second = make #second + val weekDay = make #weekDay + val year = make #year + val yearDay = make #yearDay + end + + exception Date + + (* 86400 = 24*60*6 is the number of seconds per day *) + + type tmoz = {tm_hour : C_Int.t, + tm_isdst : C_Int.t, (* 0 = no, 1 = yes, ~1 = don't know *) + tm_mday : C_Int.t, + tm_min : C_Int.t, + tm_mon : C_Int.t, + tm_sec : C_Int.t, + tm_wday : C_Int.t, + tm_yday : C_Int.t, + tm_year : C_Int.t} + local + fun make (f: C_Time.t ref -> C_Int.t C_Errno.t) (n: C_Time.t) : tmoz = + (ignore (f (ref n)) + ; {tm_hour = Tm.getHour (), + tm_isdst = Tm.getIsDst (), + tm_mday = Tm.getMDay (), + tm_min = Tm.getMin (), + tm_mon = Tm.getMon (), + tm_sec = Tm.getSec (), + tm_wday = Tm.getWDay (), + tm_yday = Tm.getYDay (), + tm_year = Tm.getYear ()}) + in + val getlocaltime_ = make Prim.localTime + val getgmtime_ = make Prim.gmTime + end + + fun setTmBuf ({tm_hour, tm_isdst, tm_mday, tm_min, tm_mon, + tm_sec, tm_wday, tm_yday, tm_year}: tmoz) : unit = + (Tm.setHour tm_hour + ; Tm.setIsDst tm_isdst + ; Tm.setMDay tm_mday + ; Tm.setMin tm_min + ; Tm.setMon tm_mon + ; Tm.setSec tm_sec + ; Tm.setWDay tm_wday + ; Tm.setYDay tm_yday + ; Tm.setYear tm_year) + + fun mktime_ (t: tmoz): C_Time.t = C_Errno.check (setTmBuf t; Prim.mkTime ()) + + (* The offset to add to local time to get UTC: positive West of UTC *) + val localoffset: int = C_Double.round (Prim.localOffset ()) + + val toweekday: int -> weekday = + fn 0 => Sun | 1 => Mon | 2 => Tue | 3 => Wed + | 4 => Thu | 5 => Fri | 6 => Sat + | _ => raise Fail "Internal error: Date.toweekday" + + val fromwday: weekday -> int = + fn Sun => 0 | Mon => 1 | Tue => 2 | Wed => 3 + | Thu => 4 | Fri => 5 | Sat => 6 + + val tomonth: int -> month = + fn 0 => Jan | 1 => Feb | 2 => Mar | 3 => Apr + | 4 => May | 5 => Jun | 6 => Jul | 7 => Aug + | 8 => Sep | 9 => Oct | 10 => Nov | 11 => Dec + | _ => raise Fail "Internal error: Date.tomonth" + + val frommonth: month -> int = + fn Jan => 0 | Feb => 1 | Mar => 2 | Apr => 3 + | May => 4 | Jun => 5 | Jul => 6 | Aug => 7 + | Sep => 8 | Oct => 9 | Nov => 10 | Dec => 11 + + fun tmozToDate ({tm_hour, tm_isdst, tm_mday, tm_min, tm_mon, + tm_sec, tm_wday, tm_yday, tm_year}: tmoz) offset = + T {day = C_Int.toInt tm_mday, + hour = C_Int.toInt tm_hour, + isDst = (case tm_isdst of + 0 => SOME false + | 1 => SOME true + | _ => NONE), + minute = C_Int.toInt tm_min, + month = tomonth (C_Int.toInt tm_mon), + offset = offset, + second = C_Int.toInt tm_sec, + weekDay = toweekday (C_Int.toInt tm_wday), + yearDay = C_Int.toInt tm_yday, + year = (C_Int.toInt tm_year) + 1900} + + fun leapyear (y: int) = + y mod 4 = 0 andalso y mod 100 <> 0 orelse y mod 400 = 0 + + fun monthdays year month : int = + case month of + Jan => 31 + | Feb => if leapyear year then 29 else 28 + | Mar => 31 + | Apr => 30 + | May => 31 + | Jun => 30 + | Jul => 31 + | Aug => 31 + | Sep => 30 + | Oct => 31 + | Nov => 30 + | Dec => 31 + + (* Check whether date may be passed to ISO/ANSI C functions: *) + + fun okDate (T {year, month, day, hour, minute, second, ...}) = + 1 <= day andalso day <= monthdays year month + andalso 0 <= hour andalso hour <= 23 + andalso 0 <= minute andalso minute <= 59 + andalso 0 <= second andalso second <= 61 (* leap seconds *) + + fun dateToTmoz (dt as T {year, month, day, hour, minute, second, + weekDay, yearDay, isDst, ...}): tmoz = + if not (okDate dt) + then raise Date + else {tm_hour = C_Int.fromInt hour, + tm_isdst = (case isDst of + SOME false => 0 + | SOME true => 1 + | NONE=> ~1), + tm_mday = C_Int.fromInt day, + tm_min = C_Int.fromInt minute, + tm_mon = C_Int.fromInt (frommonth month), + tm_sec = C_Int.fromInt second, + tm_wday = C_Int.fromInt (fromwday weekDay), + tm_yday = C_Int.fromInt yearDay, + tm_year = C_Int.fromInt (year - 1900)} + + (* -------------------------------------------------- *) + (* Translated from Emacs's calendar.el: *) + + (* Reingold: Number of the day within the year: *) + + fun dayinyear (year: int, month: month, day: int): int = + let val monthno = frommonth month + in + day - 1 + 31 * monthno + - (if monthno > 1 then + (27 + 4 * monthno) div 10 - (if leapyear year then 1 else 0) + else 0) + end + + (* Reingold: Find the number of days elapsed from the (imagined) + Gregorian date Sunday, December 31, 1 BC to the given date. *) + + fun todaynumber year month day = + let val prioryears = year - 1 + in + dayinyear (year, month, day) + + 1 + + 365 * prioryears + + prioryears div 4 + - prioryears div 100 + + prioryears div 400 + end + + (* Reingold et al: from absolute day number to year, month, date: *) + + fun fromdaynumber n = + let val d0 = n - 1 + val n400 = d0 div 146097 + val d1 = d0 mod 146097 + val n100 = d1 div 36524 + val d2 = d1 mod 36524 + val n4 = d2 div 1461 + val d3 = d2 mod 1461 + val n1 = d3 div 365 + val day = 1 + d3 mod 365 + val year = 400 * n400 + 100 * n100 + n4 * 4 + n1 + 1 + fun loop month day = + let val mdays = monthdays year (tomonth month) + in + if mdays < day then loop (month+1) (day-mdays) + else (year, tomonth month, day) + end + in + if n100 = 4 orelse n1 = 4 then + (year-1, Dec, 31) + else + loop 0 day + end + + (* -------------------------------------------------- *) + + fun weekday daynumber = toweekday (daynumber mod 7) + + (* Normalize a date, disregarding leap seconds: *) + + fun normalizedate yr0 mo0 dy0 hr0 mn0 sec0 offset = + let val mn1 = mn0 + sec0 div 60 + val second = sec0 mod 60 + val hr1 = hr0 + mn1 div 60 + val minute = mn1 mod 60 + val dayno = todaynumber yr0 mo0 dy0 + hr1 div 24 + val hour = hr1 mod 24 + val (year, month, day) = fromdaynumber dayno + val date1 = T {day = day, + hour = hour, + isDst = (case offset of + NONE => NONE + | SOME _ => SOME false), + minute = minute, + month = month, + offset = offset, + second = second, + weekDay = weekday dayno, + year = year, + yearDay = dayinyear (year, month, day)} + in + (* One cannot reliably compute DST in non-local timezones, + not even given the offset from UTC. Countries in the + Northern hemisphere have DST during Mar-Oct, those around + Equator do not have DST, and those in the Southern + hemisphere have DST during Oct-Mar. *) + if year < 1970 orelse year > 2037 then date1 + else + case offset of + NONE => + tmozToDate (getlocaltime_ (mktime_ (dateToTmoz date1))) + offset + | SOME _ => date1 + end + + fun fromTimeLocal t = + tmozToDate (getlocaltime_ (C_Time.fromInt (Time.toSeconds t))) NONE + + fun fromTimeUniv t = + tmozToDate (getgmtime_ (C_Time.fromInt (Time.toSeconds t))) (SOME 0) + + (* The following implements conversion from a local date to + * a Time.time. It IGNORES wday and yday. + *) + + fun toTime (date as T {offset, ...}) = + let + val secoffset = + case offset of + NONE => 0 + | SOME secs => localoffset + secs + val clock = C_Time.toInt (mktime_ (dateToTmoz date)) - secoffset + in + if clock < 0 then raise Date + else Time.fromSeconds clock + end + + fun localOffset () = Time.fromSeconds (localoffset mod 86400) + + local + val isFormatChar = + let + val a = Array.tabulate (Char.maxOrd + 1, fn _ => false) + val validChars = "aAbBcdHIjmMpSUwWxXyYZ%" + in Natural.foreach + (size validChars, fn i => + Array.update (a, Char.ord (String.sub (validChars, i)), true)); + fn c => Array.sub (a, Char.ord c) + end + in + fun fmt fmtStr d = + let + val _ = setTmBuf (dateToTmoz d) + val bufLen = 50 (* more than enough for a single format char *) + val buf = Array.alloc bufLen + fun strftime fmtChar = + let + val len = + Prim.strfTime + (buf, C_Size.fromInt bufLen, + NullString.fromString (concat ["%", str fmtChar, "\000"])) + val len = C_Size.toInt len + in if len = 0 + then raise Fail "Date.fmt" + else ArraySlice.vector (ArraySlice.slice (buf, 0, SOME len)) + end + val max = size fmtStr + fun loop (i, start, accum) = + let + fun newAccum () = + let val len = i - start + in + if len = 0 + then accum + else String.extract (fmtStr, start, SOME len) :: accum + end + in + if i >= max + then newAccum () + else + if #"%" = String.sub (fmtStr, i) + then + let + val i = i + 1 + in + if i >= max + then newAccum () + else let + val c = String.sub (fmtStr, i) + in + if isFormatChar c + then loop (i + 1, i + 1, + strftime c :: newAccum ()) + else loop (i, i, newAccum ()) + end + end + else loop (i + 1, start, accum) + end + in concat (rev (loop (0, 0, []))) + end + end + + val toString = fmt "%a %b %d %H:%M:%S %Y" + + type ('a, 'b) reader = ('a, 'b) Reader.reader + + fun scan (reader: (char, 'a) reader): (t, 'a) reader = + let + type 'b t = ('b, 'a) reader + val none: 'b t = fn _ => NONE + fun done (b: 'b): 'b t = fn a => SOME (b, a) + fun peek1 (f: char -> 'b t): 'b t = + fn a => + case reader a of + NONE => NONE + | SOME (c, _) => f c a + fun read1 (f: char -> 'b t): 'b t = + fn a => + case reader a of + NONE => NONE + | SOME (c, a) => f c a + fun skipSpace (r: 'b t): 'b t = + let + fun loop (): 'b t = + peek1 (fn c => + if Char.isSpace c + then read1 (fn _ => loop ()) + else r) + in + loop () + end + fun readN (n: int, f: string -> 'b t): 'b t = + let + fun loop (n: int, ac: char list): 'b t = + if 0 = n + then f (implode (rev ac)) + else read1 (fn c => loop (n - 1, c :: ac)) + in + loop (n, []) + end + fun readChar (c: char, r: 'b t): 'b t = + read1 (fn c' => if c = c' then r else none) + fun readWeekDay (f: weekday -> 'b t): 'b t = + readN (3, fn s => + case s of + "Mon" => f Mon + | "Tue" => f Tue + | "Wed" => f Wed + | "Thu" => f Thu + | "Fri" => f Fri + | "Sat" => f Sat + | "Sun" => f Sun + | _ => none) + fun readMonth (f: month -> 'b t): 'b t = + readN (3, fn s => + case s of + "Jan" => f Jan + | "Feb" => f Feb + | "Mar" => f Mar + | "Apr" => f Apr + | "May" => f May + | "Jun" => f Jun + | "Jul" => f Jul + | "Aug" => f Aug + | "Sep" => f Sep + | "Oct" => f Oct + | "Nov" => f Nov + | "Dec" => f Dec + | _ => none) + fun readDigs (n: int, lower: int, upper: int, f: int -> 'b t): 'b t = + readN (n, fn s => + if not (CharVector.all Char.isDigit s) + then none + else + let + val v = + CharVector.foldl + (fn (c, ac) => + ac * 10 + (Char.ord c - Char.ord #"0")) + 0 s + in + if lower <= v andalso v <= upper + then f v + else none + end) + fun readDay f = + peek1 (fn c => + if c = #" " + then read1 (fn _ => readDigs (1, 1, 9, f)) + else readDigs (2, 1, 31, f)) + fun readHour f = readDigs (2, 0, 23, f) + fun readMinute f = readDigs (2, 0, 59, f) + fun readSeconds f = readDigs (2, 0, 61, f) + fun readYear f = readDigs (4, 0, 9999, f) + in + skipSpace + (readWeekDay + (fn weekDay => + readChar + (#" ", + readMonth + (fn month => + readChar + (#" ", + readDay + (fn day => + readChar + (#" ", + readHour + (fn hour => + readChar + (#":", + readMinute + (fn minute => + (readChar + (#":", + readSeconds + (fn second => + readChar + (#" ", + readYear + (fn year => + done (T {day = day, + hour = hour, + isDst = NONE, + minute = minute, + month = month, + offset = NONE, + second = second, + weekDay = weekDay, + year = year, + yearDay = dayinyear (year, month, day)} + )))))))))))))))) + end + + fun fromString s = StringCvt.scanString scan s + + (* Ignore timezone and DST when comparing dates: *) + fun compare + (T {year=y1,month=mo1,day=d1,hour=h1,minute=mi1,second=s1, ...}, + T {year=y2,month=mo2,day=d2,hour=h2,minute=mi2,second=s2, ...}) = + let + fun cmp (v1, v2, cmpnext) = + case Int.compare (v1, v2) of + EQUAL => cmpnext () + | r => r + in + cmp (y1, y2, + fn _ => cmp (frommonth mo1, frommonth mo2, + fn _ => cmp (d1, d2, + fn _ => cmp (h1, h2, + fn _ => cmp (mi1, mi2, + fn _ => cmp (s1, s2, + fn _ => EQUAL)))))) + end + + fun date { year, month, day, hour, minute, second, offset } = + if year < 0 then raise Date + else + let + val (dayoffset, offset') = + case offset of + NONE => (0, NONE) + | SOME time => + let + val secs = Time.toSeconds time + val secoffset = + if secs <= 82800 then ~secs else 86400 - secs + in + (Int.quot (secs, 86400), SOME secoffset) + end + val day' = day + dayoffset + in + normalizedate year month day' hour minute second offset' + end + + fun offset (T {offset, ...}) = + Option.map + (fn secs => Time.fromSeconds ((86400 + secs) mod 86400)) + offset + end diff --git a/basis-library/system/file-sys.sig b/basis-library/system/file-sys.sig new file mode 100644 index 0000000..9ed0280 --- /dev/null +++ b/basis-library/system/file-sys.sig @@ -0,0 +1,34 @@ +signature OS_FILE_SYS = + sig + type dirstream + + val openDir: string -> dirstream + val readDir: dirstream -> string option + val rewindDir: dirstream -> unit + val closeDir: dirstream -> unit + val chDir: string -> unit + + val getDir: unit -> string + val mkDir: string -> unit + val rmDir: string -> unit + val isDir: string -> bool + val isLink: string -> bool + val readLink: string -> string + val fullPath: string -> string + val realPath: string -> string + val modTime: string -> Time.time + val fileSize: string -> Position.int + val setTime: string * Time.time option -> unit + val remove: string -> unit + val rename: {old: string, new: string} -> unit + + datatype access_mode = A_READ | A_WRITE | A_EXEC + + val access: string * access_mode list -> bool + val tmpName: unit -> string + + eqtype file_id + val fileId: string -> file_id + val hash: file_id -> word + val compare: file_id * file_id -> order + end diff --git a/basis-library/system/file-sys.sml b/basis-library/system/file-sys.sml new file mode 100644 index 0000000..c0b202b --- /dev/null +++ b/basis-library/system/file-sys.sml @@ -0,0 +1,170 @@ +(* os-filesys.sml + * + * COPYRIGHT (c) 1995 AT&T Bell Laboratories. + * + * The Posix implementation of the generic file system interface. + * + *) + +structure OS_FileSys = + struct + structure P_FSys = Posix.FileSys + + val sysWordToWord = Word.fromLargeWord o SysWord.toLargeWord + + type dirstream = P_FSys.dirstream + + val openDir = P_FSys.opendir + val readDir = P_FSys.readdir + val rewindDir = P_FSys.rewinddir + val closeDir = P_FSys.closedir + + val chDir = P_FSys.chdir + val getDir = P_FSys.getcwd + local + structure S = P_FSys.S + val mode777 = S.flags[S.irwxu, S.irwxg, S.irwxo] + in + fun mkDir path = P_FSys.mkdir(path, mode777) + end + val rmDir = P_FSys.rmdir + val isDir = P_FSys.ST.isDir o P_FSys.stat + + val isLink = P_FSys.ST.isLink o P_FSys.lstat + val readLink = P_FSys.readlink + + (* the maximum number of links allowed *) + val maxLinks: int = 64 + + structure P = OS_Path + + val isMinGW = let open Primitive.MLton.Platform.OS in host = MinGW end + + (* An implementation of fullPath which works on Unix and Windows (Cygwin and MinGW) *) + fun fullPath p = + let + val oldCWD = getDir() + fun mkPath (pathFromRoot, vol) = + P.toString {arcs = List.rev pathFromRoot, + isAbs = true, + vol = vol} + fun walkPath (n, pathFromRoot, arcs, vol) = + if n = 0 + then raise PosixError.SysErr ("too many links", NONE) + else + case arcs of + [] => mkPath (pathFromRoot, vol) + | arc :: al => + if arc = "" orelse arc = "." + then walkPath (n, pathFromRoot, al, vol) + else if arc = ".." + then + case pathFromRoot of + [] => walkPath (n, [], al, vol) + | _ :: r => + (chDir ".."; walkPath (n, r, al, vol)) + else + if isLink arc + then expandLink (n, pathFromRoot, arc, al, vol) + else + case al of + [] => mkPath (arc :: pathFromRoot, vol) + | _ => + (chDir arc + ; walkPath (n, arc :: pathFromRoot, al, vol)) + and expandLink (n, pathFromRoot, link, rest, vol) = + let + val {isAbs, arcs, ...} = P.fromString (readLink link) + val arcs = List.@ (arcs, rest) + in + if isAbs + then gotoRoot (n-1, arcs, vol) + else walkPath (n-1, pathFromRoot, arcs, vol) + end + (* If the volume is not empty, chDir to it rather than to "/" *) + and gotoRoot (n, arcs, vol) = + (if vol <> "" andalso vol <> "/" + then chDir (vol ^ (if isMinGW then "\\" else "/")) + else chDir "/" + ; walkPath (n, [], arcs, vol)) + fun computeFullPath (arcs, vol) = + (gotoRoot (maxLinks, arcs, vol) before chDir oldCWD) + handle ex => (chDir oldCWD; raise ex) + in + case (P.fromString p) + of {isAbs=false, arcs, vol} => + let + val {arcs=arcs', vol=vol, ...} = P.fromString(oldCWD) + in + computeFullPath (List.@(arcs', arcs), vol) + end + | {isAbs=true, arcs, vol} => computeFullPath (arcs, vol) + end + + fun realPath p = + if P.isAbsolute p + then fullPath p + else P.mkRelative {path = fullPath p, + relativeTo = fullPath (getDir ())} + + val fileSize = P_FSys.ST.size o P_FSys.stat + + val modTime = P_FSys.ST.mtime o P_FSys.stat + + fun setTime (path, t) = + P_FSys.utime (path, Option.map (fn t => {actime = t, modtime = t}) t) + + val remove = P_FSys.unlink + + val rename = P_FSys.rename + + datatype access_mode = datatype Posix.FileSys.access_mode + + fun access (path, al) = + let + fun cvt A_READ = P_FSys.A_READ + | cvt A_WRITE = P_FSys.A_WRITE + | cvt A_EXEC = P_FSys.A_EXEC + in + P_FSys.access (path, List.map cvt al) + end + + datatype file_id = FID of {dev: SysWord.word, ino: SysWord.word} + + fun fileId fname = let + val st = P_FSys.stat fname + in + FID{ + dev = P_FSys.devToWord(P_FSys.ST.dev st), + ino = P_FSys.inoToWord(P_FSys.ST.ino st) + } + end + + fun hash (FID{dev, ino}) = sysWordToWord(SysWord.+(SysWord.<<(dev, 0w16), ino)) + + fun compare (FID{dev=d1, ino=i1}, FID{dev=d2, ino=i2}) = + if (SysWord.<(d1, d2)) + then General.LESS + else if (SysWord.>(d1, d2)) + then General.GREATER + else if (SysWord.<(i1, i2)) + then General.LESS + else if (SysWord.>(i1, i2)) + then General.GREATER + else General.EQUAL + + end + +(* + * $Log: os-filesys.sml, v $ + * Revision 1.3 1997/06/07 15:27:51 jhr + * SML'97 Basis Library changes (phase 3; Posix changes) + * + * Revision 1.2 1997/02/26 21:00:32 george + * Defined a new top level Option structure. All 'a option related + * functions have been moved out of General. + * + * Revision 1.1.1.1 1997/01/14 01:38:25 george + * Version 109.24 + * + *) diff --git a/basis-library/system/io.sig b/basis-library/system/io.sig new file mode 100644 index 0000000..a3995b0 --- /dev/null +++ b/basis-library/system/io.sig @@ -0,0 +1,34 @@ +signature OS_IO = + sig + eqtype iodesc + eqtype iodesc_kind + + val hash: iodesc -> word + val compare: iodesc * iodesc -> order + val kind: iodesc -> iodesc_kind + + structure Kind: + sig + val file: iodesc_kind + val dir: iodesc_kind + val symlink: iodesc_kind + val tty: iodesc_kind + val pipe: iodesc_kind + val socket: iodesc_kind + val device: iodesc_kind + end + + eqtype poll_desc + type poll_info + val pollDesc: iodesc -> poll_desc option + val pollToIODesc: poll_desc -> iodesc + exception Poll + val pollIn: poll_desc -> poll_desc + val pollOut: poll_desc -> poll_desc + val pollPri: poll_desc -> poll_desc + val poll: poll_desc list * Time.time option -> poll_info list + val isIn: poll_info -> bool + val isOut: poll_info -> bool + val isPri: poll_info -> bool + val infoToPollDesc: poll_info -> poll_desc + end diff --git a/basis-library/system/io.sml b/basis-library/system/io.sml new file mode 100644 index 0000000..160e6fd --- /dev/null +++ b/basis-library/system/io.sml @@ -0,0 +1,166 @@ +(* modified from SML/NJ sources by Stephen Weeks 1998-06-25 *) +(* modified by Matthew Fluet 2002-10-11 *) +(* modified by Matthew Fluet 2002-11-21 *) +(* modified by Matthew Fluet 2006-04-30 *) +(* modified by Matthew Fluet 2008-04-06 *) +(* modified by Matthew Fluet 2013-06-18 *) + +(* os-io.sml + * + * COPYRIGHT (c) 1995 AT&T Bell Laboratories. + * + * NOTE: this interface has been proposed, but not yet adopted by the + * Standard basis committee. + * + *) + +structure OS_IO: OS_IO = + struct + structure Error = PosixError + + (* an iodesc is an abstract descriptor for an OS object that + * supports I/O (e.g., file, tty device, socket, ...). + *) + type iodesc = PreOS.IODesc.t + + datatype iodesc_kind = K of string + + val iodToFd = PrePosix.FileDesc.fromRep o PreOS.IODesc.toRep + val fdToIod = PreOS.IODesc.fromRep o PrePosix.FileDesc.toRep + + val iodescToWord = C_Fd.castToSysWord o PreOS.IODesc.toRep + + (* return a hash value for the I/O descriptor. *) + val hash = SysWord.toWord o iodescToWord + + (* compare two I/O descriptors *) + fun compare (i, i') = SysWord.compare (iodescToWord i, iodescToWord i') + + structure Kind = + struct + val file = K "FILE" + val dir = K "DIR" + val symlink = K "LINK" + val tty = K "TTY" + val pipe = K "PIPE" + val socket = K "SOCK" + val device = K "DEV" + end + + (* return the kind of I/O descriptor *) + fun kind (iod) = let + val stat = Posix.FileSys.fstat (iodToFd iod) + in + if (Posix.FileSys.ST.isReg stat) then Kind.file + else if (Posix.FileSys.ST.isDir stat) then Kind.dir + else if (Posix.FileSys.ST.isChr stat) then Kind.tty + else if (Posix.FileSys.ST.isBlk stat) then Kind.device (* ?? *) + else if (Posix.FileSys.ST.isLink stat) then Kind.symlink + else if (Posix.FileSys.ST.isFIFO stat) then Kind.pipe + else if (Posix.FileSys.ST.isSock stat) then Kind.socket + else K "UNKNOWN" + end + + type poll_flags = {rd: bool, wr: bool, pri: bool} + datatype poll_desc = PollDesc of iodesc * poll_flags + datatype poll_info = PollInfo of iodesc * poll_flags + + (* create a polling operation on the given descriptor; note that + * not all I/O devices support polling, but for the time being, we + * don't test for this. + *) + fun pollDesc iod = SOME (PollDesc (iod, {rd=false, wr=false, pri=false})) + + (* return the I/O descriptor that is being polled *) + fun pollToIODesc (PollDesc (iod, _)) = iod + + exception Poll + + (* set polling events; if the polling operation is not appropriate + * for the underlying I/O device, then the Poll exception is raised. + *) + fun pollIn (PollDesc (iod, {wr, pri, ...}: poll_flags)) = + PollDesc (iod, {rd=true, wr=wr, pri=pri}) + fun pollOut (PollDesc (iod, {rd, pri, ...}: poll_flags)) = + PollDesc (iod, {rd=rd, wr=true, pri=pri}) + fun pollPri (PollDesc (iod, {rd, wr, ...}: poll_flags)) = + PollDesc (iod, {rd=rd, wr=wr, pri=true}) + + (* polling function *) + local + structure Prim = PrimitiveFFI.OS.IO + fun join (false, _, w) = w + | join (true, b, w) = C_Short.orb(w, b) + fun test (w, b) = (C_Short.andb(w, b) <> 0) + val rdBit = PrimitiveFFI.OS.IO.POLLIN + and wrBit = PrimitiveFFI.OS.IO.POLLOUT + and priBit = PrimitiveFFI.OS.IO.POLLPRI + fun fromPollDesc (PollDesc (iod, {rd, wr, pri})) = + ( iodToFd iod, + join (rd, rdBit, + join (wr, wrBit, + join (pri, priBit, 0))) + ) + fun toPollInfo (fd, i) = + PollInfo (fdToIod fd, { + rd = test(i, rdBit), + wr = test(i, wrBit), + pri = test(i, priBit) + }) + in + fun poll (pds, timeOut) = let + val (fds, events) = ListPair.unzip (List.map fromPollDesc pds) + val fds = Vector.fromList fds + val n = Vector.length fds + val events = Vector.fromList events + val timeOut = + case timeOut of + NONE => ~1 + | SOME t => + if Time.< (t, Time.zeroTime) + then Error.raiseSys Error.inval + else (C_Int.fromLarge (Time.toMilliseconds t) + handle Overflow => Error.raiseSys Error.inval) + val revents = Array.array (n, 0: C_Short.t) + val _ = Posix.Error.SysCall.simpleRestart + (fn () => Prim.poll (PrePosix.FileDesc.vectorToRep fds, + events, + C_NFds.fromInt n, + timeOut, + revents)) + in + Array.foldri + (fn (i, w, l) => + if w <> 0 + then (toPollInfo (Vector.sub (fds, i), w))::l + else l) + [] + revents + end + end (* local *) + + (* check for conditions *) + fun isIn (PollInfo(_, flgs)) = #rd flgs + fun isOut (PollInfo(_, flgs)) = #wr flgs + fun isPri (PollInfo(_, flgs)) = #pri flgs + fun infoToPollDesc (PollInfo arg) = PollDesc arg + end (* OS_IO *) + + +(* + * $Log: os-io.sml, v $ + * Revision 1.4 1997/07/31 17:25:26 jhr + * We are now using 32-bit ints to represent the seconds portion of a + * time value. This was required to handle the change in the type of + * Time.{to, from}{Seconds, Milliseconds, Microseconds}. + * + * Revision 1.3 1997/06/07 15:27:51 jhr + * SML'97 Basis Library changes (phase 3; Posix changes) + * + * Revision 1.2 1997/06/02 19:16:19 jhr + * SML'97 Basis Library changes (phase 2) + * + * Revision 1.1.1.1 1997/01/14 01:38:25 george + * Version 109.24 + * + *) diff --git a/basis-library/system/os.sig b/basis-library/system/os.sig new file mode 100644 index 0000000..1d10f1c --- /dev/null +++ b/basis-library/system/os.sig @@ -0,0 +1,12 @@ +signature OS = + sig + structure FileSys: OS_FILE_SYS + structure Path: OS_PATH + structure Process: OS_PROCESS + structure IO: OS_IO + eqtype syserror + exception SysErr of string * syserror option + val errorMsg: syserror -> string + val errorName: syserror -> string + val syserror: string -> syserror option + end diff --git a/basis-library/system/os.sml b/basis-library/system/os.sml new file mode 100644 index 0000000..a8bc6de --- /dev/null +++ b/basis-library/system/os.sml @@ -0,0 +1,16 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure OS = + struct + structure FileSys = OS_FileSys + structure Path = OS_Path + structure Process = OS_Process + structure IO = OS_IO + open PosixError + end diff --git a/basis-library/system/path.sig b/basis-library/system/path.sig new file mode 100644 index 0000000..f33b73b --- /dev/null +++ b/basis-library/system/path.sig @@ -0,0 +1,31 @@ +signature OS_PATH = + sig + exception InvalidArc + exception Path + + val base: string -> string + val concat: string * string -> string + val currentArc: string + val dir: string -> string + val ext: string -> string option + val file: string -> string + val fromString: string -> {isAbs: bool, vol: string, arcs: string list} + val fromUnixPath: string -> string + val getParent: string -> string + val getVolume: string -> string + val isAbsolute: string -> bool + val isCanonical: string -> bool + val isRelative: string -> bool + val isRoot: string -> bool + val joinBaseExt: {base: string, ext: string option} -> string + val joinDirFile: {dir: string, file: string} -> string + val mkAbsolute: {path: string, relativeTo: string} -> string + val mkCanonical: string -> string + val mkRelative: {path: string, relativeTo: string} -> string + val parentArc: string + val splitBaseExt: string -> {base: string, ext: string option} + val splitDirFile: string -> {dir: string, file: string} + val toString: {isAbs: bool, vol: string, arcs: string list} -> string + val toUnixPath: string -> string + val validVolume: {isAbs: bool, vol: string} -> bool + end diff --git a/basis-library/system/path.sml b/basis-library/system/path.sml new file mode 100644 index 0000000..aa09b5b --- /dev/null +++ b/basis-library/system/path.sml @@ -0,0 +1,294 @@ +(* Modified from the ML Kit 4.1.4; basislib/Path.sml + * by mfluet@acm.org on 2005-8-10 based on + * modifications from the ML Kit 3 Version; basislib/Path.sml + * by sweeks@research.nj.nec.com on 1999-1-5. + *) + +structure OS_Path: OS_PATH = +struct + +exception Path +exception InvalidArc + +(* It would make sense to use substrings for internal versions of + * fromString and toString, and to allocate new strings only when + * externalizing the strings. + + * Impossible cases: + UNIX: {isAbs = false, vol = _, arcs = "" :: _} + Mac: {isAbs = true, vol = _, arcs = "" :: _} + *) + +val op @ = List.@ +infix 9 sub +val op sub = String.sub +val substring = String.extract + +val isWindows = + let + open Primitive.MLton.Platform.OS + in + host = MinGW + end + +(* the path separator used in canonical paths *) +val slash = if isWindows then "\\" else "/" + +(* MinGW and newer Windows commands treat both / and \ as path + * separators. + * + * Sadly this means that toString o fromString is not the identity + * b/c foo/bar -> foo\bar. However, there's nothing else one can do! + * This diverges from the standard. + *) +fun isslash c = c = #"/" orelse (isWindows andalso c = #"\\") +fun iscolon c = c = #":" + +fun isVolumeName v = + (isWindows andalso size v = 2 andalso + Char.isAlpha (v sub 0) andalso iscolon (v sub 1)) + +fun volumeMatch (root, relative) = + relative = "" + orelse (isVolumeName root + andalso isVolumeName relative + andalso (Char.toUpper (root sub 0) + = Char.toUpper (relative sub 0))) + +fun canonName a = + if isWindows + then String.translate (str o Char.toLower) a + else a + +val parentArc = ".." +val currentArc = "." + +(* Ahh joy. The SML basis library standard and Windows paths. + * + * The big problem with windows paths is "\foo"" + * - It's not absolute, since chdir("A:\") may switch from "C:", thus + * changing the meaning of "\foo". + *) +fun validVolume {isAbs, vol} = + if isWindows + then isVolumeName vol orelse (not isAbs andalso vol = "") + else vol = "" + +fun fromString s = + let + val (vol, rest) = (* 4:foo has a volume of "4:" even tho invalid *) + if isWindows andalso size s >= 2 andalso iscolon (s sub 1) + then (substring (s, 0, SOME 2), substring (s, 2, NONE)) + else ("", s) + val (isAbs, arcs) = + case (String.fields isslash rest) of + "" :: [] => (false, []) + | "" :: r => (true, r) + | r => (false, r) + in + {arcs = arcs, isAbs = isAbs, vol = vol} + end + +val getVolume = #vol o fromString +val isAbsolute = #isAbs o fromString +val isRelative = not o isAbsolute + +fun isArc s = + s = "" + orelse (case fromString s of + {arcs = [_], isAbs = false, vol = ""} => true + | _ => false) + +fun toString {arcs, isAbs, vol} = + if not (validVolume {isAbs = isAbs, vol = vol}) + then raise Path + else if not isAbs andalso case arcs of ("" :: _) => true | _ => false + then raise Path + else if List.exists (not o isArc) arcs + then raise InvalidArc + else + concat [vol, + if isAbs + then slash + else "", + String.concatWith slash arcs] + +fun concatArcs (a1, a2) = + let + val a1 = case List.rev a1 of "" :: r => List.rev r | _ => a1 + in + a1 @ a2 + end + +fun concat (p1, p2) = + let + val {arcs = a1, isAbs, vol = v1} = fromString p1 + val {arcs = a2, isAbs = isAbs2, vol = v2} = fromString p2 + in + if isAbs2 orelse not (volumeMatch (v1, v2)) + then raise Path + else toString {arcs = concatArcs (a1, a2), isAbs = isAbs, vol = v1} + end + +fun getParent p = + let + val {isAbs, vol, arcs} = fromString p + val arcs = + List.rev (case List.rev arcs of + [] => [parentArc] + | "." :: r => parentArc :: r + | ".." :: r => parentArc :: parentArc :: r + | _ :: [] => if isAbs then [""] else [currentArc] + | "" :: r => parentArc :: r + | _ :: r => r) + in + toString {arcs = arcs, isAbs = isAbs, vol = vol} + end + +fun mkCanonical p = + let + val {arcs, isAbs, vol} = fromString p + fun backup l = + case l of + [] => if isAbs then [] else [parentArc] + | first :: res => + if first = ".." + then parentArc :: parentArc :: res + else res + fun reduce arcs = + let + fun h (l, res) = + case l of + [] => (case res of + [] => if isAbs then [""] else [currentArc] + | _ => res ) + | a1 :: ar => + if a1 = "" orelse a1 = "." + then h (ar, res) + else if a1 = ".." + then h (ar, backup res) + else h (ar, canonName a1 :: res) + in + h (arcs, []) + end + in + toString {arcs = List.rev (reduce arcs), + isAbs = isAbs, + vol = canonName vol} + end + +val rec parentize = + fn [] => [] + | _ :: ar => parentArc :: parentize ar + +fun mkRelative {path = p1, relativeTo = p2} = + let + val {arcs = arcs1, isAbs = isAbs1, vol = vol1} = fromString p1 + val {arcs = arcs2, isAbs = isAbs2, vol = vol2} = + fromString (mkCanonical p2) + in + if not isAbs2 then raise Path + else if not isAbs1 then p1 + else + let + fun h (a1, a2) = + case (a1, a2) of + ([], []) => ["."] + | (_, []) => a1 + | ([], a2) => parentize a2 + | (a11 :: a1r, a21 :: a2r) => + if canonName a11 = a21 then h (a1r, a2r) + else parentize a2 @ (if arcs1 = [""] then [] else a1) + in + if not (volumeMatch (vol2, vol1)) + then raise Path + else toString {arcs = h (arcs1, arcs2), + isAbs = false, + vol = ""} + end + end + +fun mkAbsolute {path = p1, relativeTo = p2} = + if isRelative p2 then raise Path + else if isAbsolute p1 then p1 + else mkCanonical (concat (p2, p1)) + +fun isCanonical p = mkCanonical p = p + +fun joinDirFile {dir, file} = + let + val {arcs, isAbs, vol} = fromString dir + val arcs = + case (arcs, file) of + ([], "") => [] + | _ => concatArcs (arcs, [file]) + in + toString {arcs = arcs, + isAbs = isAbs, + vol = vol} + end + +fun splitDirFile p = + let + open List + val {isAbs, vol, arcs} = fromString p + in + case rev arcs of + [] => {dir = p, file = ""} + | arcn :: farcs => + {dir = toString {arcs = rev farcs, isAbs = isAbs, vol = vol}, + file = arcn} + + end + +val dir = #dir o splitDirFile + +val file = #file o splitDirFile + +fun joinBaseExt {base, ext} = + case ext of + NONE => base + | SOME ex => + if ex = "" then base + else String.concat [base, ".", ex] + +fun splitBaseExt s = + let + val {dir, file} = splitDirFile s + open Substring + val (fst, snd) = splitr (fn c => c <> #".") (full file) + in + if isEmpty snd (* dot at right end *) + orelse isEmpty fst (* no dot *) + orelse size fst = 1 (* dot at left end only *) + then {base = s, ext = NONE} + else {base = joinDirFile {dir = dir, + file = string (trimr 1 fst)}, + ext = SOME (string snd)} + end + +val ext = #ext o splitBaseExt +val base = #base o splitBaseExt + +fun isRoot path = + case fromString path of + {isAbs = true, arcs=[""], ...} => true + | _ => false + +fun fromUnixPath s = + if not isWindows then s + else if Char.contains s (slash sub 0) then raise InvalidArc + else String.translate (fn c => if c = #"/" then slash else str c) s + +fun toUnixPath s = + if not isWindows then s + else + let + val {arcs, isAbs, vol} = fromString s + in + if vol <> "" + then raise Path + else (if isAbs then "/" else "") ^ String.concatWith "/" arcs + end + +end diff --git a/basis-library/system/pre-os.sml b/basis-library/system/pre-os.sml new file mode 100644 index 0000000..84b7c32 --- /dev/null +++ b/basis-library/system/pre-os.sml @@ -0,0 +1,25 @@ +(* Copyright (C) 2002-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure PreOS = + struct + structure Status = + MkAbsRep(type rep = C_Status.t) + structure IODesc = + MkAbsRepEq(type rep = C_Fd.t) + end +structure OS = + struct + structure Process = + struct + type status = PreOS.Status.t + end + structure IO = + struct + type iodesc = PreOS.IODesc.t + end + end diff --git a/basis-library/system/process.sig b/basis-library/system/process.sig new file mode 100644 index 0000000..62f2325 --- /dev/null +++ b/basis-library/system/process.sig @@ -0,0 +1,27 @@ +signature OS_PROCESS = + sig + type status + + val atExit: (unit -> unit) -> unit + val exit: status -> 'a + val failure: status + val getEnv: string -> string option + val isSuccess: status -> bool + val sleep: Time.time -> unit + val success: status + val system: string -> status + val terminate: status -> 'a + end + +signature OS_PROCESS_EXTRA = + sig + include OS_PROCESS + + structure Status: + sig + type t = status + + val fromInt: int -> t + val fromPosix: Posix.Process.exit_status -> t + end + end diff --git a/basis-library/system/process.sml b/basis-library/system/process.sml new file mode 100644 index 0000000..c2ca3da --- /dev/null +++ b/basis-library/system/process.sml @@ -0,0 +1,64 @@ +(* Modified from SML/NJ sources by Stephen Weeks 1998-06-25 *) +(* modified by Stephen Weeks 1999-12-10 *) +(* modified by Stephen Weeks 2000-01-18 *) +(* modified by Matthew Fluet 2008-03-02 *) +(* modified by Matthew Fluet 2008-04-06 *) + +(* os-process.sml + * + * COPYRIGHT (c) 1995 AT&T Bell Laboratories. + * + * The Posix-based implementation of the generic process control + * interface (OS.Process). + * + *) + +structure OS_Process: OS_PROCESS_EXTRA = + struct + open Posix.Process + + structure Status = + struct + open MLtonProcess.Status + + fun equals (s1, s2) = + (toRep s1) = (toRep s2) + + val fromPosix = + fn es => + let + datatype z = datatype Posix.Process.exit_status + in + case es of + W_EXITED => success + | W_EXITSTATUS w => + fromRep (C_Status.castFromSysWord (Word8.castToSysWord w)) + | W_SIGNALED _ => failure + | W_STOPPED _ => failure + end + end + + type status = Status.t + + val failure = Status.failure + val success = Status.success + fun isSuccess st = Status.equals (st, success) + + fun system cmd = + (Status.fromRep o Posix.Error.SysCall.simpleResult) + (fn () => + PrimitiveFFI.Posix.Process.system (NullString.nullTerm cmd)) + + val atExit = MLtonProcess.atExit + + val exit = MLtonProcess.exit + + fun terminate x = Posix.Process.exit (Word8.fromInt (Status.toInt x)) + + val getEnv = Posix.ProcEnv.getenv + + fun sleep t = + if Time.<= (t, Time.zeroTime) + then () + else sleep (Posix.Process.sleep t) + end diff --git a/basis-library/system/time.sig b/basis-library/system/time.sig new file mode 100644 index 0000000..4d708c0 --- /dev/null +++ b/basis-library/system/time.sig @@ -0,0 +1,37 @@ +signature TIME = + sig + eqtype time + exception Time + + val + : time * time -> time + val - : time * time -> time + val < : time * time -> bool + val <= : time * time -> bool + val > : time * time -> bool + val >= : time * time -> bool + val compare: time * time -> order + val fmt: int -> time -> string + val fromMicroseconds: LargeInt.int -> time + val fromMilliseconds: LargeInt.int -> time + val fromNanoseconds: LargeInt.int -> time + val fromReal: LargeReal.real -> time + val fromSeconds: LargeInt.int -> time + val fromString: string -> time option + val now: unit -> time + val scan: (char, 'a) StringCvt.reader -> (time, 'a) StringCvt.reader + val toMicroseconds: time -> LargeInt.int + val toMilliseconds: time -> LargeInt.int + val toNanoseconds: time -> LargeInt.int + val toReal: time -> LargeReal.real + val toSeconds: time -> LargeInt.int + val toString: time -> string + val zeroTime: time + end + +signature TIME_EXTRA = + sig + include TIME + + val fromTicks: LargeInt.int -> time + val ticksPerSecond: LargeInt.int + end diff --git a/basis-library/system/time.sml b/basis-library/system/time.sml new file mode 100644 index 0000000..c3cd7fe --- /dev/null +++ b/basis-library/system/time.sml @@ -0,0 +1,176 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Time: TIME_EXTRA = +struct + +structure Prim = PrimitiveFFI.Time + +(* A time is represented as a number of nanoseconds. *) +val ticksPerSecond: LargeInt.int = 1000000000 + +datatype time = T of LargeInt.int + +val fromTicks = T + +exception Time + +val zeroTime = T 0 + +fun fromReal r = + T (LargeReal.toLargeInt IEEEReal.TO_NEAREST + (LargeReal.* (r, LargeReal.fromLargeInt ticksPerSecond))) + handle Overflow => raise Time + +fun toReal (T i) = + LargeReal./ (LargeReal.fromLargeInt i, + LargeReal.fromLargeInt ticksPerSecond) + +local + fun make ticksPer = + let + val d = LargeInt.quot (ticksPerSecond, ticksPer) + in + (fn i => T (LargeInt.* (i, d)), + fn T i => LargeInt.quot (i, d)) + end +in + val (fromSeconds, toSeconds) = make 1 + val (fromMilliseconds, toMilliseconds) = make 1000 + val (fromMicroseconds, toMicroseconds) = make 1000000 + val (fromNanoseconds, toNanoseconds) = make 1000000000 +end + +local + fun make f (T i, T i') = f (i, i') +in + val compare = make LargeInt.compare + val op < = make LargeInt.< + val op <= = make LargeInt.<= + val op > = make LargeInt.> + val op >= = make LargeInt.>= +end +local + fun make f (T i, T i') = T (f (i, i')) +in + val timeAdd = make LargeInt.+ + val timeSub = make LargeInt.- +end + +(* There's a mess here to work around a bug in vmware virtual machines + * that may return a decreasing(!) sequence of time values. This will + * cause some programs to raise Time exceptions where it should be + * impossible. + *) +local + fun getNow (): time = + let + val sec = ref (C_Time.castFromFixedInt 0) + val usec = ref (C_SUSeconds.castFromFixedInt 0) + in + if ~1 = Prim.getTimeOfDay (sec, usec) + then raise Fail "Time.now" + else timeAdd(fromSeconds (C_Time.toLargeInt (! sec)), + fromMicroseconds (C_SUSeconds.toLargeInt (! usec))) + end + val prev = ref (getNow ()) +in + fun now (): time = + let + val old = !prev + val t = getNow () + in + case compare (old, t) of + GREATER => old + | _ => (prev := t; t) + end +end + +val fmt: int -> time -> string = + fn n => (LargeReal.fmt (StringCvt.FIX (SOME n))) o toReal + +val toString = fmt 3 + +(* Adapted from the ML Kit 4.1.4; basislib/Time.sml + * by mfluet@acm.org on 2005-11-10 based on + * by mfluet@acm.org on 2005-8-10 based on + * adaptations from the ML Kit 3 Version; basislib/Time.sml + * by sweeks@research.nj.nec.com on 1999-1-3. + *) +fun scan getc src = + let + val charToDigit = StringCvt.charToDigit StringCvt.DEC + fun pow10 0 = 1 + | pow10 n = 10 * pow10 (n-1) + fun mkTime sign intv fracv decs = + let + val nsec = + LargeInt.div (LargeInt.+ (LargeInt.* (Int.toLarge (pow10 (10 - decs)), + Int.toLarge fracv), + 5), + 10) + val t = + LargeInt.+ (LargeInt.* (Int.toLarge intv, ticksPerSecond), + nsec) + val t = if sign then t else LargeInt.~ t + in + T t + end + fun frac' sign intv fracv decs src = + if Int.>= (decs, 7) + then SOME (mkTime sign intv fracv decs, + StringCvt.dropl Char.isDigit getc src) + else case getc src of + NONE => SOME (mkTime sign intv fracv decs, src) + | SOME (c, rest) => + (case charToDigit c of + NONE => SOME (mkTime sign intv fracv decs, src) + | SOME d => frac' sign intv (10 * fracv + d) (decs + 1) rest) + fun frac sign intv src = + case getc src of + NONE => NONE + | SOME (c, rest) => + (case charToDigit c of + NONE => NONE + | SOME d => frac' sign intv d 1 rest) + fun int' sign intv src = + case getc src of + NONE => SOME (mkTime sign intv 0 7, src) + | SOME (#".", rest) => frac sign intv rest + | SOME (c, rest) => + (case charToDigit c of + NONE => SOME (mkTime sign intv 0 7, src) + | SOME d => int' sign (10 * intv + d) rest) + fun int sign src = + case getc src of + NONE => NONE + | SOME (#".", rest) => frac sign 0 rest + | SOME (c, rest) => + (case charToDigit c of + NONE => NONE + | SOME d => int' sign d rest) + in + case getc (StringCvt.skipWS getc src) of + NONE => NONE + | SOME (#"+", rest) => int true rest + | SOME (#"~", rest) => int false rest + | SOME (#"-", rest) => int false rest + | SOME (#".", rest) => frac true 0 rest + | SOME (c, rest) => + (case charToDigit c of + NONE => NONE + | SOME d => int' true d rest) + end +handle Overflow => raise Time + +val fromString = StringCvt.scanString scan + +val op + = timeAdd +val op - = timeSub + +end diff --git a/basis-library/system/timer.sig b/basis-library/system/timer.sig new file mode 100644 index 0000000..8701735 --- /dev/null +++ b/basis-library/system/timer.sig @@ -0,0 +1,17 @@ +signature TIMER = + sig + type cpu_timer + type real_timer + + val checkCPUTimer: cpu_timer -> {sys: Time.time, usr: Time.time} + val checkCPUTimes: cpu_timer -> {gc: {sys: Time.time, + usr: Time.time}, + nongc: {sys: Time.time, + usr: Time.time}} + val checkGCTime: cpu_timer -> Time.time + val checkRealTimer: real_timer -> Time.time + val startCPUTimer: unit -> cpu_timer + val startRealTimer: unit -> real_timer + val totalCPUTimer: unit -> cpu_timer + val totalRealTimer: unit -> real_timer + end diff --git a/basis-library/system/timer.sml b/basis-library/system/timer.sml new file mode 100644 index 0000000..927403e --- /dev/null +++ b/basis-library/system/timer.sml @@ -0,0 +1,74 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Timer: TIMER = + struct + structure SysUsr = + struct + datatype t = T of {sys: Time.time, usr: Time.time} + + fun export (T r) = r + + fun (T {sys, usr}) - (T {sys = s', usr = u'}) = + T {sys = Time.- (sys, s'), + usr = Time.- (usr, u')} + end + + type cpu_timer = {gc: SysUsr.t, self: SysUsr.t} + + fun startCPUTimer (): cpu_timer = + let + val {gc = {utime = gcu, stime = gcs, ...}, + self = {utime = selfu, stime = selfs}, ...} = + MLtonRusage.rusage () + in + {gc = SysUsr.T {sys = gcs, usr = gcu}, + self = SysUsr.T {sys = selfs, usr = selfu}} + end + + fun checkCPUTimes {gc, self} = + let + val {gc = g', self = s'} = startCPUTimer () + val gc = SysUsr.- (g', gc) + val self = SysUsr.- (s', self) + in + {gc = SysUsr.export gc, + nongc = SysUsr.export (SysUsr.- (self, gc))} + end + + fun checkCPUTimer timer = + let + val {nongc, gc} = checkCPUTimes timer + in + {sys = Time.+ (#sys gc, #sys nongc), + usr = Time.+ (#usr gc, #usr nongc)} + end + + val totalCPUTimer = + let + val t = startCPUTimer () + in + fn () => t + end + + val checkGCTime = #usr o #gc o checkCPUTimes + + type real_timer = Time.time + + fun startRealTimer (): real_timer = Time.now () + + fun checkRealTimer (t: real_timer): Time.time = + Time.- (startRealTimer (), t) + + val totalRealTimer = + let + val t = startRealTimer () + in + fn () => t + end + end diff --git a/basis-library/system/unix.sig b/basis-library/system/unix.sig new file mode 100644 index 0000000..b23ab95 --- /dev/null +++ b/basis-library/system/unix.sig @@ -0,0 +1,23 @@ +signature UNIX = + sig + type ('a, 'b) proc + type signal + datatype exit_status = + W_EXITED + | W_EXITSTATUS of Word8.word + | W_SIGNALED of signal + | W_STOPPED of signal + + val binInstreamOf: (BinIO.instream, 'a) proc -> BinIO.instream + val binOutstreamOf: ('a, BinIO.outstream) proc -> BinIO.outstream + val execute: string * string list -> ('a, 'b) proc + val executeInEnv: string * string list * string list -> ('a, 'b) proc + val exit: Word8.word -> 'a + val fromStatus: OS.Process.status -> exit_status + val kill: ('a, 'b) proc * signal -> unit + val reap: ('a, 'b) proc -> OS.Process.status + val streamsOf: ((TextIO.instream, TextIO.outstream) proc + -> TextIO.instream * TextIO.outstream) + val textInstreamOf: (TextIO.instream, 'a) proc -> TextIO.instream + val textOutstreamOf: ('a, TextIO.outstream) proc -> TextIO.outstream + end diff --git a/basis-library/system/unix.sml b/basis-library/system/unix.sml new file mode 100644 index 0000000..cbfad8b --- /dev/null +++ b/basis-library/system/unix.sml @@ -0,0 +1,60 @@ +(* Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* Rewritten by wesley@terpstra.ca on 2004-11-23 to use MLtonProcess for the + * implementation. + *) + +structure Unix: UNIX = +struct + +structure Status = OS_Process.Status +structure Process = MLtonProcess +local + open Process +in + structure Child = Child + structure Param = Param +end + +type signal = Posix.Signal.signal +datatype exit_status = datatype Posix.Process.exit_status + +val fromStatus = Posix.Process.fromStatus + +type ('in, 'out) proc = ('out, 'in, Process.none) Process.t + +local + fun create {args, env, path} = + Process.create {args = args, + env = env, + path = path, + stderr = Param.self, + stdin = Param.pipe, + stdout = Param.pipe} +in + fun execute (path, args) = + create {args = args, env = NONE, path = path} + fun executeInEnv (path, args, env) = + create {args = args, env = SOME env, path = path} +end + +fun binInstreamOf proc = Child.binIn (Process.getStdout proc) +fun binOutstreamOf proc = Child.binOut (Process.getStdin proc) +fun textInstreamOf proc = Child.textIn (Process.getStdout proc) +fun textOutstreamOf proc = Child.textOut (Process.getStdin proc) + +fun streamsOf pr = (textInstreamOf pr, textOutstreamOf pr) + +val kill = Process.kill + +fun reap z = Status.fromPosix (Process.reap z) + +fun exit (w: Word8.word): 'a = + OS.Process.exit (Status.fromInt (Word8.toInt w)) + +end diff --git a/basis-library/text/byte.sig b/basis-library/text/byte.sig new file mode 100644 index 0000000..98e6cf4 --- /dev/null +++ b/basis-library/text/byte.sig @@ -0,0 +1,10 @@ +signature BYTE = + sig + val byteToChar: Word8.word -> char + val bytesToString: Word8Vector.vector -> string + val charToByte: char -> Word8.word + val packString: Word8Array.array * int * substring -> unit + val stringToBytes: string -> Word8Vector.vector + val unpackString: Word8ArraySlice.slice -> string + val unpackStringVec: Word8VectorSlice.slice -> string + end diff --git a/basis-library/text/byte.sml b/basis-library/text/byte.sml new file mode 100644 index 0000000..8ebd839 --- /dev/null +++ b/basis-library/text/byte.sml @@ -0,0 +1,31 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Byte: BYTE = + struct + val byteToChar = Primitive.Char8.idFromWord8 + + val bytesToString = Primitive.String8.idFromWord8Vector o Word8Vector.toPoly + + val charToByte = Primitive.Char8.idToWord8 + + fun packString (a: Word8Array.array, i: int, s: substring): unit = + Natural.foreach + (Substring.size s, fn j => + Word8Array.update (a, i + j, charToByte (Substring.sub (s, j)))) + + val stringToBytes = Word8Vector.fromPoly o Primitive.String8.idToWord8Vector + + local + fun make (length, sub) s = + String.tabulate (length s, fn i => byteToChar (sub (s, i))) + in + val unpackString = make (Word8ArraySlice.length, Word8ArraySlice.sub) + val unpackStringVec = make (Word8VectorSlice.length, Word8VectorSlice.sub) + end + end diff --git a/basis-library/text/char-global.sml b/basis-library/text/char-global.sml new file mode 100644 index 0000000..4655c95 --- /dev/null +++ b/basis-library/text/char-global.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure CharGlobal: CHAR_GLOBAL = Char +open CharGlobal diff --git a/basis-library/text/char.sig b/basis-library/text/char.sig new file mode 100644 index 0000000..9274833 --- /dev/null +++ b/basis-library/text/char.sig @@ -0,0 +1,55 @@ +signature CHAR_GLOBAL = + sig + eqtype char + + val ord: char -> int + val chr: int -> char + end + +signature CHAR = + sig + include CHAR_GLOBAL + + eqtype string + + val minChar: char + val maxChar: char + val maxOrd: int + val succ: char -> char + val pred: char -> char + val < : char * char -> bool + val <= : char * char -> bool + val > : char * char -> bool + val >= : char * char -> bool + val compare: char * char -> order + val contains: string -> char -> bool + val notContains: string -> char -> bool + val toLower: char -> char + val toUpper: char -> char + val isAscii: char -> bool + val isAlpha: char -> bool + val isAlphaNum: char -> bool + val isCntrl: char -> bool + val isDigit: char -> bool + val isGraph: char -> bool + val isHexDigit: char -> bool + val isLower: char -> bool + val isUpper: char -> bool + val isPrint: char -> bool + val isPunct: char -> bool + val isSpace: char -> bool + + val toString: char -> String.string + val scan: (Char.char, 'a) StringCvt.reader -> (char, 'a) StringCvt.reader + val fromString: String.string -> char option + val toCString: char -> String.string + val fromCString: String.string -> char option + end + +signature CHAR_EXTRA = + sig + include CHAR + + val formatSequences: (Char.char, 'a) StringCvt.reader -> 'a -> 'a + val scanC: (Char.char, 'a) StringCvt.reader -> (char, 'a) StringCvt.reader + end diff --git a/basis-library/text/char.sml b/basis-library/text/char.sml new file mode 100644 index 0000000..5d58efd --- /dev/null +++ b/basis-library/text/char.sml @@ -0,0 +1,368 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature CHAR_ARG = + sig + structure PreChar : PRE_CHAR + structure CharVector: EQTYPE_MONO_VECTOR_EXTRA + structure CharArray: MONO_ARRAY_EXTRA + sharing type PreChar.char = CharVector.elem = CharArray.elem + sharing type PreChar.string = CharVector.vector = CharArray.vector + end + +functor CharFn(Arg : CHAR_ARG) + :> CHAR_EXTRA + where type char = Arg.PreChar.char + where type string = Arg.PreChar.string = + struct + open Arg.PreChar + + type string = Arg.CharVector.vector + val maxOrd: int = numChars - 1 + + val fromString = Arg.CharVector.fromPoly o + Vector.map (fn x => fromChar x) o + String.toPoly + + fun succ c = + if Primitive.Controls.safe + andalso c = maxChar + then raise Chr + else chrUnsafe (Int.+ (ord c, 1)) + + fun pred c = + if Primitive.Controls.safe + andalso c = minChar + then raise Chr + else chrUnsafe (Int.- (ord c, 1)) + + fun chrOpt c = + if Primitive.Controls.safe + andalso Int.gtu (c, maxOrd) + then NONE + else SOME (chrUnsafe c) + + fun chr c = + case chrOpt c of + NONE => raise Chr + | SOME c => c + + (* To implement character classes, we cannot use lookup tables on the + * order of the number of characters. We don't want to scan the string + * each time, so instead we'll sort it and use binary search. + *) + fun contains s = + let + val a = Array.tabulate (Arg.CharVector.length s, + fn i => Arg.CharVector.sub (s, i)) + val () = Heap.heapSort (a, op <) + in + fn c => + let + val x = Heap.binarySearch (a, fn d => d < c) + in + if x = Array.length a then false else + Array.sub (a, x) = c + end + end + + fun notContains s = not o contains s + + val c = fromChar + val ( la, lA, lf, lF, lz, lZ, l0, l9, lSPACE,lBANG, lTIL, lTAB, lCR, lDEL) = + (c#"a", c#"A", c#"f", c#"F", c#"z", c#"Z", c#"0", c#"9", c#" ", c#"!", c#"~", c#"\t", c#"\r", c#"\127") + + (* Range comparisons don't need tables! It's faster to just compare. *) + fun isLower c = la <= c andalso c <= lz + fun isUpper c = c <= lZ andalso lA <= c (* More discriminating first! *) + fun isDigit c = c <= l9 andalso l0 <= c (* More discriminating first! *) + fun isGraph c = lBANG <= c andalso c <= lTIL + fun isPrint c = lSPACE <= c andalso c <= lTIL + fun isCntrl c = c < lSPACE orelse c = lDEL + fun isAscii c = c <= lDEL + + (* These take advantage of ASCII ordering to minimize comparisons. *) + fun isAlpha c = if la <= c then c <= lz else lA <= c andalso c <= lZ + fun isAlphaNum c = + if lA <= c then + if la <= c then c <= lz else c <= lZ + else + l0 <= c andalso c <= l9 + fun isHexDigit c = + if lA <= c then + if la <= c then c <= lf else c <= lF + else + l0 <= c andalso c <= l9 + fun isSpace c = if lCR < c then c = lSPACE else lTAB <= c + fun isPunct c = isGraph c andalso not (isAlphaNum c) + + local + fun make (test, diff) c = + if test c then chrUnsafe (Int.+? (ord c, diff)) else c + val diff = Int.- (ord lA, ord la) + in + val toLower = make (isUpper, Int.~ diff) + val toUpper = make (isLower, diff) + end + + fun control reader state = + case reader state of + NONE => NONE + | SOME (c, state) => + if Char.<= (#"@", c) andalso Char.<= (c, #"_") + then SOME (chr (Int.-? (Char.ord c, Char.ord #"@")), state) + else NONE + + fun formatChar reader state = + case reader state of + NONE => NONE + | SOME (c, state) => + if StringCvt.isSpace c + then SOME ((), state) + else NONE + + fun formatChars reader = + let + fun loop state = + case formatChar reader state of + NONE => state + | SOME ((), state) => loop state + in + loop + end + + val 'a formatSequences: (Char.char, 'a) StringCvt.reader -> 'a -> 'a = + fn reader => + let + fun loop state = + case reader state of + SOME (#"\\", state1) => + (case formatChar reader state1 of + NONE => state + | SOME ((), state2) => + let + val state3 = formatChars reader state2 + in + case reader state3 of + SOME (#"\\", state4) => loop state4 + | _ => state + end) + | _ => state + in + loop + end + + fun 'a scan (reader: (Char.char, 'a) StringCvt.reader) + : (char, 'a) StringCvt.reader = + let + val escape : (char, 'a) StringCvt.reader = + fn state => + case reader state of + NONE => NONE + | SOME (c, state') => + let + fun yes c = SOME (fromChar c, state') + in + case c of + #"a" => yes #"\a" + | #"b" => yes #"\b" + | #"t" => yes #"\t" + | #"n" => yes #"\n" + | #"v" => yes #"\v" + | #"f" => yes #"\f" + | #"r" => yes #"\r" + | #"\\" => yes #"\\" + | #"\"" => yes #"\"" + | #"^" => control reader state' + | #"u" => + Reader.mapOpt chrOpt + (StringCvt.digitsExact (StringCvt.HEX, 4) reader) + state' + | #"U" => + Reader.mapOpt chrOpt + (StringCvt.digitsExact (StringCvt.HEX, 8) reader) + state' + | _ => (* 3 decimal digits *) + Reader.mapOpt chrOpt + (StringCvt.digitsExact (StringCvt.DEC, 3) + reader) + state + end + val main: (char, 'a) StringCvt.reader = + fn state => + let + val state = formatSequences reader state + in + case reader state of + NONE => NONE + | SOME (c, state) => + (* isPrint doesn't exist. yuck: *) + if Char.>= (c, #" ") andalso Char.<= (c, #"~") + then + case c of + #"\\" => escape state + | #"\"" => NONE + | _ => SOME (fromChar c, formatSequences reader state) + else NONE + end + in + main + end + + val fromString = StringCvt.scanString scan + + fun 'a scanC (reader: (Char.char, 'a) StringCvt.reader) + : (char, 'a) StringCvt.reader = + let + val rec escape = + fn state => + case reader state of + NONE => NONE + | SOME (c, state') => + let fun yes c = SOME (fromChar c, state') + in case c of + #"a" => yes #"\a" + | #"b" => yes #"\b" + | #"t" => yes #"\t" + | #"n" => yes #"\n" + | #"v" => yes #"\v" + | #"f" => yes #"\f" + | #"r" => yes #"\r" + | #"?" => yes #"?" + | #"\\" => yes #"\\" + | #"\"" => yes #"\"" + | #"'" => yes #"'" + | #"^" => control reader state' + | #"x" => + Reader.mapOpt chrOpt + (StringCvt.digits StringCvt.HEX reader) + state' + | #"u" => + Reader.mapOpt chrOpt + (StringCvt.digitsExact (StringCvt.HEX, 4) reader) + state' + | #"U" => + Reader.mapOpt chrOpt + (StringCvt.digitsExact (StringCvt.HEX, 8) reader) + state' + | _ => + Reader.mapOpt chrOpt + (StringCvt.digitsPlus (StringCvt.OCT, 3) reader) + state + end + and main = + fn NONE => NONE + | SOME (c, state) => + (* yuck. isPrint is not defined yet: *) + if Char.>= (c, #" ") andalso Char.<= (c, #"~") + then + case c of + #"\\" => escape state + | _ => SOME (fromChar c, state) + else NONE + in + main o reader + end + + val fromCString = StringCvt.scanString scanC + + fun padLeft (s: String.string, n: int): String.string = + let + val m = String.size s + val diff = Int.-? (n, m) + in if Int.> (diff, 0) + then String.concat [String.new (diff, #"0"), s] + else if diff = 0 + then s + else raise Fail "padLeft" + end + + fun unicodeEscape ord = + if Int.< (ord, 65536) + then String.concat + ["\\u", padLeft (Int.fmt StringCvt.HEX ord, 4)] + else String.concat + ["\\U", padLeft (Int.fmt StringCvt.HEX ord, 8)] + + fun toString c = + let + val ord = ord c + in + if isPrint c + then + case ord of + 92 (* #"\\" *) => "\\\\" + | 34 (* #"\"" *) => "\\\"" + | _ => String.new (1, Char.chrUnsafe ord) + (* ^^^^ safe b/c isPrint < 128 *) + else + case ord of + 7 (* #"\a" *) => "\\a" + | 8 (* #"\b" *) => "\\b" + | 9 (* #"\t" *) => "\\t" + | 10 (* #"\n" *) => "\\n" + | 11 (* #"\v" *) => "\\v" + | 12 (* #"\f" *) => "\\f" + | 13 (* #"\r" *) => "\\r" + | _ => + if Int.< (ord, 32) + then String.concat + ["\\^", String.new + (1, Char.chrUnsafe + (Int.+? (ord, 64 (* #"@" *) )))] + else if Int.< (ord, 256) + then String.concat + ["\\", padLeft (Int.fmt StringCvt.DEC ord, 3)] + else unicodeEscape ord + end + + fun toCString c = + let + val ord = ord c + in + if isPrint c + then + case ord of + 92 (* #"\\" *) => "\\\\" + | 34 (* #"\"" *) => "\\\"" + | 63 (* #"?" *) => "\\?" + | 39 (* #"'" *) => "\\'" + | _ => String.new (1, Char.chrUnsafe ord) + else + case ord of + 7 (* #"\a" *) => "\\a" + | 8 (* #"\b" *) => "\\b" + | 9 (* #"\t" *) => "\\t" + | 10 (* #"\n" *) => "\\n" + | 11 (* #"\v" *) => "\\v" + | 12 (* #"\f" *) => "\\f" + | 13 (* #"\r" *) => "\\r" + | _ => + if Int.< (ord, 256) + then String.concat + ["\\", padLeft (Int.fmt StringCvt.OCT ord, 3)] + else unicodeEscape ord + end + end + +structure CharArg : CHAR_ARG = + struct + structure PreChar = Char + structure CharVector = CharVector + structure CharArray = CharArray + end + +structure WideCharArg : CHAR_ARG = + struct + structure PreChar = WideChar + structure CharVector = WideCharVector + structure CharArray = WideCharArray + end + +structure Char : CHAR_EXTRA = CharFn(CharArg) +structure WideChar : CHAR_EXTRA = CharFn(WideCharArg) diff --git a/basis-library/text/char0.sig b/basis-library/text/char0.sig new file mode 100644 index 0000000..f03e975 --- /dev/null +++ b/basis-library/text/char0.sig @@ -0,0 +1,20 @@ +signature PRE_CHAR = + sig + eqtype char + eqtype string + + val chrUnsafe: int -> char + val ord: char -> int + + val fromChar: Char.char -> char + + val minChar : char + val maxChar : char + val numChars : int + + val compare: char * char -> order + val < : char * char -> bool + val <= : char * char -> bool + val > : char * char -> bool + val >= : char * char -> bool + end diff --git a/basis-library/text/char0.sml b/basis-library/text/char0.sml new file mode 100644 index 0000000..6ccd92e --- /dev/null +++ b/basis-library/text/char0.sml @@ -0,0 +1,78 @@ +(* Copyright (C) 2017 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + structure PreCharX = + struct + structure Prim8 = Primitive.Char8 + structure Prim16 = Primitive.Char16 + structure Prim32 = Primitive.Char32 + + type 'a t = { + chrUnsafe: int -> 'a, + ord: 'a -> int, + minChar: 'a, + maxChar: 'a, + numChars: int + } + + val fChar8 : Prim8.char t = { + chrUnsafe = Prim8.idFromWord8 o Int.sextdToWord8, + ord = Int.zextdFromWord8 o Prim8.idToWord8, + minChar = #"\000", + maxChar = #"\255", + numChars = 256 (* 0x100 *) + } + val fChar16 : Prim16.char t = { + chrUnsafe = Prim16.idFromWord16 o Int.sextdToWord16, + ord = Int.zextdFromWord16 o Prim16.idToWord16, + minChar = #"\000", + maxChar = #"\uFFFF", + numChars = 65536 (* 0x10000 *) + } + val fChar32 : Prim32.char t = { + chrUnsafe = Prim32.idFromWord32 o Int.sextdToWord32, + ord = Int.zextdFromWord32 o Prim32.idToWord32, + minChar = #"\000", + maxChar = Prim32.idFromWord32 0wx0010FFFF, + numChars = 1114112 (* 0x110000 *) + } + end +in + structure Char : PRE_CHAR = + struct + (* set by config/default/default-charX.sml *) + open Char + type string = String.string + + local + structure PCX = Char_ChooseChar(PreCharX) + in + val { chrUnsafe, ord, minChar, maxChar, numChars } = PCX.f + end + + fun fromChar x = x + end + + structure WideChar : PRE_CHAR = + struct + (* set by config/default/default-widecharX.sml *) + open WideChar + type string = WideString.string + + local + structure PCX = WideChar_ChooseChar(PreCharX) + in + val { chrUnsafe, ord, minChar, maxChar, numChars } = PCX.f + end + + (* safe b/c WideChar >= Char *) + val fromChar = chrUnsafe o Char.ord + end +end diff --git a/basis-library/text/nullstring.sml b/basis-library/text/nullstring.sml new file mode 100644 index 0000000..42486a9 --- /dev/null +++ b/basis-library/text/nullstring.sml @@ -0,0 +1,18 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure NullString = + struct + open Primitive.NullString8 + + val nullTerm = fromString o String.nullTerm + end +structure NullStringArray = + struct + open Primitive.NullString8Array + end diff --git a/basis-library/text/string-cvt.sig b/basis-library/text/string-cvt.sig new file mode 100644 index 0000000..be3a13c --- /dev/null +++ b/basis-library/text/string-cvt.sig @@ -0,0 +1,51 @@ +signature STRING_CVT = + sig + datatype radix = BIN | OCT | DEC | HEX + + datatype realfmt = + SCI of int option + | FIX of int option + | GEN of int option + | EXACT + + type ('a, 'b) reader = 'b -> ('a * 'b) option + + val padLeft: char -> int -> string -> string + val padRight: char -> int -> string -> string + + val splitl: (char -> bool) -> (char, 'a) reader -> 'a -> string * 'a + + val takel: (char -> bool) -> (char, 'a) reader -> 'a -> string + val dropl: (char -> bool) -> (char, 'a) reader -> 'a -> 'a + val skipWS: (char, 'a) reader -> 'a -> 'a + + type cs + val scanString: + ((char, cs) reader -> ('a, cs) reader) -> string -> 'a option + end + +signature STRING_CVT_EXTRA = + sig + include STRING_CVT + + val radixToInt: radix -> int + val radixToWord: radix -> word + val charToDigit: radix -> char -> int option + val charToWDigit: radix -> char -> word option + + (* this exists before Char.isSpace *) + val isSpace: char -> bool + + (* maps 0...15 to #"0", #"1", ..., #"F" *) + val digitToChar: int -> char + + (* digitsExact(r, n) reads exactly n digits of radix r *) + val digitsExact: radix * int -> (char, 'a) reader -> (int, 'a) reader + + (* digitsPlus(r, m) reads between 1 and m digits of radix r *) + val digitsPlus: radix * int -> (char, 'a) reader -> (int, 'a) reader + + (* digits r reads as many digits of radix r as possible *) + val digits: radix -> (char, 'a) reader -> (int, 'a) reader + val wdigits: radix -> (char, 'a) reader -> (word, 'a) reader + end diff --git a/basis-library/text/string-cvt.sml b/basis-library/text/string-cvt.sml new file mode 100644 index 0000000..1bccafa --- /dev/null +++ b/basis-library/text/string-cvt.sml @@ -0,0 +1,205 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure StringCvt: STRING_CVT_EXTRA = + struct + open Reader + + val wordFromInt = Word.sextdFromInt + + datatype radix = BIN | OCT | DEC | HEX + + val radixToInt: radix -> int = + fn BIN => 2 + | OCT => 8 + | DEC => 10 + | HEX => 16 + val radixToWord: radix -> word = wordFromInt o radixToInt + + datatype realfmt = + SCI of int option + | FIX of int option + | GEN of int option + | EXACT + + type ('a, 'b) reader = 'b -> ('a * 'b) option + + open Int + + local + fun pad f (c: char) i s = + let + val n = String.size s + in + if n >= i + then s + else f (s, String.vector (i -? n, c)) + end + in + val padLeft = pad (fn (s, pad) => String.^ (pad, s)) + val padRight = pad String.^ + end + + fun splitl p f src = + let fun done chars = String.implode (rev chars) + fun loop (src, chars) = + case f src of + NONE => (done chars, src) + | SOME (c, src') => + if p c + then loop (src', c :: chars) + else (done chars, src) + in loop (src, []) + end + + fun takel p f s = #1 (splitl p f s) + fun dropl p f s = #2 (splitl p f s) + + type cs = int + + fun stringReader (s: string): (char, cs) reader = + fn i => if i >= String.size s + then NONE + else SOME (String.sub (s, i), i + 1) + + fun 'a scanString (f: ((char, cs) reader -> ('a, cs) reader)) (s: string) + : 'a option = + case f (stringReader s) 0 of + NONE => NONE + | SOME (a, _) => SOME a + + local + fun memoize (f: char -> 'a): char -> 'a = + let val a = Array.tabulate (Char.numChars, f o Char.chrUnsafe) + in fn c => Array.sub (a, Char.ord c) + end + + fun range (add: int, cmin: char, cmax: char): char -> int option = + let val min = Char.ord cmin + in fn c => if Char.<= (cmin, c) andalso Char.<= (c, cmax) + then SOME (add +? Char.ord c -? min) + else NONE + end + + fun 'a combine (ds: (char -> 'a option) list): char -> 'a option = + memoize + (fn c => + let + val rec loop = + fn [] => NONE + | d :: ds => + case d c of + NONE => loop ds + | z => z + in loop ds + end) + + val bin = memoize (range (0, #"0", #"1")) + val oct = memoize (range (0, #"0", #"7")) + val dec = memoize (range (0, #"0", #"9")) + val hex = combine [range (0, #"0", #"9"), + range (10, #"a", #"f"), + range (10, #"A", #"F")] + + fun isSpace c = (c = #" " orelse c = #"\t" orelse c = #"\r" orelse + c = #"\n" orelse c = #"\v" orelse c = #"\f") + in + val isSpace = memoize isSpace + fun skipWS x = dropl isSpace x + + fun charToDigit (radix: radix): char -> int option = + case radix of + BIN => bin + | OCT => oct + | DEC => dec + | HEX => hex + end + + fun charToWDigit radix = (Option.map wordFromInt) o (charToDigit radix) + + fun digits (radix, max, accum) reader state = + let + val r = radixToInt radix + fun loop (max, accum, state) = + let fun done () = SOME (accum, state) + in if max <= 0 + then done () + else + case reader state of + NONE => done () + | SOME (c, state) => + case charToDigit radix c of + NONE => done () + | SOME n => loop (max - 1, n + accum * r, state) + end + in loop (max, accum, state) + end + + fun digitsPlus (radix, max) reader state = + case reader state of + NONE => NONE + | SOME (c, state) => + case charToDigit radix c of + NONE => NONE + | SOME n => digits (radix, max -? 1, n) reader state + + fun digitsExact (radix, num) reader state = + let val r = radixToInt radix + fun loop (num, accum, state) = + if num <= 0 + then SOME (accum, state) + else + case reader state of + NONE => NONE + | SOME (c, state) => + case charToDigit radix c of + NONE => NONE + | SOME n => loop (num - 1, n + accum * r, state) + in loop (num, 0, state) + end + + fun digits radix reader state = + let + val r = radixToInt radix + fun loop (accum, state) = + case reader state of + NONE => SOME (accum, state) + | SOME (c, state') => + case charToDigit radix c of + NONE => SOME (accum, state) + | SOME n => loop (n + accum * r, state') + in case reader state of + NONE => NONE + | SOME (c, state) => + case charToDigit radix c of + NONE => NONE + | SOME n => loop (n, state) + end + + fun wdigits radix reader state = + let + val op + = Word.+ + val op * = Word.* + val r = radixToWord radix + fun loop (accum, state) = + case reader state of + NONE => SOME (accum, state) + | SOME (c, state') => + case charToWDigit radix c of + NONE => SOME (accum, state) + | SOME n => loop (n + accum * r, state') + in case reader state of + NONE => NONE + | SOME (c, state) => + case charToWDigit radix c of + NONE => NONE + | SOME n => loop (n, state) + end + + fun digitToChar (n: int): char = String.sub ("0123456789ABCDEF", n) + end diff --git a/basis-library/text/string-global.sml b/basis-library/text/string-global.sml new file mode 100644 index 0000000..b2f75bf --- /dev/null +++ b/basis-library/text/string-global.sml @@ -0,0 +1,18 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure StringGlobal: STRING_GLOBAL = String +open StringGlobal + +(* Now that concat is defined, we can add the exnMessager for Fail. *) +val _ = + General.addExnMessager + (fn e => + case e of + Fail s => SOME (concat ["Fail: ", s]) + | _ => NONE) diff --git a/basis-library/text/string.sig b/basis-library/text/string.sig new file mode 100644 index 0000000..92780f1 --- /dev/null +++ b/basis-library/text/string.sig @@ -0,0 +1,55 @@ +signature STRING_GLOBAL = + sig + eqtype char + eqtype string + + val ^ : string * string -> string + val concat: string list -> string + val explode: string -> char list + val implode: char list -> string + val size: string -> int + val str: char -> string + val substring: string * int * int -> string + end + +signature STRING = + sig + include STRING_GLOBAL + + + val < : string * string -> bool + val <= : string * string -> bool + val > : string * string -> bool + val >= : string * string -> bool + val collate: (char * char -> order) -> string * string -> order + val compare: string * string -> order + val concatWith: string -> string list -> string + val extract: string * int * int option -> string + val fields: (char -> bool) -> string -> string list + val fromCString: String.string -> string option + val fromString: String.string -> string option + val isPrefix: string -> string -> bool + val isSubstring: string -> string -> bool + val isSuffix: string -> string -> bool + val map: (char -> char) -> string -> string + val maxSize: int + val scan: (Char.char, 'a) StringCvt.reader -> (string, 'a) StringCvt.reader + val sub: string * int -> char + val toCString: string -> String.string + val toString: string -> String.string + val tokens: (char -> bool) -> string -> string list + val translate: (char -> string) -> string -> string + end + +signature STRING_EXTRA = + sig + include STRING + type array + + val unsafeFromArray: array -> string + + val new: int * char -> string + val nullTerm: string -> string + val tabulate: int * (int -> char) -> string + val toLower: string -> string + end diff --git a/basis-library/text/string.sml b/basis-library/text/string.sml new file mode 100644 index 0000000..45f94a7 --- /dev/null +++ b/basis-library/text/string.sml @@ -0,0 +1,103 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature STRING_ARG = + sig + structure Char: CHAR_EXTRA + structure CharVector: EQTYPE_MONO_VECTOR_EXTRA + sharing type Char.char = CharVector.elem + sharing type Char.string = CharVector.vector + end + +functor StringFn(Arg : STRING_ARG) + :> STRING_EXTRA + where type char = Arg.CharVector.elem + where type string = Arg.CharVector.vector + where type array = Arg.CharVector.array = + struct + open Arg + open CharVector + structure CharVectorSlice = MonoVectorSlice + + type char = elem + type string = vector + + val new = vector + fun str c = new (1, c) + + val maxSize = maxLen + val size = length + val op ^ = append + val implode = fromList + val explode = toList + + fun extract (s, start, len) = + CharVectorSlice.vector (CharVectorSlice.slice (s, start, len)) + fun substring (s, start, len) = extract (s, start, SOME len) + + val toLower = translate (str o Char.toLower) + + local + fun make f = f (op = : char * char -> bool) + in + val isPrefix = make isPrefix + val isSubstring = make isSubvector + val isSuffix = make isSuffix + end + val compare = collate Char.compare + local + structure S = StringComparisons (type t = string + val compare = compare) + in + open S + end + + fun Stranslate f = String.fromPoly o Vector.translate f o toPoly + + val toString = Stranslate Char.toString + val toCString = Stranslate Char.toCString + + val scan = + fn reader => + let + fun loop (state, cs) = + case Char.scan reader state of + NONE => SOME (implode (rev cs), + Char.formatSequences reader state) + | SOME (c, state) => loop (state, c :: cs) + in + fn state => loop (state, []) + end + + val fromString = StringCvt.scanString scan + + fun scanString scanChar reader = + fn state => + Option.map (fn (cs, state) => (implode cs, state)) + (Reader.list (scanChar reader) state) + + val fromCString = StringCvt.scanString (scanString Char.scanC) + + val null = str (Char.chr 0) + fun nullTerm s = s ^ null + end + +structure StringArg : STRING_ARG = + struct + structure Char = Char + structure CharVector = CharVector + end + +structure WideStringArg : STRING_ARG = + struct + structure Char = WideChar + structure CharVector = WideCharVector + end + +structure String : STRING_EXTRA = StringFn(StringArg) +structure WideString : STRING_EXTRA = StringFn(WideStringArg) diff --git a/basis-library/text/string0.sml b/basis-library/text/string0.sml new file mode 100644 index 0000000..fb06327 --- /dev/null +++ b/basis-library/text/string0.sml @@ -0,0 +1,31 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure String = + struct + open CharVector + type string = vector + + val size = length + val op ^ = append + val implode = fromList + val new = vector + end + +(* +structure WideString = + struct + open WideCharVector + type string = vector + + val size = length + val op ^ = append + val implode = fromList + val new = vector + end +*) diff --git a/basis-library/text/substring-global.sml b/basis-library/text/substring-global.sml new file mode 100644 index 0000000..ae6b771 --- /dev/null +++ b/basis-library/text/substring-global.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure SubstringGlobal: SUBSTRING_GLOBAL = Substring +open SubstringGlobal diff --git a/basis-library/text/substring.sig b/basis-library/text/substring.sig new file mode 100644 index 0000000..387be1d --- /dev/null +++ b/basis-library/text/substring.sig @@ -0,0 +1,53 @@ +signature SUBSTRING_GLOBAL = + sig + type substring + end + +signature SUBSTRING = + sig + include SUBSTRING_GLOBAL + eqtype char + eqtype string + + val app: (char -> unit) -> substring -> unit + val base: substring -> string * int * int + val collate: (char * char -> order) -> substring * substring -> order + val compare: substring * substring -> order + val concat: substring list -> string + val concatWith: string -> substring list -> string + val dropl: (char -> bool) -> substring -> substring + val dropr: (char -> bool) -> substring -> substring + val explode: substring -> char list + val extract: string * int * int option -> substring + val fields: (char -> bool) -> substring -> substring list + val first: substring -> char option + val foldl: (char * 'a -> 'a) -> 'a -> substring -> 'a + val foldr: (char * 'a -> 'a) -> 'a -> substring -> 'a + val full: string -> substring + val getc: substring -> (char * substring) option + val isEmpty: substring -> bool + val isPrefix: string -> substring -> bool + val isSubstring: string -> substring -> bool + val isSuffix: string -> substring -> bool + val position: string -> substring -> substring * substring + val size: substring -> int + val slice: substring * int * int option -> substring + val span: substring * substring -> substring + val splitAt: substring * int -> substring * substring + val splitl: (char -> bool) -> substring -> substring * substring + val splitr: (char -> bool) -> substring -> substring * substring + val string: substring -> string + val sub: substring * int -> char + val substring: string * int * int -> substring + val takel: (char -> bool) -> substring -> substring + val taker: (char -> bool) -> substring -> substring + val tokens: (char -> bool) -> substring -> substring list + val translate: (char -> string) -> substring -> string + val triml: int -> substring -> substring + val trimr: int -> substring -> substring + end + +signature SUBSTRING_EXTRA = + sig + include SUBSTRING + end diff --git a/basis-library/text/substring.sml b/basis-library/text/substring.sml new file mode 100644 index 0000000..97b12c9 --- /dev/null +++ b/basis-library/text/substring.sml @@ -0,0 +1,61 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +(* The :> is to hide the type substring. We must add the where's to make char + * and string the same as the toplevel types. + *) +functor SubstringFn(Arg : STRING_ARG) + :> SUBSTRING_EXTRA + where type char = Arg.CharVector.MonoVectorSlice.elem + where type string = Arg.CharVector.MonoVectorSlice.vector + where type substring = Arg.CharVector.MonoVectorSlice.slice = + struct + open Arg + open CharVector.MonoVectorSlice + + type char = elem + type string = vector + type substring = slice + + val size = length + val extract = slice + fun substring (s, start, len) = extract (s, start, SOME len) + val string = vector + val getc = getItem + fun first ss = Option.map #1 (getItem ss) + val slice = subslice + val explode = toList + local + fun make f = f (op = : char * char -> bool) + in + val isPrefix = make isPrefix + val isSubstring = make isSubvector + val isSuffix = make isSuffix + val position = make position + end + val compare = collate Char.compare + +(* + type cs = int + + fun reader (T {str, start, size}): (char, cs) Reader.reader = + fn i => if i >= size + then NONE + else SOME (String.sub (str, start +? i), i + 1) + + fun 'a scanSubstring + (f: (char, cs) Reader.reader -> ('a, int) Reader.reader) + (ss: substring): 'a option = + case f (reader ss) 0 of + NONE => NONE + | SOME (a, _) => SOME a +*) + end + +structure Substring = SubstringFn(StringArg) +structure WideSubstring = SubstringFn(WideStringArg) diff --git a/basis-library/text/text.sig b/basis-library/text/text.sig new file mode 100644 index 0000000..5c6a15a --- /dev/null +++ b/basis-library/text/text.sig @@ -0,0 +1,26 @@ +signature TEXT = + sig + structure Char: CHAR + structure CharArray: MONO_ARRAY + structure CharArraySlice: MONO_ARRAY_SLICE + structure CharVector: MONO_VECTOR + structure CharVectorSlice: MONO_VECTOR_SLICE + structure String: STRING + structure Substring: SUBSTRING + sharing type Char.char + = CharArray.elem + = CharArraySlice.elem + = CharVector.elem + = CharVectorSlice.elem + = String.char + = Substring.char + sharing type Char.string + = CharArraySlice.vector + = CharVector.vector + = CharArray.vector + = CharVectorSlice.vector + = String.string + = Substring.string + sharing type CharArray.array = CharArraySlice.array + sharing type CharVectorSlice.slice = CharArraySlice.vector_slice + end diff --git a/basis-library/text/text.sml b/basis-library/text/text.sml new file mode 100644 index 0000000..47e1bec --- /dev/null +++ b/basis-library/text/text.sml @@ -0,0 +1,28 @@ +(* Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Text: TEXT = + struct + structure Char = Char + structure CharArray = CharArray + structure CharArraySlice = CharArraySlice + structure CharVector = CharVector + structure CharVectorSlice = CharVectorSlice + structure String = String + structure Substring = Substring + end + +structure WideText: TEXT = + struct + structure Char = WideChar + structure CharArray = WideCharArray + structure CharArraySlice = WideCharArraySlice + structure CharVector = WideCharVector + structure CharVectorSlice = WideCharVectorSlice + structure String = WideString + structure Substring = WideSubstring + end diff --git a/basis-library/top-level/arithmetic.sml b/basis-library/top-level/arithmetic.sml new file mode 100644 index 0000000..a55699f --- /dev/null +++ b/basis-library/top-level/arithmetic.sml @@ -0,0 +1,18 @@ +(* Copyright (C) 1999-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +val ~ = Int.~ +val ( op + ) = Int.+ +val ( op - ) = Int.- +val ( op * ) = Int.* +val ( op div ) = Int.div +val ( op mod ) = Int.mod +val ( op < ) = Int.< +val ( op <= ) = Int.<= +val ( op > ) = Int.> +val ( op >= ) = Int.>= diff --git a/basis-library/top-level/infixes-overflow.sml b/basis-library/top-level/infixes-overflow.sml new file mode 100644 index 0000000..f4dbf9f --- /dev/null +++ b/basis-library/top-level/infixes-overflow.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +infix 7 *! +infix 6 +! -! diff --git a/basis-library/top-level/infixes-unsafe.sml b/basis-library/top-level/infixes-unsafe.sml new file mode 100644 index 0000000..7945b8b --- /dev/null +++ b/basis-library/top-level/infixes-unsafe.sml @@ -0,0 +1,10 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +infix 7 *? +infix 6 +? -? diff --git a/basis-library/top-level/infixes.sml b/basis-library/top-level/infixes.sml new file mode 100644 index 0000000..6af18f3 --- /dev/null +++ b/basis-library/top-level/infixes.sml @@ -0,0 +1,14 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +infix 7 * / mod div +infix 6 + - ^ +infixr 5 :: @ +infix 4 = <> > >= < <= +infix 3 := o +infix 0 before diff --git a/basis-library/unsafe.mlb b/basis-library/unsafe.mlb new file mode 100644 index 0000000..ce69f07 --- /dev/null +++ b/basis-library/unsafe.mlb @@ -0,0 +1,21 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +ann + "deadCode true" + "nonexhaustiveBind warn" "nonexhaustiveMatch warn" + "redundantBind warn" "redundantMatch warn" + "sequenceNonUnit warn" + "warnUnused true" "forceUsed" +in + local + libs/basis-extra/basis-extra.mlb + in + signature UNSAFE + structure Unsafe + end +end diff --git a/basis-library/util/CUtil.sig b/basis-library/util/CUtil.sig new file mode 100644 index 0000000..f5847aa --- /dev/null +++ b/basis-library/util/CUtil.sig @@ -0,0 +1,45 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature C_UTIL = + sig + structure C_Pointer : + sig + type t = C_Pointer.t + + val null: t + val isNull: t -> bool + end + + (* C char* *) + structure C_String : + sig + type t = C_String.t + + (* string must be null terminated *) + val length: t -> int + val sub: t * int -> char + val toCharArrayOfLength: t * int -> char array + (* string must be null terminated *) + val toString: t -> string + (* extract first n characters of string *) + val toStringOfLength: t * int -> string + val update: t * int * char -> unit + end + + (* NULL terminated char** *) + structure C_StringArray : + sig + type t = C_StringArray.t + + val fromList: string list -> NullString.t array + (* extract first n strings from array *) + val toArrayOfLength: t * int -> string array + val toList: t -> string list + end + end diff --git a/basis-library/util/CUtil.sml b/basis-library/util/CUtil.sml new file mode 100644 index 0000000..55825a7 --- /dev/null +++ b/basis-library/util/CUtil.sml @@ -0,0 +1,107 @@ +(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure CUtil: C_UTIL = + struct + open Int + + structure Pointer = Primitive.MLton.Pointer + + fun makeLength (sub, term) p = + let + fun loop i = + if term (sub (p, i)) + then i + else loop (i +? 1) + in loop 0 + end + + fun toArrayOfLength (s: 'a, + sub: 'a * int -> 'b, + n: int) : 'b array = + let + val (a, _) = + Array.unfoldi + (n, (), fn (i, ()) => + (sub (s, i), ())) + in + a + end + + structure C_Pointer = + struct + type t = C_Pointer.t + val null = Pointer.toWord Pointer.null + fun isNull p = p = null + end + + structure C_String = + struct + type t = C_String.t + + fun sub (cs, i) = + Primitive.Char8.idFromWord8 + (Pointer.getWord8 + (Pointer.fromWord cs, + C_Ptrdiff.fromInt i)) + + fun update (cs, i, c) = + Pointer.setWord8 + (Pointer.fromWord cs, + C_Ptrdiff.fromInt i, + Primitive.Char8.idToWord8 c) + + val length = makeLength (sub, fn #"\000" => true | _ => false) + + fun toCharArrayOfLength (cs, n) = + toArrayOfLength (cs, sub, n) + + fun toStringOfLength (cs, n) = + String.unsafeFromArray + (CharArray.fromPoly (toCharArrayOfLength (cs, n))) + + fun toString cs = toStringOfLength (cs, length cs) + end + + structure C_StringArray = + struct + type t = C_StringArray.t + + fun sub (css: t, i) = + (Pointer.toWord o Pointer.getCPointer) + (Pointer.fromWord css, + C_Ptrdiff.fromInt i) + + val length = makeLength (sub, C_Pointer.isNull) + + val toArrayOfLength = + fn (css, n) => + toArrayOfLength (css, C_String.toString o sub, n) + + fun toArray css = toArrayOfLength (css, length css) + + val toList = Array.toList o toArray + + (* The C side converts the last element of the array, "", + * to the null terminator that C primitives expect. + * As far as C can tell, the other elements of the array + * are just char*'s. + *) + fun fromList l = + let + val (a, _) = + Array.unfoldi + (1 +? List.length l, l, fn (_, l) => + case l of + [] => (NullString.empty, l) + | s::l => (NullString.nullTerm s, l)) + in + a + end + end + end diff --git a/basis-library/util/abs-rep.fun b/basis-library/util/abs-rep.fun new file mode 100644 index 0000000..9859818 --- /dev/null +++ b/basis-library/util/abs-rep.fun @@ -0,0 +1,34 @@ +(* Copyright (C) 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor MkAbsRep(type rep) :> ABS_REP where type Rep.t = rep = + struct + structure Rep = struct type t = rep end + type t = Rep.t + val arrayFromRep : rep array -> t array = fn x => x + val arrayToRep : t array -> rep array = fn x => x + val fromRep : rep -> t = fn x => x + val listFromRep : rep list -> t list = fn x => x + val listToRep : t list -> rep list = fn x => x + val toRep : t -> rep = fn x => x + val vectorFromRep : rep vector -> t vector = fn x => x + val vectorToRep : t vector -> rep vector = fn x => x + end + +functor MkAbsRepEq(eqtype rep) :> ABS_REP_EQ where type Rep.t = rep = + struct + structure Rep = struct type t = rep end + type t = Rep.t + val arrayFromRep : rep array -> t array = fn x => x + val arrayToRep : t array -> rep array = fn x => x + val fromRep : rep -> t = fn x => x + val listFromRep : rep list -> t list = fn x => x + val listToRep : t list -> rep list = fn x => x + val toRep : t -> rep = fn x => x + val vectorFromRep : rep vector -> t vector = fn x => x + val vectorToRep : t vector -> rep vector = fn x => x + end diff --git a/basis-library/util/abs-rep.sig b/basis-library/util/abs-rep.sig new file mode 100644 index 0000000..cf700ee --- /dev/null +++ b/basis-library/util/abs-rep.sig @@ -0,0 +1,34 @@ +(* Copyright (C) 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature ABS_REP = + sig + type t + structure Rep : sig type t end + val arrayFromRep : Rep.t array -> t array + val arrayToRep : t array -> Rep.t array + val fromRep : Rep.t -> t + val listFromRep : Rep.t list -> t list + val listToRep : t list -> Rep.t list + val toRep : t -> Rep.t + val vectorFromRep : Rep.t vector -> t vector + val vectorToRep : t vector -> Rep.t vector + end + +signature ABS_REP_EQ = + sig + eqtype t + structure Rep : sig eqtype t end + val arrayFromRep : Rep.t array -> t array + val arrayToRep : t array -> Rep.t array + val fromRep : Rep.t -> t + val listFromRep : Rep.t list -> t list + val listToRep : t list -> Rep.t list + val toRep : t -> Rep.t + val vectorFromRep : Rep.t vector -> t vector + val vectorToRep : t vector -> Rep.t vector + end diff --git a/basis-library/util/cleaner.sig b/basis-library/util/cleaner.sig new file mode 100644 index 0000000..465f463 --- /dev/null +++ b/basis-library/util/cleaner.sig @@ -0,0 +1,18 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature CLEANER = + sig + type t + + val addNew: t * (unit -> unit) -> unit + val atExit: t + val atLoadWorld: t + val clean: t -> unit + val new: unit -> t + end diff --git a/basis-library/util/cleaner.sml b/basis-library/util/cleaner.sml new file mode 100644 index 0000000..b4d0ef4 --- /dev/null +++ b/basis-library/util/cleaner.sml @@ -0,0 +1,24 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Cleaner: CLEANER = +struct + +type t = (unit -> unit) list ref + +fun new (): t = ref [] + +fun addNew (cs, f) = cs := f :: (!cs) + +fun clean cs = app (fn c => c () handle _ => ()) (!cs) + +val atExit = new () + +val atLoadWorld = new () + +end diff --git a/basis-library/util/dynamic-wind.sig b/basis-library/util/dynamic-wind.sig new file mode 100644 index 0000000..22532fc --- /dev/null +++ b/basis-library/util/dynamic-wind.sig @@ -0,0 +1,12 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature DYNAMIC_WIND = + sig + val wind: (unit -> 'a) * (unit -> unit) -> 'a + end diff --git a/basis-library/util/dynamic-wind.sml b/basis-library/util/dynamic-wind.sml new file mode 100644 index 0000000..de1b07f --- /dev/null +++ b/basis-library/util/dynamic-wind.sml @@ -0,0 +1,26 @@ +(* Copyright (C) 1999-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure DynamicWind: DYNAMIC_WIND = +struct + +fun try (f: unit -> 'a, k: 'a -> 'b, h: exn -> 'b) = + let + datatype t = + A of 'a + | E of exn + in + case A (f ()) handle e => E e of + A a => k a + | E e => h e + end + +fun wind (thunk, cleanup: unit -> unit) = + try (thunk, fn a => (cleanup (); a), fn e => (cleanup (); raise e)) + +end diff --git a/basis-library/util/heap.sml b/basis-library/util/heap.sml new file mode 100644 index 0000000..9ce65b7 --- /dev/null +++ b/basis-library/util/heap.sml @@ -0,0 +1,90 @@ +(* Copyright (C) 2007-2007 Wesley W. Terpstra + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Heap: + sig + (* Sorts the provided array relative to the lessthan argument*) + val heapSort: 'a array * ('a * 'a -> bool) -> unit + (* Precondition: array is 0+ true values followed by 0+ false values *) + (* Finds the index of the first array entry where: f x = false *) + val binarySearch: 'a array * ('a -> bool) -> int + end = + struct + fun heapSort (a : 'a array, lessthan : 'a * 'a -> bool) = + let + open Array + + (* Push the hole down until value > both children *) + fun pushHoleDown ( hole, end_of_heap, value ) = + let + val left_child = Int.+ (Int.* (hole, 2), 1) + val right_child = Int.+ (left_child, 1) + in + (* Recursion: two children *) + if Int.< (right_child, end_of_heap) + then let val left_value = sub (a, left_child) + val right_value = sub (a, right_child) + val (bigger_child, bigger_value) = + if lessthan (left_value, right_value) + then (right_child, right_value) + else (left_child, left_value) + in if lessthan (bigger_value, value) + then update (a, hole, value) + else (update (a, hole, bigger_value); + pushHoleDown (bigger_child, end_of_heap, value)) + end + (* Base case: one child *) + else if right_child = end_of_heap + then let val left_value = sub (a, left_child) + in if lessthan (left_value, value) + then update (a, hole, value) + else (update (a, hole, left_value); + update (a, left_child, value)) + end + (* Base case: no children *) + else update (a, hole, value) + end + + (* Move largest element to end_of_table, then restore invariant *) + fun sortHeap end_of_heap = + let val end_of_heap = Int.- (end_of_heap, 1) + in if end_of_heap = 0 then () else + let val value = sub (a, end_of_heap) + in update (a, end_of_heap, sub (a, 0)); + pushHoleDown (0, end_of_heap, value); + sortHeap end_of_heap + end end + + (* Start at last node w/ parent, loop till 0: push down *) + val heapSize = Array.length a + fun heapify i = + if i = 0 then () else + let val i = Int.- (i, 1) + in pushHoleDown (i, heapSize, sub (a, i)); + heapify i + end + in + if Int.<= (heapSize, 1) then () else + (heapify (Int.div (heapSize, 2)); sortHeap heapSize) + end + + fun binarySearch (a : 'a array, f : 'a -> bool) = + let + fun loop (lower, upper) = + (* Base case: one element left *) + if Int.- (upper, lower) = 1 + then if f (Array.sub (a, lower)) then upper else lower + (* Recursive case: check middle *) + else let val mid = Int.div (Int.+ (lower, upper), 2) + in if f (Array.sub (a, mid)) + then loop (mid, upper) + else loop (lower, mid) + end + val size = Array.length a + in + if size = 0 then 0 else loop (0, size) + end + end diff --git a/basis-library/util/integral-comparisons.sml b/basis-library/util/integral-comparisons.sml new file mode 100644 index 0000000..862a6a8 --- /dev/null +++ b/basis-library/util/integral-comparisons.sml @@ -0,0 +1,38 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor IntegralComparisons (type t + val < : t * t -> bool) = + struct + val < : t * t -> bool = < + fun <= (a, b) = not (< (b, a)) + fun > (a, b) = < (b, a) + fun >= (a, b) = <= (b, a) + + fun compare (i, j) = + if < (i, j) then LESS + else if < (j, i) then GREATER + else EQUAL + fun min (x, y) = if < (x, y) then x else y + fun max (x, y) = if < (x, y) then y else x + end +functor UnsignedIntegralComparisons (type int + type word + val idFromIntToWord : int -> word + val < : word * word -> bool) = + struct + local + fun ltu (i: int, i': int) = < (idFromIntToWord i, idFromIntToWord i') + structure S = IntegralComparisons (type t = int + val < = ltu) + in + val ltu = S.< + val leu = S.<= + val gtu = S.> + val geu = S.>= + end + end diff --git a/basis-library/util/natural.sml b/basis-library/util/natural.sml new file mode 100644 index 0000000..c986157 --- /dev/null +++ b/basis-library/util/natural.sml @@ -0,0 +1,26 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Natural = + struct + fun foldStartStop (start, stop, b, f) = + if start > stop + then raise Subscript + else + let + fun loop (i, b) = + if i >= stop then b + else loop (i + 1, f (i, b)) + in loop (start, b) + end + + fun foreachStartStop (start, stop, f) = + foldStartStop (start, stop, (), fn (i, ()) => f i) + + fun foreach (n, f) = foreachStartStop (0, n, f) + end diff --git a/basis-library/util/one.sml b/basis-library/util/one.sml new file mode 100644 index 0000000..68e17b7 --- /dev/null +++ b/basis-library/util/one.sml @@ -0,0 +1,40 @@ +(* Copyright (C) 2006-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure One: + sig + type 'a t + + val make: (unit -> 'a) -> 'a t + val use: 'a t * ('a -> 'b) -> 'b + end = + struct + datatype 'a t = T of {more: unit -> 'a, + static: 'a, + staticIsInUse: bool ref} + + fun make f = T {more = f, + static = f (), + staticIsInUse = ref false} + + fun use (T {more, static, staticIsInUse}, f) = + let + val () = Primitive.MLton.Thread.atomicBegin () + val b = ! staticIsInUse + val d = + if b then + (Primitive.MLton.Thread.atomicEnd (); + more ()) + else + (staticIsInUse := true; + Primitive.MLton.Thread.atomicEnd (); + static) + in + DynamicWind.wind (fn () => f d, + fn () => if b then () else staticIsInUse := false) + end + end diff --git a/basis-library/util/reader.sig b/basis-library/util/reader.sig new file mode 100644 index 0000000..976278e --- /dev/null +++ b/basis-library/util/reader.sig @@ -0,0 +1,30 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature READER = + sig + type ('a, 'b) reader = 'b -> ('a * 'b) option + + (* read as many items as possible (never returns NONE) *) + val list: ('a, 'b) reader -> ('a list, 'b) reader + + (* never return NONE *) + (* val tokens: ('a -> bool) -> ('a, 'b) reader -> ('a list list, 'b) reader *) + (* val fields: ('a -> bool) -> ('a, 'b) reader -> ('a list list, 'b) reader *) + + val map: ('a -> 'c) -> ('a, 'b) reader -> ('c, 'b) reader + val mapOpt: ('a -> 'c option) -> ('a, 'b) reader -> ('c, 'b) reader + + val ignore: ('a -> bool) -> ('a, 'b) reader -> ('a, 'b) reader + + (* read excatly N items *) + val readerN: ('a, 'b) reader * int -> ('a list, 'b) reader + val reader2: ('a, 'b) reader -> ('a * 'a, 'b) reader + val reader3: ('a, 'b) reader -> ('a * 'a * 'a, 'b) reader + val reader4: ('a, 'b) reader -> ('a * 'a * 'a * 'a, 'b) reader + end diff --git a/basis-library/util/reader.sml b/basis-library/util/reader.sml new file mode 100644 index 0000000..738bc33 --- /dev/null +++ b/basis-library/util/reader.sml @@ -0,0 +1,79 @@ +(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Reader: READER = +struct + +open Int + +type ('a, 'b) reader = 'b -> ('a * 'b) option + +fun list (reader: ('a, 'b) reader): ('a list, 'b) reader = + fn state => + let + fun loop (state, accum) = + case reader state of + NONE => SOME (rev accum, state) + | SOME (a, state) => loop (state, a :: accum) + in loop (state, []) + end + +fun readerN (reader: ('a, 'b) reader, n: int): ('a list, 'b) reader = + fn (state :'b) => + let + fun loop (n, state, accum) = + if n <= 0 + then SOME (rev accum, state) + else case reader state of + NONE => NONE + | SOME (x, state) => loop (n - 1, state, x :: accum) + in loop (n, state, []) + end + +fun ignore f reader = + let + fun loop state = + case reader state of + NONE => NONE + | SOME (x, state) => + if f x + then loop state + else SOME (x, state) + in loop + end +val _ = ignore + +fun map (f: 'a -> 'c) (reader: ('a, 'b) reader): ('c, 'b) reader = + fn (b: 'b) => + case reader b of + NONE => NONE + | SOME (a, b) => SOME (f a, b) + +fun mapOpt (f: 'a -> 'c option) (reader: ('a, 'b) reader): ('c, 'b) reader = + fn (b: 'b) => + case reader b of + NONE => NONE + | SOME (a, b) => + case f a of + NONE => NONE + | SOME c => SOME (c, b) + +fun reader2 reader = + map (fn [y, z] => (y, z) | _ => raise Fail "Reader.reader2") + (readerN (reader, 2)) +val _ = reader2 + +fun reader3 reader = + map (fn [x, y, z] => (x, y, z) | _ => raise Fail "Reader.reader3") + (readerN (reader, 3)) + +fun reader4 reader = + map (fn [w, x, y, z] => (w, x, y, z) | _ => raise Fail "Reader.reader4") + (readerN (reader, 4)) + +end diff --git a/basis-library/util/real-comparisons.sml b/basis-library/util/real-comparisons.sml new file mode 100644 index 0000000..8c13b65 --- /dev/null +++ b/basis-library/util/real-comparisons.sml @@ -0,0 +1,14 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor RealComparisons (type t + val < : t * t -> bool + val <= : t * t -> bool) = + struct + fun > (a, b) = < (b, a) + fun >= (a, b) = <= (b, a) + end diff --git a/basis-library/util/string-comparisons.sml b/basis-library/util/string-comparisons.sml new file mode 100644 index 0000000..4058217 --- /dev/null +++ b/basis-library/util/string-comparisons.sml @@ -0,0 +1,28 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor StringComparisons (type t + val compare: t * t -> order) = + struct + fun < (x, y) = + (case compare (x, y) of + LESS => true + | _ => false) + fun <= (x, y) = + (case compare (x, y) of + GREATER => false + | _ => true) + fun > (x, y) = + (case compare (x, y) of + GREATER => true + | _ => false) + fun >= (x, y) = + (case compare (x, y) of + LESS => false + | _ => true) + end diff --git a/basis-library/util/unique-id.fun b/basis-library/util/unique-id.fun new file mode 100644 index 0000000..e24cbb4 --- /dev/null +++ b/basis-library/util/unique-id.fun @@ -0,0 +1,14 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor UniqueId () :> UNIQUE_ID = + struct + type t = unit ref + + fun new (): t = ref () + end diff --git a/basis-library/util/unique-id.sig b/basis-library/util/unique-id.sig new file mode 100644 index 0000000..7329962 --- /dev/null +++ b/basis-library/util/unique-id.sig @@ -0,0 +1,14 @@ +(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +signature UNIQUE_ID = + sig + type t + + val new: unit -> t + end diff --git a/benchmark/.gitignore b/benchmark/.gitignore new file mode 100644 index 0000000..a20eed1 --- /dev/null +++ b/benchmark/.gitignore @@ -0,0 +1,2 @@ +/benchmark +/benchmark.exe diff --git a/benchmark/Makefile b/benchmark/Makefile new file mode 100644 index 0000000..21a12b3 --- /dev/null +++ b/benchmark/Makefile @@ -0,0 +1,50 @@ +## Copyright (C) 2013 Matthew Fluet. + # Copyright (C) 2009 Matthew Fluet. + # Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # Copyright (C) 1997-2000 NEC Research Institute. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +SRC := $(shell cd .. && pwd) +BUILD := $(SRC)/build +BIN := $(BUILD)/bin +LIB := $(BUILD)/lib/mlton +MLTON := mlton +TARGET := self +FLAGS := -target $(TARGET) \ + -default-ann 'sequenceNonUnit warn' \ + -default-ann 'warnUnused true' +NAME := benchmark +PATH := $(BIN):$(shell echo $$PATH) + +all: $(NAME) + +$(NAME): $(NAME).mlb $(shell PATH="$(BIN):$$PATH" && "$(MLTON)" -stop f $(NAME).mlb) + @echo 'Compiling $(NAME)' + "$(MLTON)" $(FLAGS) $(NAME).mlb + +.PHONY: clean +clean: + ../bin/clean + +BENCH := barnes-hut boyer checksum count-graphs DLXSimulator even-odd fft fib flat-array hamlet imp-for knuth-bendix lexgen life logic mandelbrot matrix-multiply md5 merge mlyacc model-elimination mpuz nucleic output1 peek psdes-random ratio-regions ray raytrace simple smith-normal-form string-concat tailfib tak tensor tsp tyan vector32-concat vector64-concat vector-rev vliw wc-input1 wc-scanStream zebra zern +FPBENCH := barnes-hut fft hamlet mandelbrot matrix-multiply nucleic ray raytrace simple tensor tsp tyan vliw zern + +BFLAGS := -mlton "/usr/bin/mlton" -mlton "mlton -optimize-ssa {false,true}" +BFLAGS := -wiki -mlton "/usr/bin/mlton" -mlkit -mosml -poly -smlnj +BFLAGS := -mlton "$(BIN)/mlton" + +.PHONY: test +test: $(NAME) + cd tests && ../benchmark $(BFLAGS) $(BENCH) + +QBENCH := $(BENCH) +QBFLAGS := -mlton "~/devel/mlton/builds/20171013.233239-g5513092e3/bin/mlton" +QBFLAGS += -mlton "~/devel/mlton/mlton.git/build/bin/mlton -cse-canon {ascHash,descHash,ascIndex,descIndex}" + +.PHONY: qtest +qtest: $(NAME) + cd tests && ../benchmark $(QBFLAGS) $(QBENCH) && $(MAKE) clean diff --git a/benchmark/benchmark.mlb b/benchmark/benchmark.mlb new file mode 100644 index 0000000..a2e430c --- /dev/null +++ b/benchmark/benchmark.mlb @@ -0,0 +1,12 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + sources.mlb +in + call-main.sml +end diff --git a/benchmark/call-main.sml b/benchmark/call-main.sml new file mode 100644 index 0000000..b5d050d --- /dev/null +++ b/benchmark/call-main.sml @@ -0,0 +1,9 @@ +(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +val _ = Main.main() diff --git a/benchmark/main.sml b/benchmark/main.sml new file mode 100644 index 0000000..2f9be18 --- /dev/null +++ b/benchmark/main.sml @@ -0,0 +1,697 @@ +(* Copyright (C) 2013,2014 Matthew Fluet. + * Copyright (C) 2009 Matthew Fluet. + * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +structure Main = +struct + +type int = Int.t + +fun usage msg = + Process.usage {usage = "[-mlkit] [-mlton ] [-mosml] [-poly] [-smlnj] bench1 bench2 ...", + msg = msg} + +val doOnce = ref false +val doWiki = ref false +val runArgs : string list ref = ref [] + +fun withInput (file, f: unit -> 'a): 'a = + let + open FileDesc + val inFd = + let + open Pervasive.Posix.FileSys + in + openf (file, O_RDONLY, O.flags []) + end + in + Exn.finally + (fn () => FileDesc.fluidLet (FileDesc.stdin, inFd, f), + fn () => FileDesc.close inFd) + end + +fun ignoreOutput f = + let + val nullFd = + let + open Pervasive.Posix.FileSys + in + openf ("/dev/null", O_WRONLY, O.flags []) + end + open FileDesc + in + Exn.finally + (fn () => fluidLet (stderr, nullFd, fn () => + fluidLet (stdout, nullFd, f)), + fn () => close nullFd) + end + +datatype command = + Explicit of {args: string list, + com: string} + | Shell of string list + +fun timeIt ca = + Process.time + (fn () => + case ca of + Explicit {args, com} => + Process.wait (Process.spawnp {file = com, args = com :: args}) + | Shell ss => List.foreach (ss, Process.system)) + +local + val trialTime = Time.seconds (IntInf.fromInt 60) +in + fun timeCall (com, args): real = + let + fun doit ac = + let + val {user, system} = timeIt (Explicit {args = args, com = com}) + val op + = Time.+ + in ac + user + system + end + fun loop (n, ac: Time.t): real = + if Time.> (ac, trialTime) + then Time.toReal ac / Real.fromInt n + else loop (n + 1, doit ac) + in + if !doOnce + then Time.toReal (doit Time.zero) + else loop (0, Time.zero) + end +end + +val benchCounts: (string * int) list = + ("barnes-hut", 24576):: (* 31.32 sec *) + ("boyer", 12288):: (* 40.77 sec *) + ("checksum", 8192):: (* 31.33 sec *) + ("count-graphs", 16):: (* 35.35 sec *) + ("DLXSimulator", 256):: (* 30.68 sec *) + ("even-odd", 24):: (* 37.76 sec *) + ("fft", 12):: (* 35.31 sec *) + ("fib", 12):: (* 30.48 sec *) + ("flat-array", 32768):: (* 35.03 sec *) + ("hamlet", 384):: (* 44.55 sec *) + ("imp-for", 3072):: (* 30.25 sec *) + ("knuth-bendix", 3072):: (* 37.84 sec *) + ("lexgen", 2048):: (* 34.41 sec *) + ("life", 32):: (* 37.98 sec *) + ("logic", 256):: (* 39.00 sec *) + ("mandelbrot", 6):: (* 38.49 sec *) + ("matrix-multiply", 128):: (* 30.01 sec *) + ("md5", 96):: (* 41.23 sec *) + ("merge", 16384):: (* 39.13 sec *) + ("mlyacc", 3072):: (* 37.48 sec *) + ("model-elimination", 4):: (* 39.14 sec *) + ("mpuz", 96):: (* 30.01 sec *) + ("nucleic", 4096):: (* 31.90 sec *) + ("output1", 12):: (* 33.01 sec *) + ("peek", 2048):: (* 35.93 sec *) + ("pidigits", 4096):: (* 36.27 sec *) + ("psdes-random", 24):: (* 40.57 sec *) + ("ratio-regions", 1536):: (* 45.14 sec *) + ("ray", 1536):: (* 42.18 sec *) + ("raytrace", 96):: (* 37.27 sec *) + ("simple", 768):: (* 36.10 sec *) + ("smith-normal-form", 192):: (* 41.93 sec *) + ("string-concat", 768):: (* 93.94 sec *) + ("tailfib", 512):: (* 35.36 sec *) + ("tak", 24):: (* 44.71 sec *) + ("tensor", 6):: (* 34.63 sec *) + ("tsp", 16):: (* 36.91 sec *) + ("tyan", 384):: (* 32.56 sec *) + ("vector32-concat", 96):: (* 79.84 sec *) + ("vector64-concat", 96):: + ("vector-rev", 64):: (* 32.16 sec *) + ("vliw", 768):: (* 30.51 sec *) + ("wc-input1", 24576):: (* 41.69 sec *) + ("wc-scanStream", 24576):: (* 30.55 sec *) + ("zebra", 64):: (* 33.44 sec *) + ("zern", 12288):: (* 33.59 sec *) + nil + +val benchCount = + String.memoize + (fn s => + case List.peek (benchCounts, fn (b, _) => b = s) of + NONE => Error.bug (concat ["no benchCount for ", s]) + | SOME (_, c) => Int.toString c) + +val default_main = (fn bench => concat ["val _ = Main.doit ", benchCount bench, "\n"]) + +fun compileSizeRun {command, exe, doTextPlusData: bool} = + Escape.new + (fn e => + let + val exe = "./" ^ exe + val {system, user} = timeIt command + handle _ => Escape.escape (e, {compile = NONE, + run = NONE, + size = NONE}) + val compile = SOME (Time.toReal (Time.+ (system, user))) + val size = + if doTextPlusData + then + let + val {text, data, ...} = Process.size exe + in SOME (Position.fromInt (text + data)) + end + else SOME (File.size exe) + val run = + timeCall (exe, !runArgs) + handle _ => Escape.escape (e, {compile = compile, + run = NONE, + size = size}) + in {compile = compile, + run = SOME run, + size = size} + end) + +fun batch_ {abbrv, bench} = + let + val abbrv = + String.translate + (abbrv, fn c => + if Char.isAlphaNum c + then String.fromChar c + else "_") + in + concat [bench, ".", abbrv, ".batch"] + end + +fun batch ab = + concat [batch_ ab, ".sml"] + +local + val n = Counter.new 0 +in + fun makeMLton commandPattern = + case ChoicePattern.expand commandPattern of + Result.No m => usage m + | Result.Yes cmds => + List.map + (cmds, fn cmd => + let + val abbrv = "MLton" ^ (Int.toString (Counter.next n)) + in + {name = cmd, + abbrv = abbrv, + main = default_main, + test = (fn {bench} => + let + val src = batch {abbrv = abbrv, bench = bench} + val exe = String.dropSuffix (src, 4) + val cmds = (concat [cmd, " -output ", exe, " ", src]):: + (*(concat ["strip ", exe])::*) + nil + in + compileSizeRun + {command = Shell cmds, + exe = exe, + doTextPlusData = true} + end)} + end) +end + +fun kitCompile {bench} = + let + val bargs = {abbrv = "MLKit", bench = bench} + val bin = batch_ bargs + in compileSizeRun + {command = Explicit {args = ["-o", bin, batch bargs], + com = "mlkit"}, + exe = bin, + doTextPlusData = true} + end + +fun mosmlCompile {bench} = + let + val bargs = {abbrv = "Moscow ML", bench = bench} + val bin = batch_ bargs + in compileSizeRun + {command = Explicit {args = ["-orthodox", "-standalone", "-toplevel", + "-o", bin, batch bargs], + com = "mosmlc"}, + exe = bin, + doTextPlusData = false} + end + + +val njSuffix = + Promise.delay + (fn () => + let + val sml = "sml" + val suffix = + File.withTemp + (fn tmp => + (File.withTempOut + (fn output => + Out.output + (output, concat ["val tmp = TextIO.openOut(\"", tmp, "\");\n", + "val _ = TextIO.output(tmp, SMLofNJ.SysInfo.getHeapSuffix());\n", + "val _ = TextIO.closeOut(tmp);\n"]), + fn input => + withInput + (input, fn () => + Process.wait (Process.spawnp {file = sml, args = [sml]}))) + ; In.withClose (In.openIn tmp, In.inputAll))) + in + suffix + end) + +fun njCompile {bench} = + Escape.new + (fn e => + let + (* sml should start SML/NJ *) + val sml = "sml" + val {system, user} = + File.withTempOut + (fn out => + (Out.output + (out, "local\nval _ = SMLofNJ.Internals.GC.messages false\n") + ; File.outputContents (concat [bench, ".sml"], out) + ; (Out.output + (out, + concat + ["in val _ = SMLofNJ.exportFn (\"", bench, + "\", fn _ => (Main.doit ", benchCount bench, + "; OS.Process.success))\nend\n"] + ))), + fn input => withInput (input, fn () => timeIt (Explicit {args = [], + com = sml}))) + handle _ => Escape.escape (e, {compile = NONE, + run = NONE, + size = NONE}) + val suffix = Promise.force njSuffix + val heap = concat [bench, ".", suffix] + in + if not (File.doesExist heap) + then {compile = NONE, + run = NONE, + size = NONE} + else + let + val compile = Time.toReal (Time.+ (user, system)) + val size = SOME (File.size heap) + val run = + timeCall (sml, [concat ["@SMLload=", heap]]) + handle _ => Escape.escape (e, {compile = SOME compile, + run = NONE, + size = size}) + in {compile = SOME compile, + run = SOME run, + size = size} + end + end) + +fun polyCompile {bench} = + let + val bargs = {abbrv = "Poly/ML", bench = bench} + val bin = batch_ bargs + in compileSizeRun + {command = Explicit {args = [batch bargs, "-o", bin], + com = "polyc"}, + exe = bin, + doTextPlusData = false} + end + +type 'a data = {bench: string, + compiler: string, + value: 'a} list + +fun main args = + let + val compilers: {name: string, + abbrv: string, + main: string -> string, + test: {bench: File.t} -> {compile: real option, + run: real option, + size: Position.int option}} list ref + = ref [] + fun pushCompiler compiler = List.push(compilers, compiler) + fun pushCompilers compilers' = compilers := (List.rev compilers') @ (!compilers) + + fun setData (switch, data, str) = + let + fun die () = usage (concat ["invalid -", switch, " argument: ", str]) + open Regexp + val numSave = Save.new () + val regexpSave = Save.new () + val re = seq [save (star digit, numSave), + char #",", + save (star any, regexpSave)] + val reC = compileDFA re + in + case Compiled.matchAll (reC, str) of + NONE => die () + | SOME match => + let + val num = Match.lookupString (match, numSave) + val num = case Int.fromString num of + NONE => die () + | SOME num => num + val regexp = Match.lookupString (match, regexpSave) + val (regexp, saves) = + case Regexp.fromString regexp of + NONE => die () + | SOME regexp => regexp + val save = if 0 <= num andalso num < Vector.length saves + then Vector.sub (saves, num) + else die () + val regexpC = compileDFA regexp + fun doit s = + Option.map + (Compiled.matchAll (regexpC, s), + fn match => Match.lookupString (match, save)) + in + data := SOME (str, doit) + end + end + val outData : (string * (string -> string option)) option ref = ref NONE + val setOutData = fn str => setData ("out", outData, str) + val errData : (string * (string -> string option)) option ref = ref NONE + val setErrData = fn str => setData ("err", errData, str) + (* Set the stack limit to its max, since mlkit segfaults on some benchmarks + * otherwise. + *) + val _ = + let + open MLton.Platform.OS + in + if host = Linux + then + let + open MLton.Rlimit + val {hard, ...} = get stackSize + in + set (stackSize, {hard = hard, soft = hard}) + end + else () + end + local + open Popt + in + val res = + parse + {switches = args, + opts = [("args", + SpaceString + (fn args => + runArgs := String.tokens (args, Char.isSpace))), + ("err", SpaceString setErrData), + ("mlkit", + None (fn () => pushCompiler + {name = "MLKit", + abbrv = "MLKit", + main = default_main, + test = kitCompile})), + ("mosml", + None (fn () => pushCompiler + {name = "Moscow ML", + abbrv = "Moscow ML", + main = default_main, + test = mosmlCompile})), + ("mlton", + SpaceString (fn arg => pushCompilers + (makeMLton arg))), + ("once", trueRef doOnce), + ("out", SpaceString setOutData), + ("poly", + None (fn () => pushCompiler + {name = "Poly/ML", + abbrv = "Poly/ML", + main = (fn bench => concat ["fun main _ = Main.doit ", benchCount bench, "\n"]), + test = polyCompile})), + ("smlnj", + None (fn () => pushCompiler + {name = "SML/NJ", + abbrv = "SML/NJ", + main = default_main, + test = njCompile})), + trace, + ("wiki", trueRef doWiki)]} + end + in + case res of + Result.No msg => usage msg + | Result.Yes benchmarks => + let + val compilers = List.rev (!compilers) + val base = #abbrv (hd compilers) + val _ = + let + open MLton.Signal + in + setHandler (Pervasive.Posix.Signal.pipe, Handler.ignore) + end + fun r2s n r = Real.format (r, Real.Format.fix (SOME n)) + val i2s = Int.toCommaString + val p2s = i2s o Position.toInt + val s2s = fn s => s + val failures = ref [] + fun show ({compiles, runs, sizes, errs, outs}, {showAll}) = + let + val out = Out.standard + val _ = + List.foreach + (compilers, fn {name, abbrv, ...} => + Out.output (out, concat [abbrv, " -- ", name, "\n"])) + val _ = + case !failures of + [] => () + | fs => + Out.output + (out, + concat ["WARNING: ", base, " failed on: ", + concat (List.separate (fs, ", ")), + "\n"]) + fun show (title, data: 'a data, toString, toStringHtml) = + let + val _ = Out.output (out, concat [title, "\n"]) + val compilers = + List.fold + (compilers, [], fn ({name = n, abbrv = a, ...}, ac) => + if showAll + orelse List.exists (data, fn {compiler = c', ...} => + a = c') + then (n, a) :: ac + else ac) + val benchmarks = + List.fold + (benchmarks, [], fn (b, ac) => + if showAll + orelse List.exists (data, fn {bench = b', ...} => + b = b') + then b :: ac + else ac) + fun rows toString = + ("benchmark" + :: List.revMap (compilers, fn (_, a) => a)) + :: (List.revMap + (benchmarks, fn b => + b :: (List.revMap + (compilers, fn (_, a) => + case (List.peek + (data, fn {bench = b', + compiler = c', ...} => + b = b' andalso a = c')) of + NONE => "*" + | SOME {value = v, ...} => + toString v)))) + open Justify + val () = + outputTable + (table {columnHeads = NONE, + justs = (Left :: + List.revMap (compilers, + fn _ => Right)), + rows = rows toString}, + out) + fun prow ns = + let + fun p s = Out.output (out, s) + in + case ns of + [] => raise Fail "bug" + | b :: ns => + (p "||" + ; p b + ; List.foreach (ns, fn n => + (p "||"; p n)) + ; p "||\n") + end + val _ = + if not (!doWiki) + then () + else + let + val rows = rows toStringHtml + in + prow (hd rows) + ; (List.foreach + (tl rows, + fn [] => raise Fail "bug" + | b :: r => + let + val b = + concat + ["[attachment:", + b, ".sml ", b, "]"] + in + prow (b :: r) + end)) + end + in + () + end + val bases = List.keepAll (runs, fn {compiler, ...} => + compiler = base) + val ratios = + List.fold + (runs, [], fn ({bench, compiler, value}, ac) => + if compiler = base andalso not showAll + then ac + else + {bench = bench, + compiler = compiler, + value = + case List.peek (bases, fn {bench = b, ...} => + bench = b) of + NONE => ~1.0 + | SOME {value = v, ...} => value / v} :: ac) + val _ = show ("run time ratio", ratios, r2s 2, r2s 1) + val _ = show ("size", sizes, p2s, p2s) + val _ = show ("compile time", compiles, r2s 2, r2s 2) + val _ = show ("run time", runs, r2s 2, r2s 2) + val _ = case !outData of + NONE => () + | SOME (out, _) => + show (concat ["out: ", out], outs, s2s, s2s) + val _ = case !errData of + NONE => () + | SOME (err, _) => + show (concat ["err: ", err], errs, s2s, s2s) + in () + end + val totalFailures = ref [] + val data = + List.fold + (benchmarks, {compiles = [], runs = [], sizes = [], + outs = [], errs = []}, + fn (bench, ac) => + let + val foundOne = ref false + val res = + List.fold + (compilers, ac, fn ({name, abbrv, main, test}, + ac as {compiles: real data, + runs: real data, + sizes: Position.int data, + outs: string data, + errs: string data}) => + if true + then + let + val _ = + File.withOut + (batch {abbrv = abbrv, bench = bench}, fn out => + (File.outputContents (concat [bench, ".sml"], out); + Out.output (out, (main bench)))) +(* + val outTmpFile = + File.tempName {prefix = "tmp", suffix = "out"} + val errTmpFile = + File.tempName {prefix = "tmp", suffix = "err"} +*) + val {compile, run, size} = + ignoreOutput + (fn () => test {bench = bench}) + val _ = + if name = base + andalso Option.isNone run + then List.push (failures, bench) + else () +(* + val out = + case !outData of + NONE => NONE + | SOME (_, doit) => + File.foldLines + (outTmpFile, NONE, fn (s, v) => + let val s = String.removeTrailing + (s, fn c => + Char.equals (c, Char.newline)) + in + case doit s of + NONE => v + | v => v + end) + val err = + case !errData of + NONE => NONE + | SOME (_, doit) => + File.foldLines + (errTmpFile, NONE, fn (s, v) => + let val s = String.removeTrailing + (s, fn c => + Char.equals (c, Char.newline)) + in + case doit s of + NONE => v + | v => v + end) + val _ = File.remove outTmpFile + val _ = File.remove errTmpFile +*) + val out = NONE + val err = NONE + fun add (v, ac) = + case v of + NONE => ac + | SOME v => + (foundOne := true + ; {bench = bench, + compiler = abbrv, + value = v} :: ac) + val ac = + {compiles = add (compile, compiles), + runs = add (run, runs), + sizes = add (size, sizes), + outs = add (out, outs), + errs = add (err, errs)} + val _ = show (ac, {showAll = false}) + val _ = Out.flush Out.standard + in + ac + end + else ac) + val _ = + if !foundOne + then () + else List.push (totalFailures, bench) + in + res + end) + val _ = show (data, {showAll = true}) + val totalFailures = !totalFailures + val _ = + if List.isEmpty totalFailures + then () + else (print ("The following benchmarks failed completely.\n") + ; List.foreach (totalFailures, fn s => + print (concat [s, "\n"]))) + in () + end + end + +val main = Process.makeMain main + +end diff --git a/benchmark/sources.mlb b/benchmark/sources.mlb new file mode 100644 index 0000000..58f22a8 --- /dev/null +++ b/benchmark/sources.mlb @@ -0,0 +1,14 @@ +(* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +local + ../lib/mlton/sources.mlb + main.sml +in + structure Main +end + diff --git a/benchmark/tests/.gitignore b/benchmark/tests/.gitignore new file mode 100644 index 0000000..b3a8d35 --- /dev/null +++ b/benchmark/tests/.gitignore @@ -0,0 +1,196 @@ +/ML_dbase +/PM +/a.out +/run + +/chess.ppm +/TEST + +/DLXSimulator +/DLXSimulator.*.batch +/DLXSimulator.*.batch.sml +/DLXSimulator.*-* +/barnes-hut +/barnes-hut.*.batch +/barnes-hut.*.batch.sml +/barnes-hut.*-* +/boyer +/boyer.*.batch +/boyer.*.batch.sml +/boyer.*-* +/checksum +/checksum.*.batch +/checksum.*.batch.sml +/checksum.*-* +/count-graphs +/count-graphs.*.batch +/count-graphs.*.batch.sml +/count-graphs.*-* +/even-odd +/even-odd.*.batch +/even-odd.*.batch.sml +/even-odd.*-* +/fft +/fft.*.batch +/fft.*.batch.sml +/fft.*-* +/fib +/fib.*.batch +/fib.*.batch.sml +/fib.*-* +/flat-array +/flat-array.*.batch +/flat-array.*.batch.sml +/flat-array.*-* +/fxp +/fxp.*.batch +/fxp.*.batch.sml +/fxp.*-* +/hamlet +/hamlet.*.batch +/hamlet.*.batch.sml +/hamlet.*-* +/imp-for +/imp-for.*.batch +/imp-for.*.batch.sml +/imp-for.*-* +/knuth-bendix +/knuth-bendix.*.batch +/knuth-bendix.*.batch.sml +/knuth-bendix.*-* +/lexgen +/lexgen.*.batch +/lexgen.*.batch.sml +/lexgen.*-* +/life +/life.*.batch +/life.*.batch.sml +/life.*-* +/logic +/logic.*.batch +/logic.*.batch.sml +/logic.*-* +/mandelbrot +/mandelbrot.*.batch +/mandelbrot.*.batch.sml +/mandelbrot.*-* +/matrix-multiply +/matrix-multiply.*.batch +/matrix-multiply.*.batch.sml +/matrix-multiply.*-* +/md5 +/md5.*.batch +/md5.*.batch.sml +/md5.*-* +/merge +/merge.*.batch +/merge.*.batch.sml +/merge.*-* +/mlyacc +/mlyacc.*.batch +/mlyacc.*.batch.sml +/mlyacc.*-* +/model-elimination +/model-elimination.*.batch +/model-elimination.*.batch.sml +/model-elimination.*-* +/mpuz +/mpuz.*.batch +/mpuz.*.batch.sml +/mpuz.*-* +/nucleic +/nucleic.*.batch +/nucleic.*.batch.sml +/nucleic.*-* +/output1 +/output1.*.batch +/output1.*.batch.sml +/output1.*-* +/peek +/peek.*.batch +/peek.*.batch.sml +/peek.*-* +/pidigits +/pidigits.*.batch +/pidigits.*.batch.sml +/pidigits.*-* +/psdes-random +/psdes-random.*.batch +/psdes-random.*.batch.sml +/psdes-random.*-* +/ratio-regions +/ratio-regions.*.batch +/ratio-regions.*.batch.sml +/ratio-regions.*-* +/ray +/ray.*.batch +/ray.*.batch.sml +/ray.*-* +/raytrace +/raytrace.*.batch +/raytrace.*.batch.sml +/raytrace.*-* +/simple +/simple.*.batch +/simple.*.batch.sml +/simple.*-* +/smith-normal-form +/smith-normal-form.*.batch +/smith-normal-form.*.batch.sml +/smith-normal-form.*-* +/string-concat +/string-concat.*.batch +/string-concat.*.batch.sml +/string-concat.*-* +/tailfib +/tailfib.*.batch +/tailfib.*.batch.sml +/tailfib.*-* +/tak +/tak.*.batch +/tak.*.batch.sml +/tak.*-* +/tensor +/tensor.*.batch +/tensor.*.batch.sml +/tensor.*-* +/tsp +/tsp.*.batch +/tsp.*.batch.sml +/tsp.*-* +/tyan +/tyan.*.batch +/tyan.*.batch.sml +/tyan.*-* +/vector32-concat +/vector32-concat.*.batch +/vector32-concat.*.batch.sml +/vector32-concat.*-* +/vector64-concat +/vector64-concat.*.batch +/vector64-concat.*.batch.sml +/vector64-concat.*-* +/vector-rev +/vector-rev.*.batch +/vector-rev.*.batch.sml +/vector-rev.*-* +/vliw +/vliw.*.batch +/vliw.*.batch.sml +/vliw.*-* +/wc-input1 +/wc-input1.*.batch +/wc-input1.*.batch.sml +/wc-input1.*-* +/wc-scanStream +/wc-scanStream.*.batch +/wc-scanStream.*.batch.sml +/wc-scanStream.*-* +/zebra +/zebra.*.batch +/zebra.*.batch.sml +/zebra.*-* +/zern +/zern.*.batch +/zern.*.batch.sml +/zern.*-* diff --git a/benchmark/tests/DATA/.gitignore b/benchmark/tests/DATA/.gitignore new file mode 100644 index 0000000..28c7844 --- /dev/null +++ b/benchmark/tests/DATA/.gitignore @@ -0,0 +1,6 @@ +/ml.lex.sml +/ml.grm.desc +/ml.grm.sig +/ml.grm.sml +/cmp.s +/tmp.s diff --git a/benchmark/tests/DATA/chess.gml b/benchmark/tests/DATA/chess.gml new file mode 100644 index 0000000..4eb81bb --- /dev/null +++ b/benchmark/tests/DATA/chess.gml @@ -0,0 +1,271 @@ +% chess.gml +% +% OUTPUTS: chess.ppm +% +%%% +%%% Author: +%%% Leif Kornstaedt +%%% +%%% Copyright: +%%% Leif Kornstaedt, 2000 +%%% +%%% Last change: +%%% $Date: 2000/09/04 22:34:00 $ by $Author: kornstae $ +%%% $Revision: 1.6 $ +%%% + +{ /y /x x x mulf y y mulf addf sqrt } /dist + +0.2 0.2 0.3 point /black1 +0.4 0.4 0.5 point /black2 +0.7 0.7 0.5 point /white1 +1.0 1.0 0.8 point /white2 + +%% +%% Surface functions +%% + +{ /col2 /col1 + { /v /u /face + face 0 eqi + { % rotational: stripes according to angle u + u 12.0 mulf floor 2 modi 1 eqi { col1 } { col2 } if + } + { % flat: rays according to angle from origin to (u, v) + u 0.5 subf /u v 0.5 subf /v + u u v dist apply divf /b + 0.0 v lessf { b asin } { 360.0 b asin subf } if 180.0 addf 30.0 divf + floor 2 modi 1 eqi { col1 } { col2 } if + } + if + 0.7 0.3 1.0 + } +} /figureSurface + +%% +%% Board +%% + +{ /v /u /face + 3 face lessi + { % top, bottom: checkered + 0 u 8.0 mulf floor v 8.0 mulf floor addi + } + { face 2 modi 0 eqi + { 0 } % front, left: striped black/white + { 1 } % back, right: striped white/black + if u 8.0 mulf floor + } if 2 modi eqi { black1 } { white2 } if + 0.4 0.6 0.5 +} cube -0.5 -1.0 -0.5 translate 8.0 0.3 8.0 scale /board + +%% +%% Pawns +%% + +{ /col2 /col1 + col1 col2 figureSurface apply /surface + surface sphere 0.0 1.0 0.0 translate + surface cylinder union + surface sphere 0.0 2.3 0.0 translate difference + surface sphere 0.8 uscale 0.0 2.5 0.0 translate union + 0.3 uscale +} /pawn + +white1 white2 pawn apply /whitePawn +black1 black2 pawn apply /blackPawn + +%% +%% Towers +%% + +{ /col2 /col1 + col1 col2 figureSurface apply /surface + col1 col1 figureSurface apply /surface1 + col2 col2 figureSurface apply /surface2 + % Base + surface cylinder 1.0 0.75 1.0 scale + % Wall + surface cone 0.0 -1.0 0.0 translate 180.0 rotatez 90.0 rotatey + 1.0 7.5 1.0 scale union + surface cylinder 1.0 2.8 1.0 scale intersect + % Platform + surface cylinder 0.0 3.0 0.0 translate union + % Viewholes + surface cylinder 0.7 4.0 0.7 scale + { /rot + surface1 plane 90.0 rotatex + surface2 plane -90.0 rotatex 30.0 rotatey intersect rot rotatey + } /apex + 15.0 apex apply 75.0 apex apply union 135.0 apex apply union + 195.0 apex apply union 255.0 apex apply union 315.0 apex apply union + surface cylinder intersect union + 0.0 3.5 0.0 translate difference + 0.4 uscale +} /tower + +white1 white2 tower apply /whiteTower +black1 black2 tower apply /blackTower + +%% +%% Knights +%% + +{ /col2 /col1 + col1 col2 figureSurface apply /surface + % Base + surface cylinder 1.0 0.75 1.0 scale + % Body + surface cone 180.0 rotatez 30.0 rotatey 0.0 1.0 0.0 translate + 1.0 5.0 1.0 scale + surface plane 0.0 3.0 0.0 translate intersect union + % Head + surface cone 1.0 3.0 1.0 scale 0.0 -1.0 0.0 translate + surface cylinder 1.0 2.0 1.0 scale intersect 0.0 -1.5 0.0 translate /head + head 1.25 1.0 1.25 scale 0.0 0.5 0.0 translate -90.0 rotatex + 0.0 3.2 0.0 translate difference + head 0.8 1.0 0.8 scale -90.0 rotatex 0.0 3.2 0.0 translate union + 0.4 uscale +} /knight + +white1 white2 knight apply /whiteKnight +black1 black2 knight apply 180.0 rotatey /blackKnight + +%% +%% Bishops +%% + +{ /col2 /col1 + col1 col2 figureSurface apply /surface + % Base + surface cylinder 1.0 0.75 1.0 scale + % Body + surface cone 180.0 rotatez 30.0 rotatey 0.0 1.0 0.0 translate + 1.0 5.0 1.0 scale + surface plane 0.0 3.0 0.0 translate intersect union + % Head + surface sphere 0.9 uscale 0.0 3.15 0.0 translate difference + surface sphere 0.8 uscale 0.0 3.25 0.0 translate union + 0.4 uscale +} /bishop + +white1 white2 bishop apply /whiteBishop +black1 black2 bishop apply /blackBishop + +%% +%% Queens +%% + +{ /col2 /col1 + col1 col2 figureSurface apply /surface + col1 col1 figureSurface apply /surface1 + col2 col2 figureSurface apply /surface2 + % Base + surface cylinder 1.0 0.75 1.0 scale + % Body + surface cone 180.0 rotatez 30.0 rotatey 0.0 1.0 0.0 translate + 1.0 7.5 1.0 scale + surface plane 0.0 4.0 0.0 translate intersect union + % Crown + 38.146 /phi + surface cylinder 1.0 2.0 1.0 scale + surface1 plane -90.0 phi subf rotatex + surface2 plane 90.0 phi addf rotatex intersect + -45.0 rotatez 1.0 0.0 0.0 translate /wedge + wedge wedge 60.0 rotatey union wedge 120.0 rotatey union + wedge 180.0 rotatey union wedge 240.0 rotatey union wedge 300.0 rotatey union + 0.0 1.0 0.0 translate difference + 0.6 0.25 0.6 scale 0.0 4.7 0.0 translate union + % Head + surface sphere 0.9 uscale 0.0 3.9 0.0 translate difference + surface sphere 0.8 uscale 0.0 4.0 0.0 translate union + 0.4 uscale +} /queen + +white1 white2 queen apply /whiteQueen +black1 black2 queen apply /blackQueen + +%% +%% Kings +%% + +{ /col2 /col1 + col1 col2 figureSurface apply /surface + col1 col1 figureSurface apply /surface1 + col2 col2 figureSurface apply /surface2 + % Base + surface cylinder 1.0 0.75 1.0 scale + % Body + surface cone 180.0 rotatez 30.0 rotatey 0.0 1.0 0.0 translate + 1.0 7.5 1.0 scale + surface plane 0.0 4.0 0.0 translate intersect union + % Crown + 38.146 /phi + surface cylinder 1.0 2.0 1.0 scale + surface1 plane -90.0 phi subf rotatex + surface2 plane 90.0 phi addf rotatex intersect + -45.0 rotatez 1.0 0.0 0.0 translate /wedge + wedge wedge 60.0 rotatey union wedge 120.0 rotatey union + wedge 180.0 rotatey union wedge 240.0 rotatey union wedge 300.0 rotatey union + 0.0 1.0 0.0 translate difference 0.6 0.25 0.6 scale + % Scepter + surface2 cube 0.1 0.7 0.1 scale + surface2 cube 0.6 0.1 0.1 scale -0.25 0.35 0.0 translate union + -0.05 0.4 -0.05 translate union + 0.0 4.7 0.0 translate union + % Head + surface sphere 0.9 uscale 0.0 3.9 0.0 translate difference + surface sphere 0.8 uscale 0.0 4.0 0.0 translate union + 0.4 uscale +} /king + +white1 white2 king apply /whiteKing +black1 black2 king apply /blackKing + +%% +%% The scene +%% + +board +whitePawn -3.5 0.0 -2.5 translate union +whitePawn -2.5 0.0 -2.5 translate union +whitePawn -1.5 0.0 -2.5 translate union +whitePawn -0.5 0.0 -2.5 translate union +whitePawn 0.5 0.0 -2.5 translate union +whitePawn 1.5 0.0 -2.5 translate union +whitePawn 2.5 0.0 -2.5 translate union +whitePawn 3.5 0.0 -2.5 translate union +whiteTower -3.5 0.0 -3.5 translate union +whiteTower 3.5 0.0 -3.5 translate union +whiteKnight -2.5 0.0 -3.5 translate union +whiteKnight 2.5 0.0 -3.5 translate union +whiteBishop -1.5 0.0 -3.5 translate union +whiteBishop 1.5 0.0 -3.5 translate union +whiteQueen -0.5 0.0 -3.5 translate union +whiteKing 0.5 0.0 -3.5 translate union +blackPawn -3.5 0.0 2.5 translate union +blackPawn -2.5 0.0 2.5 translate union +blackPawn -1.5 0.0 2.5 translate union +blackPawn -0.5 0.0 2.5 translate union +blackPawn 0.5 0.0 2.5 translate union +blackPawn 1.5 0.0 2.5 translate union +blackPawn 2.5 0.0 2.5 translate union +blackPawn 3.5 0.0 2.5 translate union +blackTower -3.5 0.0 3.5 translate union +blackTower 3.5 0.0 3.5 translate union +blackKnight -2.5 0.0 3.5 translate union +blackKnight 2.5 0.0 3.5 translate union +blackBishop -1.5 0.0 3.5 translate union +blackBishop 1.5 0.0 3.5 translate union +blackQueen -0.5 0.0 3.5 translate union +blackKing 0.5 0.0 3.5 translate union +30.0 rotatey -20.0 rotatex 0.4 uscale 0.3 0.0 3.0 translate + +%whiteTower -70.0 rotatex 0.0 0.0 4.0 translate + +/scene + +0.0 0.0 -1.0 point +1.0 1.0 1.0 point pointlight /l + +0.33 0.33 0.33 point [ l ] scene 3 60.0 400 300 "chess.ppm" render diff --git a/benchmark/tests/DATA/hamlet-input.sml b/benchmark/tests/DATA/hamlet-input.sml new file mode 100644 index 0000000..b12f292 --- /dev/null +++ b/benchmark/tests/DATA/hamlet-input.sml @@ -0,0 +1,9 @@ +datatype t = Z | S of t; +val zero = Z; +val one = S zero; +val two = S one; +val rec add: t * t -> t = fn (Z, n) => n | (S m, n) => S (add (m, n)); +val rec mul: t * t -> t = fn (Z, n) => Z | (S z, n) => add (n, mul (z, n)); +val four = mul (two, two); +val rec exp: t * t -> t = fn (n, Z) => one | (n, S m) => mul (n, exp (n, m)); +val _ = exp (exp (four, four), two); diff --git a/benchmark/tests/DATA/ml.grm b/benchmark/tests/DATA/ml.grm new file mode 100644 index 0000000..87dd332 --- /dev/null +++ b/benchmark/tests/DATA/ml.grm @@ -0,0 +1,732 @@ +(* Copyright 1989 by AT&T Bell Laboratories *) +open ErrorMsg Symbol Access Basics BasicTypes TypesUtil Absyn +open EnvAccess Misc CoreLang Signs Strs TyvarSet +fun fire a b c = (a(); b c) +fun markexp (e as MARKexp _, _, _) = e + | markexp(e,a,b) = if !System.Control.markabsyn + then MARKexp(e,a,b) else e +fun markdec((d as MARKdec _, e), _, _) = (d,e) + | markdec((d,e),a,b) = if !System.Control.markabsyn + then (MARKdec(d,a,b),e) else (d,e) + +fun markdec' d = + let val (d,e) = markdec d + in ([d],e) + end + +fun markdec'' (([d],e),a,b) = markdec'((d,e),a,b) + | markdec'' ((s,e),a,b) = markdec'((SEQdec s, e),a,b) + +fun markstr(f,a,b) $ = case f $ + of s as (MARKstr _,x,y) => s + | s as (t,x,y) => if !System.Control.markabsyn + then (MARKstr(t,a,b),x,y) else s + +infix \/ +val op \/ = union_tyvars + +fun V(_,vars) = vars and E(e,_) = e + +fun sequence (do1,do2) (env,a2,a3,a4) = + let val (r1,env1) = do1 (env,a2,a3,a4) + val (r2,env2) = do2 (Env.atop(env1,env),a2,a3,a4) + in (r1 @ r2, Env.atop(env2,env1)) + end + +fun sequence' (do1,do2) env = + let val (r1,env1) = do1 env + val (r2,env2) = do2 (Env.atop(env1,env)) + in (r1 @ r2, Env.atop(env2,env1)) + end + +fun seqdec (d,e) = ([d],e) + +%% +%term + EOF | SEMICOLON + | ID of string | TYVAR of string + | INT of int | INT0 of int | REAL of string | STRING of string + | ABSTRACTION | ABSTYPE | AND + | ARROW | AS | BAR | CASE | DATATYPE | DOTDOTDOT | ELSE | END | EQUAL + | EQTYPE | EXCEPTION | DO | DOT | DARROW | FN | FUN | FUNCTOR | HANDLE | HASH + | IF | IN | INCLUDE | INFIX | INFIXR | LET | LOCAL | NONFIX | OF | OP + | OPEN | OVERLOAD | QUERY | RAISE | REC | SHARING | SIG | SIGNATURE | STRUCT + | STRUCTURE | THEN | TYPE | VAL | WHILE | WILD | WITH | WITHTYPE | ASTERISK + | COLON | COMMA | LBRACE | LBRACKET | LPAREN | RBRACE | RBRACKET | RPAREN + | ORELSE | ANDALSO | IMPORT + +%nonterm ident of string + | id of string + | int of int + | op_op of unit susp + | opid of symbol enved + | qid of ((string->symbol) -> symbol list) + | qid_p0 of symbol list list + | selector of symbol + | tycon of symbol list + | tlabel of (symbol * ty) enved uvars + | tlabels of (symbol * ty) list enved uvars + | ty' of ty enved uvars + | tuple_ty of ty list enved uvars + | ty of ty enved uvars + | ty0_pc of ty list enved uvars + | match of rule list evstamped uvars + | rule of rule evstamped uvars + | elabel of (symbol * exp) evstamped uvars + | elabels of (symbol * exp) list evstamped uvars + | exp_ps of exp list evstamped uvars + | exp of exp evstamped uvars + | app_exp of exp precStack evstamped uvars + | aexp of exp evstamped uvars + | exp_list of exp list evstamped uvars + | exp_2c of exp list evstamped uvars + | pat of pat enved uvars + | pat' of pat enved uvars + | pat'' of pat enved uvars + | apat of (pat * fixity * complainer) enved uvars + | apat' of (pat * fixity * complainer) enved uvars + | apat'' of pat enved uvars + | plabel of (symbol * pat) enved uvars + | plabels of ((symbol * pat) list * bool) enved uvars + | pat_2c of pat list enved uvars + | pat_list of pat list enved uvars + | vb of vb list evstamped + | constraint of ty option enved uvars + | rvb of rawrvb list enved + | fb' of rawclause list enved uvars + | fb of rawclause list list enved uvars + | apats of (pat * fixity * complainer) list enved uvars + | clause' of (symbol * pat list) enved uvars + | clause of rawclause enved uvars + | tb of bool -> tb list withenv epathvstamped + | tyvars of tyvar list + | tyvar_pc of tyvar list + | db of (symbol * int * datacon list withenv epathed) list + | constrs of (Basics.env * ty -> (symbol * bool * ty) list) uvars + | constr of (Basics.env * ty -> symbol * bool * ty) uvars + | eb of eb list withenv epathvstamped uvars + | qid_p of structureVar list enved + | fixity of fixity + | ldec of dec withenv epathvstamped uvars + | exp_pa of exp list evstamped + | ldecs of dec withenv epathvstamped uvars + | ops of symbol list + | spec_s of spectype + | spec of spectype + | strspec of spectype + | tyspec of eqprop -> spectype + | valspec of spectype + | exnspec of spectype + | sharespec of spectype + | patheqn of (string->symbol) -> symbol list list + | sign of bool (* toplevel? *) * bool (* functor param? *) * + Structure (*param*) -> signtype + | sigconstraint_op of (Basics.env * Structure) -> Structure option + | sigb of signatureVar list withenv enved + | str of strtype + | sdecs of dec list withenv epathnstamped + | sdecs' of dec list withenv epathnstamped + | sdec of dec withenv epathnstamped + | strb of bool -> (symbol*structureVar*strb) list epathstamped + | fparam of functorFormal + | fctb of (symbol * functorVar * fctb) list enved + | importdec of string list + | interdec of dec withenv enved + +%pos int +%arg (error) : pos * pos -> ErrorMsg.severity -> string -> unit +%pure +%start interdec +%eop EOF SEMICOLON +%noshift EOF + +%nonassoc WITHTYPE +%right AND +%right ARROW +%right AS +%right DARROW +%left DO +%left ELSE +%left RAISE +%right HANDLE +%left ORELSE +%left ANDALSO +%left COLON + +%name ML + +%keyword ABSTRACTION ABSTYPE AND AS CASE DATATYPE DOTDOTDOT ELSE END + EQTYPE EXCEPTION DO DARROW FN FUN FUNCTOR HANDLE + IF IN INCLUDE INFIX INFIXR LET LOCAL NONFIX OF OP + OPEN OVERLOAD RAISE REC SHARING SIG SIGNATURE STRUCT + STRUCTURE THEN TYPE VAL WHILE WITH WITHTYPE + ORELSE ANDALSO IMPORT + +%subst EQUAL for DARROW | DARROW for EQUAL | ANDALSO for AND | OF for COLON + | COMMA for SEMICOLON | SEMICOLON for COMMA +%prefer VAL THEN ELSE LPAREN + +%value ID ("bogus") +%value TYVAR ("'bogus") +%value INT (1) +%value INT0 (0) +%value REAL ("0.0") +%value STRING ("") + +%% + +int : INT (INT) + | INT0 (INT0) + +id : ID (ID) + | ASTERISK ("*") + +ident : ID (ID) + | ASTERISK ("*") + | EQUAL ("=") + +op_op : OP (fn()=> error (OPleft,OPright) WARN "unnecessary `op'") + | (fn()=>()) + +opid : id (fn env => let val (v,f) = var'n'fix id + in case lookFIX env f of NONfix => () + | _ => error (idleft,idright) COMPLAIN + "nonfix identifier required"; + v + end) + | OP ident (fn _ => varSymbol ident) + +qid : ID DOT qid (fn kind => strSymbol ID :: qid kind) + | ident (fn kind => [kind ident]) + +selector: id (labSymbol id) + | INT (Symbol.labSymbol(makestring INT)) + +tycon : ID DOT tycon (strSymbol ID :: tycon) + | ID ([tycSymbol ID]) + +tlabel : selector COLON ty (fn $ =>(selector, E ty $), V ty) + +tlabels : tlabel COMMA tlabels (fn $ => E tlabel $ :: E tlabels $, + V tlabel \/ V tlabels) + | tlabel (fn $ => [E tlabel $], V tlabel) + +ty' : TYVAR (let val tyv = mkTyvar(mkUBOUND(tyvSymbol TYVAR)) + in (fn _ => VARty tyv, singleton_tyvar tyv) + end) + | LBRACE tlabels + RBRACE (fn $ => make_recordTy(E tlabels $, + error(LBRACEleft,RBRACEright)), + V tlabels) + | LBRACE RBRACE (fn _ => make_recordTy(nil, + error(LBRACEleft,RBRACEright)), + no_tyvars) + | LPAREN ty0_pc + RPAREN tycon (fn env =>let val ts = E ty0_pc env + in CONty(lookPathArTYC env + (tycon,length ts, + error (tyconleft,tyconright) COMPLAIN), + ts) + end, + V ty0_pc) + | LPAREN ty RPAREN (ty) + | ty' tycon (fn env =>CONty(lookPathArTYC env (tycon,1, + error(tyconleft,tyconright)COMPLAIN), + [E ty' env]), + V ty') + | tycon (fn env =>CONty(lookPathArTYC env (tycon, 0, + error(tyconleft,tyconright)COMPLAIN),[]), + no_tyvars) + +tuple_ty : ty' ASTERISK + tuple_ty (fn $ => E ty' $ :: E tuple_ty $, + V ty' \/ V tuple_ty) + | ty' ASTERISK + ty' (fn $ =>[E ty'1 $, E ty'2 $], V ty'1 \/ V ty'2) + +ty : tuple_ty (fn $ =>tupleTy(E tuple_ty $), V tuple_ty) + | ty ARROW ty (fn $ =>CONty(arrowTycon, [E ty1 $, E ty2 $]), + V ty1 \/ V ty2) + | ty' (ty') + +ty0_pc : ty COMMA ty (fn $ => [E ty1 $, E ty2 $], V ty1 \/ V ty2) + | ty COMMA + ty0_pc (fn $ => E ty $ :: E ty0_pc $, V ty \/ V ty0_pc) + +match : rule (fn evst => [E rule evst], V rule) + | rule BAR + match (fn evst => E rule evst :: E match evst, + V rule \/ V match) + +rule : pat DARROW + exp (makeRULE(E pat, fn $ => markexp(E exp $,expleft,expright), + error(patleft,patright)), + V pat \/ V exp) + + +elabel : selector EQUAL + exp (fn evst => (selector,E exp evst), V exp) + +elabels : elabel COMMA + elabels (fn evst => (E elabel evst :: E elabels evst), + V elabel \/ V elabels) + | elabel (fn evst => [E elabel evst], V elabel) + +exp_ps : exp (fn st => [E exp st], V exp) + | exp SEMICOLON + exp_ps (fn st => E exp st :: E exp_ps st, V exp \/ V exp_ps) + +exp : exp HANDLE + match (fn st=> makeHANDLEexp(E exp st, E match st), + V exp \/ V match) + + | exp ORELSE exp + (fn st=> ORELSEexp(markexp(E exp1 st, exp1left,exp1right), + markexp(E exp2 st,exp2left,expright)), + V exp1 \/ V exp2) + | exp ANDALSO exp + (fn st=> ANDALSOexp(markexp(E exp1 st,exp1left,exp1right), + markexp(E exp2 st,exp2left,exp2right)), + V exp1 \/ V exp2) + | exp COLON ty (fn (st as (env,_,_))=> CONSTRAINTexp(E exp st, + E ty env), + V exp \/ V ty) + | app_exp (fn st=> exp_finish(E app_exp st, + error(app_expright,app_expright)), + V app_exp) + + | FN match (fn st=> markexp(FNexp(completeMatch(E match st)), + FNleft,matchright), + V match) + | CASE exp + OF match (fn st=>markexp(CASEexp(E exp st, + completeMatch(E match st)), + CASEleft,matchright), + V exp \/ V match) + | WHILE exp + DO exp (fn st=> WHILEexp(E exp1 st, + markexp(E exp2 st,exp2left,exp2right)), + V exp1 \/ V exp2) + | IF exp THEN exp + ELSE exp (fn st=>IFexp(E exp1 st, + markexp(E exp2 st,exp2left,exp2right), + markexp(E exp3 st,exp3left,exp3right)), + V exp1 \/ V exp2 \/ V exp3) + | RAISE exp (fn st=>markexp(RAISEexp(E exp st),RAISEleft,expright), + V exp) + +app_exp : aexp (fn st => exp_start(markexp(E aexp st, aexpleft,aexpright), + NONfix, + error (aexpleft,aexpright)), + V aexp) + | ident (fn (env,_,_) => + let val e = error(identleft,identright) + val (v,f) = var'n'fix ident + in exp_start(markexp(lookID env (v,e), + identleft,identright), + lookFIX env f, e) + end, + no_tyvars) + | app_exp aexp (fn st => exp_parse(E app_exp st, + markexp(E aexp st, aexpleft,aexpright), + NONfix, + error (aexpleft,aexpright)), + V app_exp \/ V aexp) + | app_exp ident (fn (st as (env,_,_)) => + let val e = error(identleft,identright) + val (v,f) = var'n'fix ident + in exp_parse(E app_exp st, + markexp(lookID env (v,e), + identleft,identright), + lookFIX env f, e) + end, + V app_exp) + +aexp : OP ident (fn (env,_,_) => lookID env (varSymbol ident, error(identleft,identright)), + no_tyvars) + | ID DOT qid (fn (env,_,_) => + varcon(lookPathVARCON env (strSymbol ID + ::(qid varSymbol), + error(IDleft,qidright)COMPLAIN)), + no_tyvars) + | int (fn st => INTexp int, no_tyvars) + | REAL (fn st => REALexp REAL, no_tyvars) + | STRING (fn st => STRINGexp STRING, no_tyvars) + | HASH selector (fn st => SELECTORexp selector, no_tyvars) + | LBRACE elabels RBRACE (fn st=> makeRECORDexp(E elabels st, + error(LBRACEleft,RBRACEright)), + V elabels) + | LBRACE RBRACE (fn st=> RECORDexp nil, no_tyvars) + | LPAREN RPAREN (fn st=> unitExp, no_tyvars) + | LPAREN exp_ps RPAREN (fn st=> SEQexp(E exp_ps st), V exp_ps) + | LPAREN exp_2c RPAREN (fn st=> TUPLEexp(E exp_2c st), V exp_2c) + | LBRACKET exp_list + RBRACKET (fn st=> LISTexp(E exp_list st), V exp_list) + | LBRACKET RBRACKET (fn st=> nilExp, no_tyvars) + | LET ldecs + IN exp_ps END (fn (env,tv,st) => + let val (d,env') = E ldecs(env,[],tv,st) + val e = E exp_ps (Env.atop(env',env),tv,st) + in markexp(LETexp(d,SEQexp e), + LETleft,ENDright) + end, + V exp_ps \/ V ldecs) + +exp_2c : exp COMMA exp_2c (fn st=> E exp st :: E exp_2c st, + V exp \/ V exp_2c) + | exp COMMA exp (fn st=> [E exp1 st, E exp2 st], + V exp1 \/ V exp2) + +exp_list : exp (fn st=> [E exp st], V exp) + | exp COMMA exp_list (fn st=> E exp st :: E exp_list st, + V exp \/ V exp_list) + +pat : pat' (pat') + | apat apats (fn $ => make_app_pat(E apat $ ::E apats $), + V apat \/ V apats) + +pat' : pat AS pat (fn $ => layered(E pat1 $, E pat2 $, + error(pat1left,pat1right)), + V pat1 \/ V pat2) + | pat'' (pat'') + +pat'' : apat apats + COLON ty (fn env => CONSTRAINTpat( + make_app_pat(E apat env ::E apats env), + E ty env), + V apat \/ V apats \/ V ty) + | pat'' COLON ty (fn env => CONSTRAINTpat(E pat'' env, E ty env), + V pat'' \/ V ty) + +apat : apat' (apat') + | LPAREN pat RPAREN (fn $ =>(E pat $,NONfix,error(LPARENleft,RPARENright)), + V pat) + +apat' : apat'' (fn $ =>(E apat'' $,NONfix,error(apat''left,apat''right)), + V apat'') + | id (fn env => + let val e = error(idleft,idright) + val (v,f) = var'n'fix id + in (pat_id env v, lookFIX env f, e) + end, + no_tyvars) + | LPAREN RPAREN (fn _ =>(unitPat,NONfix, + error(LPARENleft,RPARENright)), + no_tyvars) + | LPAREN pat COMMA + pat_list RPAREN (fn $ =>(TUPLEpat(E pat $ ::E pat_list $), + NONfix,error(LPARENleft,RPARENright)), + V pat \/ V pat_list) + + +apat'' : OP ident (fn env =>pat_id env(varSymbol ident), no_tyvars) + | ID DOT qid (fn env =>qid_pat env (strSymbol ID :: qid varSymbol, + error(IDleft,qidright)), + no_tyvars) + | int (fn _ =>INTpat int, no_tyvars) + | REAL (fn _ =>REALpat REAL, no_tyvars) + | STRING (fn _ =>STRINGpat STRING, no_tyvars) + | WILD (fn _ =>WILDpat, no_tyvars) + | LBRACKET RBRACKET (fn _ =>LISTpat nil, no_tyvars) + | LBRACKET pat_list + RBRACKET (fn $ =>LISTpat(E pat_list $), V pat_list) + | LBRACE RBRACE (fn _ =>makeRECORDpat((nil,false), + error(LBRACEleft,RBRACEright)), + no_tyvars) + | LBRACE plabels RBRACE (fn $ =>makeRECORDpat(E plabels $, + error(LBRACEleft,RBRACEright)), + V plabels) + +plabel : selector EQUAL pat (fn $ => (selector,E pat $), V pat) + | ID (fn env => (labSymbol ID, pat_id env(varSymbol ID)), no_tyvars) + | ID AS pat (fn env => (labSymbol ID, LAYEREDpat(pat_id env (varSymbol ID), + E pat env)), + V pat) + | ID COLON ty (fn env => (labSymbol ID, CONSTRAINTpat(pat_id env (varSymbol ID), + E ty env)), + V ty) + | ID COLON ty AS pat (fn env => (labSymbol ID, LAYEREDpat(CONSTRAINTpat( + pat_id env (varSymbol ID), + E ty env), E pat env)), + V ty \/ V pat) + +plabels : plabel COMMA + plabels (fn $ =>let val (a,(b,fx))=(E plabel $,E plabels $) + in (a::b, fx) + end, + V plabel \/ V plabels) + | plabel (fn $ => ([E plabel $],false), V plabel) + | DOTDOTDOT (fn _ => (nil, true), no_tyvars) + +pat_list: pat (fn $ => [E pat $], V pat) + | pat COMMA pat_list (fn $ => E pat $ :: E pat_list $, + V pat \/ V pat_list) + +vb : vb AND vb (fn st=> vb1 st @ vb2 st) + | pat EQUAL exp (valbind(pat, exp)) + +constraint : (fn _ =>NONE, no_tyvars) + | COLON ty (fn env =>SOME(E ty env), V ty) + +rvb : opid constraint + EQUAL FN match (fn env =>[{name=opid env, + ty=constraint,match=match}]) + | rvb AND rvb (fn env => (rvb1 env) @ (rvb2 env)) + +fb' : clause (fn $ =>[E clause $], V clause) + | clause BAR fb' (fn $ =>E clause $ ::E fb' $, V clause \/ V fb') + +fb : fb' (fn $ => [checkFB(E fb' $,error(fb'left,fb'right))], + V fb') + | fb' AND fb (fn $ => + checkFB(E fb' $,error(fb'left,fb'right)) :: E fb $, V fb' \/ V fb) + +clause' : LPAREN apat apats + RPAREN apats (fn $ =>makecl(E apat $ ::E apats1 $,E apats2 $), + V apat \/ V apats1 \/ V apats2) + | LPAREN pat' + RPAREN apats (fn $ =>makecl([],(E pat' $,NONfix, + error(LPARENleft,RPARENright)) + ::E apats $), + V pat' \/ V apats) + | apat' apats (fn $ =>makecl([],E apat' $ ::E apats $), + V apat' \/ V apats) + +apats : (fn _ =>nil, no_tyvars) + | apat apats (fn $ => E apat $ ::E apats $, + V apat \/ V apats) + +clause : clause' constraint + EQUAL exp (fn env => + let val (id,pats) = E clause' env + in {name=id,pats=pats, + resultty=E constraint env, + exp=fn $ => markexp(E exp $,expleft,expright), + err=error(clause'left,clause'right)} + end, + V clause' \/ V constraint \/ V exp) + +tb : tyvars ID EQUAL ty (makeTB(tyvars, tycSymbol ID, ty, + error(tyleft,tyright))) + | tb AND tb (fn nw => sequence(tb1 nw,tb2 nw)) + +tyvars : TYVAR ([mkTyvar(mkUBOUND(tyvSymbol TYVAR))]) + | LPAREN tyvar_pc RPAREN (checkUniq(error(tyvar_pcleft,tyvar_pcright), + "duplicate type variable") + (List.map(fn ref(UBOUND{name,...})=>name) + tyvar_pc); + tyvar_pc) + | (nil) + +tyvar_pc: TYVAR ([mkTyvar(mkUBOUND(tyvSymbol TYVAR))]) + | TYVAR COMMA tyvar_pc (mkTyvar(mkUBOUND(tyvSymbol TYVAR)) :: tyvar_pc) + +db : db AND db (db1 @ db2) + | tyvars ident EQUAL constrs (let val name = tycSymbol ident + in [(name,length tyvars, + makeDB'(tyvars,name,constrs, + error(constrsleft,constrsright)))] + end) + +constrs : constr (fn $ => [E constr $], V constr) + | constr BAR constrs (fn $ => E constr $ :: E constrs $, + V constr \/ V constrs) + +constr : op_op ident (fire op_op (fn(_,t)=> (varSymbol ident,true,t)), + no_tyvars) + | op_op ident OF ty (fire op_op (fn(env,t)=> (varSymbol ident,false, + CONty(arrowTycon,[E ty env, t]))), + V ty) + +eb : op_op ident (fire op_op (makeEB(varSymbol ident)), no_tyvars) + | op_op ident OF ty (fire op_op (makeEBof(varSymbol ident,E ty, + error(tyleft,tyright))), + V ty) + | op_op ident EQUAL qid (fire op_op (makeEBeq(varSymbol ident,qid varSymbol, + error(qidleft,qidright))), + no_tyvars) + | eb AND eb (sequence(E eb1,E eb2), + V eb1 \/ V eb2) + +qid_p0 : qid ([qid strSymbol]) + | qid qid_p0 (qid strSymbol :: qid_p0) + +qid_p : qid (fn env => [getSTRpath env (qid strSymbol,error(qidleft,qidright))]) + | qid qid_p (fn env => getSTRpath env (qid strSymbol,error(qidleft,qidright)) :: qid_p env) + +fixity : INFIX (infixleft 0) + | INFIX int (infixleft int) + | INFIXR (infixright 0) + | INFIXR int (infixright int) + | NONFIX (NONfix) + +ldec : VAL vb (makeVALdec(vb,error(vbleft,vbright)), + no_tyvars) + | VAL REC rvb (makeVALRECdec (rvb,error(rvbleft,rvbright)), + no_tyvars) + | FUN fb (makeFUNdec fb, no_tyvars) + | TYPE tb ((fn $ => makeTYPEdec(tb true $, + error(tbleft,tbright))), + no_tyvars) + | DATATYPE db (makeDB(db, nullTB), no_tyvars) + | DATATYPE db + WITHTYPE tb (makeDB(db,tb), no_tyvars) + | ABSTYPE db + WITH ldecs END (makeABSTYPEdec(db,nullTB,E ldecs),V ldecs) + | ABSTYPE db + WITHTYPE tb + WITH ldecs END (makeABSTYPEdec(db,tb,E ldecs),V ldecs) + | EXCEPTION eb ((fn $ => makeEXCEPTIONdec(E eb $, + error(ebleft,ebright))), + V eb) + | OPEN qid_p (makeOPENdec qid_p, no_tyvars) + | fixity ops (makeFIXdec(fixity,ops), no_tyvars) + | OVERLOAD ident COLON + ty AS exp_pa (makeOVERLOADdec(varSymbol ident,ty,exp_pa), + no_tyvars) + +exp_pa : exp (fn st => [E exp st]) + | exp AND exp_pa (fn st => E exp st :: exp_pa st) + +ldecs : (fn $ => (SEQdec nil,Env.empty), no_tyvars) + | ldec ldecs (makeSEQdec(fn $ => markdec(E ldec $,ldecleft,ldecright), + E ldecs), + V ldec \/ V ldecs) + | SEMICOLON ldecs (ldecs) + | LOCAL ldecs + IN ldecs END ldecs (makeSEQdec(fn $ => + markdec(makeLOCALdec(E ldecs1,E ldecs2) $, + LOCALleft,ENDright), + E ldecs3), + V ldecs1 \/ V ldecs2 \/ V ldecs3) + +ops : ident ([fixSymbol ident]) + | ident ops (fixSymbol ident :: ops) + +spec_s : (fn $ => nil) + | spec spec_s (fn $ => spec $ @ spec_s $) + | SEMICOLON spec_s (spec_s) + +spec : STRUCTURE strspec (strspec) + | DATATYPE db (make_dtyspec db) + | TYPE tyspec (tyspec UNDEF) + | EQTYPE tyspec (tyspec YES) + | VAL valspec (valspec) + | EXCEPTION exnspec (exnspec) + | fixity ops (make_fixityspec(fixity,ops)) + | SHARING sharespec (sharespec) + | OPEN qid_p0 (make_openspec(qid_p0, + error(OPENleft,qid_p0right))) + | LOCAL spec_s + IN spec_s END (fn $ => (spec_s1 $; + error(spec_s1left,spec_s1right) WARN + "LOCAL specs are only partially implemented"; + spec_s2 $)) + | INCLUDE ident (make_includespec (sigSymbol ident,error(identleft,identright))) + +strspec : strspec AND strspec (fn $ => strspec1 $ @ strspec2 $) + | ident COLON sign (make_strspec(strSymbol ident, sign(false,false,NULLstr))) + +tyspec : tyspec AND tyspec (fn eq => fn $ => + tyspec1 eq $ @ tyspec2 eq $) + | tyvars ID (fn eq => make_tyspec(eq,tyvars,tycSymbol ID, + error(tyvarsleft,IDright))) + +valspec : valspec AND valspec (fn $ => valspec1 $ @ valspec2 $) + | op_op ident COLON ty (fire op_op (make_valspec(varSymbol ident,ty))) + +exnspec : exnspec AND exnspec (fn $ => exnspec1 $ @ exnspec2 $) + | ident (make_exnspec(varSymbol ident)) + | ident OF ty (make_exnspecOF (varSymbol ident,ty)) + +sharespec: sharespec AND + sharespec (fn $ => sharespec1 $ @ sharespec2 $) + | TYPE patheqn (make_type_sharespec(patheqn tycSymbol)) + | patheqn (make_str_sharespec(patheqn strSymbol)) + +patheqn: qid EQUAL qid (fn kind => [qid1 kind, qid2 kind]) + | qid EQUAL patheqn (fn kind => qid kind :: patheqn kind) + +sign : ID (makeSIGid(sigSymbol ID,error(IDleft,IDright))) + | SIG spec_s END (makeSIG(spec_s,error(spec_sleft,spec_sright))) + +sigconstraint_op : (fn _ => NONE) + | COLON sign (fn (env,param) => + SOME(sign(true,false,param) (env,Stampset.newStampsets()))) + +sigb : sigb AND sigb (sequence'(sigb1,sigb2)) + | ident EQUAL sign (make_sigb(sigSymbol ident, sign(true,false,NULLstr))) + +str : qid (markstr(make_str_qid(qid strSymbol, + error(qidleft,qidright)),qidleft,qidright)) + | STRUCT sdecs END (markstr(make_str_struct(sdecs, + error(STRUCTleft,ENDright)), + STRUCTleft,ENDright)) + | ID LPAREN sdecs + RPAREN (markstr(make_str_app(fctSymbol ID,error(IDleft,IDright), + (fn $ => let val (s,s')=spread_args sdecs $ + in (MARKstr(s,sdecsleft,sdecsright) + ,s') + end)),IDleft,RPARENright)) + | ID LPAREN str RPAREN (markstr(make_str_app(fctSymbol ID,error(IDleft,IDright), + single_arg str),IDleft,RPARENright)) + | LET sdecs IN str END (markstr(make_str_let(sdecs,str),LETleft,ENDright)) + +sdecs : sdec sdecs (sequence(fn $ => markdec'(sdec $,sdecleft, + sdecright), + sdecs)) + | SEMICOLON sdecs (sdecs) + | LOCAL sdecs IN sdecs + END sdecs (sequence(fn $ => markdec''(makeLOCALsdecs(sdecs1,sdecs2) $,LOCALleft,ENDright), + sdecs3)) + | (fn $ => (nil,Env.empty)) + +sdecs' : sdec sdecs' (sequence(fn $ => markdec'(sdec $,sdecleft,sdecright), + sdecs')) + | LOCAL sdecs IN sdecs + END sdecs' (sequence(fn $ => + markdec''(makeLOCALsdecs(sdecs1,sdecs2) $, + LOCALleft,ENDright), + sdecs')) + + | LOCAL sdecs IN sdecs + END (fn $ => markdec''(makeLOCALsdecs(sdecs1,sdecs2) $,LOCALleft,ENDright)) + + | sdec (fn $ => seqdec(markdec(sdec $,sdecleft,sdecright))) + +sdec : STRUCTURE strb (makeSTRBs(strb false)) + | ABSTRACTION strb (makeSTRBs(strb true)) + | SIGNATURE sigb (makeSIGdec(sigb,error(SIGNATUREleft,sigbright))) + | FUNCTOR fctb (makeFCTdec(fctb,error(FUNCTORleft,fctbright))) + | ldec (fn (env,pa,top,st) => + let val (dec,env') = markdec(E ldec(env,pa,no_tyvars,st),ldecleft,ldecright) + in Typecheck.decType(Env.atop(env',env),dec,top,error, + (ldecleft,ldecright)); + (dec,env') + end) + +strb : ident sigconstraint_op + EQUAL str (makeSTRB(strSymbol ident,sigconstraint_op,str, + error(sigconstraint_opleft,sigconstraint_opright))) + | strb AND strb (fn a => fn $ => strb1 a $ @ strb2 a $) + +fparam : ID COLON sign (single_formal(strSymbol ID, sign(true,true,NULLstr))) + | spec_s (spread_formal(spec_s, + error(spec_sleft,spec_sright))) + +fctb : ident LPAREN fparam RPAREN + sigconstraint_op EQUAL str (makeFCTB(fctSymbol ident,fparam, + sigconstraint_op,str, + error(strleft,strright))) + | fctb AND fctb (fn $ => fctb1 $ @ fctb2 $) + +importdec: STRING ([STRING]) + | STRING importdec (STRING :: importdec) + +interdec: sdecs' (fn env=> let val (s,e)= sdecs'(env,[],true,Stampset.globalStamps) + in markdec((SEQdec s,e),sdecs'left,sdecs'right) + end) + | IMPORT importdec (fn env =>(IMPORTdec importdec,env)) + | exp (fn env=>markdec(toplevelexp(env,exp,error,(expleft,expright)), + expleft,expright)) + diff --git a/benchmark/tests/DATA/ml.lex b/benchmark/tests/DATA/ml.lex new file mode 100644 index 0000000..645f147 --- /dev/null +++ b/benchmark/tests/DATA/ml.lex @@ -0,0 +1,173 @@ +(* Copyright 1989 by AT&T Bell Laboratories *) +open ErrorMsg +type svalue = Tokens.svalue +type pos = int +type lexresult = (svalue,pos) Tokens.token +type lexarg = {comLevel : int ref, + lineNum : int ref, + linePos : int list ref, (* offsets of lines in file *) + charlist : string list ref, + stringstart : int ref, (* start of current string or comment*) + err : pos*pos -> ErrorMsg.severity -> string->unit} +type arg = lexarg +type ('a,'b) token = ('a,'b) Tokens.token +val eof = fn ({comLevel,err,linePos,stringstart,lineNum,charlist}:lexarg) => + let val pos = Integer.max(!stringstart+2, hd(!linePos)) + in if !comLevel>0 then err (!stringstart,pos) COMPLAIN + "unclosed comment" + else (); + Tokens.EOF(pos,pos) + end +fun addString (charlist,s:string) = charlist := s :: (!charlist) +fun makeString charlist = (implode(rev(!charlist)) before charlist := nil) +fun makeHexInt sign s = let + fun digit d = if (d < Ascii.uc_a) then (d - Ascii.zero) + else (10 + (if (d < Ascii.lc_a) then (d - Ascii.uc_a) else (d - Ascii.lc_a))) + in + revfold (fn (c,a) => sign(a*16, digit(ord c))) (explode s) 0 + end +fun makeInt sign s = + revfold (fn (c,a) => sign(a*10, ord c - Ascii.zero)) (explode s) 0 +%% +%s A S F; +%header (functor MLLexFun(structure Tokens : ML_TOKENS)); +%arg ({comLevel,lineNum,err,linePos,charlist,stringstart}); +idchars=[A-Za-z'_0-9]; +id=[A-Za-z'_]{idchars}*; +ws=("\012"|[\t\ ])*; +sym=[!%&$+/:<=>?@~|#*`]|\\|\-|\^; +num=[0-9]+; +frac="."{num}; +exp="E"(~?){num}; +real=(~?)(({num}{frac}?{exp})|({num}{frac}{exp}?)); +hexnum=[0-9a-fA-F]+; +%% +{ws} => (continue()); +\n => (inc lineNum; linePos := yypos :: !linePos; continue()); +"*" => (Tokens.ASTERISK(yypos,yypos+1)); +"|" => (Tokens.BAR(yypos,yypos+1)); +":" => (Tokens.COLON(yypos,yypos+1)); +"=" => (Tokens.EQUAL(yypos,yypos+1)); +"_" => (Tokens.WILD(yypos,yypos+1)); +"#" => (Tokens.HASH(yypos,yypos+1)); +"," => (Tokens.COMMA(yypos,yypos+1)); +"{" => (Tokens.LBRACE(yypos,yypos+1)); +"}" => (Tokens.RBRACE(yypos,yypos+1)); +"[" => (Tokens.LBRACKET(yypos,yypos+1)); +"]" => (Tokens.RBRACKET(yypos,yypos+1)); +";" => (Tokens.SEMICOLON(yypos,yypos+1)); +"(" => (Tokens.LPAREN(yypos,yypos+1)); +")" => (Tokens.RPAREN(yypos,yypos+1)); +"and" => (Tokens.AND(yypos,yypos+3)); +"abstraction" => (Tokens.ABSTRACTION(yypos,yypos+11)); +"abstype" => (Tokens.ABSTYPE(yypos,yypos+7)); +"->" => (Tokens.ARROW(yypos,yypos+2)); +"as" => (Tokens.AS(yypos,yypos+2)); +"case" => (Tokens.CASE(yypos,yypos+4)); +"datatype" => (Tokens.DATATYPE(yypos,yypos+8)); +"." => (Tokens.DOT(yypos,yypos+1)); +"..." => (Tokens.DOTDOTDOT(yypos,yypos+3)); +"else" => (Tokens.ELSE(yypos,yypos+4)); +"end" => (Tokens.END(yypos,yypos+3)); +"eqtype" => (Tokens.EQTYPE(yypos,yypos+6)); +"exception" => (Tokens.EXCEPTION(yypos,yypos+9)); +"do" => (Tokens.DO(yypos,yypos+2)); +"=>" => (Tokens.DARROW(yypos,yypos+2)); +"fn" => (Tokens.FN(yypos,yypos+2)); +"fun" => (Tokens.FUN(yypos,yypos+3)); +"functor" => (Tokens.FUNCTOR(yypos,yypos+7)); +"handle" => (Tokens.HANDLE(yypos,yypos+6)); +"if" => (Tokens.IF(yypos,yypos+2)); +"in" => (Tokens.IN(yypos,yypos+2)); +"include" => (Tokens.INCLUDE(yypos,yypos+7)); +"infix" => (Tokens.INFIX(yypos,yypos+5)); +"infixr" => (Tokens.INFIXR(yypos,yypos+6)); +"let" => (Tokens.LET(yypos,yypos+3)); +"local" => (Tokens.LOCAL(yypos,yypos+5)); +"nonfix" => (Tokens.NONFIX(yypos,yypos+6)); +"of" => (Tokens.OF(yypos,yypos+2)); +"op" => (Tokens.OP(yypos,yypos+2)); +"open" => (Tokens.OPEN(yypos,yypos+4)); +"overload" => (Tokens.OVERLOAD(yypos,yypos+8)); +"raise" => (Tokens.RAISE(yypos,yypos+5)); +"rec" => (Tokens.REC(yypos,yypos+3)); +"sharing" => (Tokens.SHARING(yypos,yypos+7)); +"sig" => (Tokens.SIG(yypos,yypos+3)); +"signature" => (Tokens.SIGNATURE(yypos,yypos+9)); +"struct" => (Tokens.STRUCT(yypos,yypos+6)); +"structure" => (Tokens.STRUCTURE(yypos,yypos+9)); +"then" => (Tokens.THEN(yypos,yypos+4)); +"type" => (Tokens.TYPE(yypos,yypos+4)); +"val" => (Tokens.VAL(yypos,yypos+3)); +"while" => (Tokens.WHILE(yypos,yypos+5)); +"with" => (Tokens.WITH(yypos,yypos+4)); +"withtype" => (Tokens.WITHTYPE(yypos,yypos+8)); +"orelse" => (Tokens.ORELSE(yypos,yypos+6)); +"andalso" => (Tokens.ANDALSO(yypos,yypos+7)); +"import" => (Tokens.IMPORT(yypos,yypos+6)); +"'"{idchars}* => (Tokens.TYVAR(yytext, yypos, yypos+size yytext)); +({sym}+|{id}) => (Tokens.ID(yytext, yypos, yypos+size yytext)); +{real} => (Tokens.REAL(yytext,yypos,yypos+size yytext)); +[1-9][0-9]* => (Tokens.INT(makeInt (op +) yytext + handle Overflow => (err (yypos,yypos+size yytext) + COMPLAIN "integer too large"; 1), + yypos,yypos+size yytext)); +{num} => (Tokens.INT0(makeInt (op +) yytext + handle Overflow => (err (yypos,yypos+size yytext) + COMPLAIN "integer too large"; 0), + yypos,yypos+size yytext)); +~{num} => (Tokens.INT0(makeInt (op -) + (substring(yytext,1,size(yytext)-1)) + handle Overflow => (err (yypos,yypos+size yytext) + COMPLAIN "integer too large"; 0), + yypos,yypos+size yytext)); +"0x"{hexnum} => ( + Tokens.INT0(makeHexInt (op +) (substring(yytext, 2, size(yytext)-2)) + handle Overflow => (err (yypos,yypos+size yytext) + COMPLAIN "integer too large"; 0), + yypos, yypos+size yytext)); +"~0x"{hexnum} => ( + Tokens.INT0(makeHexInt (op -) (substring(yytext, 3, size(yytext)-3)) + handle Overflow => (err (yypos,yypos+size yytext) + COMPLAIN "integer too large"; 0), + yypos, yypos+size yytext)); +\" => (charlist := [""]; stringstart := yypos; + YYBEGIN S; continue()); +"(*" => (YYBEGIN A; stringstart := yypos; comLevel := 1; continue()); +\h => (err (yypos,yypos) COMPLAIN "non-Ascii character"; continue()); +. => (err (yypos,yypos) COMPLAIN "illegal token"; continue()); +"(*" => (inc comLevel; continue()); +\n => (inc lineNum; linePos := yypos :: !linePos; continue()); +"*)" => (dec comLevel; if !comLevel=0 then YYBEGIN INITIAL else (); continue()); +. => (continue()); +\" => (YYBEGIN INITIAL; Tokens.STRING(makeString charlist, + !stringstart,yypos+1)); +\n => (err (!stringstart,yypos) COMPLAIN "unclosed string"; + inc lineNum; linePos := yypos :: !linePos; + YYBEGIN INITIAL; Tokens.STRING(makeString charlist,!stringstart,yypos)); +[^"\\\n]* => (addString(charlist,yytext); continue()); +\\\n => (inc lineNum; linePos := yypos :: !linePos; + YYBEGIN F; continue()); +\\[\ \t] => (YYBEGIN F; continue()); +\n => (inc lineNum; linePos := yypos :: !linePos; continue()); +{ws} => (continue()); +\\ => (YYBEGIN S; stringstart := yypos; continue()); +. => (err (!stringstart,yypos) COMPLAIN "unclosed string"; + YYBEGIN INITIAL; Tokens.STRING(makeString charlist,!stringstart,yypos+1)); +\\t => (addString(charlist,"\t"); continue()); +\\n => (addString(charlist,"\n"); continue()); +\\\\ => (addString(charlist,"\\"); continue()); +\\\" => (addString(charlist,chr(Ascii.dquote)); continue()); +\\\^[@-_] => (addString(charlist,chr(ordof(yytext,2)-ord("@"))); continue()); +\\[0-9]{3} => + (let val x = ordof(yytext,1)*100 + +ordof(yytext,2)*10 + +ordof(yytext,3) + -(Ascii.zero*111) + in (if x>255 + then err (yypos,yypos+4) COMPLAIN "illegal ascii escape" + else addString(charlist,chr x); + continue()) + end); +\\ => (err (yypos,yypos+1) COMPLAIN "illegal string escape"; + continue()); diff --git a/benchmark/tests/DATA/ndotprod.s b/benchmark/tests/DATA/ndotprod.s new file mode 100644 index 0000000..dad3117 --- /dev/null +++ b/benchmark/tests/DATA/ndotprod.s @@ -0,0 +1,97 @@ +ARITHI new_allocptr/R1 := zero/R0 iadd 257 +LABEL v/L0: ( zero/R0 allocptr/R1 exnhandler/R2 std_closure/R3 std_arg/R4 std_cont/R5 ) +GETLAB v/R6 := v/L4 +STORE M[ allocptr/R1 + 0 ] := v/R6 +STORE M[ allocptr/R1 + 1 ] := std_cont/R5 +ARITHI closure/R5 := allocptr/R1 iadd 0 +ARITHI int10/R8 := zero/R0 iadd 10 +GETREAL real3.0/R9 := 3.0 +ARITHI new_allocptr/R1 := allocptr/R1 iadd 2 +BRANCH IF zero/R0 ieq zero/R0 GOTO array/L1 ( zero/R0 allocptr/R1 exnhandler/R2 n/R8 v/R9 v/R5 ) +LABEL array/L1: ( zero/R0 allocptr/R1 exnhandler/R2 n/R8 v/R9 v/R5 ) +STORE M[ allocptr/R1 + 0 ] := n/R8 +ARITH new_allocptr/R1 := n/R8 iadd allocptr/R1 +ARITH arr/R4 := allocptr/R1 isub n/R8 +BRANCH IF zero/R0 ige n/R8 GOTO else/L8 ( zero/R0 allocptr/R1 exnhandler/R2 arr/R4 v/R5 ) +GETLAB v/R6 := v/L3 +STORE M[ allocptr/R1 + 1 ] := v/R6 +STORE M[ allocptr/R1 + 2 ] := arr/R4 +STORE M[ allocptr/R1 + 3 ] := v/R5 +ARITHI closure/R5 := allocptr/R1 iadd 1 +STORE M[ arr/R4 + 1 ] := v/R9 +ARITHI int1/R6 := zero/R0 iadd 1 +ARITHI new_allocptr/R1 := allocptr/R1 iadd 4 +BRANCH IF zero/R0 ieq zero/R0 GOTO g/L2 ( zero/R0 allocptr/R1 exnhandler/R2 i/R6 v/R5 arr/R4 n/R8 v/R9 ) +LABEL else/L8: ( zero/R0 allocptr/R1 exnhandler/R2 arr/R4 v/R5 ) +FETCHi v/R6 := M[ v/R5 + 0 ] +ARITHI new_allocptr/R1 := allocptr/R1 iadd 1 +JUMP v/R6 ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) +LABEL g/L2: ( zero/R0 allocptr/R1 exnhandler/R2 i/R6 v/R5 arr/R4 n/R8 v/R9 ) +BRANCH IF i/R6 ige n/R8 GOTO else/L9 ( zero/R0 allocptr/R1 exnhandler/R2 v/R5 ) +ARITH x/R7 := arr/R4 iadd i/R6 +STORE M[ x/R7 + 1 ] := v/R9 +ARITHI i/R6 := i/R6 iadd 1 +BRANCH IF i/R6 ige n/R8 GOTO else/L10 ( zero/R0 allocptr/R1 exnhandler/R2 v/R5 ) +ARITH x/R7 := arr/R4 iadd i/R6 +STORE M[ x/R7 + 1 ] := v/R9 +ARITHI i/R6 := i/R6 iadd 1 +BRANCH IF zero/R0 ieq zero/R0 GOTO g/L2 ( zero/R0 allocptr/R1 exnhandler/R2 i/R6 v/R5 arr/R4 n/R8 v/R9 ) +LABEL else/L10: ( zero/R0 allocptr/R1 exnhandler/R2 v/R5 ) +FETCHi v/R6 := M[ v/R5 + 0 ] +MOVE std_arg/R4 := zero/R0 +JUMP v/R6 ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) +LABEL else/L9: ( zero/R0 allocptr/R1 exnhandler/R2 v/R5 ) +FETCHi v/R6 := M[ v/R5 + 0 ] +MOVE std_arg/R4 := zero/R0 +JUMP v/R6 ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) +LABEL v/L3: ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) +FETCHi arr/R4 := M[ std_cont/R5 + 1 ] +FETCHi v/R5 := M[ std_cont/R5 + 2 ] +FETCHi v/R6 := M[ v/R5 + 0 ] +JUMP v/R6 ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) +LABEL v/L4: ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) +GETLAB v/R6 := v/L5 +STORE M[ allocptr/R1 + 0 ] := v/R6 +FETCHi x/R6 := M[ std_cont/R5 + 1 ] +STORE M[ allocptr/R1 + 1 ] := x/R6 +STORE M[ allocptr/R1 + 2 ] := std_arg/R4 +ARITHI closure/R5 := allocptr/R1 iadd 0 +ARITHI int10/R8 := zero/R0 iadd 10 +GETREAL real4.0/R9 := 4.0 +ARITHI new_allocptr/R1 := allocptr/R1 iadd 3 +BRANCH IF zero/R0 ieq zero/R0 GOTO array/L1 ( zero/R0 allocptr/R1 exnhandler/R2 n/R8 v/R9 v/R5 ) +LABEL v/L5: ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) +GETLAB v/R6 := v/L7 +STORE M[ allocptr/R1 + 0 ] := v/R6 +FETCHi x/R6 := M[ std_cont/R5 + 1 ] +STORE M[ allocptr/R1 + 1 ] := x/R6 +ARITHI closure/R11 := allocptr/R1 iadd 0 +GETREAL real0.0/R10 := 0.0 +ARITHI new_allocptr/R1 := allocptr/R1 iadd 2 +MOVE k/R8 := zero/R0 +BRANCH IF zero/R0 ieq zero/R0 GOTO f/L6 ( zero/R0 allocptr/R1 exnhandler/R2 k/R8 Q/R10 v/R11 X1/R4 closure/R5 ) +LABEL f/L6: ( zero/R0 allocptr/R1 exnhandler/R2 k/R8 Q/R10 v/R11 X1/R4 closure/R5 ) +ARITHI int10/R6 := zero/R0 iadd 10 +BRANCH IF k/R8 ige int10/R6 GOTO else/L11 ( zero/R0 allocptr/R1 exnhandler/R2 v/R11 Q/R10 ) +ARITHI v/R9 := k/R8 iadd 1 +FETCHi Z1/R6 := M[ closure/R5 + 2 ] +ARITH x/R6 := Z1/R6 iadd k/R8 +FETCHm v/R7 := M[ x/R6 + 1 ] +ARITH x/R6 := X1/R4 iadd k/R8 +FETCHm v/R6 := M[ x/R6 + 1 ] +ARITH v/R6 := v/R7 fmul v/R6 +ARITH v/R10 := Q/R10 fadd v/R6 +MOVE k/R8 := v/R9 +BRANCH IF zero/R0 ieq zero/R0 GOTO f/L6 ( zero/R0 allocptr/R1 exnhandler/R2 k/R8 Q/R10 v/R11 X1/R4 closure/R5 ) +LABEL else/L11: ( zero/R0 allocptr/R1 exnhandler/R2 v/R11 Q/R10 ) +FETCHi v/R6 := M[ v/R11 + 0 ] +MOVE std_cont/R5 := v/R11 +MOVE std_arg/R4 := Q/R10 +JUMP v/R6 ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) +LABEL v/L7: ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) +STORE M[ allocptr/R1 + 0 ] := std_arg/R4 +ARITHI S/R4 := allocptr/R1 iadd 0 +FETCHi v/R5 := M[ std_cont/R5 + 1 ] +FETCHi v/R6 := M[ v/R5 + 0 ] +ARITHI new_allocptr/R1 := allocptr/R1 iadd 1 +JUMP v/R6 ( zero/R0 allocptr/R1 exnhandler/R2 std_cont/R5 std_arg/R4 ) diff --git a/benchmark/tests/DATA/ray b/benchmark/tests/DATA/ray new file mode 100644 index 0000000..2a46c97 --- /dev/null +++ b/benchmark/tests/DATA/ray @@ -0,0 +1,3 @@ +100 0 0 0 8 8 8 color sphere +/./TEST raytrace +stop diff --git a/benchmark/tests/DLXSimulator.sml b/benchmark/tests/DLXSimulator.sml new file mode 100644 index 0000000..dea864b --- /dev/null +++ b/benchmark/tests/DLXSimulator.sml @@ -0,0 +1,2845 @@ +(* Minor tweaks by Stephen Weeks (sweeks@sweeks.com) on 2001-07-17 to turn into a + * benchmark. + * Added rand function. + *) +(* + * Matthew Thomas Fluet + * Harvey Mudd College + * Claremont, CA 91711 + * e-mail: Matthew_Fluet@hmc.edu + * + * A DLX Simulator in Standard ML + * + * Description: + * The DLX Simulator is a partial implementation of the RISC instruction + * set described in Patterson's and Hennessy's _Computer Architecture_. + * Currently, the DLX Simulator implements the following instructions: + * ADD ADDI + * ADDU ADDUI + * SUB SUBI + * SUBU SUBUI + * AND ANDI + * OR ORI + * XOR XORI + * + * LHI + * + * SLL SLLI + * SRL SRLI + * SRA SRAI + * + * SEQ SEQI + * SNE SNEI + * SLT SLTI + * SGT SGTI + * SLE SLEI + * SGE SGEI + * + * LB LBU SB + * LH LHU SH + * LW SW + * + * BEQZ BNEZ + * J JR + * JAL JALR + * + * TRAP + * + * NOP + * + * Currently, the DLX Simulator uses 32 bit words for addressing and + * the register file and a 65535 word memory. To augment the memory + * a cache can be installed in the simulator, with a number of different + * caching options that can be made. Caches can also cache other caches, + * so realistic dual level caches can be simulated. Input and output + * is limited to requesting and outputing signed integers. + * + * Usage: + * DLXSimulatorCX.run_file : string -> unit + * DLXSimulatorCX.run_prog : string list -> unit; + * The DLXSimualatorCX family of structures represent different caches + * used on the simulator. The following table describes the different + * caches used: + * C1: a small level 1 cache + * DLXSimulatorCX.run_file attempts to open and execute the instructions + * in a file. DLXSimulatorCX.run_prog runs a set of instructions as + * a list of strings. Four programs are included here. + * Simple : simply outputs the number 42. + * Twos: performs the twos complement on an inputed number. + * Abs: performs the absolute value on an imputed number. + * Fact: performs the factorial on an inputed number. + * GCD: performs the greatest common divisor on two imputed numbers. + * After running, the DLX Simulator outputs a set of statistics + * concerning memory reads and writes, and cache hits and misses. + * + * Future Work: + * With the implementation of the PACK_REAL structures + * as documented in the SML'97 Basis Library, the remainder + * of the DLX instruction set should be implemented. + * Currently, without an efficient and correct means of + * converting a 32 bit word into a 32 bit float, it is + * difficult to incorporate these instructions. + * In order to finish following the current development + * model, a FPALU structure should be implemented as the + * floating point arithmetic-logic unit. + * Another possibility for future work would be to + * model a pipelined processor. Currently, the DLX Simulator + * uses a simple one cycle per instruction model. + * It should be possible to break this model and implement + * a pipeline, but it would mean a major reworking of the + * DLXSimulatorFun functor. + * + * References: + * Patterson, David A. and John L. Hennessy. _Computer Architecture: A + * Quantitative Approach: Second Edition_. San Francisco: Morgan + * Kaufmann Publishers, Inc., 1996. + * + *) + +(* ************************************************************************* *) + +(* sweeks added rand *) +local + open Word + val seed: word ref = ref 0w13 +in + (* From page 284 of Numerical Recipes in C. *) + fun rand (): word = + let + val res = 0w1664525 * !seed + 0w1013904223 + val _ = seed := res + in + res + end +end + +(* + * ImmArray.sml + * + * The ImmArray structure defines an immutable array implementation. + * An immarray is stored internally as a list. + * This results in O(n) sub and update functions, as opposed + * to O(1) sub and update functions found in Array. However, + * immutable arrays are truly immutable, and can be integrated + * with a functionally programming style easier than mutable + * arrays. + * + * The ImmArray structure mimics the Array structure as much as possible. + * The most obvious deviation is that unit return types in Array are replaced + * by 'a immarray return types in ImmArray. Unlike an 'a array, an 'a immarray + * is an equality type if and only if 'a is an equality type. Further immarray + * equality is structural, rather than the "creation" equality used by Array. + * Additionally, no vector type is supported, and consequently no copyVec + * function is supported. Finally, the functions mapi and map provide + * similar functionality as modifyi and modify, but relax the constraint that + * the argument function need be of type 'a -> 'a. + * + * Future Work : There are random-access list implementations + * that support O(log n) sub and update functions, + * which may provide a faster implementation, although + * possibly at the expense of space and the ease of + * implementing app, foldl, foldr, modify, and map functions. + *) + +signature IMMARRAY + = sig + type 'a immarray; + + val maxLen : int; + val immarray : (int * 'a) -> 'a immarray; + val fromList : 'a list -> 'a immarray; + val toList : 'a immarray -> 'a list; + + val tabulate : int * (int -> 'a) -> 'a immarray; + val length : 'a immarray -> int; + + val sub : 'a immarray * int -> 'a; + val update : 'a immarray * int * 'a -> 'a immarray; + val extract : 'a immarray * int * int option -> 'a immarray; + + val copy : {src : 'a immarray, si : int, len : int option, + dst : 'a immarray, di : int} -> 'a immarray; + + val appi : (int * 'a -> unit) -> ('a immarray * int * int option) + -> unit; + val app : ('a -> unit) -> 'a immarray -> unit; + val foldli : ((int * 'a * 'b) -> 'b) -> 'b + -> ('a immarray * int * int option) -> 'b; + val foldri : ((int * 'a * 'b) -> 'b) -> 'b + -> ('a immarray * int * int option) -> 'b; + val foldl : (('a * 'b) -> 'b) -> 'b -> 'a immarray -> 'b; + val foldr : (('a * 'b) -> 'b) -> 'b -> 'a immarray -> 'b; + val mapi : ((int * 'a) -> 'b) -> ('a immarray * int * int option) + -> 'b immarray; + val map : ('a -> 'b) -> 'a immarray -> 'b immarray; + val modifyi : ((int * 'a) -> 'a) -> ('a immarray * int * int option) + -> 'a immarray; + val modify : ('a -> 'a) -> 'a immarray -> 'a immarray; + end; + + +structure ImmArray : IMMARRAY + = struct + + (* datatype 'a immarray + * An immarray is stored internally as a list. + * The use of a constructor prevents list functions from + * treating immarray type as a list. + *) + datatype 'a immarray = IA of 'a list; + + (* val maxLen : int + * The maximum length of immarrays supported. + * Technically, under this implementation, the maximum length + * of immarrays is the same as the maximum length of a list, + * but for convience and compatibility, use the Array structure's + * maximum length. + *) + val maxLen = Array.maxLen; + + (* val tabulate : int * (int -> 'a) -> 'a immarray + * val immarray : int * 'a -> 'a immarray + * val fromList : 'a list -> 'a immarray + * val toList : 'a immarray -> 'a list + * val length : 'a immarray -> int + * These functions perform basic immarray functions. + * The tabulate, immarray, and fromList functions create an immarray. + * The toList function converts an immarray to a list. + * The length function returns the length of an immarray. + *) + fun tabulate (n, initfn) = IA (List.tabulate (n, initfn)); + fun immarray (n, init) = tabulate (n, fn _ => init); + fun fromList l = IA l; + fun toList (IA ia) = ia; + fun length (IA ia) = List.length ia; + + (* val sub : 'a immarray * int -> 'a + * val update : 'a immarray * int * 'a -> 'a immarray + * These functions sub and update an immarray by index. + *) + fun sub (IA ia, i) = List.nth (ia, i); + fun update (IA ia, i, x) = IA ((List.take (ia, i)) @ + (x::(List.drop (ia, i + 1)))); + + (* val extract : 'a immarray * int * int option -> 'a immarray + * This function extracts an immarray slice from an immarray from + * one index either through the rest of the immarray (NONE) + * or for n elements (SOME n), as described in the + * Standard ML Basis Library. + *) + fun extract (IA ia, i, NONE) = IA (List.drop (ia, i)) + | extract (IA ia, i, SOME n) = IA (List.take (List.drop (ia, i), n)); + + (* val copy : {src : 'a immarray, si : int, len : int option, + dst : 'a immarray, di : int} -> 'a immarray + * This function copies an immarray slice from src into dst starting + * at the di element. + *) + fun copy {src, si, len, dst=IA ia, di} + = let + val IA sia = extract (src, si, len); + val pre = List.take (ia, di); + val post = case len + of NONE => List.drop (ia, di+(List.length sia)) + | SOME n => List.drop (ia, di+n); + in + IA (pre @ sia @ post) + end; + + (* val appi : ('a * int -> unit) -> ('a immarray * int * int option) + * -> unit + * val app : ('a -> unit) -> 'a immarray -> unit + * These functions apply a function to every element + * of an immarray. The appi function also provides the + * index of the element as an argument to the applied function + * and uses an immarray slice argument. + *) + local + fun appi_aux f i [] = () + | appi_aux f i (h::t) = (f(i,h); appi_aux f (i + 1) t); + in + fun appi f (IA ia, i, len) = let + val IA sia = extract (IA ia, i, len); + in + appi_aux f i sia + end; + end; + fun app f immarr = appi (f o #2) (immarr, 0, NONE); + + (* val foldli : (int * 'a * 'b -> 'b) -> 'b + * -> ('a immarray * int * int option) -> 'b; + * val foldri : (int * 'a * 'b -> 'b) -> 'b + * -> ('a immarray * int * int option) -> 'b; + * val foldl : ('a * 'b -> 'b) -> 'b -> 'a immarray -> 'b + * val foldr : ('a * 'b -> 'b) -> 'b -> 'a immarray -> 'b + * These functions fold a function over every element + * of an immarray. The foldri and foldli functions also provide + * the index of the element as an argument to the folded function + * and uses an immarray slice argument. + *) + local + fun foldli_aux f b i [] = b + | foldli_aux f b i (h::t) = foldli_aux f (f(i,h,b)) (i+1) t; + fun foldri_aux f b i [] = b + | foldri_aux f b i (h::t) = f(i,h,foldri_aux f b (i+1) t); + in + fun foldli f b (IA ia, i, len) + = let + val IA ia2 = extract (IA ia, i, len); + in + foldli_aux f b i ia2 + end; + fun foldri f b (IA ia, i, len) + = let + val IA ia2 = extract (IA ia, i, len); + in + foldri_aux f b i ia2 + end; + end; + fun foldl f b (IA ia) = foldli (fn (_,i,x) => f(i,x)) b (IA ia, 0, NONE); + fun foldr f b (IA ia) = foldri (fn (_,i,x) => f(i,x)) b (IA ia, 0, NONE); + + (* val mapi : ('a * int -> 'b) -> 'a immarray -> 'b immarray + * val map : ('a -> 'b) -> 'a immarray -> 'b immarray + * These functions map a function over every element + * of an immarray. The mapi function also provides the + * index of the element as an argument to the mapped function + * and uses an immarray slice argument. Although there are + * similarities between mapi and modifyi, note that when mapi is + * used with an immarray slice, the resulting immarray is the + * same size as the slice. This is necessary to preserve the + * type of the resulting immarray. Thus, mapi with the identity + * function reduces to the extract function. + *) + local + fun mapi_aux f i [] = [] + | mapi_aux f i (h::t) = (f (i,h))::(mapi_aux f (i + 1) t); + in + fun mapi f (IA ia, i, len) = let + val IA ia2 = extract (IA ia, i, len); + in + IA (mapi_aux f i ia2) + end; + end; + fun map f (IA ia)= mapi (f o #2) (IA ia, 0, NONE); + + (* val modifyi : (int * 'a -> 'a) -> ('a immarray * int * int option) + * -> 'a immarray + * val modify : ('a -> 'a) -> 'a immarray -> 'a immarray + * These functions apply a function to every element of an immarray + * in left to right order and returns a new immarray where corresponding + * elements are replaced by their modified values. The modifyi + * function also provides the index of the element as an argument + * to the mapped function and uses an immarray slice argument. + *) + local + fun modifyi_aux f i [] = [] + | modifyi_aux f i (h::t) = (f (i,h))::(modifyi_aux f (i + 1) t); + in + fun modifyi f (IA ia, i, len) + = let + val pre = List.take (ia, i); + val IA ia2 = extract (IA ia, i, len); + val post = case len + of NONE => [] + | SOME n => List.drop (ia, i+n); + in + IA (pre @ (modifyi_aux f i ia2) @ post) + end; + end; + fun modify f (IA ia) = modifyi (f o #2) (IA ia, 0, NONE); + + end; + +(* ************************************************************************* *) + +(* + * ImmArray2.sml + * + * The ImmArray2 structure defines a two dimensional immutable array + * implementation. An immarray2 is stored internally as an immutable + * array of immutable arrays. As such, the ImmArray2 makes heavy use + * of the ImmArray structure. + * + * The ImmArray2 structure mimics the Array2 structure as much as possible. + * The most obvious deviation is that unit return types in Array2 are replaced + * by 'a immarray2 return types in ImmArray2. Unlike an 'a array, + * an 'a immarray2 is an equality type if and only if 'a is an equality type. + * Further immarray2 equality is structural, rather than the "creation" + * equality used by Array2. Also, the 'a region type is not included in + * ImmArray2, but all functions in Array2 that require 'a regions are present + * with arguments taken in the natural order. Finally, the functions mapi + * and map provide similar functionality as modifyi and modify, but relax + * the constraint that the argument function need be of type 'a -> 'a. + *) + +signature IMMARRAY2 + = sig + + type 'a immarray2; + + datatype traversal = RowMajor | ColMajor + + val immarray2 : int * int * 'a -> 'a immarray2; + val tabulate : traversal -> int * int * ((int * int) -> 'a) + -> 'a immarray2; + val fromList : 'a list list -> 'a immarray2; + val dimensions : 'a immarray2 -> int * int; + + val sub : 'a immarray2 * int * int -> 'a; + val update : 'a immarray2 * int * int * 'a -> 'a immarray2; + val extract : 'a immarray2 * int * int * int option * int option + -> 'a immarray2; + + val copy : {src : 'a immarray2, si : int, sj : int, + ilen : int option, jlen : int option, + dst : 'a immarray2, di : int, dj : int} -> 'a immarray2; + + val nRows : 'a immarray2 -> int; + val nCols : 'a immarray2 -> int; + val row : 'a immarray2 * int -> 'a ImmArray.immarray; + val column : 'a immarray2 * int -> 'a ImmArray.immarray; + + val appi : traversal -> (int * int * 'a -> unit) + -> ('a immarray2 * int * int * int option * int option) + -> unit; + val app : traversal -> ('a -> unit) -> 'a immarray2 -> unit; + val foldli : traversal -> ((int * int * 'a * 'b) -> 'b) -> 'b + -> ('a immarray2 * int * int * int option * int option) + -> 'b + val foldri : traversal -> ((int * int * 'a * 'b) -> 'b) -> 'b + -> ('a immarray2 * int * int * int option * int option) + -> 'b + val foldl : traversal -> (('a * 'b) -> 'b) -> 'b -> 'a immarray2 -> 'b + val foldr : traversal -> (('a * 'b) -> 'b) -> 'b -> 'a immarray2 -> 'b + val mapi : traversal -> (int * int * 'a -> 'b) + -> ('a immarray2 * int * int * int option * int option) + -> 'b immarray2; + val map : traversal -> ('a -> 'b) -> 'a immarray2 -> 'b immarray2; + val modifyi : traversal -> ((int * int * 'a) -> 'a) + -> ('a immarray2 * int * int * int option * int option) + -> 'a immarray2; + val modify : traversal -> ('a -> 'a) -> 'a immarray2 -> 'a immarray2; + end; + +structure ImmArray2 : IMMARRAY2 + = struct + + (* datatype 'a immarray2 + * An immarray2 is stored internally as an immutable array + * of immutable arrays. The use of a contructor prevents ImmArray + * functions from treating the immarray2 type as an immarray. + *) + datatype 'a immarray2 = IA2 of 'a ImmArray.immarray ImmArray.immarray; + datatype traversal = RowMajor | ColMajor + + (* val tabulate : traversal -> int * int * (int * int -> 'a) + * -> 'a immarray2 + * val immarray2 : int * int * 'a -> 'a immarray2 + * val fromList : 'a list list -> 'a immarray2 + * val dmensions : 'a immarray2 -> int * int + * These functions perform basic immarray2 functions. + * The tabulate and immarray2 functions create an immarray2. + * The fromList function converts a list of lists into an immarray2. + * Unlike Array2.fromList, fromList will accept lists of different + * lengths, allowing one to create an immarray2 in which the + * rows have different numbers of columns, although it is likely that + * exceptions will be raised when other ImmArray2 functions are applied + * to such an immarray2. Note that dimensions will return the + * number of columns in row 0. + * The dimensions function returns the dimensions of an immarray2. + *) + fun tabulate RowMajor (r, c, initfn) + = let + fun initrow r = ImmArray.tabulate (c, fn ic => initfn (r,ic)); + in + IA2 (ImmArray.tabulate (r, fn ir => initrow ir)) + end + | tabulate ColMajor (r, c, initfn) + = turn (tabulate RowMajor (c,r, fn (c,r) => initfn(r,c))) + and immarray2 (r, c, init) = tabulate RowMajor (r, c, fn (_, _) => init) + and fromList l + = IA2 (ImmArray.tabulate (length l, + fn ir => ImmArray.fromList (List.nth(l,ir)))) + and dimensions (IA2 ia2) = (ImmArray.length ia2, + ImmArray.length (ImmArray.sub (ia2, 0))) + + (* turn : 'a immarray2 -> 'a immarray2 + * This function reverses the rows and columns of an immarray2 + * to allow handling of ColMajor traversals. + *) + and turn ia2 = let + val (r,c) = dimensions ia2; + in + tabulate RowMajor (c,r,fn (cc,rr) => sub (ia2,rr,cc)) + end + + (* val sub : 'a immarray2 * int * int -> 'a + * val update : 'a immarray2 * int * int * 'a -> 'a immarray2 + * These functions sub and update an immarray2 by indices. + *) + and sub (IA2 ia2, r, c) = ImmArray.sub(ImmArray.sub (ia2, r), c); + fun update (IA2 ia2, r, c, x) + = IA2 (ImmArray.update (ia2, r, + ImmArray.update (ImmArray.sub (ia2, r), + c, x))); + + (* val extract : 'a immarray2 * int * int * + * int option * int option -> 'a immarray2 + * This function extracts a subarray from an immarray2 from + * one pair of indices either through the rest of the + * immarray2 (NONE, NONE) or for the specfied number of elements. + *) + fun extract (IA2 ia2, i, j, rlen, clen) + = IA2 (ImmArray.map (fn ia => ImmArray.extract (ia, j, clen)) + (ImmArray.extract (ia2, i, rlen))); + + (* val nRows : 'a immarray2 -> int + * val nCols : 'a immarray2 -> int + * These functions return specific dimensions of an immarray2. + *) + fun nRows (IA2 ia2) = (#1 o dimensions) (IA2 ia2); + fun nCols (IA2 ia2) = (#2 o dimensions) (IA2 ia2); + (* val row : immarray2 * int -> ImmArray.immarray + * val column : immarray2 * int -> ImmArray.immarray + * These functions extract an entire row or column from + * an immarray2 by index, returning the row or column as + * an ImmArray.immarray. + *) + fun row (ia2, r) = let + val (c, _) = dimensions ia2; + in + ImmArray.tabulate (c, fn i => sub (ia2, r, i)) + end; + fun column (ia2, c) = let + val (_, r) = dimensions ia2; + in + ImmArray.tabulate (r, fn i => sub (ia2, i, c)) + end; + + (* val copy : {src : 'a immarray2, si : int, sj : int, + * ilen : int option, jlen : int option, + * dst : 'a immarray2, di : int, dj : int}; + * This function copies an immarray2 slice from src int dst starting + * at the di,dj element. + *) + fun copy {src, si, sj, ilen, jlen, dst=IA2 ia2, di, dj} + = let + val nilen = case ilen + of NONE => SOME ((nRows src) - si) + | SOME n => SOME n; + in + IA2 (ImmArray.modifyi (fn (r, ia) + => ImmArray.copy {src=row (src, si+r-di), + si=sj, len=jlen, + dst=ia, di=dj}) + (ia2, di, nilen)) + end; + + (* val appi : traversal -> ('a * int * int -> unit) -> 'a immarray2 + * -> unit + * val app : traversal -> ('a -> unit) -> 'a immarray2 -> unit + * These functions apply a function to every element + * of an immarray2. The appi function also provides the + * indices of the element as an argument to the applied function + * and uses an immarray2 slice argument. + *) + fun appi RowMajor f (IA2 ia2, i, j, rlen, clen) + = ImmArray.appi (fn (r,ia) => ImmArray.appi (fn (c,x) => f(r,c,x)) + (ia, j, clen)) + (ia2, i, rlen) + | appi ColMajor f (ia2, i, j, rlen, clen) + = appi RowMajor (fn (c,r,x) => f(r,c,x)) (turn ia2, j, i, clen, rlen); + fun app tr f (IA2 ia2) = appi tr (f o #3) (IA2 ia2, 0, 0, NONE, NONE); + + (* val foldli : traversal -> ((int * int * 'a * 'b) -> 'b) -> 'b + * -> ('a immarray2 * int * int * int option * int option) + * -> 'b + * val foldri : traversal -> ((int * int * 'a * 'b) -> 'b) -> 'b + * -> ('a immarray2 * int * int * int option * int option) + * -> 'b + * val foldl : traversal -> ('a * 'b -> 'b) -> 'b -> 'a immarray2 -> 'b + * val foldr : traversal -> ('a * 'b -> 'b) -> 'b -> 'a immarray2 -> 'b + * These functions fold a function over every element + * of an immarray2. The foldri and foldli functions also provide + * the index of the element as an argument to the folded function + * and uses an immarray2 slice argument. + *) + fun foldli RowMajor f b (IA2 ia2, i, j, rlen, clen) + = ImmArray.foldli (fn (r,ia,b) + => ImmArray.foldli (fn (c,x,b) => f(r,c,x,b)) + b + (ia, j, clen)) + b + (ia2, i, rlen) + | foldli ColMajor f b (ia2, i, j, rlen, clen) + = foldli RowMajor (fn (c,r,x,b) => f(r,c,x,b)) b + (turn ia2, j, i, clen, rlen); + fun foldri RowMajor f b (IA2 ia2, i, j, rlen, clen) + = ImmArray.foldri (fn (r,ia,b) + => ImmArray.foldri (fn (c,x,b) => f(r,c,x,b)) + b + (ia, j, clen)) + b + (ia2, i, rlen) + | foldri ColMajor f b (ia2, i, j, rlen, clen) + = foldri RowMajor (fn (c,r,x,b) => f(r,c,x,b)) b + (turn ia2, j, i, clen, rlen); + fun foldl tr f b (IA2 ia2) + = foldli tr (fn (_,_,x,b) => f(x,b)) b (IA2 ia2, 0, 0, NONE, NONE); + fun foldr tr f b (IA2 ia2) + = foldri tr (fn (_,_,x,b) => f(x,b)) b (IA2 ia2, 0, 0, NONE, NONE); + + (* val mapi : traversal -> ('a * int * int -> 'b) -> 'a immarray2 + * -> 'b immarray2 + * val map : traversal -> ('a -> 'b) -> 'a immarray2 -> 'b immarray2 + * These functions map a function over every element + * of an immarray2. The mapi function also provides the + * indices of the element as an argument to the mapped function + * and uses an immarray2 slice argument. Although there are + * similarities between mapi and modifyi, note that when mapi is + * used with an immarray2 slice, the resulting immarray2 is the + * same size as the slice. This is necessary to preserve the + * type of the resulting immarray2. Thus, mapi with the identity + * function reduces to the extract function. + *) + fun mapi RowMajor f (IA2 ia2, i, j, rlen, clen) + = IA2 (ImmArray.mapi (fn (r,ia) => ImmArray.mapi (fn (c,x) => f(r,c,x)) + (ia, j, clen)) + (ia2, i, rlen)) + | mapi ColMajor f (ia2, i, j, rlen, clen) + = turn (mapi RowMajor (fn (c,r,x) => f(r,c,x)) + (turn ia2, j, i, clen, rlen)) + fun map tr f (IA2 ia2) + = mapi tr (f o #3) (IA2 ia2, 0, 0, NONE, NONE); + + (* val modifyi : traversal -> (int * int* 'a -> 'a) + -> ('a immarray2 * int * int * int option * int option) + * -> 'a immarray2 + * val modify : traversal -> ('a -> 'a) -> 'a immarray2 -> 'a immarray2 + * These functions apply a function to every element of an immarray2 + * in row by column order and returns a new immarray2 where corresponding + * elements are replaced by their modified values. The modifyi + * function also provides the index of the element as an argument + * to the mapped function and uses an immarray2 slice argument. + *) + fun modifyi RowMajor f (IA2 ia2, i, j, rlen, clen) + = IA2 (ImmArray.modifyi (fn (r,ia) => ImmArray.modifyi (fn (c,x) + => f(r,c,x)) + (ia, j, clen)) + (ia2, i, rlen)) + | modifyi ColMajor f (ia2, i, j, rlen, clen) + = turn (modifyi RowMajor (fn (c,r,x) => f(r,c,x)) + (turn ia2, j, i, clen, rlen)); + fun modify tr f (IA2 ia2) + = modifyi tr (f o #3) (IA2 ia2, 0, 0, NONE, NONE); + + end; + +(* ************************************************************************* *) + +(* + * RegisterFile.sig + * + * This defines the exported datatype and functions provided by the + * register file. The datatype registerfile provides the encapsulation + * of the register file, InitRegisterFile initializes the registerfile, + * setting all registers to zero and setting r0, gp, sp, and fp to + * their appropriate values, LoadRegister takes a registerfile and + * an integer corresponding to the register, and returns the + * Word32.word value at that register, and StoreRegister takes a + * registerfile, an integer corresponding to the register, and a + * Word32.word and returns the registerfile updated with the word + * stored in the appropriate register. + *) + +signature REGISTERFILE + = sig + + type registerfile; + + val InitRegisterFile : unit -> registerfile; + + val LoadRegister : registerfile * int -> Word32.word; + + val StoreRegister : registerfile * int * Word32.word -> registerfile; + + end; + +(*****************************************************************************) + +(* + * RegisterFile.sml + * + * This defines the RegisterFile structure, which provides the + * functionality of the register file. The datatype registerfile + * provides the encapsulation of the register file, InitRegisterFile + * initializes the registerfile, setting all registers to zero and + * setting r0, gp, sp, and fp to their appropriate values, + * LoadRegister takes a registerfile and an integer corresponding to + * the register, and returns the Word32.word value at that register, + * and StoreRegister takes a registerfile, an integer corresponding to + * the register, and a Word32.word and returns the registerfile + * updated with the word stored in the appropriate register. + * + * The underlying structure of registerfile is an immutable array of + * Word32.word. + *) + +structure RegisterFile : REGISTERFILE + = struct + + type registerfile = Word32.word ImmArray.immarray; + + fun InitRegisterFile () + = ImmArray.update + (ImmArray.update + (ImmArray.update + (ImmArray.update + (ImmArray.immarray(32, 0wx00000000 : Word32.word), + 00, 0wx00000000 : Word32.word), + 28, 0wx00000000 : Word32.word), + 29, 0wx00040000 : Word32.word), + 30, 0wx00040000 : Word32.word) : registerfile; + + fun LoadRegister (rf, reg) = ImmArray.sub(rf, reg); + + fun StoreRegister (rf, reg, data) = ImmArray.update(rf, reg, data); + + end; + + +(*****************************************************************************) + +(* + * ALU.sig + * + * This defines the exported datatype and function provided by the + * ALU. The datatype ALUOp provides a means to specify which + * operation is to be performed by the ALU, and PerformAL performs + * one of the operations on two thirty-two bit words, returning the + * result as a thirty-two bit word. + *) + +signature ALU + = sig + + datatype ALUOp = SLL | SRL | SRA | + ADD | ADDU | + SUB | SUBU | + AND | OR | XOR | + SEQ | SNE | + SLT | SGT | + SLE | SGE; + + val PerformAL : (ALUOp * Word32.word * Word32.word) -> Word32.word; + + end; + +(*****************************************************************************) + +(* + * ALU.sml + * + * This defines the ALU structure, which provides the functionality of + * an Arithmetic/Logic Unit. The datatype ALUOp provides a means to + * specify which operation is to be performed by the ALU, and + * PerformAL performs one of the operations on two thirty-two bit + * words, returning the result as a thirty-two bit word. + * + * A note about SML'97 Basis Library implementation of thirty-two bit + * numbers: the Word32.word is an unsigned thirty-two bit integer, + * while Int.int (equivalent to Int.int) is a signed thirty-two + * bit integer. In order to perform the signed operations, it is + * necessary to convert the words to signed form, using the + * Word32.toIntX function, which performs sign extension, + * and to convert the result back into unsigned form using the + * Word32.fromInt function. In addition, to perform a shift, + * the second Word32.word needs to be "downsized" to a normal + * Word.word using the Word.fromWord function. + *) + +structure ALU : ALU + = struct + + datatype ALUOp = SLL | SRL | SRA | + ADD | ADDU | + SUB | SUBU | + AND | OR | XOR | + SEQ | SNE | + SLT | SGT | + SLE | SGE; + + fun PerformAL (opcode, s1, s2) = + (case opcode + of SLL => + Word32.<< (s1, Word.fromLarge (Word32.toLarge s2)) + | SRL => + Word32.>> (s1, Word.fromLarge (Word32.toLarge s2)) + | SRA => + Word32.~>> (s1, Word.fromLarge (Word32.toLarge s2)) + | ADD => + Word32.fromInt (Int.+ (Word32.toIntX s1, + Word32.toIntX s2)) + | ADDU => + Word32.+ (s1, s2) + | SUB => + Word32.fromInt (Int.- (Word32.toIntX s1, + Word32.toIntX s2)) + | SUBU => + Word32.- (s1, s2) + | AND => + Word32.andb (s1, s2) + | OR => + Word32.orb (s1, s2) + | XOR => + Word32.xorb (s1, s2) + | SEQ => + if (s1 = s2) + then 0wx00000001 : Word32.word + else 0wx00000000 : Word32.word + | SNE => + if not (s1 = s2) + then 0wx00000001 : Word32.word + else 0wx00000000 : Word32.word + | SLT => + if Int.< (Word32.toIntX s1, Word32.toIntX s2) + then 0wx00000001 : Word32.word + else 0wx00000000 : Word32.word + | SGT => + if Int.> (Word32.toIntX s1, Word32.toIntX s2) + then 0wx00000001 : Word32.word + else 0wx00000000 : Word32.word + | SLE => + if Int.<= (Word32.toIntX s1, Word32.toIntX s2) + then 0wx00000001 : Word32.word + else 0wx00000000 : Word32.word + | SGE => + if Int.>= (Word32.toIntX s1, Word32.toIntX s2) + then 0wx00000001 : Word32.word + else 0wx00000000 : Word32.word) + (* + * This handle will handle all ALU errors, most + * notably overflow and division by zero, and will + * print an error message and return 0. + *) + handle _ => + (print "Error : ALU returning 0\n"; + 0wx00000000 : Word32.word); + + end; + +(*****************************************************************************) + +(* + * Memory.sig + * + * This defines the exported datatype and functions provided by + * memory. The datatype memory provides the encapsulation + * of memory, InitMemory initializes memory, setting all + * addresses to zero, LoadWord takes memory and + * a Word32.word corresponding to the address, and returns the + * Word32.word value at that address, StoreWord takes memory, + * a Word32.word corresponding to the address, and a + * Word32.word and returns memory updated with the word + * stored at the appropriate address. LoadHWord, LoadHWordU, + * LoadByte, and LoadByteU load halfwords, unsigned halfwords, + * bytes, and unsigned bytes respectively from memory into the + * lower portion of the returned Word32.word. StoreHWord and + * StoreByte store halfwords and bytes taken from the lower portion + * of the Word32.word into memory. + * GetStatistics takes memory and returns the read and write + * statistics as a string. + *) + +signature MEMORY + = sig + + type memory; + + val InitMemory : unit -> memory; + + val LoadWord : memory * Word32.word -> memory * Word32.word; + val StoreWord : memory * Word32.word * Word32.word -> memory; + + val LoadHWord : memory * Word32.word -> memory * Word32.word; + val LoadHWordU : memory * Word32.word -> memory * Word32.word; + val StoreHWord : memory * Word32.word * Word32.word -> memory; + + val LoadByte : memory * Word32.word -> memory * Word32.word; + val LoadByteU : memory * Word32.word -> memory * Word32.word; + val StoreByte : memory * Word32.word * Word32.word -> memory; + + val GetStatistics : memory -> string; + + end; + + + + + +(*****************************************************************************) + +(* + * Memory.sml + * + * This defines the Memory structure, which provides the functionality + * of memory. The datatype memory provides the encapsulation of + * memory, InitMemory initializes memory, setting all + * addresses to zero, LoadWord takes memory and + * a Word32.word corresponding to the address, and returns the + * Word32.word value at that address and the updated memory, + * StoreWord takes memory, a Word32.word corresponding to the + * address, and a Word32.word and returns memory updated with the word + * stored at the appropriate address. LoadHWord, LoadHWordU, + * LoadByte, and LoadByteU load halfwords, unsigned halfwords, + * bytes, and unsigned bytes respectively from memory into the + * lower portion of the returned Word32.word. StoreHWord and + * StoreByte store halfwords and bytes taken from the lower portion + * of the Word32.word into memory. + * GetStatistics takes memory and returns the read and write + * statistics as a string. + * + * The underlying structure of memory is an immutable array of Word32.word. + * The array has a length of 0x10000, since every element of the array + * corresponds to a thirty-two bit integer. + * + * Also, the functions AlignWAddress and AlignHWAddress aligns a memory + * address to a word and halfword address, respectively. If LoadWord, + * StoreWord, LoadHWord, LoadHWordU, or StoreHWord is asked to access an + * unaligned address, it writes an error message, and uses the address + * rounded down to the aligned address. + *) + +structure Memory : MEMORY + = struct + + type memory = Word32.word ImmArray.immarray * (int * int); + + fun InitMemory () = + (ImmArray.immarray(Word32.toInt(0wx10000 : Word32.word), + 0wx00000000 : Word32.word), + (0, 0)) : memory; + + fun AlignWAddress address + = Word32.<< (Word32.>> (address, 0wx0002), 0wx0002); + + fun AlignHWAddress address + = Word32.<< (Word32.>> (address, 0wx0001), 0wx0001); + + (* Load and Store provide errorless access to memory. + * They provide a common interface to memory, while + * the LoadX and StoreX specifically access words, + * halfwords and bytes, requiring address to be aligned. + * In Load and Store, two intermediate values are + * generated. The value aligned_address is the aligned + * version of the given address, and is used to compare with + * the original address to determine if it was aligned. The + * value use_address is equivalent to aligned_address divided + * by four, and it corresponds to the index of the memory + * array where the corresponding aligned address can be found. + *) + + fun Load ((mem, (reads, writes)), address) + = let + val aligned_address = AlignWAddress address; + val use_address = Word32.>> (aligned_address, 0wx0002); + in + ((mem, (reads + 1, writes)), + ImmArray.sub(mem, Word32.toInt(use_address))) + end; + + fun Store ((mem, (reads, writes)), address, data) + = let + val aligned_address = AlignWAddress address; + val use_address = Word32.>> (aligned_address, 0wx0002); + in + (ImmArray.update(mem, Word32.toInt(use_address), data), + (reads, writes + 1)) + end; + + + fun LoadWord (mem, address) + = let + val aligned_address + = if address = AlignWAddress address + then address + else (print "Error LW: Memory using aligned address\n"; + AlignWAddress address); + in + Load(mem, aligned_address) + end; + + fun StoreWord (mem, address, data) + = let + val aligned_address + = if address = AlignWAddress address + then address + else (print "Error SW: Memory using aligned address\n"; + AlignWAddress address); + in + Store(mem, aligned_address, data) + end; + + fun LoadHWord (mem, address) + = let + val aligned_address + = if address = AlignHWAddress address + then address + else (print "Error LH: Memory using aligned address\n"; + AlignHWAddress address); + val (nmem,l_word) = Load(mem, aligned_address); + in + (nmem, + case aligned_address + of 0wx00000000 : Word32.word + => Word32.~>>(Word32.<<(l_word, 0wx0010), + 0wx0010) + | 0wx00000010 : Word32.word + => Word32.~>>(Word32.<<(l_word, 0wx0000), + 0wx0010) + | _ => (print "Error LH: Memory returning 0\n"; + 0wx00000000 : Word32.word)) + end; + + fun LoadHWordU (mem, address) + = let + val aligned_address + = if address = AlignHWAddress address + then address + else (print "Error LHU: Memory using aligned address\n"; + AlignHWAddress address); + val (nmem, l_word) = Load(mem, aligned_address); + in + (nmem, + case aligned_address + of 0wx00000000 : Word32.word + => Word32.>>(Word32.<<(l_word, 0wx0010), + 0wx0010) + | 0wx00000010 : Word32.word + => Word32.>>(Word32.<<(l_word, 0wx0000), + 0wx0010) + | _ => (print "Error LHU: Memory returning 0\n"; + 0wx00000000 : Word32.word)) + end; + + fun StoreHWord (mem, address, data) + = let + val aligned_address + = if address = AlignHWAddress address + then address + else (print "Error SH: Memory using aligned address\n"; + AlignWAddress address); + val (_, s_word) = Load(mem, aligned_address); + in + case aligned_address + of 0wx00000000 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wxFFFF0000 : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx0000FFFF : + Word32.word, + data), + 0wx0000))) + | 0wx00000010 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wx0000FFFF : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx0000FFFF : + Word32.word, + data), + 0wx0010))) + | _ => (print "Error SH: Memory unchanged\n"; + mem) + end; + + fun LoadByte (mem, address) + = let + val aligned_address = address; + val (nmem, l_word) = Load(mem, aligned_address); + in + (nmem, + case aligned_address + of 0wx00000000 : Word32.word + => Word32.~>>(Word32.<<(l_word, + 0wx0018), + 0wx0018) + | 0wx00000008 : Word32.word + => Word32.~>>(Word32.<<(l_word, + 0wx0010), + 0wx0018) + | 0wx00000010 : Word32.word + => Word32.~>>(Word32.<<(l_word, + 0wx0008), + 0wx0018) + | 0wx00000018 : Word32.word + => Word32.~>>(Word32.<<(l_word, + 0wx0000), + 0wx0018) + | _ => (print "Error LB: Memory returning 0\n"; + 0wx00000000 : Word32.word)) + end; + + fun LoadByteU (mem, address) + = let + val aligned_address = address; + val (nmem, l_word) = Load(mem, aligned_address); + in + (nmem, + case aligned_address + of 0wx00000000 : Word32.word + => Word32.>>(Word32.<<(l_word, + 0wx0018), + 0wx0018) + | 0wx00000008 : Word32.word + => Word32.>>(Word32.<<(l_word, + 0wx0010), + 0wx0018) + | 0wx00000010 : Word32.word + => Word32.>>(Word32.<<(l_word, + 0wx0008), + 0wx0018) + | 0wx00000018 : Word32.word + => Word32.>>(Word32.<<(l_word, + 0wx0000), + 0wx0018) + | _ => (print "Error LBU: Memory returning 0\n"; + 0wx00000000 : Word32.word)) + end; + + fun StoreByte (mem, address, data) + = let + val aligned_address = address; + val (_, s_word) = Load(mem, aligned_address); + in + case aligned_address + of 0wx00000000 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wxFFFFFF00 : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx000000FF : + Word32.word, + data), + 0wx0000))) + | 0wx00000008 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wxFFFF00FF : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx000000FF : + Word32.word, + data), + 0wx0008))) + | 0wx00000010 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wxFF00FFFF : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx000000FF : + Word32.word, + data), + 0wx0010))) + | 0wx00000018 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wx00FFFFFF : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx000000FF : + Word32.word, + data), + 0wx0018))) + | _ => (print "Error SB: Memory unchanged\n"; + mem) + end; + + fun GetStatistics (mem, (reads, writes)) + = "Memory :\n" ^ + "Memory Reads : " ^ (Int.toString reads) ^ "\n" ^ + "Memory Writes : " ^ (Int.toString writes) ^ "\n"; + + end; + +(*****************************************************************************) + +(* + * CacheSpec.sig + * + * This defines the signature that outlines the specifications to + * describe a cache. The two datatypes are given to provide clear + * means of differentiating between the write hit and write miss + * options. CacheName can be any string describing the cache. + * CacheSize is an integer that represents the total number of words + * in the cache. BlockSize is an integer that represents the total + * number of words in a block. Associativity is an integer that + * represents the associativity of the cache. WriteHit and WriteMiss + * represent the write hit and write miss options to be implemented by + * this cache. + *) + +signature CACHESPEC + = sig + + datatype WriteHitOption = Write_Through + | Write_Back; + + datatype WriteMissOption = Write_Allocate + | Write_No_Allocate; + + val CacheName : string; + val CacheSize : int; + val BlockSize : int; + val Associativity : int; + val WriteHit : WriteHitOption; + val WriteMiss : WriteMissOption; + + end; + +(*****************************************************************************) + +(* + * CachedMemory.sml + * + * This defines the CachedMemory functor, which provides the + * functionality of a cached memory and which takes two structures, + * corresponding to the cache specification and the the level of + * memory which the cache will be caching. The datatype memory + * provides the encapsulation of the cache along with the memory + * system that is being cached, InitMemory initializes the cache and + * the memory system that is being cached, LoadWord takes memory and a + * Word32.word corresponding to the address, and returns the + * Word32.word at that address and the updated cache and memory, + * StoreWord takes memory, a Word32.word corresponding to the address, + * and a Word32.word and returns the cache and memory updated with the + * stored at the appropriate address. LoadHWord, LoadHWordU, + * LoadByte, and LoadByteU load halfwords, unsigned halfwords, + * bytes, and unsigned bytes respectively from memory into the + * lower portion of the returned Word32.word. StoreHWord and + * StoreByte store halfwords and bytes taken from the lower portion + * of the Word32.word into memory. + * GetStatistics takes memory and returns the read and write + * statistics as a string. + * + * The underlying structure of cache is a two dimensional array of + * cache lines, where a cache line consists of a valid bit, dirty bit, + * a tag and a block of words, as a Word32.word array. + * The size of the cache, the associativity, and the block size are + * specified by the cache specification. + * + * Also, the functions AlignWAddress and AlignHWAddress aligns a memory + * address to a word and halfword address, respectively. If LoadWord, + * StoreWord, LoadHWord, LoadHWordU, or StoreHWord is asked to access an + * unaligned address, it writes an error message, and uses the address + * rounded down to the aligned address. + *) + +functor CachedMemory (structure CS : CACHESPEC; + structure MEM : MEMORY;) : MEMORY + = struct + + type cacheline + = bool * bool * Word32.word * Word32.word ImmArray.immarray; + + type cacheset + = cacheline ImmArray.immarray; + + type cache + = cacheset ImmArray.immarray; + + type memory = (cache * (int * int * int * int)) * MEM.memory; + + + (* Performs log[base2] on an integer. *) + fun exp2 0 = 1 + | exp2 n = 2 * (exp2 (n-1)) + fun log2 x = let + fun log2_aux n = if exp2 n > x + then (n-1) + else log2_aux (n+1) + in + log2_aux 0 + end + + open CS; + + (* + * The following values of index size and field bits are + * calculated from the values in the cache specification + * structure. + *) + val IndexSize = CacheSize div (BlockSize * Associativity); + val BlockOffsetBits = log2 (BlockSize * 4); + val IndexBits = log2 IndexSize; + val TagBits = 32 - BlockOffsetBits - IndexBits; + + + (* + * RandEntry returns a random number between + * [0, Associativity - 1]. It is used to determine + * replacement of data in the cache. + *) + val RandEntry = let + val modulus = Word.fromInt(Associativity - 1) + in + fn () => Word.toInt(Word.mod(rand (), + modulus)) + end + + (* + * The InitCache function initializes the cache to + * not-valid, not-dirty, 0wx00000000 tag, blocks initialized + * to 0wx00000000. + *) + fun InitCache () + = let + val cacheline = (false, false, 0wx00000000 : Word32.word, + ImmArray.immarray (BlockSize, + 0wx00000000 : Word32.word)); + val cacheset = ImmArray.immarray (Associativity, cacheline); + in + (ImmArray.immarray (IndexSize, cacheset), + (0, 0, 0, 0)) + end; + + + (* + * The InitMemory function initializes the cache + * and the memory being cached. + *) + fun InitMemory () = (InitCache (), MEM.InitMemory ()) : memory; + + + (* + * GetTag returns the Word32.word corresponding to the tag field of + * address + *) + fun GetTag address + = Word32.>> (address, + Word.fromInt (IndexBits + BlockOffsetBits)); + + + (* + * GetIndex returns the Word32.word corresponding to the index + * field of address. + *) + fun GetIndex address + = let + val mask + = Word32.notb + (Word32.<< + (Word32.>> (0wxFFFFFFFF : Word32.word, + Word.fromInt (IndexBits + BlockOffsetBits)), + Word.fromInt (IndexBits + BlockOffsetBits))); + in + Word32.>> (Word32.andb (address, mask), + Word.fromInt (BlockOffsetBits)) + end; + + + (* + * GetBlockOffset returns the Word32.word corresponding to the + * block offset field of address. + *) + fun GetBlockOffset address + = let + val mask + = Word32.notb + (Word32.<< + (Word32.>> (0wxFFFFFFFF : Word32.word, + Word.fromInt BlockOffsetBits), + Word.fromInt BlockOffsetBits)); + in + Word32.andb (address, mask) + end; + + + (* + * The InCache* family of functions returns a boolean value + * that determines if the word specified by address is in the + * cache at the current time (and that the data is valid). + *) + fun InCache_aux_entry ((valid, dirty, tag, block), address) + = tag = (GetTag address) andalso valid; + + fun InCache_aux_set (set, address) + = ImmArray.foldr (fn (entry, result) => + (InCache_aux_entry (entry, address)) orelse + result) + false + set; + + fun InCache (cac, address) + = InCache_aux_set (ImmArray.sub (cac, + Word32.toInt (GetIndex address)), + address); + + (* + * The ReadCache* family of functions returns the Word32.word + * stored at address in the cache. + *) + fun ReadCache_aux_entry ((valid, dirty, tag, block), address) + = ImmArray.sub (block, + Word32.toInt (Word32.>> (GetBlockOffset address, + 0wx0002))); + + fun ReadCache_aux_set (set, address) + = ImmArray.foldr (fn (entry, result) => + if InCache_aux_entry (entry, address) + then ReadCache_aux_entry (entry, address) + else result) + (0wx00000000 : Word32.word) + set; + + fun ReadCache (cac, address) + = ReadCache_aux_set (ImmArray.sub (cac, + Word32.toInt(GetIndex address)), + address); + + + (* + * The WriteCache* family of functions returns the updated + * cache with data stored at address. + *) + fun WriteCache_aux_entry ((valid, dirty, tag, block), address, data) + = let + val ndirty = case WriteHit + of Write_Through => false + | Write_Back => true; + in + (true, ndirty, tag, + ImmArray.update (block, + Word32.toInt (Word32.>> + (GetBlockOffset address, + 0wx0002)), + data)) + end; + + fun WriteCache_aux_set (set, address, data) + = ImmArray.map (fn entry => + if InCache_aux_entry (entry, address) + then WriteCache_aux_entry (entry, address, + data) + else entry) + set; + + fun WriteCache (cac, address, data) + = let + val index = Word32.toInt (GetIndex address); + val nset = WriteCache_aux_set (ImmArray.sub (cac, index), + address, data); + in + ImmArray.update (cac, index, nset) + end; + + + (* + * The LoadBlock function returns the updated + * memory and the block containing address loaded from memory. + *) + fun LoadBlock (mem, address) + = ImmArray.foldr (fn (offset, (block, mem)) => + let + val laddress + = Word32.+ (Word32.<< + (Word32.>> + (address, + Word.fromInt + BlockOffsetBits), + Word.fromInt + BlockOffsetBits), + Word32.<< (Word32.fromInt + offset, + 0wx0002)); + val (nmem, nword) = MEM.LoadWord (mem, + laddress); + in + (ImmArray.update (block, offset, nword), nmem) + end) + (ImmArray.immarray (BlockSize, + 0wx00000000 : Word32.word), mem) + (ImmArray.tabulate (BlockSize, fn i => i)); + + + (* + * The StoreBlock functionsreturns the updated + * memory with block stored into the block containing address. + *) + fun StoreBlock (block, mem, address) + = ImmArray.foldr (fn (offset, mem) => + let + val saddress + = Word32.+ (Word32.<< + (Word32.>> + (address, + Word.fromInt + BlockOffsetBits), + Word.fromInt + BlockOffsetBits), + Word32.<< (Word32.fromInt + offset, + 0wx0002)); + in + MEM.StoreWord (mem, saddress, + ImmArray.sub (block, offset)) + end) + mem + (ImmArray.tabulate (BlockSize, fn i => i)); + + + (* + * The LoadCache* family of functions returns the updated + * cache and memory, with the block containing address loaded + * into the cache at the appropriate cache line, and dirty + * data written back to memory as needed. + *) + fun LoadCache_aux_entry ((valid, dirty, tag, block), mem, address) + = let + val saddress + = Word32.orb (Word32.<< (tag, + Word.fromInt TagBits), + Word32.<< (GetIndex address, + Word.fromInt IndexBits)); + val nmem = if valid andalso dirty + then StoreBlock (block, mem, saddress) + else mem; + val (nblock, nnmem) = LoadBlock (nmem, address); + in + ((true, false, GetTag address, nblock), nnmem) + end; + + fun LoadCache_aux_set (set, mem, address) + = let + val entry = RandEntry (); + val (nentry, nmem) = LoadCache_aux_entry (ImmArray.sub (set, + entry), + mem, address); + in + (ImmArray.update (set, entry, nentry), nmem) + end; + + fun LoadCache (cac, mem, address) + = let + val index = Word32.toInt (GetIndex address); + val (nset, nmem) + = LoadCache_aux_set (ImmArray.sub (cac, index), + mem, address); + in + (ImmArray.update (cac, index, nset), nmem) + end; + + + (* + * The remainder of the function defined here satisfy the MEMORY + * signature. This allows a CachedMemory to act exactly like + * a normal Memory, and thus caches can be nested to an arbitrary + * depth. + *) + + fun AlignWAddress address + = Word32.<< (Word32.>> (address, 0wx0002), 0wx0002); + + fun AlignHWAddress address + = Word32.<< (Word32.>> (address, 0wx0001), 0wx0001); + + (* Load and Store provide errorless access to memory. + * They provide a common interface to memory, while + * the LoadX and StoreX specifically access words, + * halfwords and bytes, requiring address to be aligned. + * In Load and Store, two intermediate values are + * generated. The value aligned_address is the aligned + * version of the given address, and is used to compare with + * the original address to determine if it was aligned. The + * value use_address is equivalent to aligned_address divided + * by four, and it corresponds to the index of the memory + * array where the corresponding aligned address can be found. + *) + + fun Load (((cac, (rh, rm, wh, wm)), mem), address) + = let + val aligned_address = AlignWAddress address; + in + if InCache (cac, aligned_address) + then (((cac, (rh + 1, rm, wh, wm)), mem), + ReadCache (cac, aligned_address)) + else let + val (ncac, nmem) + = LoadCache (cac, mem, aligned_address); + in + (((ncac, (rh, rm + 1, wh, wm)), nmem), + ReadCache (ncac, aligned_address)) + end + end; + + + fun Store (((cac, (rh, rm, wh, wm)), mem), address, data) + = let + val aligned_address = AlignWAddress address; + in + if InCache (cac, aligned_address) + then let + val ncac = WriteCache (cac, aligned_address, data); + in + case WriteHit + of Write_Through => + ((ncac, (rh, rm, wh + 1, wm)), + MEM.StoreWord (mem, aligned_address, data)) + | Write_Back => + ((ncac, (rh, rm, wh + 1, wm)), mem) + end + else case WriteMiss + of Write_Allocate => + let + val (ncac, nmem) + = LoadCache (cac, mem, aligned_address); + val nncac + = WriteCache (ncac, aligned_address, data); + in + case WriteHit + of Write_Through => + ((nncac, (rh, rm, wh, wm + 1)), + MEM.StoreWord (nmem, aligned_address, + data)) + | Write_Back => + ((nncac, (rh, rm, wh, wm + 1)), + nmem) + end + | Write_No_Allocate => + ((cac, (rh, rm, wh, wm + 1)), + MEM.StoreWord (mem, aligned_address, data)) + end; + + fun LoadWord (mem, address) + = let + val aligned_address + = if address = AlignWAddress address + then address + else (print "Error LW: Memory using aligned address\n"; + AlignWAddress address); + in + Load(mem, aligned_address) + end; + + fun StoreWord (mem, address, data) + = let + val aligned_address + = if address = AlignWAddress address + then address + else (print "Error SW: Memory using aligned address\n"; + AlignWAddress address); + in + Store(mem, aligned_address, data) + end; + + fun LoadHWord (mem, address) + = let + val aligned_address + = if address = AlignHWAddress address + then address + else (print "Error LH: Memory using aligned address\n"; + AlignHWAddress address); + val (nmem,l_word) = Load(mem, aligned_address); + in + (nmem, + case aligned_address + of 0wx00000000 : Word32.word + => Word32.~>>(Word32.<<(l_word, 0wx0010), + 0wx0010) + | 0wx00000010 : Word32.word + => Word32.~>>(Word32.<<(l_word, 0wx0000), + 0wx0010) + | _ => (print "Error LH: Memory returning 0\n"; + 0wx00000000 : Word32.word)) + end; + + fun LoadHWordU (mem, address) + = let + val aligned_address + = if address = AlignHWAddress address + then address + else (print "Error LHU: Memory using aligned address\n"; + AlignHWAddress address); + val (nmem, l_word) = Load(mem, aligned_address); + in + (nmem, + case aligned_address + of 0wx00000000 : Word32.word + => Word32.>>(Word32.<<(l_word, 0wx0010), + 0wx0010) + | 0wx00000010 : Word32.word + => Word32.>>(Word32.<<(l_word, 0wx0000), + 0wx0010) + | _ => (print "Error LHU: Memory returning 0\n"; + 0wx00000000 : Word32.word)) + end; + + fun StoreHWord (mem, address, data) + = let + val aligned_address + = if address = AlignHWAddress address + then address + else (print "Error SH: Memory using aligned address\n"; + AlignWAddress address); + val (_, s_word) = Load(mem, aligned_address); + in + case aligned_address + of 0wx00000000 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wxFFFF0000 : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx0000FFFF : + Word32.word, + data), + 0wx0000))) + | 0wx00000010 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wx0000FFFF : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx0000FFFF : + Word32.word, + data), + 0wx0010))) + | _ => (print "Error SH: Memory unchanged\n"; + mem) + end; + + fun LoadByte (mem, address) + = let + val aligned_address = address; + val (nmem, l_word) = Load(mem, aligned_address); + in + (nmem, + case aligned_address + of 0wx00000000 : Word32.word + => Word32.~>>(Word32.<<(l_word, + 0wx0018), + 0wx0018) + | 0wx00000008 : Word32.word + => Word32.~>>(Word32.<<(l_word, + 0wx0010), + 0wx0018) + | 0wx00000010 : Word32.word + => Word32.~>>(Word32.<<(l_word, + 0wx0008), + 0wx0018) + | 0wx00000018 : Word32.word + => Word32.~>>(Word32.<<(l_word, + 0wx0000), + 0wx0018) + | _ => (print "Error LB: Memory returning 0\n"; + 0wx00000000 : Word32.word)) + end; + + fun LoadByteU (mem, address) + = let + val aligned_address = address; + val (nmem, l_word) = Load(mem, aligned_address); + in + (nmem, + case aligned_address + of 0wx00000000 : Word32.word + => Word32.>>(Word32.<<(l_word, + 0wx0018), + 0wx0018) + | 0wx00000008 : Word32.word + => Word32.>>(Word32.<<(l_word, + 0wx0010), + 0wx0018) + | 0wx00000010 : Word32.word + => Word32.>>(Word32.<<(l_word, + 0wx0008), + 0wx0018) + | 0wx00000018 : Word32.word + => Word32.>>(Word32.<<(l_word, + 0wx0000), + 0wx0018) + | _ => (print "Error LBU: Memory returning 0\n"; + 0wx00000000 : Word32.word)) + end; + + fun StoreByte (mem, address, data) + = let + val aligned_address = address; + val (_, s_word) = Load(mem, aligned_address); + in + case aligned_address + of 0wx00000000 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wxFFFFFF00 : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx000000FF : + Word32.word, + data), + 0wx0000))) + | 0wx00000008 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wxFFFF00FF : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx000000FF : + Word32.word, + data), + 0wx0008))) + | 0wx00000010 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wxFF00FFFF : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx000000FF : + Word32.word, + data), + 0wx0010))) + | 0wx00000018 : Word32.word + => Store(mem, aligned_address, + Word32.orb(Word32.andb(0wx00FFFFFF : Word32.word, + s_word), + Word32.<<(Word32.andb(0wx000000FF : + Word32.word, + data), + 0wx0018))) + | _ => (print "Error SB: Memory unchanged\n"; + mem) + end; + + fun GetStatistics ((cac, (rh, rm, wh, wm)), mem) + = let + + val th = rh + wh; + + val tm = rm + wm; + + val who = case WriteHit + of Write_Through => "Write Through" + | Write_Back => "Write Back"; + + val wmo = case WriteMiss + of Write_Allocate => "Write Allocate" + | Write_No_Allocate => "Write No Allocate"; + + in + CacheName ^ " :\n" ^ + "CacheSize : " ^ (Int.toString CacheSize) ^ "\n" ^ + "BlockSize : " ^ (Int.toString BlockSize) ^ "\n" ^ + "Associativity : " ^ (Int.toString Associativity) ^ "\n" ^ + "Write Hit : " ^ who ^ "\n" ^ + "Write Miss : " ^ wmo ^ "\n" ^ + "Read hits : " ^ (Int.toString rh) ^ "\n" ^ + "Read misses : " ^ (Int.toString rm) ^ "\n" ^ + "Write hits : " ^ (Int.toString wh) ^ "\n" ^ + "Write misses : " ^ (Int.toString wm) ^ "\n" ^ + "Total hits : " ^ (Int.toString th) ^ "\n" ^ + "Total misses : " ^ (Int.toString tm) ^ "\n" ^ + (MEM.GetStatistics mem) + end; + + end; + +(*****************************************************************************) + +(* + * DLXSimulator.sig + * + * This defines the exported function provided by the DLXSimulator. + * The function run_file takes a string corresponding to the name of the + * file to be run, and executes it. The function run_prog takes a + * list of instructions and executes them. + *) + +signature DLXSIMULATOR + = sig + + val run_file : string -> unit; + val run_prog : string list -> unit; + + end; + +(*****************************************************************************) + +(* + * DLXSimulator.sml + * + * This defines the DLXSimulatorFun functor, which takes three + * structures, corresponding to the register file, the ALU, and memory, + * and provides the functionality of a DLX processor, able to execute + * DLX programs. The function run_file takes a string corresponding to the + * name of the file to be executed, and executes it. The function + * run_prog takes a list of instructions and executes them. + *) + +functor DLXSimulatorFun (structure RF : REGISTERFILE; + structure ALU : ALU; + structure MEM : MEMORY; ) : DLXSIMULATOR + = struct + + (* + * The datatype Opcode provides a means of differentiating * + * among the main opcodes. + *) + datatype Opcode = + (* for R-type opcodes *) + SPECIAL | + (* I-type opcodes *) + BEQZ | BNEZ | + ADDI | ADDUI | SUBI | SUBUI | + ANDI | ORI | XORI | + LHI | + SLLI | SRLI | SRAI | + SEQI | SNEI | SLTI | SGTI | SLEI | SGEI | + LB | LBU | SB | + LH | LHU | SH | + LW | SW | + (* J-type opcodes *) + J | JAL | TRAP | JR | JALR | + (* Unrecognized opcode *) + NON_OP; + + (* + * The datatype RRFuncCode provides a means of + * differentiating among + * the register-register function codes. + *) + datatype RRFunctCode = NOP | SLL | SRL | SRA | + ADD | ADDU | SUB | SUBU | + AND | OR | XOR | + SEQ | SNE | SLT | SGT | SLE | SGE | + NON_FUNCT; + + (* + * The datatype Instruction provides a means of + * differentiating among the three different types of + * instructions, I-type, R-type, and J-type. + * An I-type is interpreted as (opcode, rs1, rd, immediate). + * An R-type is interpreted as (opcode, rs1, rs2, rd, shamt, funct). + * An J-type is interpreted as (opcode, offset). + * An ILLEGAL causes the simulator to end. + *) + datatype Instruction + = ITYPE of Opcode * int * int * Word32.word + | RTYPE of Opcode * int * int * int * int * RRFunctCode + | JTYPE of Opcode * Word32.word + | ILLEGAL; + + (* + * The value HALT is set to the DLX instruction TRAP #0, + * and is used to check for the halt of the program. + *) + val HALT = JTYPE (TRAP, 0wx00000000); + + (* + * The function DecodeIType decodes a Word32.word into an + * I-type instruction. + *) + fun DecodeIType instr + = let + val opc = Word32.andb (Word32.>> (instr, + 0wx001A), + 0wx0000003F : Word32.word); + + val opcode = case opc + of 0wx00000004 : Word32.word => BEQZ + | 0wx00000005 : Word32.word => BNEZ + | 0wx00000008 : Word32.word => ADDI + | 0wx00000009 : Word32.word => ADDUI + | 0wx0000000A : Word32.word => SUBI + | 0wx0000000B : Word32.word => SUBUI + | 0wx0000000C : Word32.word => ANDI + | 0wx0000000D : Word32.word => ORI + | 0wx0000000E : Word32.word => XORI + | 0wx0000000F : Word32.word => LHI + | 0wx00000014 : Word32.word => SLLI + | 0wx00000016 : Word32.word => SRLI + | 0wx00000017 : Word32.word => SRAI + | 0wx00000018 : Word32.word => SEQI + | 0wx00000019 : Word32.word => SNEI + | 0wx0000001A : Word32.word => SLTI + | 0wx0000001B : Word32.word => SGTI + | 0wx0000001C : Word32.word => SLEI + | 0wx0000001D : Word32.word => SGEI + | 0wx00000020 : Word32.word => LB + | 0wx00000024 : Word32.word => LBU + | 0wx00000028 : Word32.word => SB + | 0wx00000021 : Word32.word => LH + | 0wx00000025 : Word32.word => LHU + | 0wx00000029 : Word32.word => SH + | 0wx00000023 : Word32.word => LW + | 0wx0000002B : Word32.word => SW + | _ => (print "Error : Non I-Type opcode\n"; + NON_OP); + + val rs1 = Word32.toInt(Word32.andb (Word32.>> (instr, 0wx0015), + 0wx0000001F : Word32.word)); + + val rd = Word32.toInt(Word32.andb (Word32.>> (instr, 0wx0010), + 0wx0000001F : Word32.word)); + + val immediate = Word32.~>> (Word32.<< (instr, 0wx0010), + 0wx0010); + + in + if opcode = NON_OP + then ILLEGAL + else ITYPE (opcode, rs1, rd, immediate) + end; + + (* + * The function DecodeRType decodes a Word32.word into an + * R-type instruction. + *) + fun DecodeRType instr + = let + + val rs1 = Word32.toInt (Word32.andb (Word32.>> (instr, 0wx0015), + 0wx0000001F : Word32.word)); + + val rs2 = Word32.toInt (Word32.andb (Word32.>> (instr, 0wx0010), + 0wx0000001F : Word32.word)); + + val rd = Word32.toInt (Word32.andb (Word32.>> (instr, 0wx000B), + 0wx0000001F : Word32.word)); + + val shamt + = Word32.toInt (Word32.andb (Word32.>> (instr, 0wx0006), + 0wx0000001F : Word32.word)); + + val funct = Word32.andb (instr, 0wx0000003F : Word32.word); + + val functcode = case funct + of 0wx00000000 : Word32.word => NOP + | 0wx00000004 : Word32.word => SLL + | 0wx00000006 : Word32.word => SRL + | 0wx00000007 : Word32.word => SRA + | 0wx00000020 : Word32.word => ADD + | 0wx00000021 : Word32.word => ADDU + | 0wx00000022 : Word32.word => SUB + | 0wx00000023 : Word32.word => SUBU + | 0wx00000024 : Word32.word => AND + | 0wx00000025 : Word32.word => OR + | 0wx00000026 : Word32.word => XOR + | 0wx00000028 : Word32.word => SEQ + | 0wx00000029 : Word32.word => SNE + | 0wx0000002A : Word32.word => SLT + | 0wx0000002B : Word32.word => SGT + | 0wx0000002C : Word32.word => SLE + | 0wx0000002D : Word32.word => SGE + | _ => (print "Error : Non R-type funct\n"; + NON_FUNCT); + + in + if functcode = NON_FUNCT + then ILLEGAL + else RTYPE (SPECIAL, rs1, rs2, rd, shamt, functcode) + end; + + (* + * The function DecodeJType decodes a Word32.word into an + * J-type instruction. + *) + fun DecodeJType instr + = let + + val opc = Word32.andb (Word32.>> (instr, 0wx1A), + 0wx0000003F : Word32.word); + + val opcode = case opc + of 0wx00000002 : Word32.word => J + | 0wx00000003 : Word32.word => JAL + | 0wx00000011 : Word32.word => TRAP + | 0wx00000012 : Word32.word => JR + | 0wx00000013 : Word32.word => JALR + | _ => (print "Error : Non J-type opcode\n"; + NON_OP); + + val offset = Word32.~>> (Word32.<< (instr, 0wx0006), + 0wx0006); + + in + if opcode = NON_OP + then ILLEGAL + else JTYPE (opcode, offset) + end; + + (* + * The function DecodeInstr decodes a Word32.word into an + * instruction. It first checks the opcode, and then calls + * one of DecodeIType, DecodeJType, and DecodeRType to + * complete the decoding process. + *) + fun DecodeInstr instr + = let + + val opcode = Word32.andb (Word32.>> (instr, 0wx1A), + 0wx0000003F : Word32.word); + + in + case opcode + of 0wx00000000 : Word32.word => DecodeRType instr + | 0wx00000002 : Word32.word => DecodeJType instr + | 0wx00000003 : Word32.word => DecodeJType instr + | 0wx00000004 : Word32.word => DecodeIType instr + | 0wx00000005 : Word32.word => DecodeIType instr + | 0wx00000008 : Word32.word => DecodeIType instr + | 0wx00000009 : Word32.word => DecodeIType instr + | 0wx0000000A : Word32.word => DecodeIType instr + | 0wx0000000B : Word32.word => DecodeIType instr + | 0wx0000000C : Word32.word => DecodeIType instr + | 0wx0000000D : Word32.word => DecodeIType instr + | 0wx0000000E : Word32.word => DecodeIType instr + | 0wx0000000F : Word32.word => DecodeIType instr + | 0wx00000011 : Word32.word => DecodeJType instr + | 0wx00000012 : Word32.word => DecodeJType instr + | 0wx00000013 : Word32.word => DecodeJType instr + | 0wx00000016 : Word32.word => DecodeIType instr + | 0wx00000017 : Word32.word => DecodeIType instr + | 0wx00000018 : Word32.word => DecodeIType instr + | 0wx00000019 : Word32.word => DecodeIType instr + | 0wx0000001A : Word32.word => DecodeIType instr + | 0wx0000001B : Word32.word => DecodeIType instr + | 0wx0000001C : Word32.word => DecodeIType instr + | 0wx0000001D : Word32.word => DecodeIType instr + | 0wx00000020 : Word32.word => DecodeIType instr + | 0wx00000024 : Word32.word => DecodeIType instr + | 0wx00000028 : Word32.word => DecodeIType instr + | 0wx00000021 : Word32.word => DecodeIType instr + | 0wx00000025 : Word32.word => DecodeIType instr + | 0wx00000029 : Word32.word => DecodeIType instr + | 0wx00000023 : Word32.word => DecodeIType instr + | 0wx0000002B : Word32.word => DecodeIType instr + | _ => (print "Error : Unrecognized opcode\n"; + ILLEGAL) + end; + + + (* + * The function PerformIType performs one of the I-Type + * instructions. A number of the instructions make use of the + * ALU, and as such, call ALU.PerformAL. + *) + fun PerformIType ((BEQZ, rs1, rd, immediate), (PC, rf, mem)) + = if (RF.LoadRegister(rf, rs1) = (0wx00000000 : Word32.word)) + then (Word32.fromInt (Int.+ (Word32.toIntX PC, + Word32.toIntX + (Word32.<< (immediate, + 0wx0002)))), + rf, mem) + else (PC, rf, mem) + + | PerformIType ((BNEZ, rs1, rd, immediate), (PC, rf, mem)) + = if not (RF.LoadRegister(rf, rs1) = (0wx00000000 : Word32.word)) + then (Word32.fromInt (Int.+ (Word32.toIntX PC, + Word32.toIntX + (Word32.<< (immediate, + 0wx0002)))), + rf, mem) + else (PC, rf, mem) + + | PerformIType ((ADDI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.ADD, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((ADDUI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.ADDU, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((SUBI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SUB, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((SUBUI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SUBU, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((ANDI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.AND, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((ORI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.OR, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((XORI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.XOR, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((LHI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, RF.StoreRegister(rf, rd, Word32.<< (immediate, 0wx0010)), mem) + + | PerformIType ((SLLI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, RF.StoreRegister(rf, rd, + Word32.<< (RF.LoadRegister(rf, rs1), + Word.fromLarge (Word32.toLarge immediate))), + mem) + + | PerformIType ((SRLI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, RF.StoreRegister(rf, rd, + Word32.>> (RF.LoadRegister(rf, rs1), + Word.fromLarge (Word32.toLarge immediate))), + mem) + + | PerformIType ((SRAI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, RF.StoreRegister(rf, rd, + Word32.~>> (RF.LoadRegister(rf, rs1), + Word.fromLarge (Word32.toLarge immediate))), + mem) + + | PerformIType ((SEQI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SEQ, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((SNEI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SNE, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((SLTI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SLT, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((SGTI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SGT, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((SLEI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SLE, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((SGEI, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SGE, + RF.LoadRegister(rf, rs1), + immediate)), + mem) + + | PerformIType ((LB, rs1, rd, immediate), (PC, rf, mem)) + = let + val (nmem, l_byte) + = MEM.LoadByte(mem, Word32.+ (RF.LoadRegister(rf, rs1), + immediate)); + in + (PC, + RF.StoreRegister(rf, rd, l_byte), + nmem) + end + + | PerformIType ((LBU, rs1, rd, immediate), (PC, rf, mem)) + = let + val (nmem, l_byte) + = MEM.LoadByteU(mem, Word32.+ (RF.LoadRegister(rf, rs1), + immediate)); + in + (PC, + RF.StoreRegister(rf, rd, l_byte), + nmem) + end + + | PerformIType ((SB, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + rf, + MEM.StoreByte(mem, + Word32.+ (RF.LoadRegister(rf, rs1), immediate), + Word32.andb(0wx000000FF, RF.LoadRegister(rf, rd)))) + + | PerformIType ((LH, rs1, rd, immediate), (PC, rf, mem)) + = let + val (nmem, l_hword) + = MEM.LoadHWord(mem, Word32.+ (RF.LoadRegister(rf, rs1), + immediate)); + in + (PC, + RF.StoreRegister(rf, rd, l_hword), + nmem) + end + + | PerformIType ((LHU, rs1, rd, immediate), (PC, rf, mem)) + = let + val (nmem, l_hword) + = MEM.LoadHWordU(mem, Word32.+ (RF.LoadRegister(rf, rs1), + immediate)); + in + (PC, + RF.StoreRegister(rf, rd, l_hword), + nmem) + end + + | PerformIType ((SH, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + rf, + MEM.StoreByte(mem, + Word32.+ (RF.LoadRegister(rf, rs1), immediate), + Word32.andb(0wx0000FFFF, RF.LoadRegister(rf, rd)))) + + + | PerformIType ((LW, rs1, rd, immediate), (PC, rf, mem)) + = let + val (nmem, l_word) + = MEM.LoadWord(mem, Word32.+ (RF.LoadRegister(rf, rs1), + immediate)); + in + (PC, + RF.StoreRegister(rf, rd, l_word), + nmem) + end + + | PerformIType ((SW, rs1, rd, immediate), (PC, rf, mem)) + = (PC, + rf, + MEM.StoreWord(mem, + Word32.+ (RF.LoadRegister(rf, rs1), immediate), + RF.LoadRegister(rf, rd))) + + | PerformIType ((_, rs1, rd, immediate), (PC, rf, mem)) + = (print "Error : Non I-Type opcode, performing NOP\n"; + (PC, rf, mem)); + + + (* + * The function PerformRType performs one of the R-Type + * instructions. All of the instructions make use of the + * ALU, and as such, call ALU.PerformAL. + *) + fun PerformRType ((SPECIA, rs1, rs2, rd, shamt, NOP), (PC, rf, mem)) + = (PC, rf, mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SLL), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SLL, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SRL), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SRL, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SRA), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SRA, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, ADD), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.ADD, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, ADDU), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.ADDU, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SUB), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SUB, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SUBU), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SUBU, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, AND), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.AND, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, OR), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.OR, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, XOR), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.XOR, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SEQ), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SEQ, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SNE), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SNE, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SLT), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SLT, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SGT), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SGT, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SLE), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SLE, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((SPECIAL, rs1, rs2, rd, shamt, SGE), (PC, rf, mem)) + = (PC, + RF.StoreRegister(rf, rd, + ALU.PerformAL(ALU.SGE, + RF.LoadRegister(rf, rs1), + RF.LoadRegister(rf, rs2))), + mem) + + | PerformRType ((_, rs1, rs2, rd, shamt, _), (PC, rf, mem)) + = (print "Error : Non R-Type opcode, performing NOP\n"; + (PC, rf, mem)); + + + (* + * The function PerformJType performs one of the J-Type + * instructions. + *) + fun PerformJType ((J, offset), (PC, rf, mem)) + = (Word32.fromInt (Int.+ (Word32.toIntX PC, + Word32.toIntX + (Word32.<< (offset, 0wx0002)))), + rf, mem) + + | PerformJType ((JR, offset), (PC, rf, mem)) + = (RF.LoadRegister(rf, + Word32.toInt(Word32.andb (Word32.>> (offset, + 0wx0015), + 0wx0000001F : + Word32.word))), + rf, mem) + + | PerformJType ((JAL, offset), (PC, rf, mem)) + = (Word32.fromInt (Int.+ (Word32.toIntX PC, + Word32.toIntX + (Word32.<< (offset, 0wx0002)))), + RF.StoreRegister(rf, 31, PC), + mem) + + | PerformJType ((JALR, offset), (PC, rf, mem)) + = (RF.LoadRegister(rf, + Word32.toInt (Word32.andb (Word32.>> (offset, + 0wx0015), + 0wx0000001F : + Word32.word))), + RF.StoreRegister(rf, 31, PC), + mem) + + | PerformJType ((TRAP, 0wx00000003 : Word32.word), (PC, rf, mem)) + = let + val x = TextIO.print "Value? "; + val s = "10" (* TextIO.inputLine TextIO.stdIn; *) + val i = Int.fromString s; + val input = if isSome i + then valOf i + else (TextIO.print "Error : Returning 0\n"; + Int.fromInt 0); + in + (PC, + RF.StoreRegister(rf, 14, Word32.fromInt input), + mem) + end + + | PerformJType ((TRAP, 0wx00000004 : Word32.word), (PC, rf, mem)) + = let + val output = Int.toString (Word32.toIntX + (RF.LoadRegister(rf, 14))); + + in + (TextIO.print ("Output: " ^ output ^ "\n"); + (PC, rf, mem)) + end + + | PerformJType ((_, offset), (PC, rf, mem)) + = (print "Error : Non J-Type opcode, performing NOP\n"; + (PC, rf, mem)); + + + (* + * The function PerformInstr performs an instruction by + * passing the instruction to the appropriate auxiliary function. + *) + fun PerformInstr (ITYPE instr, (PC, rf, mem)) + = PerformIType (instr, (PC, rf, mem)) + | PerformInstr (RTYPE instr, (PC, rf, mem)) + = PerformRType (instr, (PC, rf, mem)) + | PerformInstr (JTYPE instr, (PC, rf, mem)) + = PerformJType (instr, (PC, rf, mem)) + | PerformInstr (ILLEGAL, (PC, rf, mem)) + = (PC, rf, mem); + + + (* + * The function CycleLoop represents the basic clock cylce of + * the DLX processor. It takes as input the current program + * counter, the current register file, and the current memory. + * It loads, decodes, and executes an instruction and increments + * the program counter. If the instruction that was loaded is + * the HALT instruction, the program terminates, otherwise, + * CycleLoop is recursively called with the result of performing + * the instruction. + *) + fun CycleLoop (PC, rf, mem) + = let + val (nmem, instr_word) = MEM.LoadWord (mem, PC); + val instr = DecodeInstr instr_word; + val nPC = Word32.+ (PC, 0wx00000004 : Word32.word); + in + if instr = HALT orelse instr = ILLEGAL + then (print "Program halted.\n"; + print (MEM.GetStatistics (nmem)); + ()) + else CycleLoop (PerformInstr (instr, (nPC, rf, nmem))) + end + + + (* + * The function LoadProgAux is an auxilary function that + * assists in loading a program into memory. It recursively + * calls itself, each time loading an instruction and incrementing + * the address to which the next instruction is to be loaded. + *) + fun LoadProgAux ([], mem, address) + = mem + | LoadProgAux (instrs::instr_list, mem, address) + = let + val instro = Word32.fromString instrs; + val instr = if isSome instro + then valOf instro + else (print ("Error : Invalid " ^ + "instruction format, " ^ + "returning NOP\n"); + 0wx00000000 : Word32.word); + in + LoadProgAux (instr_list, + MEM.StoreWord (mem, address, instr), + Word32.+ (address, 0wx00000004 : Word32.word)) + end; + + (* + * The function LoadProg takes a list of instructions and memory, and + * loads the file into memory, beginning at 0x10000. + *) + fun LoadProg (instr_list, mem) + = LoadProgAux (instr_list, mem, 0wx00010000 : Word32.word); + + + (* + * The function ReadFileToInstr reads the sequence of + * instructions in a file into a list. + *) + fun ReadFileToInstr file + = (case TextIO.inputLine file of + NONE => [] + | SOME l => l :: (ReadFileToInstr file)); + + + (* + * The function run_prog is exported by DLXSimulator. + * It takes a list of instructions, then begins + * execution of the instructions loaded at 0x10000, with an + * initialized register file, and the loaded program in an + * initialised memory. + *) + fun run_prog instructions + = CycleLoop (0wx00010000 : Word32.word, + RF.InitRegisterFile (), + LoadProg (instructions, MEM.InitMemory ())); + + (* + * The function run_file is exported by DLXSimulator. + * It takes the name of a file to be run, then begins + * execution of the loaded program at 0x10000, with an + * initialized register file, and the loaded program in an + * initialized memory. + *) + fun run_file filename + = (run_prog o ReadFileToInstr) (TextIO.openIn filename); + + end; + + + + +(* ************************************************************************* *) + +(* + * Cache1.sml + * + * This file describes a small simple level 1 cache. + *) + +structure L1CacheSpec1 : CACHESPEC + = struct + + datatype WriteHitOption = Write_Through + | Write_Back; + + datatype WriteMissOption = Write_Allocate + | Write_No_Allocate; + + val CacheName = "Level 1 Cache"; + val CacheSize = 256; + val BlockSize = 4; + val Associativity = 2; + val WriteHit = Write_Through; + val WriteMiss = Write_No_Allocate; + + end; + + +structure L1Cache1 : MEMORY + = CachedMemory (structure CS = L1CacheSpec1; + structure MEM = Memory; ); + + +structure DLXSimulatorC1 : DLXSIMULATOR + = DLXSimulatorFun (structure RF = RegisterFile; + structure ALU = ALU; + structure MEM = L1Cache1; ); + +(* Example programs *) + +val Simple = ["200E002F", + "44000004", + "44000000"]; + +val Twos = ["44000003", + "00000000", + "3D00FFFF", + "3508FFFF", + "010E7026", + "25CE0001", + "44000004", + "00000000", + "44000000", + "00000000"]; + + +val Abs = ["44000003", + "00000000", + "01C0402A", + "11000002", + "00000000", + "000E7022", + "44000004", + "00000000", + "44000000", + "00000000"] + +val Fact = ["0C000002", + "00000000", + "44000000", + "44000003", + "000E2020", + "2FBD0020", + "AFBF0014", + "AFBE0010", + "27BE0020", + "0C000009", + "00000000", + "8FBE0010", + "8FBF0014", + "27BD0020", + "00027020", + "44000004", + "00001020", + "4BE00000", + "00000000", + "20080001", + "0088402C", + "11000004", + "00000000", + "20020001", + "08000016", + "00000000", + "2FBD0004", + "AFA40000", + "28840001", + "2FBD0020", + "AFBF0014", + "AFBE0010", + "27BE0020", + "0FFFFFF1", + "00000000", + "8FBE0010", + "8FBF0014", + "27BD0020", + "8FA40000", + "27BD0004", + "00004020", + "10800005", + "00000000", + "01024020", + "28840001", + "0BFFFFFB", + "00000000", + "01001020", + "4BE00000", + "00000000"]; + +val GCD = ["0C000002", + "00000000", + "44000000", + "44000003", + "00000000", + "000E2020", + "0080402A", + "11000002", + "00000000", + "00042022", + "44000003", + "00000000", + "000E2820", + "00A0402A", + "11000002", + "00000000", + "00052822", + "2FBD0020", + "AFBF0014", + "AFBE0010", + "27BE0020", + "0C00000A", + "00000000", + "8FBE0010", + "8FBF0014", + "27BD0020", + "00027020", + "44000004", + "00000000", + "00001020", + "4BE00000", + "00000000", + "14A00004", + "00000000", + "00801020", + "08000013", + "00000000", + "0085402C", + "15000006", + "00000000", + "00804020", + "00A02020", + "01002820", + "08000002", + "00000000", + "00A42822", + "2FBD0020", + "AFBF0014", + "AFBE0010", + "27BE0020", + "0FFFFFED", + "00000000", + "8FBE0010", + "8FBF0014", + "27BD0020", + "4BE00000", + "00000000"]; + +(* +val _ = DLXSimulatorC1.run_prog GCD +*) + +structure Main = + struct + fun doit () = + (DLXSimulatorC1.run_prog Simple + ; DLXSimulatorC1.run_prog Twos + ; DLXSimulatorC1.run_prog Abs + ; DLXSimulatorC1.run_prog Fact + ; DLXSimulatorC1.run_prog GCD + ) + + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop size + end + end diff --git a/benchmark/tests/Makefile b/benchmark/tests/Makefile new file mode 100644 index 0000000..3e1aa75 --- /dev/null +++ b/benchmark/tests/Makefile @@ -0,0 +1,19 @@ +## Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # Copyright (C) 1997-2000 NEC Research Institute. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +all: + +.PHONY: clean +clean: + ../../bin/clean + rm -f *.c *.s + for f in *; do \ + if [ -x "$$f" -a ! -d "$$f" ]; then \ + rm -f "$$f"; \ + fi; \ + done diff --git a/benchmark/tests/barnes-hut.sml b/benchmark/tests/barnes-hut.sml new file mode 100644 index 0000000..edfebe9 --- /dev/null +++ b/benchmark/tests/barnes-hut.sml @@ -0,0 +1,1250 @@ +(* From the SML/NJ benchmark suite. *) +(* vector-sig.sml + * + * COPYRIGHT (c) 1993, AT&T Bell Laboratories. + * + * The abstract interface of vectors and matrices in some dimension. + *) + +signature VECTOR = + sig + type 'a vec + + val dim : int (* dimension of the vectors *) + + val tabulate : (int -> 'a) -> 'a vec + + val equal : real vec * real vec -> bool + val zerov : real vec + val addv : (real vec * real vec) -> real vec + val subv : (real vec * real vec) -> real vec + val dotvp : (real vec * real vec) -> real + val crossvp : (real vec * real vec) -> real vec + val addvs : (real vec * real) -> real vec + val mulvs : (real vec * real) -> real vec + val divvs : (real vec * real) -> real vec + + val mapv : ('a -> 'b) -> 'a vec -> 'b vec + val map3v : (('a * 'b * 'c) -> 'd) -> ('a vec * 'b vec * 'c vec) -> 'd vec + val foldv : ('a * 'b -> 'b) -> 'a vec -> 'b -> 'b + val format : {lp : string, sep : string, rp : string, cvt : 'a -> string} + -> 'a vec -> string + val explode : 'a vec -> 'a list + val implode : 'a list -> 'a vec + + type matrix (* matrices are always real valued *) + + val zerom : matrix + val addm : (matrix * matrix) -> matrix + val outvp : (real vec * real vec) -> matrix + + end +(* space.sml + * + * COPYRIGHT (c) 1993, AT&T Bell Laboratories. + * + * The quad/oct-tree representation of space. + *) + +signature SPACE = + sig + + structure V : VECTOR + + datatype body = Body of { + mass : real, + pos : real V.vec ref, + vel : real V.vec ref, + acc : real V.vec ref, + phi : real ref + } + + datatype cell + = BodyCell of body + | Cell of node Array.array + + and node + = Empty + | Node of { + mass : real ref, + pos : real V.vec ref, + cell : cell + } + + datatype space = Space of { + rmin : real V.vec, + rsize : real, + root : node + } + + val nsub : int (* number of sub cells / cell (2 ^ V.dim) *) + + val putCell : (cell * int * node) -> unit + val getCell : (cell * int) -> node + val mkCell : unit -> cell + val mkBodyNode : body -> node + val mkCellNode : cell -> node + val eqBody : body * body -> bool + + (* debugging code *) + val dumpTree : node -> unit + val prBody : body -> string + val prNode : node -> string + + end; (* SPACE *) + +functor Space (V : VECTOR) : SPACE = + struct + + structure V = V + + datatype body = Body of { + mass : real, + pos : real V.vec ref, + vel : real V.vec ref, + acc : real V.vec ref, + phi : real ref + } + + datatype cell + = BodyCell of body + | Cell of node Array.array + + and node + = Empty + | Node of { + mass : real ref, + pos : real V.vec ref, + cell : cell + } + + datatype space = Space of { + rmin : real V.vec, + rsize : real, + root : node + } + + fun eqBody(Body{mass,pos,vel,acc,phi}, + Body{mass=m1,pos=p1,vel=v1,acc=a1,phi=h1}) = + (Real.==(mass, m1) andalso Real.==(!phi, !h1) + andalso V.equal(!pos, !p1) andalso V.equal(!vel, !v1) + andalso V.equal(!acc, !a1)) + + (* number of sub cells per cell (2 ^ V.dim) *) + val nsub = Word.toInt(Word.<<(0w1, Word.fromInt V.dim)) + + fun putCell (Cell a, i, nd) = Array.update(a, i, nd) + fun getCell (Cell a, i) = Array.sub(a, i) + fun mkCell () = Cell(Array.array(nsub, Empty)) + fun mkBodyNode (body as Body{pos, mass, ...}) = Node{ + cell = BodyCell body, + mass = ref mass, + pos = ref (!pos) + } + fun mkCellNode cell = Node{cell = cell, mass = ref 0.0, pos = ref V.zerov} + + (* debugging code *) + local + val rfmt = Real.toString + val vfmt = V.format{lp="[", rp="]", sep=",", cvt = rfmt} + in + fun prBody (Body{mass, pos, vel, acc, phi}) = String.concat [ + "B{m=", rfmt mass, + ", p=", vfmt(!pos), + ", v=", vfmt(!vel), + ", a=", vfmt(!acc), + ", phi=", rfmt(!phi), "}" + ] + fun prNode Empty = "Empty" + | prNode (Node{mass, pos, cell}) = let + val cell = (case cell + of (Cell _) => "Cell" + | (BodyCell b) => (*prBody b*) "Body" + (* end case *)) + in + String.concat [ + "N{m=", rfmt(!mass), + ", p=", vfmt(!pos), + cell, "}" + ] + end + end + + fun dumpTree tree = let + fun printf items = TextIO.output(TextIO.stdOut, String.concat items) + fun indent i = StringCvt.padLeft #" " (i+1) "" + fun dump (node, l) = let + fun dump' (Node{cell=Cell a, ...}) = let + fun dump'' i = (dump(Array.sub(a, i), l+1); dump''(i+1)) + in + (dump'' 0) handle _ => () + end + | dump' _ = () + in + printf [ + StringCvt.padLeft #" " 2 (Int.toString l), + indent l, + prNode node, "\n" + ]; + dump' node + end + in + dump (tree, 0) + end + + end; (* Space *) + +(* load.sml + * + * COPYRIGHT (c) 1993, AT&T Bell Laboratories. + * + * Code to build the tree from a list of bodies. + *) + +signature LOAD = + sig + + structure S : SPACE + structure V : VECTOR + sharing S.V = V + + val makeTree : (S.body list * real V.vec * real) -> S.space + + end; (* LOAD *) + +functor Load (S : SPACE) : LOAD = + struct + + structure S = S + structure V = S.V + + exception NotIntCoord + + fun rshift (n, k) = Word.toInt(Word.~>>(Word.fromInt n, Word.fromInt k)) + + val IMAX = 0x20000000 (* 2^29 *) + val IMAXrs1 = rshift(IMAX, 1) + val rIMAX = real IMAX + + (* compute integerized coordinates. Raises the NotIntCoord exception, + * if rp is out of bounds. + *) + fun intcoord (rp, rmin, rsize) = let + val xsc = V.divvs (V.subv(rp, rmin), rsize) + fun cvt x = if ((0.0 <= x) andalso (x < 1.0)) + then floor(rIMAX * x) + else raise NotIntCoord + in + V.mapv cvt xsc + end + + (* determine which subcell to select. *) + fun subindex (iv, l) = let + fun aux (v, (i, k)) = if (Word.andb(Word.fromInt v, Word.fromInt l) <> 0w0) + then (i + rshift(S.nsub, k+1), k+1) + else (i, k+1) + in + #1 (V.foldv aux iv (0, 0)) + end + + (* enlarge cubical "box", salvaging existing tree structure. *) + fun expandBox (nd as S.Body{pos, ...}, box as S.Space{rmin, rsize, root}) = ( + (intcoord (!pos, rmin, rsize); box) + handle NotIntCoord => let + val rmid = V.addvs (rmin, 0.5 * rsize) + val rmin' = V.map3v (fn (x,y,z) => + if x < y then z - rsize else z) (!pos, rmid, rmin) + val rsize' = 2.0 * rsize + fun mksub (v, r) = let + val x = intcoord (v, rmin', rsize') + val k = subindex (x, IMAXrs1) + val cell = S.mkCell () + in + S.putCell (cell, k, r); cell + end + val box = (case root + of S.Empty => S.Space{rmin=rmin', rsize=rsize', root=root} + | _ => S.Space{ + rmin = rmin', + rsize = rsize', + root = S.mkCellNode (mksub (rmid, root)) + } + (* end case *)) + in + expandBox (nd, box) + end) + + + (* insert a single node into the tree *) + fun loadTree (body as S.Body{pos=posp, ...}, S.Space{rmin, rsize, root}) = let + val xp = intcoord (!posp, rmin, rsize) + fun insert (S.Empty, _) = S.mkBodyNode body + | insert (n as S.Node{cell=S.BodyCell _, pos=posq, ...}, l) = let + val xq = intcoord (!posq, rmin, rsize) + val k = subindex (xq, l) + val a = S.mkCell() + in + S.putCell(a, k, n); + insert (S.mkCellNode a, l) + end + | insert (n as S.Node{cell, ...}, l) = let + val k = subindex (xp, l) + val subtree = insert (S.getCell (cell, k), rshift(l, 1)) + in + S.putCell (cell, k, subtree); + n + end + in + S.Space{rmin = rmin, rsize = rsize, root = insert (root, IMAXrs1)} + end + + (* descend tree finding center-of-mass coordinates. *) + fun hackCofM S.Empty = () + | hackCofM (S.Node{cell = S.BodyCell _, ...}) = () + | hackCofM (S.Node{cell = S.Cell subcells, mass, pos}) = let + fun sumMass (i, totMass, cofm) = if (i < S.nsub) + then (case Array.sub(subcells, i) + of S.Empty => sumMass (i+1, totMass, cofm) + | (nd as S.Node{mass, pos, ...}) => let + val _ = hackCofM nd + val m = !mass + in + sumMass (i+1, totMass + m, V.addv(cofm, V.mulvs(!pos, m))) + end + (* end case *)) + else ( + mass := totMass; + pos := V.divvs(cofm, totMass)) + in + sumMass (0, 0.0, V.zerov) + end + + (* initialize tree structure for hack force calculation. *) + fun makeTree (bodies, rmin, rsize) = let + fun build ([], space) = space + | build ((body as S.Body{mass, ...}) :: r, space) = + if Real.==(mass, 0.0) then build (r, space) + else let + val box = expandBox (body, space) + val box = loadTree(body, box) + in build (r, box) + end + val (space as S.Space{root, ...}) = + build (bodies, S.Space{rmin=rmin, rsize=rsize, root=S.Empty}) + in + hackCofM root; + space + end + + end; (* functor Load *) +(* grav.sml + * + * COPYRIGHT (c) 1993, AT&T Bell Laboratories. + * + * Gravity module for hierarchical N-body code; routines to compute gravity. + *) + +signature GRAV = + sig + + structure S : SPACE + structure V : VECTOR + sharing S.V = V + + val hackGrav : {body:S.body, root:S.node, rsize:real, tol:real, eps : real} + -> {n2bterm:int, nbcterm:int, skipSelf:bool} + + end; (* GRAV *) + +functor Grav (S : SPACE) : GRAV = + struct + + structure S = S + structure V = S.V + + fun walk {acc0, phi0, pos0, pskip, eps, rsize, tol, root} = let + val skipSelf = ref false + val nbcterm = ref 0 and n2bterm = ref 0 + val tolsq = (tol * tol) + (* compute a single body-body or body-cell interaction. *) + fun gravsub (S.Empty, phi0, acc0, _) = (phi0, acc0) + | gravsub (p as S.Node{mass, pos, cell, ...}, phi0, acc0, memo) = let + val (dr, drsq) = (case memo + of NONE => let + val dr = V.subv(!pos, pos0) + in + (dr, V.dotvp(dr, dr) + (eps*eps)) + end + | SOME(dr', drsq') => (dr', drsq' + (eps*eps)) + (* end case *)) + val phii = !mass / (Math.sqrt drsq) + in + case cell + of (S.Cell _) => nbcterm := !nbcterm + 1 + | _ => n2bterm := !n2bterm + 1 + (* end case *); + (phi0 - phii, V.addv(acc0, V.mulvs(dr, phii / drsq))) + end (* gravsub *) + (* recursive routine to do hackwalk operation. This combines the + * subdivp and walksub routines from the C version. + *) + fun walksub (p, dsq, phi0, acc0) = ( +(*print(implode[" walksub: dsq = ", makestring dsq, ", ", S.prNode p, "\n"]);*) + case p + of S.Empty => (phi0, acc0) + | (S.Node{cell = S.BodyCell body, ...}) => + if S.eqBody(body, pskip) + then (skipSelf := true; (phi0, acc0)) + else gravsub (p, phi0, acc0, NONE) + | (S.Node{cell = S.Cell a, pos, ...}) => let + val dr = V.subv(!pos, pos0) + val drsq = V.dotvp(dr, dr) + in + if ((tolsq * drsq) < dsq) + then let (* open p up *) + fun loop (i, phi0, acc0) = if (i < S.nsub) + then let + val (phi0', acc0') = walksub ( + Array.sub(a, i), dsq/4.0, phi0, acc0) + in + loop (i+1, phi0', acc0') + end + else (phi0, acc0) + in + loop (0, phi0, acc0) + end + else gravsub (p, phi0, acc0, SOME(dr, drsq)) + end + (* end case *)) + val (phi0, acc0) = walksub (root, rsize*rsize, phi0, acc0) + in + { phi0 = phi0, acc0 = acc0, + nbcterm = !nbcterm, n2bterm = !n2bterm, skip = !skipSelf + } + end (* walk *) + + (* evaluate grav field at a given particle. *) + fun hackGrav {body as S.Body{pos, phi, acc, ...}, root, rsize, eps, tol} = let + val {phi0, acc0, nbcterm, n2bterm, skip} = walk { + acc0 = V.zerov, phi0 = 0.0, pos0 = !pos, pskip = body, + eps = eps, rsize = rsize, tol = tol, root = root + } + in + phi := phi0; + acc := acc0; +(** +app (fn (fmt, items) => print(Format.format fmt items)) [ + ("pos = [%f %f %f]\n", map Format.REAL (V.explode(!pos))), + ("pos = [%f %f %f]\n", map Format.REAL (V.explode acc0)), + ("phi = %f\n", [Format.REAL phi0]) +]; +raise Fail ""; +**) + {nbcterm=nbcterm, n2bterm=n2bterm, skipSelf=skip} + end (* hackgrav *) + + end; (* Grav *) +(* data-io.sml + * + * COPYRIGHT (c) 1993, AT&T Bell Laboratories. + * + * I/O routines for export version of hierarchical N-body code. + *) + +signature DATA_IO = + sig + + structure S : SPACE + + val inputData : string -> { + nbody : int, + bodies : S.body list, + tnow : real, + headline : string + } + + (* output routines *) + val initOutput : { + outfile : string, headline : string, nbody : int, tnow : real, + dtime : real, eps : real, tol : real, dtout : real, tstop : real + } -> unit + val output : { + nbody : int, bodies : S.body list, n2bcalc : int, nbccalc : int, + selfint : int, tnow : real + } -> unit + val stopOutput : unit -> unit + + end; + +functor DataIO (S : SPACE) : DATA_IO = + struct + + structure SS = Substring + structure S = S + structure V = S.V + + val atoi = valOf o Int.scan StringCvt.DEC SS.getc + + (* NOTE: this really out to be implemented using the lazy IO streams, + * but SML/NJ doesn't implement these correctly yet. + *) + fun inputData fname = let + val strm = TextIO.openIn fname + val buf = ref(SS.full "") + fun getLn () = (case (TextIO.inputLine strm) + of NONE => raise Fail "inputData: EOF" + | SOME s => buf := SS.full s + (* end case *)) + fun skipWS () = let + val buf' = SS.dropl Char.isSpace (!buf) + in + if (SS.isEmpty buf') + then (getLn(); skipWS()) + else buf' + end + fun readInt () = let + val (n, ss) = atoi (skipWS ()) + in + buf := ss; n + end + fun readReal () = let + val (r, ss) = valOf (Real.scan SS.getc (skipWS())) + in + buf := ss; r + end + val nbody = readInt() + val _ = if (nbody < 1) + then raise Fail "absurd nbody" + else () + val ndim = readInt() + val _ = if (ndim <> V.dim) + then raise Fail "absurd ndim" + else () + val tnow = readReal() + fun iter f = let + fun loop (0, l) = l + | loop (n, l) = loop (n-1, f() :: l) + in + fn n => loop (n, []) + end + fun readVec () = V.implode (rev (iter readReal ndim)) + val massList = iter readReal nbody + val posList = iter readVec nbody + val velList = iter readVec nbody + fun mkBodies ([], [], [], l) = l + | mkBodies (m::r1, p::r2, v::r3, l) = let + val b = S.Body{ + mass = m, + pos = ref p, + vel = ref v, + acc = ref V.zerov, + phi = ref 0.0 + } + in + mkBodies(r1, r2, r3, b::l) + end + in + TextIO.closeIn strm; + { nbody = nbody, + bodies = mkBodies (massList, posList, velList, []), + tnow = tnow, + headline = concat["Hack code: input file ", fname, "\n"] + } + end + + local + val timer = ref (Timer.startCPUTimer ()) + in + fun initTimer () = timer := Timer.startCPUTimer() + fun cputime () = let + val {usr, sys, ...} = Timer.checkCPUTimer(!timer) + val totTim = usr + in + (Time.toReal totTim) / 60.0 + end + end + + type out_state = { + tout : real, + dtout : real, + dtime : real, + strm : TextIO.outstream + } + val outState = ref (NONE : out_state option) + + fun fprintf (strm, items) = TextIO.output(strm, String.concat items) + fun printf items = fprintf(TextIO.stdOut, items) + fun pad n s = StringCvt.padLeft #" " n s + fun fmtInt (wid, i) = pad wid (Int.toString i) + fun fmtReal (wid, prec, r) = pad wid (Real.fmt (StringCvt.FIX(SOME prec)) r) + fun fmtRealE (wid, prec, r) = pad wid (Real.fmt (StringCvt.SCI(SOME prec)) r) + local + fun itemFmt r = fmtReal (9, 4, r) + val fmt = V.format{lp="", sep="", rp="", cvt=itemFmt} + in + fun printvec (init, vec) = printf [ + "\t ", pad 9 init, fmt vec, "\n" + ] + end (* local *) + + fun stopOutput () = (case (! outState) + of NONE => () + | (SOME{strm, ...}) => (TextIO.closeOut strm; outState := NONE) + (* end case *)) + + fun initOutput {outfile, headline, nbody, tnow, dtime, eps, tol, dtout, tstop} = ( + initTimer(); + printf ["\n\t\t", headline, "\n\n"]; + printf (map (pad 12) ["nbody", "dtime", "eps", "tol", "dtout", "tstop"]); + printf ["\n"]; + printf [fmtInt(12, nbody), fmtReal(12, 5, dtime)]; + printf [ + fmtInt(12, nbody), fmtReal(12, 5, dtime), + fmtReal(12, 4, eps), fmtReal(12, 2, tol), + fmtReal(12, 3, dtout), fmtReal(12, 2, tstop), "\n\n" + ]; + case outfile + of "" => stopOutput() + | _ => outState := SOME{ + dtime = dtime, + tout = tnow, + dtout = dtout, + strm = TextIO.openOut outfile + } + (* end case *)) + + (* compute set of dynamical diagnostics. *) + fun diagnostics bodies = let + fun loop ([], arg) = { + mtot = #totM arg, (* total mass *) + totKE = #totKE arg, (* total kinetic energy *) + totPE = #totPE arg, (* total potential energy *) + cOfMPos = #cOfMPos arg, (* center of mass: position *) + cOfMVel = #cOfMVel arg, (* center of mass: velocity *) + amVec = #amVec arg (* angular momentum vector *) + } + | loop (S.Body{ + mass, pos=ref pos, vel=ref vel, acc=ref acc, phi=ref phi + } :: r, arg) = let + val velsq = V.dotvp(vel, vel) + val halfMass = 0.5 * mass + val posXmass = V.mulvs(pos, mass) + in + loop ( r, { + totM = (#totM arg) + mass, + totKE = (#totKE arg) + halfMass * velsq, + totPE = (#totPE arg) + halfMass * phi, + keTen = V.addm(#keTen arg, V.outvp(V.mulvs(vel, halfMass), vel)), + peTen = V.addm(#peTen arg, V.outvp(posXmass, acc)), + cOfMPos = V.addv(#cOfMPos arg, posXmass), + cOfMVel = V.addv(#cOfMVel arg, V.mulvs(vel, mass)), + amVec = V.addv(#amVec arg, V.mulvs(V.crossvp(pos, vel), mass)) + }) + end + in + loop (bodies, { + totM = 0.0, totKE = 0.0, totPE = 0.0, + keTen = V.zerom, peTen = V.zerom, + cOfMPos = V.zerov, cOfMVel = V.zerov, + amVec = V.zerov + }) + end (* diagnostics *) + + fun outputData (strm, tnow, nbody, bodies) = let + fun outInt i = fprintf(strm, [" ", Int.toString i, "\n"]) + fun outReal r = fprintf(strm, [" ", fmtRealE(21, 14, r), "\n"]) + fun prReal r = fprintf(strm, [" ", fmtRealE(21, 14, r)]) + fun outVec v = let + fun out [] = TextIO.output(strm, "\n") + | out (x::r) = (prReal x; out r) + in + out(V.explode v) + end + in + outInt nbody; + outInt V.dim; + outReal tnow; + app (fn (S.Body{mass, ...}) => outReal mass) bodies; + app (fn (S.Body{pos, ...}) => outVec(!pos)) bodies; + app (fn (S.Body{vel, ...}) => outVec(!vel)) bodies; + printf ["\n\tparticle data written\n"] + end; + + fun output {nbody, bodies, n2bcalc, nbccalc, selfint, tnow} = let + val nttot = n2bcalc + nbccalc + val nbavg = floor(real n2bcalc / real nbody) + val ncavg = floor(real nbccalc / real nbody) + val data = diagnostics bodies + in + printf ["\n"]; + printf (map (pad 9) [ + "tnow", "T+U", "T/U", "nttot", "nbavg", "ncavg", "selfint", + "cputime" + ]); + printf ["\n"]; + printf [ + fmtReal(9, 3, tnow), fmtReal(9, 4, #totKE data + #totPE data), + fmtReal(9, 4, #totKE data / #totPE data), fmtInt(9, nttot), + fmtInt(9, nbavg), fmtInt(9, ncavg), fmtInt(9, selfint), + fmtReal(9, 2, cputime()), "\n\n" + ]; + printvec ("cm pos", #cOfMPos data); + printvec ("cm vel", #cOfMVel data); + printvec ("am pos", #amVec data); + case !outState + of NONE => () + | (SOME{tout, dtout, dtime, strm}) => + if ((tout - 0.01 * dtime) <= tnow) + then ( + outputData (strm, tnow, nbody, bodies); + outState := SOME{ + tout=tout+dtout, dtout=dtout, dtime=dtime, strm=strm + }) + else () + (* end case *) + end + + end; (* DataIO *) + +(* getparam.sml + * + * COPYRIGHT (c) 1993, AT&T Bell Laboratories. + *) + +structure GetParam : sig + + exception EOF + + val initParam : (string list * string list) -> unit + val getParam : string -> string + val getIParam : string -> int + val getRParam : string -> real + val getBParam : string -> bool + + end = struct + + exception EOF + + val defaults = ref ([] : string list) + + (* ignore arg vector, remember defaults. *) + fun initParam (argv, defl) = defaults := defl + + fun prompt items = ( + TextIO.output(TextIO.stdOut, String.concat items); + TextIO.flushOut TextIO.stdOut) + + structure SS = Substring + + (* export version prompts user for value. *) + fun getParam name = let + fun scanBind [] = NONE + | scanBind (s::r) = let + val (_, suffix) = SS.position name (SS.full s) + in + if (SS.isEmpty suffix) + then scanBind r + else SOME(SS.string(SS.triml (size name+1) suffix)) + end + fun get default = (case (TextIO.inputLine TextIO.stdIn) + of NONE => raise EOF + | SOME "\n" => default + | SOME s => substring(s, 0, size s - 1) + (* end case *)) + in + if (null (! defaults)) + then raise Fail "getParam called before initParam" + else (); + case (scanBind (! defaults)) + of (SOME s) => ( + prompt ["enter ", name, " [", s, "]: "]; + get s) + | NONE => (prompt ["enter ", name, ": "]; get "") + (* end case *) + end + + local + fun cvt scanFn = let + fun cvt' name = let + fun get () = (case getParam name of "" => get () | s => s) + val param = get () + in + (valOf (scanFn param)) handle _ => (cvt' name) + end + in + cvt' + end + in + (* get integer parameter *) + val getIParam = cvt Int.fromString + (* get real parameter *) + val getRParam = cvt Real.fromString + (* get bool parameter *) + val getBParam = cvt Bool.fromString + end (* local *) + + end; (* GetParam *) + +(* rand-sig.sml + * + * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * + * Signature for a simple random number generator. + * + *) + +signature RAND = + sig + + val randMin : real + val randMax : real + val random : real -> real + (* Given seed, return value randMin <= v <= randMax + * Iteratively using the value returned by random as the + * next seed to random will produce a sequence of pseudo-random + * numbers. + *) + + val mkRandom : real -> unit -> real + (* Given seed, return function generating a sequence of + * random numbers randMin <= v <= randMax + *) + + val norm : real -> real + (* r -> r / (randMax + 1.0) *) + + val range : (int * int) -> real -> int + (* Map v, randMin <= v <= randMax to integer range [i,j] + * Exception - + * BadArg if j < i + *) + + end (* RAND *) +(* rand.sml + * + * COPYRIGHT (c) 1991 by AT&T Bell Laboratories. See COPYRIGHT file for details + * + * Random number generator taken from Paulson, pp. 170-171. + * Recommended by Stephen K. Park and Keith W. Miller, + * Random number generators: good ones are hard to find, + * CACM 31 (1988), 1192-1201 + * + * Note: The Random structure provides a better generator. + *) + +structure Rand : RAND = + struct + + (* real number version for systems with 46-bit mantissas *) + val a = 16807.0 and m = 2147483647.0 + + val randMin = 1.0 + val randMax = m - 1.0 + + fun random seed = let + val t = a*seed + in + t - m * real(floor(t/m)) + end + + fun mkRandom seed = let + val seed = ref seed + in + fn () => (seed := random (!seed); !seed) + end + + fun norm r = r / m + + fun range (i,j) = + if j < i + then raise Fail "Rand.range" + else let + val R = real(j - i + 1) + in + fn r => i + floor(R*(r/m)) + end handle _ => let + val ri = real i + val R = (real j)-ri+1.0 + in + fn r => floor(ri + R*(r/m)) + end + + end (* Rand *) + +(* main.sml + * + * COPYRIGHT (c) 1993, AT&T Bell Laboratories. + * + * This is the main driver for the Barnse-HutN-body code. + *) + +functor Main (V : VECTOR) : sig + + structure S : SPACE + structure V : VECTOR + structure L : LOAD + + val srand : int -> unit + (* reset the random number generator *) + + val testdata : int -> S.body list + (* generate the Plummer model data *) + + val go : { + output : {n2bcalc:int, nbccalc:int, nstep:int, selfint:int, tnow:real} + -> unit, + bodies : S.body list, tnow : real, tstop : real, + dtime : real, eps : real, tol : real, + rmin : real V.vec, rsize : real + } -> unit + + val doit : unit -> unit + + end = struct + + structure V = V + structure S = Space(V) + structure L = Load(S) + structure G = Grav(S) + structure DataIO = DataIO(S) + + (* some math utilities *) +(** NOTE: these are part of the Math structure in the new basis *) + val pi = 3.14159265358979323846 + fun pow(x, y) = + if Real.==(y, 0.0) then 1.0 else Math.exp (y * Math.ln x) + + (* random numbers *) + local + val seed = ref 0.0 + in + fun srand s = (seed := real s) + fun xrand (xl, xh) = let + val r = Rand.random (! seed) + in + seed := r; + xl + (((xh - xl) * r) / 2147483647.0) + end + end (* local *) + + (* default parameter values *) + val defaults = [ + (* file names for input/output *) + "in=", (* snapshot of initial conditions *) + "out=", (* stream of output snapshots *) + + (* params, used if no input specified, to make a Plummer Model*) + "nbody=128", (* number of particles to generate *) + "seed=123", (* random number generator seed *) + + (* params to control N-body integration *) + "dtime=0.025", (* integration time-step *) + "eps=0.05", (* usual potential softening *) + "tol=1.0", (* cell subdivision tolerence *) + "fcells=0.75", (* cell allocation parameter *) + + "tstop=2.0", (* time to stop integration *) + "dtout=0.25", (* data-output interval *) + + "debug=false", (* turn on debugging messages *) + "VERSION=1.0" (* JEB 06 March 1988 *) + ] + + (* pick a random point on a sphere of specified radius. *) + fun pickshell rad = let + fun pickvec () = let + val vec = V.tabulate (fn _ => xrand(~1.0, 1.0)) + val rsq = V.dotvp(vec, vec) + in + if (rsq > 1.0) + then pickvec () + else V.mulvs (vec, rad / Math.sqrt(rsq)) + end + in + pickvec () + end + + (* generate Plummer model initial conditions for test runs, scaled + * to units such that M = -4E = G = 1 (Henon, Hegge, etc). + * See Aarseth, SJ, Henon, M, & Wielen, R (1974) Astr & Ap, 37, 183. + *) + fun testdata n = let + val mfrac = 0.999 (* mass cut off at mfrac of total *) + val rn = real n + val rsc = (3.0 * pi) / 16.0 + val vsc = Math.sqrt(1.0 / rsc) + fun mkBodies (0, cmr, cmv, l) = let + (* offset bodies by normalized cm coordinates. Also, reverse + * the list to get the same order of bodies as in the C version. + *) + val cmr = V.divvs(cmr, rn) + val cmv = V.divvs(cmv, rn) + fun norm ([], l) = l + | norm ((p as S.Body{pos, vel, ...}) :: r, l) = ( + pos := V.subv(!pos, cmr); + vel := V.subv(!vel, cmv); + norm (r, p::l)) + in + norm (l, []) + end + | mkBodies (i, cmr, cmv, l) = let + val r = 1.0 / Math.sqrt (pow(xrand(0.0, mfrac), ~2.0/3.0) - 1.0) + val pos = pickshell (rsc * r) + fun vN () = let (* von Neumann technique *) + val x = xrand(0.0,1.0) + val y = xrand(0.0,0.1) + in + if (y > x*x * (pow (1.0-x*x, 3.5))) then vN () else x + end + val v = ((Math.sqrt 2.0) * vN()) / pow(1.0 + r*r, 0.25) + val vel = pickshell (vsc * v) + val body = S.Body{ + mass = 1.0 / rn, + pos = ref pos, + vel = ref vel, + acc = ref V.zerov, + phi = ref 0.0 + } + in + mkBodies (i-1, V.addv(cmr, pos), V.addv(cmv, vel), body :: l) + end + in + mkBodies (n, V.zerov, V.zerov, []) + end (* testdata *) + + (* startup hierarchical N-body code. This either reads in or generates + * an initial set of bodies, and other parameters. + *) + + fun startrun argv = let + val _ = GetParam.initParam(argv, defaults) + val {nbody, bodies, tnow, headline} = (case (GetParam.getParam "in") + of "" => let + val nbody = GetParam.getIParam "nbody" + in + if (nbody < 1) + then raise Fail "startrun: absurd nbody" + else (); + srand (GetParam.getIParam "seed"); + { nbody = nbody, + bodies = testdata nbody, + tnow = 0.0, + headline = "Hack code: Plummer model" + } + end + | fname => DataIO.inputData fname + (* end case *)) + in + { nbody = nbody, + bodies = bodies, + headline = headline, + outfile = GetParam.getParam "out", + dtime = GetParam.getRParam "dtime", + eps = GetParam.getRParam "eps", + tol = GetParam.getRParam "tol", + tnow = tnow, + tstop = GetParam.getRParam "tstop", + dtout = GetParam.getRParam "dtout", + debug = GetParam.getBParam "debug", + rmin = V.tabulate (fn _ => ~2.0), + rsize = 4.0 + } + end + + (* advance N-body system one time-step. *) + fun stepSystem output {plist, dtime, eps, nstep, rmin, rsize, tnow, tol} = let + val dthf = 0.5 * dtime + val S.Space{rmin, rsize, root} = L.makeTree (plist, rmin, rsize) + (* recalculate accelaration *) + fun recalc ([], n2bcalc, nbccalc, selfint) = (n2bcalc, nbccalc, selfint) + | recalc (p::r, n2bcalc, nbccalc, selfint) = let + val S.Body{acc as ref acc1, vel, ...} = p + val {n2bterm, nbcterm, skipSelf} = G.hackGrav { + body = p, root = root, rsize = rsize, eps = eps, tol = tol + } + in + if (nstep > 0) + then (* use change in accel to make 2nd order *) + (* correction to vel. *) + vel := V.addv(!vel, V.mulvs(V.subv(!acc, acc1), dthf)) + else (); + recalc (r, n2bcalc+n2bterm, nbccalc+nbcterm, + if skipSelf then selfint else (selfint+1)) + end + (* advance bodies *) + fun advance (S.Body{pos, acc, vel, ...}) = let + val dvel = V.mulvs (!acc, dthf) + val vel1 = V.addv (!vel, dvel) + val dpos = V.mulvs (vel1, dtime) + in + pos := V.addv (!pos, dpos); + vel := V.addv (vel1, dvel) + end + val (n2bcalc, nbccalc, selfint) = recalc (plist, 0, 0, 0) + in + output {nstep=nstep, tnow=tnow, n2bcalc=n2bcalc, nbccalc=nbccalc, selfint=selfint}; + app advance plist; + (nstep+1, tnow + dtime) + end + + (* given an initial configuration, run the simulation *) + fun go { + output, bodies, tnow, tstop, + dtime, eps, tol, rsize, rmin + } = let + val step = stepSystem output + fun loop (nstep, tnow) = if (tnow < tstop + (0.1 * dtime)) + then loop (step { + plist = bodies, dtime = dtime, eps = eps, nstep = nstep, + rmin = rmin, rsize = rsize, tnow = tnow, tol = tol + }) + else () + in + loop (0, tnow) + end + + fun doit () = let + val { nbody, bodies, headline, outfile, + dtime, eps, tol, tnow, tstop, dtout, + debug, rsize, rmin + } = startrun [] + fun output {nstep, tnow, n2bcalc, nbccalc, selfint} = DataIO.output{ + bodies = bodies, nbody = nbody, + n2bcalc = n2bcalc, nbccalc = nbccalc, + selfint = selfint, tnow = tnow + } + in + DataIO.initOutput { + outfile = outfile, headline = headline, nbody = nbody, tnow = tnow, + dtime = dtime, eps = eps, tol = tol, dtout = dtout, tstop = tstop + }; + go { + output=output, bodies=bodies, tnow=tnow, tstop=tstop, + dtime=dtime, eps=eps, tol=tol, rsize=rsize, rmin=rmin + }; + DataIO.stopOutput() + end (* doit *) + + end; (* Main *) +(* vector3.sml + * + * COPYRIGHT (c) 1993, AT&T Bell Laboratories. + * + * 3 dimensional vector arithmetic. + *) + +structure Vector3 : VECTOR = + struct + + type 'a vec = {x : 'a, y : 'a, z : 'a} + type realvec = real vec + + val dim = 3 + + fun tabulate f = {x = f 0, y = f 1, z = f 2} + + val zerov = {x = 0.0, y = 0.0, z = 0.0} + fun equal({x, y, z}, {x=x1, y=y1, z=z1}) = + Real.==(x, x1) andalso Real.==(y, y1) andalso Real.==(z, z1) + + fun addv ({x=x1, y=y1, z=z1} : realvec, {x=x2, y=y2, z=z2}) = + {x=x1+x2, y=y1+y2, z=z1+z2} + + fun subv ({x=x1, y=y1, z=z1} : realvec, {x=x2, y=y2, z=z2}) = + {x=x1-x2, y=y1-y2, z=z1-z2} + + fun dotvp ({x=x1, y=y1, z=z1} : realvec, {x=x2, y=y2, z=z2}) = + x1*x2 + y1*y2 + z1*z2 + + fun crossvp ({x=x1, y=y1, z=z1} : realvec, {x=x2, y=y2, z=z2}) = + {x = y1*z2 - z1*y2, y = x1*z2 - z1*x2, z = x1*y2 - y1*x2} + + fun addvs ({x, y, z} : realvec, s) = {x=x+s, y=y+s, z=z+s} + + fun mulvs ({x, y, z} : realvec, s) = {x=x*s, y=y*s, z=z*s} + + fun divvs ({x, y, z} : realvec, s) = {x=x/s, y=y/s, z=z/s} + + fun mapv f {x, y, z} = {x = f x, y = f y, z = f z} + + fun map3v f ({x=x1, y=y1, z=z1}, {x=x2, y=y2, z=z2}, {x=x3, y=y3, z=z3}) = + {x = f(x1, x2, x3), y = f(y1, y2, y3), z = f(z1, z2, z3)} + + fun foldv f {x, y, z} init = f(z, f(y, f(x, init))) + + fun format {lp, rp, sep, cvt} {x, y, z} = String.concat[ + lp, cvt x, sep, cvt y, sep, cvt z, rp + ] + + fun explode {x, y, z} = [x, y, z] + + fun implode [x, y, z] = {x=x, y=y, z=z} + | implode _ = raise Fail "implode: bad dimension" + + type matrix = { + m00 : real, m01 : real, m02 : real, + m10 : real, m11 : real, m12 : real, + m20 : real, m21 : real, m22 : real + } + + val zerom = { + m00 = 0.0, m01 = 0.0, m02 = 0.0, + m10 = 0.0, m11 = 0.0, m12 = 0.0, + m20 = 0.0, m21 = 0.0, m22 = 0.0 + } + + fun addm (a : matrix, b : matrix) = { + m00=(#m00 a + #m00 b), m01=(#m01 a + #m01 b), m02=(#m02 a + #m02 b), + m10=(#m10 a + #m10 b), m11=(#m11 a + #m11 b), m12=(#m12 a + #m12 b), + m20=(#m20 a + #m20 b), m21=(#m21 a + #m21 b), m22=(#m22 a + #m22 b) + } + + fun outvp ({x=a0, y=a1, z=a2} : realvec, {x=b0, y=b1, z=b2}) = { + m00=(a0*b0), m01=(a0*b1), m02=(a0*b2), + m10=(a1*b0), m11=(a1*b1), m12=(a1*b2), + m20=(a2*b0), m21=(a2*b1), m22=(a2*b2) + } + + end (* VectMath *) + +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; +(* load file for bmark version *) + +(* +app use [ + "rand-sig.sml", + "rand.sml", + "vector-sig.sml", + "space.sml", + "load.sml", + "grav.sml", + "getparam.sml", + "data-io.sml", + "main.sml", + "vector3.sml" + ]; +*) +structure Main : BMARK = + struct + structure M3 = Main(Vector3); + + val name = "Barnes-Hut (3d)" + + fun testit strm = () + + fun doit n = ( + M3.srand 123; + M3.go { + output = fn _ => (), + bodies = M3.testdata n, + tnow = 0.0, tstop = 2.0, + dtime = 0.025, eps = 0.05, tol = 1.0, + rmin = M3.S.V.tabulate (fn _ => ~2.0), + rsize = 4.0 + }) + end; + diff --git a/benchmark/tests/boyer.sml b/benchmark/tests/boyer.sml new file mode 100644 index 0000000..20ac6ab --- /dev/null +++ b/benchmark/tests/boyer.sml @@ -0,0 +1,931 @@ +(* From the SML/NJ benchmark suite. *) +(* terms.sml: + * + * Manipulations over terms + *) + +signature TERMS = + sig + type head; + datatype term = + Var of int + | Prop of head * term list; + datatype binding = Bind of int * term; + val get: string -> head + and headname: head -> string + and add_lemma: term -> unit + and apply_subst: binding list -> term -> term + and rewrite: term -> term + end; + +structure Terms:TERMS = + struct + + datatype term + = Var of int + | Prop of { name: string, props: (term * term) list ref } * term list + + type head = { name: string, props: (term * term) list ref } + + val lemmas = ref ([] : head list) + +(* replacement for property lists *) + + fun headname {name = n, props=p} = n; + +fun get name = + let fun get_rec ((hd1 as {name=n,...})::hdl) = + if n = name then hd1 else get_rec hdl + | get_rec [] = + let val entry = {name = name, props = ref []} in + lemmas := entry :: !lemmas; + entry + end + in + get_rec (!lemmas) + end +; + +fun add_lemma (Prop(_, [(left as Prop({props=r,...},_)), right])) = + r := (left, right) :: !r +; + +(* substitutions *) + +exception failure of string; + +datatype binding = Bind of int * term +; + +fun get_binding v = + let fun get_rec [] = raise (failure "unbound") + | get_rec (Bind(w,t)::rest) = + if v = w then t else get_rec rest + in + get_rec + end +; + +fun apply_subst alist = + let fun as_rec (term as Var v) = + ((get_binding v alist) handle failure _ => term) + | as_rec (Prop (head,argl)) = + Prop (head, map as_rec argl) + in + as_rec + end +; + +exception Unify; + +fun unify (term1, term2) = unify1 (term1, term2, []) +and unify1 (term1, term2, unify_subst) = + (case term2 of + Var v => + ((if get_binding v unify_subst = term1 + then unify_subst + else raise Unify) + handle failure _ => + Bind(v,term1)::unify_subst) + | Prop (head2,argl2) => + case term1 of + Var _ => raise Unify + | Prop (head1,argl1) => + if head1=head2 then unify1_lst (argl1, argl2, unify_subst) + else raise Unify) +and unify1_lst ([], [], unify_subst) = unify_subst + | unify1_lst (h1::r1, h2::r2, unify_subst) = + unify1_lst(r1, r2, unify1(h1, h2, unify_subst)) + | unify1_lst _ = raise Unify +; + +fun rewrite (term as Var _) = term + | rewrite (Prop ((head as {props=p,...}), argl)) = + rewrite_with_lemmas (Prop (head, map rewrite argl), !p) +and rewrite_with_lemmas (term, []) = term + | rewrite_with_lemmas (term, (t1,t2)::rest) = + rewrite (apply_subst (unify (term, t1)) t2) + handle unify => + rewrite_with_lemmas (term, rest) +; +end; +(* rules.sml: + *) + +structure Rules = + struct + + open Terms; + + datatype cterm = CVar of int | CProp of string * cterm list; + + fun cterm_to_term (CVar v) = Var v + | cterm_to_term (CProp(p, l)) = Prop(get p, map cterm_to_term l) + + fun add t = add_lemma (cterm_to_term t) + + val _ = ( +add (CProp +("equal", + [CProp ("compile",[CVar 5]), + CProp + ("reverse", + [CProp ("codegen",[CProp ("optimize",[CVar 5]), CProp ("nil",[])])])])); +add (CProp +("equal", + [CProp ("eqp",[CVar 23, CVar 24]), + CProp ("equal",[CProp ("fix",[CVar 23]), CProp ("fix",[CVar 24])])])); +add (CProp +("equal", + [CProp ("gt",[CVar 23, CVar 24]), CProp ("lt",[CVar 24, CVar 23])])); +add (CProp +("equal", + [CProp ("le",[CVar 23, CVar 24]), CProp ("ge",[CVar 24, CVar 23])])); +add (CProp +("equal", + [CProp ("ge",[CVar 23, CVar 24]), CProp ("le",[CVar 24, CVar 23])])); +add (CProp +("equal", + [CProp ("boolean",[CVar 23]), + CProp + ("or", + [CProp ("equal",[CVar 23, CProp ("true",[])]), + CProp ("equal",[CVar 23, CProp ("false",[])])])])); +add (CProp +("equal", + [CProp ("iff",[CVar 23, CVar 24]), + CProp + ("and", + [CProp ("implies",[CVar 23, CVar 24]), + CProp ("implies",[CVar 24, CVar 23])])])); +add (CProp +("equal", + [CProp ("even1",[CVar 23]), + CProp + ("if", + [CProp ("zerop",[CVar 23]), CProp ("true",[]), + CProp ("odd",[CProp ("sub1",[CVar 23])])])])); +add (CProp +("equal", + [CProp ("countps_",[CVar 11, CVar 15]), + CProp ("countps_loop",[CVar 11, CVar 15, CProp ("zero",[])])])); +add (CProp +("equal", + [CProp ("fact_",[CVar 8]), + CProp ("fact_loop",[CVar 8, CProp ("one",[])])])); +add (CProp +("equal", + [CProp ("reverse_",[CVar 23]), + CProp ("reverse_loop",[CVar 23, CProp ("nil",[])])])); +add (CProp +("equal", + [CProp ("divides",[CVar 23, CVar 24]), + CProp ("zerop",[CProp ("remainder",[CVar 24, CVar 23])])])); +add (CProp +("equal", + [CProp ("assume_true",[CVar 21, CVar 0]), + CProp ("cons",[CProp ("cons",[CVar 21, CProp ("true",[])]), CVar 0])])); +add (CProp +("equal", + [CProp ("assume_false",[CVar 21, CVar 0]), + CProp ("cons",[CProp ("cons",[CVar 21, CProp ("false",[])]), CVar 0])])); +add (CProp +("equal", + [CProp ("tautology_checker",[CVar 23]), + CProp ("tautologyp",[CProp ("normalize",[CVar 23]), CProp ("nil",[])])])); +add (CProp +("equal", + [CProp ("falsify",[CVar 23]), + CProp ("falsify1",[CProp ("normalize",[CVar 23]), CProp ("nil",[])])])); +add (CProp +("equal", + [CProp ("prime",[CVar 23]), + CProp + ("and", + [CProp ("not",[CProp ("zerop",[CVar 23])]), + CProp + ("not", + [CProp ("equal",[CVar 23, CProp ("add1",[CProp ("zero",[])])])]), + CProp ("prime1",[CVar 23, CProp ("sub1",[CVar 23])])])])); +add (CProp +("equal", + [CProp ("and",[CVar 15, CVar 16]), + CProp + ("if", + [CVar 15, + CProp ("if",[CVar 16, CProp ("true",[]), CProp ("false",[])]), + CProp ("false",[])])])); +add (CProp +("equal", + [CProp ("or",[CVar 15, CVar 16]), + CProp + ("if", + [CVar 15, CProp ("true",[]), + CProp ("if",[CVar 16, CProp ("true",[]), CProp ("false",[])]), + CProp ("false",[])])])); +add (CProp +("equal", + [CProp ("not",[CVar 15]), + CProp ("if",[CVar 15, CProp ("false",[]), CProp ("true",[])])])); +add (CProp +("equal", + [CProp ("implies",[CVar 15, CVar 16]), + CProp + ("if", + [CVar 15, + CProp ("if",[CVar 16, CProp ("true",[]), CProp ("false",[])]), + CProp ("true",[])])])); +add (CProp +("equal", + [CProp ("fix",[CVar 23]), + CProp ("if",[CProp ("numberp",[CVar 23]), CVar 23, CProp ("zero",[])])])); +add (CProp +("equal", + [CProp ("if",[CProp ("if",[CVar 0, CVar 1, CVar 2]), CVar 3, CVar 4]), + CProp + ("if", + [CVar 0, CProp ("if",[CVar 1, CVar 3, CVar 4]), + CProp ("if",[CVar 2, CVar 3, CVar 4])])])); +add (CProp +("equal", + [CProp ("zerop",[CVar 23]), + CProp + ("or", + [CProp ("equal",[CVar 23, CProp ("zero",[])]), + CProp ("not",[CProp ("numberp",[CVar 23])])])])); +add (CProp +("equal", + [CProp ("plus",[CProp ("plus",[CVar 23, CVar 24]), CVar 25]), + CProp ("plus",[CVar 23, CProp ("plus",[CVar 24, CVar 25])])])); +add (CProp +("equal", + [CProp ("equal",[CProp ("plus",[CVar 0, CVar 1]), CProp ("zero",[])]), + CProp ("and",[CProp ("zerop",[CVar 0]), CProp ("zerop",[CVar 1])])])); +add (CProp +("equal",[CProp ("difference",[CVar 23, CVar 23]), CProp ("zero",[])])); +add (CProp +("equal", + [CProp + ("equal", + [CProp ("plus",[CVar 0, CVar 1]), CProp ("plus",[CVar 0, CVar 2])]), + CProp ("equal",[CProp ("fix",[CVar 1]), CProp ("fix",[CVar 2])])])); +add (CProp +("equal", + [CProp + ("equal",[CProp ("zero",[]), CProp ("difference",[CVar 23, CVar 24])]), + CProp ("not",[CProp ("gt",[CVar 24, CVar 23])])])); +add (CProp +("equal", + [CProp ("equal",[CVar 23, CProp ("difference",[CVar 23, CVar 24])]), + CProp + ("and", + [CProp ("numberp",[CVar 23]), + CProp + ("or", + [CProp ("equal",[CVar 23, CProp ("zero",[])]), + CProp ("zerop",[CVar 24])])])])); +add (CProp +("equal", + [CProp + ("meaning", + [CProp ("plus_tree",[CProp ("append",[CVar 23, CVar 24])]), CVar 0]), + CProp + ("plus", + [CProp ("meaning",[CProp ("plus_tree",[CVar 23]), CVar 0]), + CProp ("meaning",[CProp ("plus_tree",[CVar 24]), CVar 0])])])); +add (CProp +("equal", + [CProp + ("meaning", + [CProp ("plus_tree",[CProp ("plus_fringe",[CVar 23])]), CVar 0]), + CProp ("fix",[CProp ("meaning",[CVar 23, CVar 0])])])); +add (CProp +("equal", + [CProp ("append",[CProp ("append",[CVar 23, CVar 24]), CVar 25]), + CProp ("append",[CVar 23, CProp ("append",[CVar 24, CVar 25])])])); +add (CProp +("equal", + [CProp ("reverse",[CProp ("append",[CVar 0, CVar 1])]), + CProp + ("append",[CProp ("reverse",[CVar 1]), CProp ("reverse",[CVar 0])])])); +add (CProp +("equal", + [CProp ("times",[CVar 23, CProp ("plus",[CVar 24, CVar 25])]), + CProp + ("plus", + [CProp ("times",[CVar 23, CVar 24]), + CProp ("times",[CVar 23, CVar 25])])])); +add (CProp +("equal", + [CProp ("times",[CProp ("times",[CVar 23, CVar 24]), CVar 25]), + CProp ("times",[CVar 23, CProp ("times",[CVar 24, CVar 25])])])); +add (CProp +("equal", + [CProp + ("equal",[CProp ("times",[CVar 23, CVar 24]), CProp ("zero",[])]), + CProp ("or",[CProp ("zerop",[CVar 23]), CProp ("zerop",[CVar 24])])])); +add (CProp +("equal", + [CProp ("exec",[CProp ("append",[CVar 23, CVar 24]), CVar 15, CVar 4]), + CProp + ("exec",[CVar 24, CProp ("exec",[CVar 23, CVar 15, CVar 4]), CVar 4])])); +add (CProp +("equal", + [CProp ("mc_flatten",[CVar 23, CVar 24]), + CProp ("append",[CProp ("flatten",[CVar 23]), CVar 24])])); +add (CProp +("equal", + [CProp ("member",[CVar 23, CProp ("append",[CVar 0, CVar 1])]), + CProp + ("or", + [CProp ("member",[CVar 23, CVar 0]), + CProp ("member",[CVar 23, CVar 1])])])); +add (CProp +("equal", + [CProp ("member",[CVar 23, CProp ("reverse",[CVar 24])]), + CProp ("member",[CVar 23, CVar 24])])); +add (CProp +("equal", + [CProp ("length",[CProp ("reverse",[CVar 23])]), + CProp ("length",[CVar 23])])); +add (CProp +("equal", + [CProp ("member",[CVar 0, CProp ("intersect",[CVar 1, CVar 2])]), + CProp + ("and", + [CProp ("member",[CVar 0, CVar 1]), CProp ("member",[CVar 0, CVar 2])])])); +add (CProp +("equal",[CProp ("nth",[CProp ("zero",[]), CVar 8]), CProp ("zero",[])])); +add (CProp +("equal", + [CProp ("exp",[CVar 8, CProp ("plus",[CVar 9, CVar 10])]), + CProp + ("times", + [CProp ("exp",[CVar 8, CVar 9]), CProp ("exp",[CVar 8, CVar 10])])])); +add (CProp +("equal", + [CProp ("exp",[CVar 8, CProp ("times",[CVar 9, CVar 10])]), + CProp ("exp",[CProp ("exp",[CVar 8, CVar 9]), CVar 10])])); +add (CProp +("equal", + [CProp ("reverse_loop",[CVar 23, CVar 24]), + CProp ("append",[CProp ("reverse",[CVar 23]), CVar 24])])); +add (CProp +("equal", + [CProp ("reverse_loop",[CVar 23, CProp ("nil",[])]), + CProp ("reverse",[CVar 23])])); +add (CProp +("equal", + [CProp ("count_list",[CVar 25, CProp ("sort_lp",[CVar 23, CVar 24])]), + CProp + ("plus", + [CProp ("count_list",[CVar 25, CVar 23]), + CProp ("count_list",[CVar 25, CVar 24])])])); +add (CProp +("equal", + [CProp + ("equal", + [CProp ("append",[CVar 0, CVar 1]), CProp ("append",[CVar 0, CVar 2])]), + CProp ("equal",[CVar 1, CVar 2])])); +add (CProp +("equal", + [CProp + ("plus", + [CProp ("remainder",[CVar 23, CVar 24]), + CProp ("times",[CVar 24, CProp ("quotient",[CVar 23, CVar 24])])]), + CProp ("fix",[CVar 23])])); +add (CProp +("equal", + [CProp + ("power_eval",[CProp ("big_plus",[CVar 11, CVar 8, CVar 1]), CVar 1]), + CProp ("plus",[CProp ("power_eval",[CVar 11, CVar 1]), CVar 8])])); +add (CProp +("equal", + [CProp + ("power_eval", + [CProp ("big_plus",[CVar 23, CVar 24, CVar 8, CVar 1]), CVar 1]), + CProp + ("plus", + [CVar 8, + CProp + ("plus", + [CProp ("power_eval",[CVar 23, CVar 1]), + CProp ("power_eval",[CVar 24, CVar 1])])])])); +add (CProp +("equal", + [CProp ("remainder",[CVar 24, CProp ("one",[])]), CProp ("zero",[])])); +add (CProp +("equal", + [CProp ("lt",[CProp ("remainder",[CVar 23, CVar 24]), CVar 24]), + CProp ("not",[CProp ("zerop",[CVar 24])])])); +add (CProp +("equal",[CProp ("remainder",[CVar 23, CVar 23]), CProp ("zero",[])])); +add (CProp +("equal", + [CProp ("lt",[CProp ("quotient",[CVar 8, CVar 9]), CVar 8]), + CProp + ("and", + [CProp ("not",[CProp ("zerop",[CVar 8])]), + CProp + ("or", + [CProp ("zerop",[CVar 9]), + CProp ("not",[CProp ("equal",[CVar 9, CProp ("one",[])])])])])])); +add (CProp +("equal", + [CProp ("lt",[CProp ("remainder",[CVar 23, CVar 24]), CVar 23]), + CProp + ("and", + [CProp ("not",[CProp ("zerop",[CVar 24])]), + CProp ("not",[CProp ("zerop",[CVar 23])]), + CProp ("not",[CProp ("lt",[CVar 23, CVar 24])])])])); +add (CProp +("equal", + [CProp ("power_eval",[CProp ("power_rep",[CVar 8, CVar 1]), CVar 1]), + CProp ("fix",[CVar 8])])); +add (CProp +("equal", + [CProp + ("power_eval", + [CProp + ("big_plus", + [CProp ("power_rep",[CVar 8, CVar 1]), + CProp ("power_rep",[CVar 9, CVar 1]), CProp ("zero",[]), + CVar 1]), + CVar 1]), + CProp ("plus",[CVar 8, CVar 9])])); +add (CProp +("equal", + [CProp ("gcd",[CVar 23, CVar 24]), CProp ("gcd",[CVar 24, CVar 23])])); +add (CProp +("equal", + [CProp ("nth",[CProp ("append",[CVar 0, CVar 1]), CVar 8]), + CProp + ("append", + [CProp ("nth",[CVar 0, CVar 8]), + CProp + ("nth", + [CVar 1, CProp ("difference",[CVar 8, CProp ("length",[CVar 0])])])])])); +add (CProp +("equal", + [CProp ("difference",[CProp ("plus",[CVar 23, CVar 24]), CVar 23]), + CProp ("fix",[CVar 24])])); +add (CProp +("equal", + [CProp ("difference",[CProp ("plus",[CVar 24, CVar 23]), CVar 23]), + CProp ("fix",[CVar 24])])); +add (CProp +("equal", + [CProp + ("difference", + [CProp ("plus",[CVar 23, CVar 24]), CProp ("plus",[CVar 23, CVar 25])]), + CProp ("difference",[CVar 24, CVar 25])])); +add (CProp +("equal", + [CProp ("times",[CVar 23, CProp ("difference",[CVar 2, CVar 22])]), + CProp + ("difference", + [CProp ("times",[CVar 2, CVar 23]), + CProp ("times",[CVar 22, CVar 23])])])); +add (CProp +("equal", + [CProp ("remainder",[CProp ("times",[CVar 23, CVar 25]), CVar 25]), + CProp ("zero",[])])); +add (CProp +("equal", + [CProp + ("difference", + [CProp ("plus",[CVar 1, CProp ("plus",[CVar 0, CVar 2])]), CVar 0]), + CProp ("plus",[CVar 1, CVar 2])])); +add (CProp +("equal", + [CProp + ("difference", + [CProp ("add1",[CProp ("plus",[CVar 24, CVar 25])]), CVar 25]), + CProp ("add1",[CVar 24])])); +add (CProp +("equal", + [CProp + ("lt", + [CProp ("plus",[CVar 23, CVar 24]), CProp ("plus",[CVar 23, CVar 25])]), + CProp ("lt",[CVar 24, CVar 25])])); +add (CProp +("equal", + [CProp + ("lt", + [CProp ("times",[CVar 23, CVar 25]), + CProp ("times",[CVar 24, CVar 25])]), + CProp + ("and", + [CProp ("not",[CProp ("zerop",[CVar 25])]), + CProp ("lt",[CVar 23, CVar 24])])])); +add (CProp +("equal", + [CProp ("lt",[CVar 24, CProp ("plus",[CVar 23, CVar 24])]), + CProp ("not",[CProp ("zerop",[CVar 23])])])); +add (CProp +("equal", + [CProp + ("gcd", + [CProp ("times",[CVar 23, CVar 25]), + CProp ("times",[CVar 24, CVar 25])]), + CProp ("times",[CVar 25, CProp ("gcd",[CVar 23, CVar 24])])])); +add (CProp +("equal", + [CProp ("value",[CProp ("normalize",[CVar 23]), CVar 0]), + CProp ("value",[CVar 23, CVar 0])])); +add (CProp +("equal", + [CProp + ("equal", + [CProp ("flatten",[CVar 23]), + CProp ("cons",[CVar 24, CProp ("nil",[])])]), + CProp + ("and", + [CProp ("nlistp",[CVar 23]), CProp ("equal",[CVar 23, CVar 24])])])); +add (CProp +("equal", + [CProp ("listp",[CProp ("gother",[CVar 23])]), + CProp ("listp",[CVar 23])])); +add (CProp +("equal", + [CProp ("samefringe",[CVar 23, CVar 24]), + CProp + ("equal",[CProp ("flatten",[CVar 23]), CProp ("flatten",[CVar 24])])])); +add (CProp +("equal", + [CProp + ("equal", + [CProp ("greatest_factor",[CVar 23, CVar 24]), CProp ("zero",[])]), + CProp + ("and", + [CProp + ("or", + [CProp ("zerop",[CVar 24]), + CProp ("equal",[CVar 24, CProp ("one",[])])]), + CProp ("equal",[CVar 23, CProp ("zero",[])])])])); +add (CProp +("equal", + [CProp + ("equal", + [CProp ("greatest_factor",[CVar 23, CVar 24]), CProp ("one",[])]), + CProp ("equal",[CVar 23, CProp ("one",[])])])); +add (CProp +("equal", + [CProp ("numberp",[CProp ("greatest_factor",[CVar 23, CVar 24])]), + CProp + ("not", + [CProp + ("and", + [CProp + ("or", + [CProp ("zerop",[CVar 24]), + CProp ("equal",[CVar 24, CProp ("one",[])])]), + CProp ("not",[CProp ("numberp",[CVar 23])])])])])); +add (CProp +("equal", + [CProp ("times_list",[CProp ("append",[CVar 23, CVar 24])]), + CProp + ("times", + [CProp ("times_list",[CVar 23]), CProp ("times_list",[CVar 24])])])); +add (CProp +("equal", + [CProp ("prime_list",[CProp ("append",[CVar 23, CVar 24])]), + CProp + ("and", + [CProp ("prime_list",[CVar 23]), CProp ("prime_list",[CVar 24])])])); +add (CProp +("equal", + [CProp ("equal",[CVar 25, CProp ("times",[CVar 22, CVar 25])]), + CProp + ("and", + [CProp ("numberp",[CVar 25]), + CProp + ("or", + [CProp ("equal",[CVar 25, CProp ("zero",[])]), + CProp ("equal",[CVar 22, CProp ("one",[])])])])])); +add (CProp +("equal", + [CProp ("ge",[CVar 23, CVar 24]), + CProp ("not",[CProp ("lt",[CVar 23, CVar 24])])])); +add (CProp +("equal", + [CProp ("equal",[CVar 23, CProp ("times",[CVar 23, CVar 24])]), + CProp + ("or", + [CProp ("equal",[CVar 23, CProp ("zero",[])]), + CProp + ("and", + [CProp ("numberp",[CVar 23]), + CProp ("equal",[CVar 24, CProp ("one",[])])])])])); +add (CProp +("equal", + [CProp ("remainder",[CProp ("times",[CVar 24, CVar 23]), CVar 24]), + CProp ("zero",[])])); +add (CProp +("equal", + [CProp ("equal",[CProp ("times",[CVar 0, CVar 1]), CProp ("one",[])]), + CProp + ("and", + [CProp ("not",[CProp ("equal",[CVar 0, CProp ("zero",[])])]), + CProp ("not",[CProp ("equal",[CVar 1, CProp ("zero",[])])]), + CProp ("numberp",[CVar 0]), CProp ("numberp",[CVar 1]), + CProp ("equal",[CProp ("sub1",[CVar 0]), CProp ("zero",[])]), + CProp ("equal",[CProp ("sub1",[CVar 1]), CProp ("zero",[])])])])); +add (CProp +("equal", + [CProp + ("lt", + [CProp ("length",[CProp ("delete",[CVar 23, CVar 11])]), + CProp ("length",[CVar 11])]), + CProp ("member",[CVar 23, CVar 11])])); +add (CProp +("equal", + [CProp ("sort2",[CProp ("delete",[CVar 23, CVar 11])]), + CProp ("delete",[CVar 23, CProp ("sort2",[CVar 11])])])); +add (CProp ("equal",[CProp ("dsort",[CVar 23]), CProp ("sort2",[CVar 23])])); +add (CProp +("equal", + [CProp + ("length", + [CProp + ("cons", + [CVar 0, + CProp + ("cons", + [CVar 1, + CProp + ("cons", + [CVar 2, + CProp + ("cons", + [CVar 3, + CProp ("cons",[CVar 4, CProp ("cons",[CVar 5, CVar 6])])])])])])]) + , CProp ("plus",[CProp ("six",[]), CProp ("length",[CVar 6])])])); +add (CProp +("equal", + [CProp + ("difference", + [CProp ("add1",[CProp ("add1",[CVar 23])]), CProp ("two",[])]), + CProp ("fix",[CVar 23])])); +add (CProp +("equal", + [CProp + ("quotient", + [CProp ("plus",[CVar 23, CProp ("plus",[CVar 23, CVar 24])]), + CProp ("two",[])]), + CProp + ("plus",[CVar 23, CProp ("quotient",[CVar 24, CProp ("two",[])])])])); +add (CProp +("equal", + [CProp ("sigma",[CProp ("zero",[]), CVar 8]), + CProp + ("quotient", + [CProp ("times",[CVar 8, CProp ("add1",[CVar 8])]), CProp ("two",[])])])); +add (CProp +("equal", + [CProp ("plus",[CVar 23, CProp ("add1",[CVar 24])]), + CProp + ("if", + [CProp ("numberp",[CVar 24]), + CProp ("add1",[CProp ("plus",[CVar 23, CVar 24])]), + CProp ("add1",[CVar 23])])])); +add (CProp +("equal", + [CProp + ("equal", + [CProp ("difference",[CVar 23, CVar 24]), + CProp ("difference",[CVar 25, CVar 24])]), + CProp + ("if", + [CProp ("lt",[CVar 23, CVar 24]), + CProp ("not",[CProp ("lt",[CVar 24, CVar 25])]), + CProp + ("if", + [CProp ("lt",[CVar 25, CVar 24]), + CProp ("not",[CProp ("lt",[CVar 24, CVar 23])]), + CProp ("equal",[CProp ("fix",[CVar 23]), CProp ("fix",[CVar 25])])])])]) +); +add (CProp +("equal", + [CProp + ("meaning", + [CProp ("plus_tree",[CProp ("delete",[CVar 23, CVar 24])]), CVar 0]), + CProp + ("if", + [CProp ("member",[CVar 23, CVar 24]), + CProp + ("difference", + [CProp ("meaning",[CProp ("plus_tree",[CVar 24]), CVar 0]), + CProp ("meaning",[CVar 23, CVar 0])]), + CProp ("meaning",[CProp ("plus_tree",[CVar 24]), CVar 0])])])); +add (CProp +("equal", + [CProp ("times",[CVar 23, CProp ("add1",[CVar 24])]), + CProp + ("if", + [CProp ("numberp",[CVar 24]), + CProp + ("plus", + [CVar 23, CProp ("times",[CVar 23, CVar 24]), + CProp ("fix",[CVar 23])])])])); +add (CProp +("equal", + [CProp ("nth",[CProp ("nil",[]), CVar 8]), + CProp + ("if",[CProp ("zerop",[CVar 8]), CProp ("nil",[]), CProp ("zero",[])])])); +add (CProp +("equal", + [CProp ("last",[CProp ("append",[CVar 0, CVar 1])]), + CProp + ("if", + [CProp ("listp",[CVar 1]), CProp ("last",[CVar 1]), + CProp + ("if", + [CProp ("listp",[CVar 0]), + CProp ("cons",[CProp ("car",[CProp ("last",[CVar 0])]), CVar 1]), + CVar 1])])])); +add (CProp +("equal", + [CProp ("equal",[CProp ("lt",[CVar 23, CVar 24]), CVar 25]), + CProp + ("if", + [CProp ("lt",[CVar 23, CVar 24]), + CProp ("equal",[CProp ("true",[]), CVar 25]), + CProp ("equal",[CProp ("false",[]), CVar 25])])])); +add (CProp +("equal", + [CProp ("assignment",[CVar 23, CProp ("append",[CVar 0, CVar 1])]), + CProp + ("if", + [CProp ("assignedp",[CVar 23, CVar 0]), + CProp ("assignment",[CVar 23, CVar 0]), + CProp ("assignment",[CVar 23, CVar 1])])])); +add (CProp +("equal", + [CProp ("car",[CProp ("gother",[CVar 23])]), + CProp + ("if", + [CProp ("listp",[CVar 23]), + CProp ("car",[CProp ("flatten",[CVar 23])]), CProp ("zero",[])])])); +add (CProp +("equal", + [CProp ("flatten",[CProp ("cdr",[CProp ("gother",[CVar 23])])]), + CProp + ("if", + [CProp ("listp",[CVar 23]), + CProp ("cdr",[CProp ("flatten",[CVar 23])]), + CProp ("cons",[CProp ("zero",[]), CProp ("nil",[])])])])); +add (CProp +("equal", + [CProp ("quotient",[CProp ("times",[CVar 24, CVar 23]), CVar 24]), + CProp + ("if", + [CProp ("zerop",[CVar 24]), CProp ("zero",[]), + CProp ("fix",[CVar 23])])])); +add (CProp +("equal", + [CProp ("get",[CVar 9, CProp ("set",[CVar 8, CVar 21, CVar 12])]), + CProp + ("if", + [CProp ("eqp",[CVar 9, CVar 8]), CVar 21, + CProp ("get",[CVar 9, CVar 12])])]))) + + end; (* Rules *) + +(* boyer.sml: + * + * Tautology checker + *) + +signature BOYER = + sig + include TERMS + val tautp: term -> bool + end + +structure Boyer: BOYER = + struct + +open Terms + +fun mem x [] = false + | mem x (y::L) = x=y orelse mem x L + +fun truep (x, lst) = + case x of + Prop(head, _) => + headname head = "true" orelse mem x lst + | _ => + mem x lst + +and falsep (x, lst) = + case x of + Prop(head, _) => + headname head = "false" orelse mem x lst + | _ => + mem x lst + +fun tautologyp (x, true_lst, false_lst) = + if truep (x, true_lst) then true else + if falsep (x, false_lst) then false else + (case x of + Var _ => false + | Prop (head,[test, yes, no]) => + if headname head = "if" then + if truep (test, true_lst) then + tautologyp (yes, true_lst, false_lst) + else if falsep (test, false_lst) then + tautologyp (no, true_lst, false_lst) + else tautologyp (yes, test::true_lst, false_lst) andalso + tautologyp (no, true_lst, test::false_lst) + else + false) + + fun tautp x = tautologyp(rewrite x, [], []); + + end; (* Boyer *) + +signature BMARK = + sig + val doit : unit -> unit + val testit : TextIO.outstream -> unit + end; + +(* the benchmark *) +structure Main : BMARK = + struct + + open Terms; + open Boyer; + +val subst = +[Bind(23, + Prop + (get "f", + [Prop + (get "plus", + [Prop (get "plus",[Var 0, Var 1]), + Prop (get "plus",[Var 2, Prop (get "zero",[])])])])), + Bind(24, + Prop + (get "f", + [Prop + (get "times", + [Prop (get "times",[Var 0, Var 1]), + Prop (get "plus",[Var 2, Var 3])])])), + Bind(25, + Prop + (get "f", + [Prop + (get "reverse", + [Prop + (get "append", + [Prop (get "append",[Var 0, Var 1]), + Prop (get "nil",[])])])])), + Bind(20, + Prop + (get "equal", + [Prop (get "plus",[Var 0, Var 1]), + Prop (get "difference",[Var 23, Var 24])])), + Bind(22, + Prop + (get "lt", + [Prop (get "remainder",[Var 0, Var 1]), + Prop (get "member",[Var 0, Prop (get "length",[Var 1])])]))] + +val term = + Prop + (get "implies", + [Prop + (get "and", + [Prop (get "implies",[Var 23, Var 24]), + Prop + (get "and", + [Prop (get "implies",[Var 24, Var 25]), + Prop + (get "and", + [Prop (get "implies",[Var 25, Var 20]), + Prop (get "implies",[Var 20, Var 22])])])]), + Prop (get "implies",[Var 23, Var 22])]) + + fun testit outstrm = if tautp (apply_subst subst term) + then TextIO.output (outstrm, "Proved!\n") + else TextIO.output (outstrm, "Cannot prove!\n") + + fun doit () = (tautp (apply_subst subst term); ()) + + end; (* Main *) + +structure Main = + struct + val doit = + fn n => + let + fun loop n = + if n = 0 + then () + else (Main.doit (); + loop(n-1)) + in loop n + end + end; diff --git a/benchmark/tests/checksum.sml b/benchmark/tests/checksum.sml new file mode 100644 index 0000000..50b14c5 --- /dev/null +++ b/benchmark/tests/checksum.sml @@ -0,0 +1,46 @@ +(* Author: sweeks@sweeks.com + * This code is based on the following paper. + * The Performance of FoxNet 2.0 + * Herb Derby + * CMU-CS-99-137 + * June 1999 + *) + +fun checkOne (new, ac) = + let open Word32 + in ac + >> (new, 0w16) + andb (new, 0wxFFFF) + end + +fun fold f b (buf, first, last) = + let + fun loop (i, ac) = + if i > last + then ac + else loop (i + 1, + f (Word32.fromLarge (PackWord32Little.subArr (buf, i)), + ac)) + in + loop (first, b) + end + +fun checksum buf = fold checkOne 0w0 buf + +structure Main = + struct + fun doit n = + let + val first = 0 + val size = 10000000 + val buf = Word8Array.array (size, 0w0) + val bytesPerWord = 4 + val last = size div bytesPerWord - 1 + val rec loop = + fn 0 => () + | n => + let val w = checksum (buf, first, last) + val _ = if w <> 0w0 then raise Fail "bug" else () + in loop (n - 1) + end + in loop n + end + end diff --git a/benchmark/tests/count-graphs.sml b/benchmark/tests/count-graphs.sml new file mode 100644 index 0000000..ecb8ed8 --- /dev/null +++ b/benchmark/tests/count-graphs.sml @@ -0,0 +1,537 @@ +(* Written by Henry Cejtin (henry@sourcelight.com). *) + +fun print _ = () + +(* + * My favorite high-order procedure. + *) +fun fold (lst, folder, state) = + let fun loop (lst, state) = + case lst of + [] => state + | first::rest => loop (rest, folder (first, state)) + in loop (lst, state) + end + +fun naturalFold (limit, folder, state) = + if limit < 0 + then raise Domain + else let fun loop (i, state) = + if i = limit + then state + else loop (i+1, folder (i, state)) + in loop (0, state) + end + +fun naturalAny (limit, ok) = + if limit < 0 + then raise Domain + else let fun loop i = + i <> limit andalso + (ok i orelse loop (i+1)) + in loop 0 + end + +fun naturalAll (limit, ok) = + if limit < 0 + then raise Domain + else let fun loop i = + i = limit orelse + (ok i andalso loop (i+1)) + in loop 0 + end +(* + * Fold over all permutations. + * Universe is a list of all the items to be permuted. + * pFolder is used to build up the permutation. It is called via + * pFolder (next, pState, state, accross) + * where next is the next item in the permutation, pState is the + * partially constructed permutation and state is the current fold + * state over permutations that have already been considered. + * If pFolder knows what will result from folding over all permutations + * descending from the resulting partial permutation (starting at state), + * it should raise the accross exception carrying the new state value. + * If pFolder wants to continue building up the permutation, it should + * return (newPState, newState). + * When a permutation has been completely constructed, folder is called + * via + * folder (pState, state) + * where pState is the final pState and state is the current state. + * It should return the new state. + *) +fun 'a foldOverPermutations (universe, pFolder, pState, folder, state: 'a) = + let exception accross of 'a + fun outer (universe, pState, state) = + case universe of + [] => folder (pState, state) + | first::rest => + let fun inner (first, rest, revOut, state) = + let val state = + let val (newPState, state) = + pFolder (first, + pState, + state, + accross) + in outer (fold (revOut, + op ::, + rest), + newPState, + state) + end handle accross state => state + in case rest of + [] => state + | second::rest => + inner (second, + rest, + first::revOut, + state) + end + in inner (first, rest, [], state) + end + in outer (universe, pState, state) + end +(* + * Fold over all arrangements of bag elements. + * Universe is a list of lists of items, with equivalent items in the + * same list. + * pFolder is used to build up the permutation. It is called via + * pFolder (next, pState, state, accross) + * where next is the next item in the permutation, pState is the + * partially constructed permutation and state is the current fold + * state over permutations that have already been considered. + * If pFolder knows what will result from folding over all permutations + * descending from the resulting partial permutation (starting at state), + * it should raise the accross exception carrying the new state value. + * If pFolder wants to continue building up the permutation, it should + * return (newPState, newState). + * When a permutation has been completely constructed, folder is called + * via + * folder (pState, state) + * where pState is the final pState and state is the current state. + * It should return the new state. + *) +fun 'a foldOverBagPerms (universe, pFolder, pState, folder, state: 'a) = + let exception accross of 'a + fun outer (universe, pState, state) = + case universe of + [] => folder (pState, state) + | (fbag as (first::fclone))::rest => + let fun inner (fbag, first, fclone, rest, revOut, state) = + let val state = + let val (newPState, state) = + pFolder (first, + pState, + state, + accross) + in outer (fold (revOut, + op ::, + case fclone of + [] => rest + | _ => fclone::rest), + newPState, + state) + end handle accross state => state + in case rest of + [] => state + | (sbag as (second::sclone))::rest => + inner (sbag, + second, + sclone, + rest, + fbag::revOut, + state) + end + in inner (fbag, first, fclone, rest, [], state) + end + in outer (universe, pState, state) + end +(* + * Fold over the tree of subsets of the elements of universe. + * The tree structure comes from the root picking if the first element + * is in the subset, etc. + * eFolder is called to build up the subset given a decision on wether + * or not a given element is in it or not. It is called via + * eFolder (elem, isinc, eState, state, fini) + * If this determines the result of folding over all the subsets consistant + * with the choice so far, then eFolder should raise the exception + * fini newState + * If we need to proceed deeper in the tree, then eFolder should return + * the tuple + * (newEState, newState) + * folder is called to buld up the final state, folding over subsets + * (represented as the terminal eStates). It is called via + * folder (eState, state) + * It returns the new state. + * Note, the order in which elements are folded (via eFolder) is the same + * as the order in universe. + *) +fun 'a foldOverSubsets (universe, eFolder, eState, folder, state: 'a) = + let exception fini of 'a + fun f (first, rest, eState) (isinc, state) = + let val (newEState, newState) = + eFolder (first, + isinc, + eState, + state, + fini) + in outer (rest, newEState, newState) + end handle fini state => state + and outer (universe, eState, state) = + case universe of + [] => folder (eState, state) + | first::rest => + let val f = f (first, rest, eState) + in f (false, f (true, state)) + end + in outer (universe, eState, state) + end + +fun f universe = + foldOverSubsets (universe, + fn (elem, isinc, set, state, _) => + (if isinc + then elem::set + else set, + state), + [], + fn (set, sets) => set::sets, + []) +(* + * Given a partitioning of [0, size) into equivalence classes (as a list + * of the classes, where each class is a list of integers), and where two + * vertices are equivalent iff transposing the two is an automorphism + * of the full subgraph on the vertices [0, size), return the equivalence + * classes for the graph. The graph is provided as a connection function. + * In the result, two equivalent vertices in [0, size) remain equivalent + * iff they are either both connected or neither is connected to size. + * The vertex size is equivalent to a vertex x in [0, size) iff + * connected (size, y) = connected (x, if y = x then size else y) + * for all y in [0, size). + *) +fun refine (size: int, + classes: int list list, + connected: int*int -> bool): int list list = + let fun sizeMatch x = + (* Check if vertex size is equivalent to vertex x. *) + naturalAll (size, + fn y => connected (size, y) = + connected (x, + if y = x + then size + else y)) + fun merge (class, (merged, classes)) = + (* Add class into classes, testing if size should be merged. *) + if merged + then (true, (rev class)::classes) + else let val first::_ = class + in if sizeMatch first + then (true, fold (class, + op ::, + [size])::classes) + else (false, (rev class)::classes) + end + fun split (elem, (yes, no)) = + if connected (elem, size) + then (elem::yes, no) + else (yes, elem::no) + fun subdivide (class, state) = + case class of + [first] => merge (class, state) + | _ => case fold (class, split, ([], [])) of + ([], no) => merge (no, state) + | (yes, []) => merge (yes, state) + | (yes, no) => merge (no, merge (yes, state)) + in case fold (classes, subdivide, (false, [])) of + (true, classes) => rev classes + | (false, classes) => fold (classes, op ::, [[size]]) + end +(* + * Given a count of the number of vertices, a partitioning of the vertices + * into equivalence classes (where two vertices are equivalent iff + * transposing them is a graph automorphism), and a function which, given + * two distinct vertices, returns a bool indicating if there is an edge + * connecting them, check if the graph is minimal. + * If it is, return + * SOME how-many-clones-we-walked-through + * If not, return NONE. + * A graph is minimal iff its connection matrix is (weakly) smaller + * then all its permuted friends, where true is less than false, and + * the entries are compared lexicographically in the following order: + * - + * 0 - + * 1 2 - + * 3 4 5 - + * ... + * Note, the vertices are the integers in [0, nverts). + *) +fun minimal (nverts: int, + classes: int list list, + connected: int*int -> bool): int option = + let val perm = Array.array (nverts, ~1) + exception fini + fun pFolder (new, old, state, accross) = + let fun loop v = + if v = old + then (Array.update (perm, old, new); + (old + 1, state)) + else case (connected (old, + v), + connected (new, + Array.sub (perm, + v))) of + (true, false) => + raise (accross state) + | (false, true) => + raise fini + | _ => + loop (v + 1) + in loop 0 + end + fun folder (_, state) = + state + 1 + in SOME (foldOverBagPerms ( + classes, + pFolder, + 0, + folder, + 0)) handle fini => NONE + end +(* + * Fold over the tree of graphs. + * + * eFolder is used to fold over the choice of edges via + * eFolder (from, to, isinc, eState, state, accross) + * with from > to. + * + * If eFolder knows the result of folding over all graphs which agree + * with the currently made decisions, then it should raise the accross + * exception carrying the resulting state as a value. + * + * To continue normally, it should return the tuple + * (newEState, newState) + * + * When all decisions are made with regards to edges from `from', folder + * is called via + * folder (size, eState, state, accross) + * where size is the number of vertices in the graph (the last from+1) and + * eState is the final eState for edges from `from'. + * + * If folder knows the result of folding over all extensions of this graph, + * it should raise accross carrying the resulting state as a value. + * + * If extensions of this graph should be folded over, it should return + * the new state. + *) +fun ('a, 'b) foldOverGraphs (eFolder, eState: 'a, folder, state: 'b) = + let exception noextend of 'b + fun makeVertss limit = + Vector.tabulate (limit, + fn nverts => + List.tabulate (nverts, + fn v => v)) + val vertss = ref (makeVertss 0) + fun findVerts size = ( + if size >= Vector.length (!vertss) + then vertss := makeVertss (size + 1) + else (); + Vector.sub (!vertss, size)) + fun f (size, eState, state) = + let val state = + folder (size, eState, state, noextend) + in g (size+1, state) + end handle noextend state => state + and g (size, state) = + let val indices = + findVerts (size - 1) + fun SeFolder (to, isinc, eState, state, accross) = + eFolder (size-1, + to, + isinc, + eState, + state, + accross) + fun Sf (eState, state) = + f (size, eState, state) + in foldOverSubsets ( + indices, + SeFolder, + eState, + Sf, + state) + end + in f (0, eState, state) + end + +(* + * Given the size of a graph, a list of the vertices (the integers in + * [0, size)), and the connected function, check if for all full subgraphs, + * 3*V - 4 - 2*E >= 0 or V <= 1 + * where V is the number of vertices and E is the number of edges. + *) +local fun short lst = + case lst of + [] => true + | [_] => true + | _ => false +in fun okSoFar (size, verts, connected) = + let exception fini of unit + fun eFolder (elem, isinc, eState as (ac, picked), _, accross) = + (if isinc + then (fold (picked, + fn (p, ac) => + if connected (elem, p) + then ac - 2 + else ac, + ac + 3), + elem::picked) + else eState, + ()) + fun folder ((ac, picked), state) = + if ac >= 0 orelse short picked + then state + else raise (fini ()) + in (foldOverSubsets ( + verts, + eFolder, + (~4, []), + folder, + ()); + true) handle fini () => false + end +end + +fun showGraph (size, connected) = + naturalFold (size, + fn (from, _) => ( + print ((Int.toString from) ^ ":"); + naturalFold (size, + fn (to, _) => + if from <> to andalso connected (from, to) + then print (" " ^ (Int.toString to)) + else (), + ()); + print "\n"), + ()); + +fun showList (start, sep, stop, trans) lst = ( + start (); + case lst of + [] => () + | first::rest => ( + trans first; + fold (rest, + fn (item, _) => ( + sep (); + trans item), + ())); + stop ()) + +val showIntList = showList ( + fn () => print "[", + fn () => print ", ", + fn () => print "]", + fn i => print (Int.toString i)) + +val showIntListList = showList ( + fn () => print "[", + fn () => print ", ", + fn () => print "]", + showIntList) + +fun h (maxSize, folder, state) = + let val ctab = Array.tabulate (maxSize, + fn v => Array.array (v, false)) + val classesv = Array.array (maxSize+1, []) + fun connected (from, to) = + let val (from, to) = if from > to + then (from, to) + else (to, from) + in Array.sub (Array.sub (ctab, from), to) + end + fun update (from, to, value) = + let val (from, to) = if from > to + then (from, to) + else (to, from) + in Array.update (Array.sub (ctab, from), to, value) + end + fun triangle (vnum, e) = + naturalAny (e, + fn f => connected (vnum, f) + andalso connected (e, f)) + fun eFolder (from, to, isinc, _, state, accross) = + if isinc andalso triangle (from, to) + then raise (accross state) + else ( + update (from, to, isinc); + ((), state)) + fun Gfolder (size, _, state, accross) = ( + if size <> 0 + then Array.update (classesv, + size, + refine (size-1, + Array.sub (classesv, + size-1), + connected)) + else (); + case minimal (size, Array.sub (classesv, size), connected) of + NONE => raise (accross state) + | SOME eatMe => + if okSoFar (size, + List.tabulate (size, fn v => v), + connected) + then let val state = + folder (size, connected, state) + in if size = maxSize + then raise (accross state) + else state + end + else raise (accross state)) + in foldOverGraphs (eFolder, + (), + Gfolder, + state) + end + +local fun final (size: int, connected: int * int -> bool): int = + naturalFold (size, + fn (from, ac) => + naturalFold (from, + fn (to, ac) => + if connected (from, to) + then ac - 2 + else ac, + ac), + 3*size - 4) +in fun f maxSize = + h (maxSize, + fn (size, connected, state) => + if final (size, connected) = 0 + then state + 1 + else state, + 0) +end + +fun doOne arg = ( + print (arg ^ " -> "); + case Int.fromString arg of + SOME n => + print ((Int.toString (f n)) ^ "\n") + | NONE => + print "NOT A NUMBER\n") + + structure Main = + struct + fun doit() = + List.app doOne ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11"] + + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop size + end + end diff --git a/benchmark/tests/even-odd.sml b/benchmark/tests/even-odd.sml new file mode 100644 index 0000000..4cad50a --- /dev/null +++ b/benchmark/tests/even-odd.sml @@ -0,0 +1,23 @@ +local + fun even' 0 = true + | even' i = odd' (i-1) + and odd' 0 = false + | odd' i = even' (i-1) +in + fun even i = even' (abs i) + fun odd i = odd' (abs i) +end + +structure Main = + struct + fun doit n = + if n = 0 + then () + else let + val _ = if (even 500000000) <> not (odd 500000000) + then raise Fail "bug" + else () + in + doit (n - 1) + end + end diff --git a/benchmark/tests/fft.sml b/benchmark/tests/fft.sml new file mode 100644 index 0000000..ce51142 --- /dev/null +++ b/benchmark/tests/fft.sml @@ -0,0 +1,300 @@ +(* From the SML/NJ benchmark suite. *) +fun print _ = () +signature BMARK = + sig + val doit : int -> unit + end; +structure Main: BMARK = struct + +local +open Array Math + +val printr = print o (Real.fmt (StringCvt.SCI(SOME 14))) +val printi = print o Int.toString +in + +val PI = 3.14159265358979323846 + +val tpi = 2.0 * PI +(* +fun trace(name,f) x = + (print name ; + print "(" ; + printr x ; + print ") = " ; + let val y = f x + in printr y ; + print "\n" ; + y + end) + +fun trace2(name,f) (x,y) = + (printr x ; + print " "; + print name ; + print " "; + printr y ; + print " = " ; + let val z = f(x,y) + in printr z ; + print "\n" ; + z + end) + +fun trace2(_,f) = f + +val op * = trace2("*", Real.* ) +val op - = trace2("-", Real.-) +val op + = trace2("+", Real.+) + +local + nonfix * + - +in + _overload * : ('a * 'a -> 'a) + as Int.* + and * + + _overload + : ('a * 'a -> 'a) + as Int.+ + and + + + _overload - : ('a * 'a -> 'a) + as Int.- + and - +end + +val sin = trace("sin", sin) +val cos = trace("cos", cos) + +val sub = + fn (a,i) => + let val x = sub(a,i) + in print "sub(_, " ; + printi i ; + print ") = "; + printr x ; + print "\n" ; + x + end + +val update = + fn (a,i,x) => + (update(a,i,x); + print "update(_, " ; + printi i ; + print ", " ; + printr x ; + print ")\n") + +*) +fun fft px py np = + let + fun find_num_points i m = + if i < np + then find_num_points (i+i) (m+1) + else (i,m) + val (n,m) = find_num_points 2 1 +(* val _ = (printi n ; + print "\n" ; + printi m ; + print "\n") *) + in + if n <> np then + let + fun loop i = + if i > n then () + else (update(px, i, 0.0); + update(py, i, 0.0); + loop (i+1)) + in + loop (np+1); + print "Use "; printi n; print " point fft\n" + end + else (); + + let + fun loop_k k n2 = + if k >= m then () + else + let + val n4 = n2 div 4 + val e = tpi / (real n2) + fun loop_j j a = + if j > n4 then () + else + let val a3 = 3.0 * a + val cc1 = cos(a) + val ss1 = sin(a) + val cc3 = cos(a3) + val ss3 = sin(a3) + fun loop_is is id = + if is >= n + then () + else + let + fun loop_i0 i0 = + if i0 >= n + then () + else + let val i1 = i0 + n4 + val i2 = i1 + n4 + val i3 = i2 + n4 + val r1 = sub(px, i0) - sub(px, i2) + val _ = update(px, i0, sub(px, i0) + sub(px, i2)) + val r2 = sub(px, i1) - sub(px, i3) + val _ = update(px, i1, sub(px, i1) + sub(px, i3)) + val s1 = sub(py, i0) - sub(py, i2) + val _ = update(py, i0, sub(py, i0) + sub(py, i2)) + val s2 = sub(py, i1) - sub(py, i3) + val _ = update(py, i1, sub(py, i1) + sub(py, i3)) + val s3 = r1 - s2 + val r1 = r1 + s2 + val s2 = r2 - s1 + val r2 = r2 + s1 + val _ = update(px, i2, r1*cc1 - s2*ss1) + val _ = update(py, i2, ~s2*cc1 - r1*ss1) + val _ = update(px, i3, s3*cc3 + r2*ss3) + val _ = update(py, i3, r2*cc3 - s3*ss3) + in + loop_i0 (i0 + id) + end + in + loop_i0 is; + loop_is (2 * id - n2 + j) (4 * id) + end + in + loop_is j (2 * n2); + loop_j (j+1) (e * real j) + end + in + loop_j 1 0.0; + loop_k (k+1) (n2 div 2) + end + in + loop_k 1 n + end; + +(************************************) +(* Last stage, length=2 butterfly *) +(************************************) + +let fun loop_is is id = if is >= n then () else + let fun loop_i0 i0 = if i0 > n then () else + let val i1 = i0 + 1 + val r1 = sub(px, i0) + val _ = update(px, i0, r1 + sub(px, i1)) + val _ = update(px, i1, r1 - sub(px, i1)) + val r1 = sub(py, i0) + val _ = update(py, i0, r1 + sub(py, i1)) + val _ = update(py, i1, r1 - sub(py, i1)) + in + loop_i0 (i0 + id) + end + in + loop_i0 is; + loop_is (2*id - 1) (4 * id) + end + in + loop_is 1 4 + end; + +(*************************) +(* Bit reverse counter *) +(*************************) + + let + fun loop_i i j = + if i >= n + then () + else + (if i < j + then (let val xt = sub(px, j) + in update(px, j, sub(px, i)); update(px, i, xt) + end; + let val xt = sub(py, j) + in update(py, j, sub(py, i)); update(py, i, xt) + end) + else (); + let + fun loop_k k j = + if k < j then loop_k (k div 2) (j-k) else j+k + val j' = loop_k (n div 2) j + in + loop_i (i+1) j' + end) + in + loop_i 1 1 + end; + + n + + end + +fun abs x = if x >= 0.0 then x else ~x + +fun test np = + let val _ = (printi np; print "... ") + val enp = real np + val npm = (np div 2) - 1 + val pxr = array (np+2, 0.0) + val pxi = array (np+2, 0.0) + val t = PI / enp + val _ = update(pxr, 1, (enp - 1.0) * 0.5) + val _ = update(pxi, 1, 0.0) + val n2 = np div 2 + val _ = update(pxr, n2+1, ~0.5) + val _ = update(pxi, n2+1, 0.0) + fun loop_i i = if i > npm then () else + let val j = np - i + val _ = update(pxr, i+1, ~0.5) + val _ = update(pxr, j+1, ~0.5) + val z = t * real i + val y = ~0.5*(cos(z)/sin(z)) + val _ = update(pxi, i+1, y) + val _ = update(pxi, j+1, ~y) + in + loop_i (i+1) + end + val _ = loop_i 1 + +(* val _ = print "\n" + fun loop_i i = if i > 15 then () else + (printi i; print "\t"; + printr (sub(pxr, i+1)); print "\t"; + printr (sub(pxi, i+1)); print "\n"; loop_i (i+1)) + val _ = loop_i 0 +*) + val _ = fft pxr pxi np +(* + fun loop_i i = if i > 15 then () else + (printi i; print "\t"; + printr (sub(pxr, i+1)); print "\t"; + printr (sub(pxi, i+1)); print "\n"; loop_i (i+1)) + val _ = loop_i 0 +*) + fun loop_i i zr zi kr ki = if i >= np then (zr,zi) else + let val a = abs(sub(pxr, i+1) - real i) + val (zr, kr) = + if zr < a then (a, i) else (zr, kr) + val a = abs(sub(pxi, i+1)) + val (zi, ki) = + if zi < a then (a, i) else (zi, ki) + in + loop_i (i+1) zr zi kr ki + end + val (zr, zi) = loop_i 0 0.0 0.0 0 0 + val zm = if abs zr < abs zi then zi else zr + in + printr zm; print "\n" + end + +fun loop_np i np = if i > 15 then () else + (test np; loop_np (i+1) (np*2)) + +fun doit n = + if n = 0 + then () + else (loop_np 1 256; doit (n - 1)) + +end +end; diff --git a/benchmark/tests/fib.sml b/benchmark/tests/fib.sml new file mode 100644 index 0000000..0eec460 --- /dev/null +++ b/benchmark/tests/fib.sml @@ -0,0 +1,18 @@ +val rec fib = + fn 0 => 0 + | 1 => 1 + | n => fib (n - 1) + fib (n - 2) + +structure Main = + struct + fun doit n = + if n = 0 + then () + else let + val _ = if 165580141 <> fib 41 + then raise Fail "bug" + else () + in + doit (n - 1) + end + end diff --git a/benchmark/tests/flat-array.sml b/benchmark/tests/flat-array.sml new file mode 100644 index 0000000..ef99472 --- /dev/null +++ b/benchmark/tests/flat-array.sml @@ -0,0 +1,20 @@ +structure Main = + struct + fun doit n = + let + val v = Vector.tabulate (1000000, fn i => (i, i + 1)) + fun loop n = + if 0 = n + then () + else + let + val sum = Vector.foldl (fn ((a, b), c) => + a + b + c handle Overflow => 0) 0 v + in + loop (n - 1) + end + in + loop n + end + end + diff --git a/benchmark/tests/fxp.sml b/benchmark/tests/fxp.sml new file mode 100644 index 0000000..0706560 --- /dev/null +++ b/benchmark/tests/fxp.sml @@ -0,0 +1,15882 @@ +(* MLton 20010629 (built Fri Jun 29 11:14:21 2001 on starlinux) *) +(* created this file on Fri Jun 29 13:02:19 2001. *) +(* Do not edit this file. *) +(* Flag settings: *) +(* aux: false *) +(* chunk: chunk per function *) +(* debug: false *) +(* defines: [NODEBUG,MLton_safe=TRUE,MLton_detectOverflow=TRUE] *) +(* detect overflow: true *) +(* fixed heap: None *) +(* indentation: 3 *) +(* includes: [mlton.h] *) +(* inline: NonRecursive {product = 320,small = 60} *) +(* input file: fxp.cm *) +(* instrument: false *) +(* instrument Sxml: false *) +(* keep Cps: false *) +(* native: true *) +(* native commented: 0 *) +(* native copy prop: true *) +(* future: 64 *) +(* native ieee fp: false *) +(* native live transfer: true *) +(* native move hoist: true *) +(* native optimize: 1 *) +(* native split: Some (20000) *) +(* polyvariance: Some ({rounds = 2,small = 30,product = 300}) *) +(* print at fun entry: false *) +(* profile: false *) +(* safe: true *) +(* show types: false *) +(* static: false *) +(* use basis library: true *) +(* verbosity: Silent *) +(* start of ../../Util/utilTime.sml *) + + + +(*--------------------------------------------------------------------------*) +(* Structure: UtilTime *) +(* *) +(* Depends on: *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* time : none *) +(* timeN : none *) +(*--------------------------------------------------------------------------*) +signature UtilTime = + sig + val time : ('a -> 'b) -> 'a -> 'b * {usr:Time.time, sys:Time.time, gc:Time.time} + val timeN : int -> ('a -> 'b) -> 'a -> 'b * {usr:Time.time, sys:Time.time, gc:Time.time} + end + +structure UtilTime : UtilTime = + struct + (*--------------------------------------------------------------------*) + (* run f on x, and measure the runtime. return the result and time. *) + (*--------------------------------------------------------------------*) + fun time f x = let val timer = Timer.startCPUTimer () + val y = f x + val ptime = Timer.checkCPUTimer timer + in (y,ptime) + end + + (*--------------------------------------------------------------------*) + (* run f n times on x, and measure the runtime. return the time. *) + (*--------------------------------------------------------------------*) + fun timeN n f x = + let fun iter m = if m<=1 then f x else (ignore (f x); iter (m-1)) + in time iter n + end + end +(* stop of ../../Util/utilTime.sml *) +(* start of ../../Util/utilString.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: UtilString *) +(*--------------------------------------------------------------------------*) +signature UtilString = + sig + val quoteString : char -> string -> string + + val numberNth : int -> string + val prependAnA : string -> string + + val nBlanks : int -> string + val padxLeft : char -> string * int -> string + val padxRight : char -> string * int -> string + + val breakLines : int -> string -> string list + + val toUpperFirst : string -> string + val toUpperString : string -> string + + val Int2String : int -> string + + val Bool2xString : string * string -> bool -> string + val Bool2String : bool -> string + + val Option2xString : string * (('a -> string) -> 'a -> string) + -> ('a -> string) -> 'a option -> string + val Option2String0 : ('a -> string) -> 'a option -> string + val Option2String : ('a -> string) -> 'a option -> string + + val List2xString : string * string * string -> ('a -> string) -> 'a list -> string + val List2String0 : ('a -> string) -> 'a list -> string + val List2String : ('a -> string) -> 'a list -> string + + val Vector2xString : string * string * string -> ('a -> string) -> 'a vector -> string + val Vector2String : ('a -> string) -> 'a vector -> string + end + +structure UtilString : UtilString = + struct + fun quoteString q s = let val quote = String.implode [q] in quote^s^quote end + + (*--------------------------------------------------------------------*) + (* generate a string with the ordinal number of n, by appending *) + (* "st", "nd", "rd" or "th" to the number. *) + (*--------------------------------------------------------------------*) + fun numberNth n = + let val suffix = case n mod 9 + of 1 => "st" + | 2 => "nd" + | 3 => "rd" + | _ => "th" + in Int.toString n^suffix + end + + (*--------------------------------------------------------------------*) + (* is the single character c represented by a word starting with a *) + (* vocal in the alphabet? (l~ell->true, k~kay->false) *) + (*--------------------------------------------------------------------*) + fun vocalLetter c = + case Char.toLower c + of #"a" => true + | #"f" => true + | #"h" => true + | #"i" => true + | #"l" => true + | #"m" => true + | #"n" => true + | #"o" => true + | #"r" => true + | #"s" => true + | #"x" => true + | #"8" => true + | _ => false + + (*--------------------------------------------------------------------*) + (* is character c a vocal? *) + (*--------------------------------------------------------------------*) + fun isVocal c = + case Char.toLower c + of #"a" => true + | #"e" => true + | #"i" => true + | #"o" => true + | #"u" => true + | _ => false + + (*--------------------------------------------------------------------*) + (* does a word require "an" as undefinite article? true if: *) + (* - it is a single letter that starts with a vocal in the alphabet *) + (* - its first two letters are capitals, i.e. it is an abbreviation, *) + (* and its first letter starts with a vocal in the alphabet *) + (* - it has more than one letter, is not an abbreviation, and either *) + (* + it starts with a, i or o *) + (* + it starts with e and the second letter is not a u (europe) *) + (* + it starts with a u and continues with a vocal (very unlikely, *) + (* only in c.s., like uuencoded or uid *) + (* + it starts with a u, continues with a consonant not followed by *) + (* an i (like in unicode); that is something like un-... *) + (* This ruleset is not complete since it does not cover, e.g., the *) + (* word uninvented, but sufficient for most cases. *) + (* (Is english pronounciation decidable at all?) *) + (*--------------------------------------------------------------------*) + fun extendsAtoAn word = + case String.explode word + of nil => false + | [c] => vocalLetter c + | c1::c2::cs => if not (Char.isLower c1 orelse Char.isLower c2) + then vocalLetter c1 + else case Char.toLower c1 + of #"a" => true + | #"i" => true + | #"o" => true + | #"e" => Char.toLower c2 <> #"u" + | #"u" => if isVocal c2 then false + else (case cs + of nil => true + | c3::_ => Char.toLower c3 <> #"i") + | _ => false + + (*--------------------------------------------------------------------*) + (* add an undefinite article to a word. *) + (*--------------------------------------------------------------------*) + fun prependAnA word = if extendsAtoAn word then "an "^word else "a "^word + + (*--------------------------------------------------------------------*) + (* generate a list/string of n times character c. *) + (*--------------------------------------------------------------------*) + fun nCharsC c n = if n>0 then c::nCharsC c (n-1) else nil + fun nChars c n = String.implode (nCharsC c n) + val nBlanks = nChars #" " + + (*--------------------------------------------------------------------*) + (* add a minimal number of characters c to the left/right of a string *) + (* in order to make its length at least n. *) + (*--------------------------------------------------------------------*) + fun padxLeft c (s,n) = (nChars c (n-String.size s))^s + fun padxRight c (s,n) = s^(nChars c (n-String.size s)) + val padLeft = padxLeft #" " + val padRight = padxRight #" " + + (*--------------------------------------------------------------------*) + (* break a string into several lines of length width. *) + (*--------------------------------------------------------------------*) + fun breakLines width str = + let + val tokens = String.tokens (fn c => #" "=c) str + fun makeLine(toks,lines) = if null toks then lines + else (String.concat (rev toks))::lines + fun doit w (toks,lines) nil = makeLine(toks,lines) + | doit w (toks,lines) (one::rest) = + let + val l = String.size one + val w1 = w+l + in + if w1=width then doit 0 (nil,one::makeLine(toks,lines)) rest + else doit (l+1) ([" ",one],makeLine(toks,lines)) rest + end + in List.rev (doit 0 (nil,nil) tokens) + end + + (*--------------------------------------------------------------------*) + (* convert the first/all characters of a string to upper case *) + (*--------------------------------------------------------------------*) + fun toUpperFirst str = + case String.explode str + of nil => "" + | c::cs => String.implode (Char.toUpper c::cs) + fun toUpperString str = + String.implode(map Char.toUpper (String.explode str)) + + (*--------------------------------------------------------------------*) + (* return a string representation of an int, char or unit. *) + (*--------------------------------------------------------------------*) + val Int2String = Int.toString + val Char2String = Char.toString + fun Unit2String() = "()" + + (*--------------------------------------------------------------------*) + (* return a string representation of a boolean. *) + (*--------------------------------------------------------------------*) + fun Bool2xString (t,f) b = if b then t else f + val Bool2String = Bool2xString ("true","false") + + (*--------------------------------------------------------------------*) + (* return a string representation of an option. *) + (* the first arg is a string for the NONE case, the second a function *) + (* that converts x to a string, given a function for doing so. *) + (*--------------------------------------------------------------------*) + fun Option2xString (none,Some2String) x2String opt = + case opt + of NONE => none + | SOME x => Some2String x2String x + fun Option2String0 x2String = Option2xString ("",fn f => fn x => f x) x2String + fun Option2String x2String = Option2xString ("NONE",fn f => fn x => "SOME "^f x) x2String + + (*--------------------------------------------------------------------*) + (* return a string representation of list; start with pre, separate *) + (* with sep and finish with post; use X2String for each element. *) + (*--------------------------------------------------------------------*) + fun List2xString (pre,sep,post) X2String nil = pre^post + | List2xString (pre,sep,post) X2String l = + let fun doit nil _ = [post] + | doit (x::r) str = str::X2String x::doit r sep + in String.concat (doit l pre) + end + fun List2String X2String nil = "[]" + | List2String X2String l = + let fun doit nil _ = ["]"] + | doit (x::r) str = str::X2String x::doit r "," + in String.concat (doit l "[") + end + fun List2String0 X2String nil = "" + | List2String0 X2String l = + let fun doit nil _ = nil + | doit (x::r) str = str::X2String x::doit r " " + in String.concat (doit l "") + end + + (* a compiler bug in smlnj 110 makes the following uncompilable: *) + (* fun List2String X2String xs = List2xString ("[",",","]") X2String xs *) + (* fun List2String0 X2String xs = List2xString (""," ","") X2String xs *) + + (*--------------------------------------------------------------------*) + (* return a string representation of list; start with pre, separate *) + (* with sep and finish with post; use X2String for each element. *) + (*--------------------------------------------------------------------*) + fun Vector2xString (pre,sep,post) X2String vec = + if Vector.length vec=0 then pre^post + else String.concat + (pre::X2String(Vector.sub(vec,0)):: + Vector.foldri (fn (_,x,yet) => sep::X2String x::yet) [post] (vec,1,NONE)) + fun Vector2String X2String vec = Vector2xString ("#[",",","]") X2String vec + end +(* stop of ../../Util/utilString.sml *) +(* start of ../../Util/utilCompare.sml *) +signature UtilCompare = + sig + type 'a Comparer = 'a * 'a -> order + + val comparePair : 'a Comparer * 'b Comparer -> ('a * 'b) Comparer + val compareTriple : 'a Comparer * 'b Comparer * 'c Comparer -> ('a * 'b * 'c) Comparer + + val compareOption : 'a Comparer -> 'a option Comparer + val compareList : 'a Comparer -> 'a list Comparer + val compareVector : 'a Comparer -> 'a vector Comparer + + val compareInt : int Comparer + val compareIntPair : (int * int) Comparer + val compareIntTriple : (int * int * int) Comparer + + val compareWord : word Comparer + val compareWordPair : (word * word) Comparer + val compareWordTriple : (word * word * word) Comparer + end + +structure UtilCompare : UtilCompare = + struct + type 'a Comparer = 'a * 'a -> order + + fun comparePair (compareA,compareB) ((a1,b1),(a2,b2)) = + case compareA(a1,a2) + of EQUAL => compareB(b1,b2) + | order => order + fun compareTriple (compareA,compareB,compareC) ((a1,b1,c1),(a2,b2,c2)) = + case compareA(a1,a2) + of EQUAL => (case compareB(b1,b2) + of EQUAL => compareC(c1,c2) + | order => order) + | order => order + + val compareInt = Int.compare + fun compareIntPair((x1,y1),(x2,y2)) = + case Int.compare(x1,x2) + of EQUAL => Int.compare (y1,y2) + | order => order + fun compareIntTriple((x1,y1,z1),(x2,y2,z2)) = + case Int.compare(x1,x2) + of EQUAL => (case Int.compare (y1,y2) + of EQUAL => Int.compare (z1,z2) + | order => order) + | order => order + + val compareWord = Word.compare + fun compareWordPair((x1,y1),(x2,y2)) = + case Word.compare(x1,x2) + of EQUAL => Word.compare (y1,y2) + | order => order + fun compareWordTriple((x1,y1,z1),(x2,y2,z2)) = + case Word.compare(x1,x2) + of EQUAL => (case Word.compare (y1,y2) + of EQUAL => Word.compare (z1,z2) + | order => order) + | order => order + + fun compareOption compareA opts = + case opts + of (NONE,NONE) => EQUAL + | (NONE,SOME x) => LESS + | (SOME x,NONE) => GREATER + | (SOME x,SOME y) => compareA(x,y) + + fun compareList compA ll = + let fun doit (nil,nil) = EQUAL + | doit (nil,_) = LESS + | doit (_,nil) = GREATER + | doit (a1::as1,a2::as2) = case compA(a1,a2) + of EQUAL => doit(as1,as2) + | order => order + in doit ll + end + + fun compareVector compA (vec1,vec2) = + let val (l,l2) = (Vector.length vec1,Vector.length vec2) + in case Int.compare(l,l2) + of EQUAL => let fun doit i = if i>=l then EQUAL + else case compA(Vector.sub(vec1,i),Vector.sub(vec2,i)) + of EQUAL => doit (i+1) + | order => order + in doit 0 + end + | order => order + end + end + +(* stop of ../../Util/utilCompare.sml *) +(* start of ../../Util/utilHash.sml *) +signature UtilHash = + sig + val hashPair : ('a -> word) * ('b -> word) -> 'a * 'b -> word + val hashTriple : ('a -> word) * ('b -> word) * ('c -> word) -> 'a * 'b * 'c -> word + + val hashOption : ('a -> word) -> 'a option -> word + val hashList : ('a -> word) -> 'a list -> word + val hashVector : ('a -> word) -> 'a vector -> word + + val hashString : string -> word + + val hashInt : int -> word + val hashIntPair : int * int -> word + val hashIntTriple : int * int * int -> word + + val hashWord : word -> word + val hashWordPair : word * word -> word + val hashWordTriple : word * word * word -> word + end + +structure UtilHash : UtilHash = + struct + fun hashPair (hashA,hashB) (a,b) = + 0w1327 * hashA a + 0w3853 * hashB b + fun hashTriple (hashA,hashB,hashC) (a,b,c) = + 0w1327 * hashA a + 0w3853 * hashB b + 0w2851 * hashC c + + val hashInt = + Word.fromInt + fun hashIntPair (i,j) = + 0w1327 * Word.fromInt i + 0w3853 * Word.fromInt j + fun hashIntTriple (i,j,k) = + 0w1327 * Word.fromInt i + 0w3853 * Word.fromInt j + 0w2851 * Word.fromInt k + + fun hashWord w = w + fun hashWordPair (i,j) = 0w1327 * i + 0w3853 * j + fun hashWordTriple (i,j,k) = 0w1327 * i + 0w3853 * j + 0w2851 * k + + val hashChar = Word.fromInt o ord + fun hashString s = + case String.size s + of 0 => 0wx0 + | 1 => 0w1 + hashChar(String.sub(s,0)) + | 2 => let val w1 = String.sub(s,0) + val w2 = String.sub(s,1) + in 0w2 + hashChar w1 * 0wx1327 + hashChar w2 + end + | n => let val w1 = String.sub(s,0) + val w2 = String.sub(s,1) + val wn = String.sub(s,n-1) + in 0w3 + hashChar w1 * 0wx3853 + hashChar w2 * 0wx1327 + hashChar wn + end + + + fun hashOption hashA opt = + case opt + of NONE => 0w0 + | SOME a => 0w1 + hashA a + + fun hashList hashA l = + case l + of nil => 0wx0 + | [a] => 0w1 + hashA a + | a1::a2::_ => 0w2 + 0w3853 * hashA a1 + 0wx1327 * hashA a2 + + fun hashVector hashA cv = + case Vector.length cv + of 0 => 0wx0 + | 1 => 0w1 + hashA(Vector.sub(cv,0)) + | 2 => let val w1 = Vector.sub(cv,0) + val w2 = Vector.sub(cv,1) + in 0w2 + hashA w1 * 0wx1327 + hashA w2 + end + | n => let val w1 = Vector.sub(cv,0) + val w2 = Vector.sub(cv,1) + val wn = Vector.sub(cv,n-1) + in 0w3 + hashA w1 * 0wx3853 + hashA w2 * 0wx1327 + hashA wn + end + end + +(* stop of ../../Util/utilHash.sml *) +(* start of ../../Util/SymDict/key.sml *) + + + +(*--------------------------------------------------------------------------*) +(* In order to be used as a dictinary/symbol table key, a type must have a *) +(* null value, hash to words, must be comparable and printable. *) +(*--------------------------------------------------------------------------*) +signature Key = + sig + type Key + + val null : Key + val hash : Key -> word + val compare : Key * Key -> order + val toString : Key -> string + end +(* stop of ../../Util/SymDict/key.sml *) +(* start of ../../Util/utilInt.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: UtilInt *) +(* *) +(* Depends on: *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* appInterval : none *) +(* insertInt : none *) +(* insertNewInt : none *) +(* nextPowerTwo : none *) +(*--------------------------------------------------------------------------*) +signature UtilInt = + sig + val intervalList : (int * int) -> int list + val appInterval : (int -> unit) -> (int * int) -> unit + val insertInt : int * int list -> int list + val insertNewInt : int * int list -> int list option + val powerOfTwo : int -> int + val nextPowerTwo : int -> int + end + +structure UtilInt : UtilInt = + struct + (*--------------------------------------------------------------------*) + (* generate the list [n,...,m] *) + (*--------------------------------------------------------------------*) + fun intervalList(n,m) = if n>m then nil else n::intervalList(n+1,m) + + (*--------------------------------------------------------------------*) + (* apply f to each number in [n...m] *) + (*--------------------------------------------------------------------*) + fun appInterval f (n,m) = + let fun doit i = + if i>m then () + else let val _ = f i + in doit (i+1) + end + in doit n + end + + (*--------------------------------------------------------------------*) + (* insert an integer into a sorted list without duplicates. *) + (*--------------------------------------------------------------------*) + fun insertInt (x:int,l) = + let fun go nil = [x] + | go (l as y::ys) = case Int.compare (x,y) + of LESS => x::l + | EQUAL => l + | GREATER => y::go ys + in go l + end + + (*--------------------------------------------------------------------*) + (* insert an integer into a sorted list if it is not yet in it. *) + (*--------------------------------------------------------------------*) + fun insertNewInt (x:int,l) = + let + fun go nil = SOME [x] + | go (l as y::ys) = case Int.compare (x,y) + of LESS => SOME(x::l) + | EQUAL => NONE + | GREATER => case go ys + of NONE => NONE + | SOME xys => SOME(y::xys) + in go l + end + + (*--------------------------------------------------------------------*) + (* compute the power to the base of two. *) + (*--------------------------------------------------------------------*) + fun powerOfTwo n = + if n=0 then 1 + else if n mod 2=0 then let val x=powerOfTwo (n div 2) in x*x end + else let val x=powerOfTwo (n-1) in 2*x end + + (*--------------------------------------------------------------------*) + (* find the smallest p with 2^p >= n. *) + (*--------------------------------------------------------------------*) + fun nextPowerTwo n = + let fun doit (p,m) = + if m>=n then p + else if m*m<2*n then doit (2*p,m*m) + else doit (1+p,2*m) + in doit (1,2) + end + end +(* stop of ../../Util/utilInt.sml *) +(* start of ../../Util/utilError.sml *) + + + + + +signature UtilError = + sig + exception InternalError of string * string * string + exception NoSuchFile of string * string + + val formatMessage : int * int -> string list -> string + end + +structure UtilError : UtilError = + struct + open UtilString + + exception InternalError of string * string * string + exception NoSuchFile of string * string + + fun formatMessage (indentWidth,lineWidth) strs = + let + val indent = nBlanks indentWidth + val nl = "\n"^indent + val blank = " " + val dot = "." + + fun isSep c = #" "=c orelse #"\n"=c orelse #"\t"=c + + fun go (w,yet) nil = List.rev ("\n"::yet) + | go (w,yet) (x::xs) = + let + val y = if null xs then x^dot else x + val l = String.size y + val w1 = w+l + val (w2,yet2) = if w1<=lineWidth then (w1,y::yet) + else (indentWidth+l,y::nl::yet) + val (w3,yet3) = if null xs then (w2,yet2) + else (if w2 'a Dict + val makeDict : string * int * 'a -> 'a Dict + val clearDict : 'a Dict * int option -> unit + + val hasIndex : 'a Dict * Key -> int option + val getIndex : 'a Dict * Key -> int + val getKey : 'a Dict * int -> Key + + val getByIndex : 'a Dict * int -> 'a + val getByKey : 'a Dict * Key -> 'a + + val setByIndex : 'a Dict * int * 'a -> unit + val setByKey : 'a Dict * Key * 'a -> unit + + val usedIndices : 'a Dict -> int + + val extractDict : 'a Dict -> (Key * 'a) array + val printDict : ('a -> string) -> 'a Dict -> unit + end + +functor Dict (structure Key : Key) : Dict = + struct + open UtilError UtilInt + + type Key = Key.Key + + exception NoSuchIndex + + (*--------------------------------------------------------------------*) + (* a dictionary can have at most size MAX_WIDTH. This is because *) + (* arrays may at most have Array.maxLen elements. We only use powers *) + (* of two as sizes, so we are really only interested in the position *) + (* of maxLen's highest bit. That would be the maximal width for hash *) + (* tables, and thus we must decrease it by one for obtaining the max *) + (* table width. *) + (*--------------------------------------------------------------------*) + fun highestBit w = if w=0w0 then 0 else 1+highestBit(Word.>>(w,0w1)) + val MAX_WIDTH = highestBit (Word.fromInt Array.maxLen)-1 + + type Bucket = (Key * int) list + val nullBucket = nil : Bucket + + (*--------------------------------------------------------------------*) + (* buckets are unsorted - they are probably small, so comparing the *) + (* keys might be overkill. *) + (*--------------------------------------------------------------------*) + fun addToBucket (ni as (key,_),bucket) = + let + fun doit nil = [ni] + | doit (nis as (ni' as (key',_))::rest) = + case Key.compare (key',key) + of LESS => ni'::doit rest + | EQUAL => ni::rest + | GREATER => ni::nis + in + doit bucket + end + fun searchBucket (key,bucket) = + let + fun doit nil = NONE + | doit ((key',i)::rest) = + case Key.compare (key',key) + of LESS => doit rest + | EQUAL => SOME i + | GREATER => NONE + in + doit bucket + end + + (*--------------------------------------------------------------------*) + (* a dictionary consists of *) + (* - a string desc saying what is stored in this dictionary *) + (* - an array tab holding for each index its key and value *) + (* - a hash table, i.e. Bucket array, of double size than tab *) + (* - a hashFun mapping Key to the range of the hash table *) + (* - an integer width for computing table sizes *) + (* - an integer size wich is the size of the value table *) + (* - an integer count holding the next free index *) + (* - a default value for the value table *) + (*--------------------------------------------------------------------*) + type 'a Dict = {desc : string, + tab : (Key * 'a) array ref, + hashTab : Bucket array ref, + hashFun : (Key -> int) ref, + width : int ref, (* bit width *) + size : int ref, (* tab size=2^width, hash size is double *) + count : int ref, (* number of entries *) + def : 'a (* default for values *) + } + fun nullDict (desc,def) = {desc = desc, + tab = ref (Array.array(1,(Key.null,def))), + hashTab = ref (Array.array(2,nullBucket)), + hashFun = ref (fn _ => 0), + count = ref 0, + size = ref 1, + width = ref 0, + def = def} + + (*--------------------------------------------------------------------*) + (* how many entries are in the dictionary? *) + (*--------------------------------------------------------------------*) + fun usedIndices ({count,...}:'a Dict) = !count + + (*--------------------------------------------------------------------*) + (* what is the table load, i.e. percentage of number of entries to *) + (* hash table size = 100*count/(2*size) = 50*count/size. *) + (*--------------------------------------------------------------------*) + fun hashRatio({count,size,...}:'a Dict) = 50 * !count div !size + handle Div => 100 + + (*--------------------------------------------------------------------*) + (* this is the hash function. Key.hash hashes data to arbitrary *) + (* words, that are mapped to the hash range by this function, where *) + (* mask is the bitmask corresponding to the size of the hash table: *) + (* 1. square the word produced by Key.hash *) + (* 2. take the width bits from the middle of the square, these are *) + (* the bit-places influenced by all input bit-places: *) + (* - shift to the right by half of the destination width *) + (* - mask out all bits to the left of destination *) + (* this is a simple strategy but experiences good results. *) + (*--------------------------------------------------------------------*) + fun square (x:word) = Word.*(x,x) + fun hashKey(half,mask) x = + Word.toInt(Word.andb(mask,Word.>>(square(Key.hash x),half))) + fun makeHashFun(size,width) = + let + val mask = 0w2*Word.fromInt size-0w1 + val half = Word.fromInt((width+1) div 2) + in + hashKey(half,mask) + end + + (*--------------------------------------------------------------------*) + (* create a new dictionary for 2^w, but at least 2 and at most 2^m *) + (* entries, where m is the value of MAX_WIDTH. *) + (*--------------------------------------------------------------------*) + fun makeDict (desc,w,def) = + let + val width= Int.min(Int.max(1,w),MAX_WIDTH) + val size = Word.toInt(Word.<<(0w1,Word.fromInt(width-1))) + in {desc = desc, + tab = ref (Array.array(size,(Key.null,def))), + hashTab = ref (Array.array(2*size,nullBucket)), + hashFun = ref (makeHashFun(size,width)), + width = ref width, + size = ref size, + count = ref 0, + def = def} + end + + (*--------------------------------------------------------------------*) + (* clear a dictionary. If the 2nd arg is SOME w, use w for resizing. *) + (*--------------------------------------------------------------------*) + fun clearDict (dict:'a Dict,widthOpt) = + case widthOpt + of NONE => + let + val {tab=ref tab,hashTab=ref hashTab,size,count,def,...} = dict + val _ = appInterval (fn i => Array.update(tab,i,(Key.null,def))) (0,!count-1) + val _ = appInterval (fn i => Array.update(hashTab,i,nullBucket)) (0,!size*2-1) + in + count := 0 + end + | SOME w => + let + val {tab,hashTab,hashFun,width,size,count,def,...} = dict + val newWidth = Int.min(Int.max(1,w),MAX_WIDTH) + val newSize = Word.toInt(Word.<<(0w1,Word.fromInt(newWidth-1))) + val _ = tab := (Array.array(newSize,(Key.null,def))) + val _ = hashTab := (Array.array(2*newSize,nullBucket)) + val _ = hashFun := (makeHashFun(newSize,newWidth)) + val _ = width := newWidth + val _ = size := newSize + in + count := 0 + end + + (*--------------------------------------------------------------------*) + (* grow a dictionary to the double size. raise InternalError if the *) + (* dictionary already has maximal size. *) + (*--------------------------------------------------------------------*) + fun growDictionary ({desc,tab,hashTab,hashFun,width,size,count,def}:'a Dict) = + let + val oldTab = !tab + val _ = if !width < MAX_WIDTH then width := !width+1 + else raise InternalError + ("Dict","growDictionary", + String.concat ["growing the ",desc," dictionary ", + "exceeded the system maximum size of ", + Int.toString Array.maxLen," for arrays"]) + val _ = size := !size*2 + val _ = tab := Array.array(!size,(Key.null,def)) + val _ = hashTab := Array.array(!size*2,nullBucket) + val _ = hashFun := makeHashFun(!size,!width) + + fun addTo (i,kv as (key,_)) = + let + val idx = !hashFun key + val _ = Array.update(!hashTab,idx,addToBucket((key,i),Array.sub(!hashTab,idx))) + val _ = Array.update(!tab,i,kv) + in () + end + in + Array.appi addTo (oldTab,0,NONE) + end + + (*--------------------------------------------------------------------*) + (* lookup the key for an index of the dictionary. *) + (*--------------------------------------------------------------------*) + fun getKey({tab,count,...}:'a Dict,idx) = + if !count>idx then #1(Array.sub(!tab,idx)) + else raise NoSuchIndex + + (*--------------------------------------------------------------------*) + (* map a Key to its index in the dictionary. if it is not in the *) + (* dictionary yet, add a new entry with a new index. grow the table *) + (* if there is no more free index in the dictionary. *) + (*--------------------------------------------------------------------*) + fun getIndex(dict as {tab,hashTab,hashFun,size,count,def,...}:'a Dict,key) = + let + val k = !hashFun key + val bucket = Array.sub(!hashTab,k) + in + case searchBucket(key,bucket) + of SOME idx => idx + | NONE => let val idx = !count + val (k',buck') = if !size>idx then (k,bucket) + else let val _ = growDictionary dict + val k' = !hashFun key + val buck' = Array.sub(!hashTab,k') + in (k',buck') + end + val _ = Array.update(!hashTab,k',addToBucket((key,idx),buck')) + val _ = Array.update(!tab,idx,(key,def)) + val _ = count := idx+1 + in idx + end + end + + (*--------------------------------------------------------------------*) + (* does a Key have an entry in a dictionary? *) + (*--------------------------------------------------------------------*) + fun hasIndex({hashTab,hashFun,...}:'a Dict,key) = + let + val idx = !hashFun key + val bucket = Array.sub(!hashTab,idx) + in + searchBucket(key,bucket) + end + + (*--------------------------------------------------------------------*) + (* get the value stored for index idx *) + (*--------------------------------------------------------------------*) + fun getByIndex({tab,count,...}:'a Dict,idx) = + if !count>idx then #2(Array.sub(!tab,idx)) + else raise NoSuchIndex + + (*--------------------------------------------------------------------*) + (* get the value stored for a key *) + (*--------------------------------------------------------------------*) + fun getByKey(dict,key) = + getByIndex(dict,getIndex(dict,key)) + + (*--------------------------------------------------------------------*) + (* enter a value for index idx. *) + (*--------------------------------------------------------------------*) + fun setByIndex({tab,count,...}:'a Dict,idx,a) = + if !count>idx then let val (key,_) = Array.sub(!tab,idx) + in Array.update(!tab,idx,(key,a)) + end + else raise NoSuchIndex + + (*--------------------------------------------------------------------*) + (* enter a value for a key. *) + (*--------------------------------------------------------------------*) + fun setByKey(dict,key,v) = + setByIndex(dict,getIndex(dict,key),v) + + (*--------------------------------------------------------------------*) + (* extract the contents of the dictionary to an array. *) + (*--------------------------------------------------------------------*) + fun extractDict({count,tab,...}:'a Dict) = + Array.tabulate(!count,fn i => Array.sub(!tab,i)) + + (*--------------------------------------------------------------------*) + (* print the contents of the dictionary. *) + (*--------------------------------------------------------------------*) + fun printDict X2String ({desc,tab,count,...}:'a Dict) = + (print (desc^" dictionary:\n"); + Array.appi + (fn (n,(key,value)) => + print (" "^Int.toString n^": "^Key.toString key^" = "^X2String value^"\n")) + (!tab,0,SOME (!count))) + end +(* stop of ../../Util/SymDict/dict.sml *) +(* start of ../../Util/SymDict/symbolTable.sml *) + + + + + + +(*--------------------------------------------------------------------------*) +(* Functor: SymbolTable *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* getSymIndex : Key.InternalError *) +(* getSymKey : NoSuchSymbol *) +(* hasSymIndex : none *) +(* makeSymTable : none *) +(* nullSymTable : none *) +(* printSymTable : none *) +(* usedSymbols : none *) +(*--------------------------------------------------------------------------*) +(* A symbol table maps Keys to consecutive integers. *) +(*--------------------------------------------------------------------------*) +signature SymTable = + sig + type Key + type SymTable + + exception NoSuchSymbol + + val nullSymTable : string -> SymTable + val makeSymTable : string * int -> SymTable + val clearSymTable : SymTable * int option -> unit + + val hasSymIndex : SymTable * Key -> int option + val getSymIndex : SymTable * Key -> int + val getSymKey : SymTable * int -> Key + val usedSymbols : SymTable -> int + + val assignSymIndex : SymTable * Key * int -> unit + val reserveSymIndex : SymTable -> int + + val extractSymTable : SymTable -> Key vector + val printSymTable : SymTable -> unit + end + +functor SymTable (structure Key : Key) : SymTable = + struct + open UtilError UtilInt + + exception NoSuchSymbol + + type Key = Key.Key + + (*--------------------------------------------------------------------*) + (* a symbol table can have at most size MAX_WIDTH. This is because *) + (* arrays may at most have Array.maxLen elements. We only use powers *) + (* of two as sizes, so we are really only interested in the position *) + (* of maxLen's highest bit. That would be the maximal width for hash *) + (* tables, and thus we must decrease it by one for obtaining the max *) + (* table width. *) + (*--------------------------------------------------------------------*) + fun highestBit w = if w=0w0 then 0 else 1+highestBit(Word.>>(w,0w1)) + val MAX_WIDTH = highestBit (Word.fromInt Array.maxLen)-1 + + type Bucket = (Key * int) list + val nullBucket = nil : Bucket + + (*--------------------------------------------------------------------*) + (* buckets are sorted - though they are probably small. *) + (*--------------------------------------------------------------------*) + fun addToBucket (ni as (key,_),bucket) = + let + fun doit nil = [ni] + | doit (nis as (ni' as (key',_))::rest) = + case Key.compare (key',key) + of LESS => ni'::doit rest + | EQUAL => ni::rest + | GREATER => ni::nis + in + doit bucket + end + fun searchBucket (key,bucket) = + let + fun doit nil = NONE + | doit ((key',i)::rest) = + case Key.compare (key',key) + of LESS => doit rest + | EQUAL => SOME i + | GREATER => NONE + in + doit bucket + end + + (*--------------------------------------------------------------------*) + (* a symbol table consists of *) + (* - an array tab holding for each index its key *) + (* - a hash table, i.e. Bucket array, of double size than tab *) + (* - a hashFun mapping Key to the range of the hash table *) + (* - an integer width for computing table sizes *) + (* - an integer size wich is the size of the value table *) + (* - an integer count holding the next free index *) + (*--------------------------------------------------------------------*) + type SymTable = {desc : string, + tab : Key array ref, + hash : Bucket array ref, + hashFun : (Key -> int) ref, + width : int ref, (* bit width *) + size : int ref, (* tab size=2^width, hash size is double *) + count : int ref (* number of entries *) + } + + fun nullSymTable desc = {desc = desc, + tab = ref (Array.array(1,Key.null)), + hash = ref (Array.array(2,nullBucket)), + hashFun = ref (fn _ => 0), + count = ref 0, + size = ref 1, + width = ref 0} : SymTable + + (*--------------------------------------------------------------------*) + (* how many entries are in the symtable? *) + (*--------------------------------------------------------------------*) + fun usedSymbols ({count,...}:SymTable) = !count + + (*--------------------------------------------------------------------*) + (* what is the table load, i.e. percentage of number of entries to *) + (* hash table size = 100*count/(2*size) = 50*count/size. *) + (*--------------------------------------------------------------------*) + fun hashRatio({count,size,...}:SymTable) = 50 * !count div !size + handle Div => 100 + + (*--------------------------------------------------------------------*) + (* this is the hash function. Key.hash hashes data to arbitrary *) + (* words, that are mapped to the hash range by this function, where *) + (* mask is the bitmask corresponding to the size of the hash table: *) + (* 1. square the word produced by Key.hash *) + (* 2. take the width bits from the middle of the square, these are *) + (* the bit-places influenced by all input bit-places: *) + (* - shift to the right by half of the destination width *) + (* - mask out all bits to the left of destination *) + (* this is a simple strategy but experiences good results. *) + (*--------------------------------------------------------------------*) + fun square (x:word) = Word.*(x,x) + fun hashKey(half,mask) x = + Word.toInt(Word.andb(mask,Word.>>(square(Key.hash x),half))) + fun makeHashFun(size,width) = + let + val mask = Word.fromInt(2*size-1) + val half = Word.fromInt((width+1) div 2) + in + hashKey(half,mask) + end + + (*--------------------------------------------------------------------*) + (* create a new symtable for 2^w, but at least 2 and at most 2^m *) + (* entries, where m is the value of MAX_WIDTH. *) + (*--------------------------------------------------------------------*) + fun makeSymTable (desc,w) = + let + val width= Int.min(Int.max(1,w),MAX_WIDTH) + val size = Word.toInt(Word.<<(0w1,Word.fromInt(width-1))) + in {desc = desc, + tab = ref (Array.array(size,Key.null)), + hash = ref (Array.array(2*size,nullBucket)), + hashFun = ref (makeHashFun(size,width)), + width = ref width, + size = ref size, + count = ref 0} + end + + (*--------------------------------------------------------------------*) + (* clear a dictionary. If the 2nd arg is SOME w, use w for resizing. *) + (*--------------------------------------------------------------------*) + fun clearSymTable (symTab:SymTable,widthOpt) = + case widthOpt + of NONE => + let + val {tab=ref tab,hash=ref hash,size,count,...} = symTab + val _ = appInterval (fn i => Array.update(tab,i,Key.null)) (0,!count-1) + val _ = appInterval (fn i => Array.update(hash,i,nullBucket)) (0,!size*2-1) + in + count := 0 + end + | SOME w => + let + val {tab,hash,hashFun,width,size,count,...} = symTab + val newWidth = Int.min(Int.max(1,w),MAX_WIDTH) + val newSize = Word.toInt(Word.<<(0w1,Word.fromInt(newWidth-1))) + val _ = tab := (Array.array(newSize,Key.null)) + val _ = hash := (Array.array(2*newSize,nullBucket)) + val _ = hashFun := (makeHashFun(newSize,newWidth)) + val _ = width := newWidth + val _ = size := newSize + in + count := 0 + end + + (*--------------------------------------------------------------------*) + (* grow a symtable to the double size. raise InternalError if the *) + (* table already has maximal size. *) + (*--------------------------------------------------------------------*) + fun growTable ({desc,tab,hash,hashFun,width,size,count}:SymTable) = + let + val newWidth = if !width < MAX_WIDTH then !width+1 + else raise InternalError + ("SymTable","growTable", + String.concat ["growing the ",desc," symbol table ", + "exceeded the system maximum size of ", + Int.toString Array.maxLen," for arrays"]) + val newSize = !size*2 + + val oldTab = !tab + val newTab = Array.array(newSize,Key.null) + val newHash = Array.array(2*newSize,nullBucket) + val newHashFun = makeHashFun(newSize,newWidth) + + fun addToNew (inv as (i,key)) = + let + val idx = newHashFun key + val _ = Array.update(newHash,idx,addToBucket((key,i),Array.sub(newHash,idx))) + val _ = Array.update(newTab,i,key) + in () + end + val _ = Array.appi addToNew (!tab,0,NONE) + + val _ = tab := newTab + val _ = hash := newHash + val _ = size := newSize + val _ = width := newWidth + val _ = hashFun := newHashFun + in () + end + + (*--------------------------------------------------------------------*) + (* lookup the key for an index of the symbol table. *) + (*--------------------------------------------------------------------*) + fun getSymKey({tab,count,...}:SymTable,idx) = + if !count>idx then Array.sub(!tab,idx) + else raise NoSuchSymbol + + (*--------------------------------------------------------------------*) + (* map a Key to its index in the symbol table. if it is not in the *) + (* symbol table yet, add a new entry with a new index. grow the table *) + (* if there is no more free index in the table. *) + (*--------------------------------------------------------------------*) + fun getSymIndex(st as {tab,hash,hashFun,size,count,...}:SymTable,key) = + let + val idx = !hashFun key + val bucket = Array.sub(!hash,idx) + in + case searchBucket(key,bucket) + of SOME i => i + | NONE => let val i = !count + val (idx',buck') = if !size>i then (idx,bucket) + else let val _ = growTable st + val idx' = !hashFun key + val buck' = Array.sub(!hash,idx') + in (idx',buck') + end + val _ = Array.update(!hash,idx',addToBucket((key,i),buck')) + val _ = Array.update(!tab,i,key) + val _ = count := i+1 + in i + end + end + + (*--------------------------------------------------------------------*) + (* does a Key have an entry in a symbol table? *) + (*--------------------------------------------------------------------*) + fun hasSymIndex({hash,hashFun,...}:SymTable,key) = + let + val idx = !hashFun key + val buck = Array.sub(!hash,idx) + in + searchBucket(key,buck) + end + + (*--------------------------------------------------------------------*) + (* reserve an index for a (yet unknown) key. *) + (*--------------------------------------------------------------------*) + fun reserveSymIndex(st as {size,count=count as ref i,...}:SymTable) = + let + val _ = if !size>i then () else growTable st + val _ = count := i+1 + in i + end + + (*--------------------------------------------------------------------*) + (* assign an index to a (previously reserved) index. *) + (*--------------------------------------------------------------------*) + fun assignSymIndex(st as {count,hash,hashFun,tab,...}:SymTable,key,i) = + if !count<=i then raise NoSuchSymbol + else let val idx = !hashFun key + val buck = Array.sub(!hash,idx) + val newBuck = addToBucket((key,i),buck) + val _ = Array.update(!hash,idx,newBuck) + val _ = Array.update(!tab,i,key) + in () + end + + (*--------------------------------------------------------------------*) + (* extract the contents of a symbol table to a vector. *) + (*--------------------------------------------------------------------*) + fun extractSymTable({count,tab,...}:SymTable) = + Array.extract(!tab,0,SOME(!count)) + + (*--------------------------------------------------------------------*) + (* print the contents of the symbol table. *) + (*--------------------------------------------------------------------*) + fun printSymTable ({desc,tab,count,...}:SymTable) = + (print (desc^" table:\n"); + Array.appi + (fn (n,key) => + print (" "^Int.toString n^": "^Key.toString key^"\n")) + (!tab,0,SOME (!count))) + end +(* stop of ../../Util/SymDict/symbolTable.sml *) +(* start of ../../Util/SymDict/intListDict.sml *) + + + + + + +structure KeyIntList : Key = + struct + type Key = int list + + val null = nil + val hash = UtilHash.hashList Word.fromInt + val compare = UtilCompare.compareList Int.compare + val toString = UtilString.List2String Int.toString + end + +structure IntListDict = Dict (structure Key = KeyIntList) +structure IntListSymTab = SymTable (structure Key = KeyIntList) + + +(* stop of ../../Util/SymDict/intListDict.sml *) +(* start of ../../Util/SymDict/intDict.sml *) + + + + + + + +structure KeyInt : Key = + struct + type Key = int + + val null = 0 + val hash = Word.fromInt + val compare = Int.compare + val toString = Int.toString + end + +structure IntDict = Dict (structure Key = KeyInt) +structure IntSymTab = SymTable (structure Key = KeyInt) + + +(* stop of ../../Util/SymDict/intDict.sml *) +(* start of ../../Unicode/Chars/uniChar.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: UniChar *) +(* *) +(* Depends on: *) +(* UtilString *) +(* *) +(* Exceptions raised by functions in this structure: *) +(*--------------------------------------------------------------------------*) +signature UniChar = + sig + structure Chars : WORD + + type Char = Chars.word + type Data = Char list + type Vector = Char vector + + val nullData : Data + val nullVector : Vector + + val hashChar : Char -> word + val hashData : Data -> word + val hashVector : Vector -> word + + val compareChar : Char * Char -> order + val compareData : Data * Data -> order + val compareVector : Vector * Vector -> order + + val char2Char : char -> Char + val Char2char : Char -> char + + val Char2Uni : Char -> string + val Char2String : Char -> string + + val String2Data : string -> Data + val Data2String : Data -> string + val Latin2String : Data -> string + + val Data2Vector : Data -> Vector + val Vector2Data : Vector -> Data + + val String2Vector : string -> Vector + val Vector2String : Vector -> string + + val quoteUni : Char -> string -> string + val quoteChar : Char -> Char -> string + val quoteData : Char -> Data -> string + val quoteVector : Char -> Vector -> string + end + +structure UniChar : UniChar = + struct + val O_VECTOR_PRINTLEN = 48 + + structure Chars = Word + + val _ = if Chars.wordSize > 21 then () + else let val str = ("UniChar: Chars.wordSize is too small.\n"^ + "Cannot compile on this system!\n" ) + val _ = print str + in raise Fail str + end + + type Char = Chars.word + type Data = Char list + + type CharInterval = Char * Char + type CharRange = CharInterval list + + type Vector = Char vector + + val nullChar = 0wx0:Char + val nullData = nil:Data + val nullVector = Vector.fromList nullData + + val hashChar = Word.fromLargeWord o Chars.toLargeWord + val hashData = UtilHash.hashList hashChar + val hashVector = UtilHash.hashVector hashChar + + val compareChar = Chars.compare + val compareData = UtilCompare.compareList compareChar + val compareVector = UtilCompare.compareVector compareChar + + val char2Char = Chars.fromLargeWord o Word8.toLargeWord o Byte.charToByte + val Char2char = Byte.byteToChar o Word8.fromLargeWord o Chars.toLargeWord + + fun Char2Uni c = + "U+"^UtilString.toUpperString(StringCvt.padLeft #"0" 4 (Chars.toString c)) + fun Char2String c = + case c + of 0wx9 => "\\t" + | 0wxA => "\\n" + | _ => if c<0wx100 then String.implode [Char2char c] + else Char2Uni c + + fun String2Data s = map char2Char (String.explode s) + fun Data2String cs = String.concat (map Char2String cs) + fun Latin2String cs = String.implode (map Char2char cs) + + val Data2Vector = Vector.fromList + fun String2Vector s = Vector.tabulate(String.size s,fn i => char2Char(String.sub(s,i))) + + fun Vector2Data vec = Vector.foldr (op ::) nil vec + fun Vector2String vec = + let + val maxlen = O_VECTOR_PRINTLEN + val len = Vector.length vec + in + if len<=maxlen orelse maxlen=0 + then Data2String (Vector2Data vec) + else let + val cs1 = Vector.foldri + (fn (_,c,cs) => c::cs) nil (vec,0,SOME (maxlen div 2)) + val cs2 = Vector.foldri + (fn (_,c,cs) => c::cs) nil (vec,len-3-maxlen div 2,NONE) + in Data2String cs1^"..."^Data2String cs2 + end + end + + fun quoteUni q s = let val sQ = Char2String q in sQ^s^sQ end + fun quoteChar q c = if c=0wx0 then "entity end" else quoteUni q (Char2String c) + fun quoteData q cs = quoteUni q (Data2String cs) + fun quoteVector q v = quoteUni q (Vector2String v) + end + + +(* stop of ../../Unicode/Chars/uniChar.sml *) +(* start of ../../Unicode/Chars/charVecDict.sml *) +structure KeyVector : Key = + struct + type Key = UniChar.Vector + + val null = UniChar.nullVector + val compare = UniChar.compareVector + val toString = UniChar.Vector2String + val hash = UniChar.hashVector + end + +structure VectorDict = Dict (structure Key = KeyVector) +(* stop of ../../Unicode/Chars/charVecDict.sml *) +(* start of ../../Util/SymDict/stringDict.sml *) + + + + + + + + +structure KeyString : Key = + struct + type Key = string + + val null = "" + val hash = UtilHash.hashString + val compare = String.compare + + fun toString str = str + end + +structure StringDict = Dict (structure Key = KeyString) +(* stop of ../../Util/SymDict/stringDict.sml *) +(* start of ../../Unicode/encoding.sml *) + + +signature Encoding = + sig + datatype Encoding = + NOENC | ASCII | EBCDIC | LATIN1 + | UCS4B | UCS4L | UCS4SB | UCS4SL + | UCS2B | UCS2L | UTF16B | UTF16L + | UTF8 + + val UCS2 : Encoding + val UCS4 : Encoding + val UTF16 : Encoding + + val encodingName : Encoding -> string + val isEncoding : string -> Encoding + val switchEncoding : Encoding * Encoding -> Encoding + end + +structure Encoding : Encoding = + struct + open StringDict + + datatype Encoding = + NOENC | ASCII | EBCDIC | LATIN1 + | UCS4B | UCS4L | UCS4SB | UCS4SL + | UCS2B | UCS2L | UTF16B | UTF16L + | UTF8 + + val UCS2 = UCS2B + val UCS4 = UCS4B + val UTF16 = UTF16B + + fun encodingName enc = + case enc + of NOENC => "NONE" + | ASCII => "ASCII" + | EBCDIC => "EBCDIC" + | LATIN1 => "ISO-8859-1" + | UCS2B => "UCS-2" + | UCS2L => "UCS-2" + | UCS4B => "UCS-4" + | UCS4L => "UCS-4" + | UCS4SB => "UCS-4" + | UCS4SL => "UCS-4" + | UTF8 => "UTF-8" + | UTF16B => "UTF-16" + | UTF16L => "UTF-16" + + val encDict = makeDict("encoding",6,NOENC) + val encAliases = + [(ASCII,["ANSI_X3.4-1968","ANSI_X3.4-1986","ASCII","US-ASCII","US", + "ISO646-US","ISO-IR-6","ISO_646.IRV:1991","IBM367","CP367"]), + (EBCDIC,["EBCDIC"]), + (LATIN1,["ISO_8859-1:1987","ISO-8859-1","ISO_8859-1", + "ISO-IR-100","CP819","IBM819","L1","LATIN1"]), + (UCS2,["UCS-2","ISO-10646-UCS-2"]), + (UCS4,["UCS-4","ISO-10646-UCS-4"]), + (UTF16,["UTF-16"]), + (UTF8,["UTF-8"]) + ] + val _ = app (fn (x,ys) => app (fn y => setByKey(encDict,y,x)) ys) encAliases + fun isEncoding name = getByKey(encDict,name) + + fun compatAscii new = + case new + of ASCII => new + | LATIN1 => new + | UTF8 => new + | _ => NOENC + fun compatUcs4 (old,new) = + if new=UCS4 then old else NOENC + + fun switchEncoding(old,new) = + case old + of NOENC => NOENC + | ASCII => compatAscii new + | EBCDIC => if new=EBCDIC then new else NOENC + | LATIN1 => compatAscii new + | UCS4B => compatUcs4(old,new) + | UCS4L => compatUcs4(old,new) + | UCS4SB => compatUcs4(old,new) + | UCS4SL => compatUcs4(old,new) + | UTF16B => if new=UTF16 then old else if new=UCS2 then UCS2B else NOENC + | UTF16L => if new=UTF16 then old else if new=UCS2 then UCS2L else NOENC + | UCS2B => if new=UCS2 then old else if new=UTF16 then UTF16B else NOENC + | UCS2L => if new=UCS2 then old else if new=UTF16 then UTF16L else NOENC + | UTF8 => compatAscii new + end +(* stop of ../../Unicode/encoding.sml *) +(* start of ../../Unicode/Encode/encodeBasic.sml *) + + + + + + +(*--------------------------------------------------------------------------*) +(* Structure: EncodeBasic *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* closeFile : none *) +(* fileName : none *) +(* openFile : NoSuchFile *) +(* writeByte : Io *) +(*--------------------------------------------------------------------------*) +signature EncodeBasic = + sig + type File + + val stdOutFile : File + val closeFile : File -> unit + val fileName : File -> string + val openFile : string -> File + val writeByte : File * Word8.word -> File + end + +structure EncodeBasic : EncodeBasic = + struct + open UtilError + + type outstream = TextIO.outstream + val closeOut = TextIO.closeOut + val openOut = TextIO.openOut + val output1 = TextIO.output1 + val stdOut = TextIO.stdOut + + type File = string * outstream + + val stdOutFile = ("-",stdOut) + + fun closeFile(fname,s) = if fname="-" then () else closeOut s + fun fileName(fname,_) = if fname="-" then "" else fname + fun openFile fname = + if fname = "-" then (fname,stdOut) + else (fname,openOut fname) + handle IO.Io {name,cause,...} => raise NoSuchFile(name,exnMessage cause) + fun writeByte (f as (_,s),b) = f before output1(s,chr(Word8.toInt b)) + end +(* stop of ../../Unicode/Encode/encodeBasic.sml *) +(* start of ../../Unicode/Encode/encodeError.sml *) + + + + + + + +signature EncodeError = + sig + datatype EncodeError = + ERR_ILLEGAL_CHAR of UniChar.Char * string + + val encodeMessage : EncodeError -> string list + + exception EncodeError of EncodeBasic.File * EncodeError + end + +structure EncodeError : EncodeError = + struct + open + UtilString + UniChar + + datatype EncodeError = + ERR_ILLEGAL_CHAR of UniChar.Char * string + + fun encodeMessage err = + case err + of ERR_ILLEGAL_CHAR(c,what) => [Char2Uni c,"is not",prependAnA what,"character"] + + exception EncodeError of EncodeBasic.File * EncodeError + end +(* stop of ../../Unicode/Encode/encodeError.sml *) +(* start of ../../Unicode/Encode/encodeMisc.sml *) +(* +require "basis.__word"; +require "basis.__word8"; +require "basis.__word8_vector"; + +require "chars"; +require "encodeBasic"; +require "encodeError"; +*) +signature EncodeMisc = + sig + val writeCharAscii : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharEbcdic : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharLatin1 : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharUcs4B : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharUcs4L : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharUcs4SB : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharUcs4SL : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharUtf8 : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharUtf16B : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharUtf16L : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharUcs2B : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + val writeCharUcs2L : UniChar.Char * EncodeBasic.File -> EncodeBasic.File + + val validCharAscii : UniChar.Char -> bool + val validCharEbcdic : UniChar.Char -> bool + val validCharLatin1 : UniChar.Char -> bool + end + +structure EncodeMisc : EncodeMisc = + struct + open UniChar EncodeBasic EncodeError + + infix 8 >> + infix 7 && + infix 6 || + + val op && = Chars.andb + val op >> = Chars.>> + val op || = Word8.orb + + fun splitSurrogates (c : Char) = + (((c-0wx10000) >> 0w10)+0wxD800,c && 0wx3FF + 0wxDC00) + + fun Char2Byte c = Word8.fromLargeWord(Chars.toLargeWord c) + + (*---------------------------------------------------------------------*) + (* Ascii *) + (*---------------------------------------------------------------------*) + fun validCharAscii (c : Char) = c<0wx80 + fun writeCharAscii(c,f) = + if c<0wx80 then writeByte(f,Char2Byte c) + else raise EncodeError(f,ERR_ILLEGAL_CHAR(c,"ASCII")) + + (*---------------------------------------------------------------------*) + (* Ebcdic *) + (*---------------------------------------------------------------------*) + val latin2ebcdicTab = Word8Vector.fromList + [0wx00,0wx01,0wx02,0wx03,0wx37,0wx2D,0wx2E,0wx2F, + 0wx16,0wx05,0wx25,0wx0B,0wx0C,0wx0D,0wx0E,0wx0F, + 0wx10,0wx11,0wx12,0wx13,0wx3C,0wx3D,0wx32,0wx26, + 0wx18,0wx19,0wx3F,0wx27,0wx1C,0wx1D,0wx1E,0wx1F, + 0wx40,0wx4F,0wx7F,0wx7B,0wx5B,0wx6C,0wx50,0wx7D, + 0wx4D,0wx5D,0wx5C,0wx4E,0wx6B,0wx60,0wx4B,0wx61, + 0wxF0,0wxF1,0wxF2,0wxF3,0wxF4,0wxF5,0wxF6,0wxF7, + 0wxF8,0wxF9,0wx7A,0wx5E,0wx4C,0wx7E,0wx6E,0wx6F, + 0wx7C,0wxC1,0wxC2,0wxC3,0wxC4,0wxC5,0wxC6,0wxC7, + 0wxC8,0wxC9,0wxD1,0wxD2,0wxD3,0wxD4,0wxD5,0wxD6, + 0wxD7,0wxD8,0wxD9,0wxE2,0wxE3,0wxE4,0wxE5,0wxE6, + 0wxE7,0wxE8,0wxE9,0wx4A,0wxE0,0wx5A,0wx5F,0wx6D, + 0wx79,0wx81,0wx82,0wx83,0wx84,0wx85,0wx86,0wx87, + 0wx88,0wx89,0wx91,0wx92,0wx93,0wx94,0wx95,0wx96, + 0wx97,0wx98,0wx99,0wxA2,0wxA3,0wxA4,0wxA5,0wxA6, + 0wxA7,0wxA8,0wxA9,0wxC0,0wx6A,0wxD0,0wxA1,0wx07, + 0wx20,0wx21,0wx22,0wx23,0wx24,0wx15,0wx06,0wx17, + 0wx28,0wx29,0wx2A,0wx2B,0wx2C,0wx09,0wx0A,0wx1B, + 0wx30,0wx31,0wx1A,0wx33,0wx34,0wx35,0wx36,0wx08, + 0wx38,0wx39,0wx3A,0wx3B,0wx04,0wx14,0wx3E,0wxE1, + 0wx41,0wx42,0wx43,0wx44,0wx45,0wx46,0wx47,0wx48, + 0wx49,0wx51,0wx52,0wx53,0wx54,0wx55,0wx56,0wx57, + 0wx58,0wx59,0wx62,0wx63,0wx64,0wx65,0wx66,0wx67, + 0wx68,0wx69,0wx70,0wx71,0wx72,0wx73,0wx74,0wx75, + 0wx76,0wx77,0wx78,0wx80,0wx8A,0wx8B,0wx8C,0wx8D, + 0wx8E,0wx8F,0wx90,0wx9A,0wx9B,0wx9C,0wx9D,0wx9E, + 0wx9F,0wxA0,0wxAA,0wxAB,0wxAC,0wxAD,0wxAE,0wxAF, + 0wxB0,0wxB1,0wxB2,0wxB3,0wxB4,0wxB5,0wxB6,0wxB7, + 0wxB8,0wxB9,0wxBA,0wxBB,0wxBC,0wxBD,0wxBE,0wxBF, + 0wxCA,0wxCB,0wxCC,0wxCD,0wxCE,0wxCF,0wxDA,0wxDB, + 0wxDC,0wxDD,0wxDE,0wxDF,0wxEA,0wxEB,0wxEC,0wxED, + 0wxEE,0wxEF,0wxFA,0wxFB,0wxFC,0wxFD,0wxFE,0wxFF + ] + fun validCharEbcdic (c : Char) = c<0wx100 + fun writeCharEbcdic(c,f) = + if c<0wx100 then writeByte(f,Word8Vector.sub(latin2ebcdicTab,Chars.toInt c)) + else raise EncodeError(f,ERR_ILLEGAL_CHAR(c,"EBCDIC")) + + (*---------------------------------------------------------------------*) + (* Latin1 *) + (*---------------------------------------------------------------------*) + fun validCharLatin1 (c : Char) = c<0wx100 + fun writeCharLatin1(c,f) = + if c<0wx100 then writeByte(f,Char2Byte c) + else raise EncodeError(f,ERR_ILLEGAL_CHAR(c,"LATIN-1")) + + (*---------------------------------------------------------------------*) + (* UCS-4 *) + (*---------------------------------------------------------------------*) + fun ucs4Bytes c = (Char2Byte(c >> 0w24), + Char2Byte(c >> 0w16), + Char2Byte(c >> 0w8), + Char2Byte c) + fun writeCharUcs4 perm = + fn (c,f) => let val bytes = ucs4Bytes c + val (b1,b2,b3,b4) = perm bytes + val f1 = writeByte(f,b1) + val f2 = writeByte(f1,b2) + val f3 = writeByte(f2,b3) + val f4 = writeByte(f3,b4) + in f4 + end + fun permUcs4B x = x + fun permUcs4L (b1,b2,b3,b4) = (b4,b3,b2,b1) + fun permUcs4SB (b1,b2,b3,b4) = (b2,b1,b4,b3) + fun permUcs4SL (b1,b2,b3,b4) = (b3,b4,b1,b2) + + val writeCharUcs4B = writeCharUcs4 permUcs4B + val writeCharUcs4L = writeCharUcs4 permUcs4L + val writeCharUcs4SB = writeCharUcs4 permUcs4SB + val writeCharUcs4SL = writeCharUcs4 permUcs4SL + + (*---------------------------------------------------------------------*) + (* UTF-8 *) + (*---------------------------------------------------------------------*) + fun writeCharUtf8(c,f) = + if c<0wx80 then writeByte(f,Char2Byte c) + else if c<0wx800 + then let val f1 = writeByte(f,0wxC0 || Char2Byte(c >> 0w6)) + val f2 = writeByte(f1,0wx80 || Char2Byte(c && 0wx3F)) + in f2 + end + else if c<0wx10000 + then let val f1 = writeByte(f, 0wxE0 || Char2Byte(c >> 0w12)) + val f2 = writeByte(f1,0wx80 || Char2Byte((c >> 0w6) && 0wx3F)) + val f3 = writeByte(f2,0wx80 || Char2Byte(c && 0wx3F)) + in f3 + end + else if c<0wx200000 + then let val f1 = writeByte(f, 0wxF0 || Char2Byte(c >> 0w18)) + val f2 = writeByte(f1,0wx80 || Char2Byte((c >> 0w12) && 0wx3F)) + val f3 = writeByte(f2,0wx80 || Char2Byte((c >> 0w6) && 0wx3F)) + val f4 = writeByte(f3,0wx80 || Char2Byte(c && 0wx3F)) + in f4 + end + else if c<0wx4000000 + then let val f1 = writeByte(f, 0wxF8 || Char2Byte(c >> 0w24)) + val f2 = writeByte(f1,0wx80 || Char2Byte((c >> 0w18) && 0wx3F)) + val f3 = writeByte(f2,0wx80 || Char2Byte((c >> 0w12) && 0wx3F)) + val f4 = writeByte(f3,0wx80 || Char2Byte((c >> 0w6) && 0wx3F)) + val f5 = writeByte(f4,0wx80 || Char2Byte(c && 0wx3F)) + in f5 + end + else let val f1 = writeByte(f, 0wxFC || Char2Byte(c >> 0w30)) + val f2 = writeByte(f1,0wx80 || Char2Byte((c >> 0w24) && 0wx3F)) + val f3 = writeByte(f2,0wx80 || Char2Byte((c >> 0w18) && 0wx3F)) + val f4 = writeByte(f3,0wx80 || Char2Byte((c >> 0w12) && 0wx3F)) + val f5 = writeByte(f4,0wx80 || Char2Byte((c >> 0w6) && 0wx3F)) + val f6 = writeByte(f5,0wx80 || Char2Byte(c && 0wx3F)) + in f6 + end + + (*---------------------------------------------------------------------*) + (* UTF-16 *) + (*---------------------------------------------------------------------*) + fun oneUtf16 isL (c,f) = + let val (b1,b2) = (Char2Byte(c >> 0w8),Char2Byte c) + in if isL then writeByte(writeByte(f,b2),b1) + else writeByte(writeByte(f,b1),b2) + end + fun writeCharUtf16 isL = + fn (c,f) => + if c<0wx10000 then oneUtf16 isL (c,f) + else let val (hi,lo) = splitSurrogates c + val f1 = oneUtf16 isL (hi,f) + val f2 = oneUtf16 isL (lo,f1) + in f2 + end + val writeCharUtf16B = writeCharUtf16 false + val writeCharUtf16L = writeCharUtf16 true + + (*---------------------------------------------------------------------*) + (* UCS-2 *) + (*---------------------------------------------------------------------*) + fun writeCharUcs2 isL = + fn (c,f) => + if c<0wx10000 + then let val (b1,b2) = (Char2Byte(c >> 0w8),Char2Byte c) + in if isL then writeByte(writeByte(f,b2),b1) + else writeByte(writeByte(f,b1),b2) + end + else raise EncodeError(f,ERR_ILLEGAL_CHAR(c,"UCS-2")) + + val writeCharUcs2B = writeCharUcs2 false + val writeCharUcs2L = writeCharUcs2 true + + end +(* stop of ../../Unicode/Encode/encodeMisc.sml *) +(* start of ../../Unicode/Encode/encode.sml *) + + + + + + + + + + +signature Encode = + sig + include EncodeError + + type File + type EncFile + + val encNoFile : EncFile + val encStdOut : EncFile + val encOpenFile : string * Encoding.Encoding * string -> EncFile + val encCloseFile : EncFile -> unit + val encAdapt : EncFile * File -> EncFile + + val encPutChar : EncFile * UniChar.Char -> EncFile + val encValidChar : EncFile * UniChar.Char -> bool + end + +structure Encode : Encode = + struct + open + Encoding UtilError + EncodeBasic EncodeError EncodeMisc + + type EncFile = Encoding * File + + val encNoFile = (NOENC,stdOutFile) + val encStdOut = (LATIN1,stdOutFile) + + fun encAdapt((enc,_),f) = (enc,f) + + fun encValidChar((enc,_),c) = + case enc + of ASCII => validCharAscii c + | EBCDIC => validCharEbcdic c + | LATIN1 => validCharLatin1 c + | _ => true + + fun encPutChar((enc,f),c) = + let val f1 = + case enc + of NOENC => f + | ASCII => (writeCharAscii(c,f)) + | EBCDIC => (writeCharEbcdic(c,f)) + | LATIN1 => (writeCharLatin1(c,f)) + | UCS2B => (writeCharUcs2B(c,f)) + | UCS2L => (writeCharUcs2L(c,f)) + | UCS4B => (writeCharUcs4B(c,f)) + | UCS4L => (writeCharUcs4L(c,f)) + | UCS4SB => (writeCharUcs4SB(c,f)) + | UCS4SL => (writeCharUcs4SL(c,f)) + | UTF8 => (writeCharUtf8(c,f)) + | UTF16B => (writeCharUtf16B(c,f)) + | UTF16L => (writeCharUtf16L(c,f)) + in (enc,f1) + end + + fun encCloseFile(_,f) = closeFile f + + fun encOpenFile (fname,enc,name) = + let + val outEnc = + case enc + of NOENC => + (case isEncoding name + of NOENC => raise NoSuchFile(fname,"Unsupported encoding \""^name^"\"") + | enc => enc) + | enc => enc + val f = openFile fname + val f1 = case outEnc + of UTF16B => writeByte(writeByte(f,0wxFE),0wxFF) + | UTF16L => writeByte(writeByte(f,0wxFF),0wxFE) + | _ => f + in (outEnc,f1) + end + end + +(* stop of ../../Unicode/Encode/encode.sml *) +(* start of nullHard.sml *) + + + + + + + + + + + + + + + + + + + + + +(* +structure NullHard = + struct + fun parseNull uri = NullParse.parseDocument uri NONE NullHooks.nullStart + + open + NullCatOptions NullOptions Options NullParserOptions Uri + + val usage = List.concat [parserUsage,[("","")],catalogUsage,[("","")],nullUsage] + + exception Exit of OS.Process.status + + fun null(prog,args) = + let + val prog = "fxp" + val hadError = ref false + + fun optError msg = + let val _ = TextIO.output(TextIO.stdErr,msg^".\n") + in hadError := true + end + fun exitError msg = + let val _ = TextIO.output(TextIO.stdErr,msg^".\n") + in raise Exit OS.Process.failure + end + fun exitHelp prog = + let val _ = printUsage TextIO.stdOut prog usage + in raise Exit OS.Process.success + end + fun exitVersion prog = + let val _ = app print [prog," version ",Version.FXP_VERSION,"\n"] + in raise Exit OS.Process.success + end + + fun summOpt prog = "For a summary of options type "^prog^" --help" + fun noFile(f,cause) = "can't open file '"^f^"': "^exnMessage cause + + val opts = parseOptions args + val _ = setParserDefaults() + val opts1 = setParserOptions (opts,optError) + val _ = setCatalogDefaults() + val opts2 = setCatalogOptions (opts1,optError) + val _ = setNullDefaults() + val (vers,help,err,file) = setNullOptions (opts2,optError) + val _ = if !hadError then exitError (summOpt prog) else () + val _ = if vers then exitVersion prog else () + val _ = if help then exitHelp prog else () + val _ = case err + of SOME "-" => O_ERROR_DEVICE := TextIO.stdErr + | SOME f => (O_ERROR_DEVICE := TextIO.openOut f + handle IO.Io {cause,...} => exitError(noFile(f,cause))) + | NONE => () + val f = valOf file handle Option => "-" + val uri = if f="-" then NONE else SOME(String2Uri f) + val status = parseNull uri + val _ = if isSome err then TextIO.closeOut (!O_ERROR_DEVICE) else () + in status + end + handle Exit status => status + | exn => + let val _ = TextIO.output + (TextIO.stdErr,prog^": Unexpected exception: "^exnMessage exn^".\n") + in OS.Process.failure + end + end +*) +structure NullHard = struct end +(* stop of nullHard.sml *) +(* start of ../../Util/options.sml *) +signature Options= + sig + datatype Option = + OPT_LONG of string * string option + | OPT_SHORT of char list + | OPT_NEG of char list + | OPT_NOOPT + | OPT_STRING of string + val parseOptions : string list -> Option list + + datatype UsageItem = + U_SEP + | U_TITLE of string + | U_ITEM of string list * string + type Usage = UsageItem list + val printUsage : TextIO.outstream -> string -> Usage -> unit + end + +structure Options : Options = + struct + exception BadOption of string + + datatype Option = + OPT_LONG of string * string option + | OPT_SHORT of char list + | OPT_NEG of char list + | OPT_NOOPT + | OPT_STRING of string + + datatype UsageItem = + U_SEP + | U_TITLE of string + | U_ITEM of string list * string + type Usage = UsageItem list + + fun parseOptions ss = + let + fun doOne opt = + if String.isPrefix "--" opt + then let val opt1 = Substring.extract(opt,2,NONE) + val (key0,opt2) = Substring.splitl (fn c => #"="<>c) opt1 + val key = if Substring.isEmpty key0 then raise BadOption opt + else Substring.string key0 + val valOpt = if Substring.isPrefix "=" opt2 + then let val val0 = Substring.triml 1 opt2 + in if Substring.isEmpty val0 + then raise BadOption opt + else SOME(Substring.string val0) + end + else NONE + in OPT_LONG(key,valOpt) + end + handle BadOption s => if opt="--" then OPT_NOOPT else OPT_STRING opt + else if String.isPrefix "-" opt + then let val chars = tl(String.explode opt) + (* val _ = app (fn c => if Char.isAlphaNum c then () + else raise BadOption opt) chars *) + in case chars + of nil => OPT_STRING opt + | #"n"::(cs as _::_) => OPT_NEG cs + | _ => OPT_SHORT chars + end + handle BadOption s => OPT_STRING opt + else OPT_STRING opt + + fun doAll nil = nil + | doAll (s::ss) = let val opt = doOne s + in case opt + of OPT_NOOPT => opt::map OPT_STRING ss + | _ => opt::doAll ss + end + in doAll ss + end + + fun printUsage stream prog usage = + let + val KEY_WIDTH = 30 + val LINE_WIDTH = 80 + val EMPTY_KEY = UtilString.nBlanks KEY_WIDTH + fun appendKeys col nil = if col>KEY_WIDTH then "\n"^EMPTY_KEY + else UtilString.nBlanks (KEY_WIDTH-col) + | appendKeys col [key] = key^" "^appendKeys (col+1+String.size key) nil + | appendKeys col (key::keys) = let val col1 = col+2+String.size key + in if col1>KEY_WIDTH + then key^",\n"^appendKeys 0 keys + else key^", "^appendKeys col1 keys + end + fun makeKey keylist = appendKeys 0 keylist + val makeText = UtilString.breakLines(LINE_WIDTH-KEY_WIDTH) + fun format (keylist,text) = + let val key = makeKey keylist + in case makeText text + of nil => [key] + | line::lines => key^line::map (fn line => EMPTY_KEY^line) lines + end + val _ = app (fn x => TextIO.output(stream,x)) + ["Usage: ",prog," [option ...] file\n","where option is one of:\n\n"] + val _ = app (fn item => app (fn x => TextIO.output(stream,x^"\n")) + (case item + of U_SEP => [""] + | U_TITLE txt => ["",txt] + | U_ITEM option => format option)) usage + in () + end + end +(* stop of ../../Util/options.sml *) +(* start of ../../config.sml *) +structure Config = + struct + (*---------------------------------------------------------------------*) + (* The OS command for retrieving a URI from the internet and storing *) + (* it in a local file, where *) + (* %1 is replaced by the URI. *) + (* %2 is replaced by the local filename. *) + (* It is recommended that the command exits with failure in case the *) + (* URI cannot be retrieved. If the command generates a HTML error *) + (* message instead (like, e.g., lynx), this HTML file is considered *) + (* to be XML and will probably cause a mess of parsing errors. If you *) + (* don't need URI retrieval, use "exit 1" which always fails. *) + (* Sensible values are, e.g.: *) + (* val retrieveCommand = "wget -qO %2 %1" *) + (* val retrieveCommand = "got_it -o %2 %1" *) + (* val retrieveCommand = "urlget -s -o %2 %1" *) + (*---------------------------------------------------------------------*) + val retrieveCommand = "wget -qO %2 %1" + end +(* stop of ../../config.sml *) +(* start of ../../Unicode/Chars/charClasses.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: CharClasses *) +(* *) +(* Notes: *) +(* This implementation uses the UNSAFE array operations, and does NO *) +(* range checks. This is for efficiency reasons. *) +(* If class=makeCharClass(lo,hi) then a filed of size hi-lo+1 is allo- *) +(* cated. In order to lookup a character, first make sure it in [lo..hi], *) +(* then subtract lo before calling inCharClass! *) +(* The same holds for addChar. *) +(* *) +(* Depends on: *) +(* UniChar *) +(* UtilInt *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* addChar : none *) +(* addCharClass : none *) +(* inCharClass : none *) +(* makeCharClass : none *) +(*--------------------------------------------------------------------------*) +signature CharClasses = + sig + type CharClass + type MutableClass + type CharInterval = UniChar.Char * UniChar.Char + type CharRange = CharInterval list + + val initialize : CharInterval -> MutableClass + val finalize : MutableClass -> CharClass + + val addChar : MutableClass * UniChar.Char * UniChar.Char * UniChar.Char -> unit + val addCharRange : MutableClass * UniChar.Char * UniChar.Char * CharRange -> CharRange + + val inCharClass : UniChar.Char * CharClass -> bool + end + +structure CharClasses : CharClasses = + struct + open UniChar + + type CharInterval = Char * Char + type CharRange = CharInterval list + + val Char2Word = Word.fromLargeWord o Chars.toLargeWord + + (*--------------------------------------------------------------------*) + (* helpers *) + (*--------------------------------------------------------------------*) + infix 5 >> >>> <<< + infix 6 || ||| + infix 6 -- + infix 7 & && &&& + val op >> = Chars.>> + val op -- = Chars.- + val op || = Chars.orb + val op && = Chars.andb + val op >>> = Word32.>> + val op <<< = Word32.<< + val op &&& = Word32.andb + val op ||| = Word32.orb + val op & = Word.andb + + val max32 = Word32.notb 0wx0 + + (*--------------------------------------------------------------------*) + (* a char class is an array of words, interpreted as bitvectors. *) + (*--------------------------------------------------------------------*) + type MutableClass = Word32.word array + type CharClass = Word32.word vector + + (*--------------------------------------------------------------------*) + (* each word in a char class holds 32 entries. Thus the for a char c *) + (* is c div 32 == c >> 5. The bitmask is a word of zeros, only the *) + (* significant bit for c, i.e. the (c && 31==0x1F)th bit set to one. *) + (*--------------------------------------------------------------------*) + fun indexMask c = let val idx = Chars.toInt(c>>0w5) + val mask = 0wx1 <<< Char2Word c & 0w31 + in (idx,mask) + end + + (*--------------------------------------------------------------------*) + (* generate index and mask, then lookup. *) + (*--------------------------------------------------------------------*) + fun inCharClass(c,vec) = let val (idx,mask) = indexMask c + in mask &&& Vector.sub(vec,idx) <> 0wx0 + end + + (*--------------------------------------------------------------------*) + (* generate a CharClass large enough to hold (max-min+1) characters. *) + (*--------------------------------------------------------------------*) + fun initialize(min,max) = + Array.array((Chars.toInt max-Chars.toInt min+1) div 32+1,0wx0):MutableClass + fun finalize arr = Array.extract(arr,0,NONE) + + (*--------------------------------------------------------------------*) + (* add a single character to a CharClass. *) + (*--------------------------------------------------------------------*) + fun addChar(cls,min,max,c) = + let + val (idx,new) = indexMask c + val old = Array.sub(cls,idx) + in + Array.update(cls,idx,old|||new) + end + + (*--------------------------------------------------------------------*) + (* add a full range of characters to a CharClass. *) + (* this is the only function that computes the offset before access *) + (* to the array. *) + (*--------------------------------------------------------------------*) + fun addCharRange(cls,min,max,range) = + let + fun doOne (lo,hi) = + let + val (l,h) = (lo-min,hi-min) + val (idxL,idxH) = ((Chars.toInt l) div 32,(Chars.toInt h) div 32) + val (bitL,bitH) = (Char2Word l & 0w31,Char2Word h & 0w31) + in + if idxL=idxH then + let + val new = (max32>>>(0w31-bitH+bitL))<<>>(0w31-bitH) + val oldL = Array.sub(cls,idxL) + val oldH = Array.sub(cls,idxH) + val _ = Array.update(cls,idxL,oldL|||newL) + val _ = Array.update(cls,idxH,oldH|||newH) + val _ = UtilInt.appInterval (fn i => Array.update(cls,i,max32)) + (idxL+1,idxH-1) + in () + end + else () + end + fun doAll nil = nil + | doAll ((lh as (lo,hi))::lhs) = + if himax then lh::doAll lhs + else if lo=min andalso hi<=max + then (doOne lh; doAll lhs) + else if lo>=min andalso hi>max + then (doOne(lo,max); (max+0w1,hi)::lhs) + else (doOne(min,max); (max+0w1,hi)::lhs) + val _ = doAll range + in + doAll range + end + end + +(* stop of ../../Unicode/Chars/charClasses.sml *) +(* start of ../../Unicode/Chars/uniRanges.sml *) + + + + +structure UniRanges = + struct + val digitRange = [(0wx0030,0wx0039), + (0wx0660,0wx0669), + (0wx06F0,0wx06F9), + (0wx0966,0wx096F), + (0wx09E6,0wx09EF), + (0wx0A66,0wx0A6F), + (0wx0AE6,0wx0AEF), + (0wx0B66,0wx0B6F), + (0wx0BE7,0wx0BEF), + (0wx0C66,0wx0C6F), + (0wx0CE6,0wx0CEF), + (0wx0D66,0wx0D6F), + (0wx0E50,0wx0E59), + (0wx0ED0,0wx0ED9), + (0wx0F20,0wx0F29) + ] : CharClasses.CharRange + + val digitRange09 = [(0wx0030,0wx0039), + (0wx0660,0wx0669), + (0wx06F0,0wx06F9), + (0wx0E50,0wx0E59), + (0wx0ED0,0wx0ED9), + (0wx0F20,0wx0F29) + ] : CharClasses.CharRange + + val digitRange6F = [(0wx0966,0wx096F), + (0wx09E6,0wx09EF), + (0wx0A66,0wx0A6F), + (0wx0AE6,0wx0AEF), + (0wx0B66,0wx0B6F), + (0wx0BE7,0wx0BEF), + (0wx0C66,0wx0C6F), + (0wx0CE6,0wx0CEF), + (0wx0D66,0wx0D6F) + ] : CharClasses.CharRange + + val baseRange = [(0wx0041,0wx005A), + (0wx0061,0wx007A), + (0wx00C0,0wx00D6), + (0wx00D8,0wx00F6), + (0wx00F8,0wx00FF), + (0wx0100,0wx0131), + (0wx0134,0wx013E), + (0wx0141,0wx0148), + (0wx014A,0wx017E), + (0wx0180,0wx01C3), + (0wx01CD,0wx01F0), + (0wx01F4,0wx01F5), + (0wx01FA,0wx0217), + (0wx0250,0wx02A8), + (0wx02BB,0wx02C1), + (0wx0386,0wx0386), + (0wx0388,0wx038A), + (0wx038C,0wx038C), + (0wx038E,0wx03A1), + (0wx03A3,0wx03CE), + (0wx03D0,0wx03D6), + (0wx03DA,0wx03DA), + (0wx03DC,0wx03DC), + (0wx03DE,0wx03DE), + (0wx03E0,0wx03E0), + (0wx03E2,0wx03F3), + (0wx0401,0wx040C), + (0wx040E,0wx044F), + (0wx0451,0wx045C), + (0wx045E,0wx0481), + (0wx0490,0wx04C4), + (0wx04C7,0wx04C8), + (0wx04CB,0wx04CC), + (0wx04D0,0wx04EB), + (0wx04EE,0wx04F5), + (0wx04F8,0wx04F9), + (0wx0531,0wx0556), + (0wx0559,0wx0559), + (0wx0561,0wx0586), + (0wx05D0,0wx05EA), + (0wx05F0,0wx05F2), + (0wx0621,0wx063A), + (0wx0641,0wx064A), + (0wx0671,0wx06B7), + (0wx06BA,0wx06BE), + (0wx06C0,0wx06CE), + (0wx06D0,0wx06D3), + (0wx06D5,0wx06D5), + (0wx06E5,0wx06E6), + (0wx0905,0wx0939), + (0wx093D,0wx093D), + (0wx0958,0wx0961), + (0wx0985,0wx098C), + (0wx098F,0wx0990), + (0wx0993,0wx09A8), + (0wx09AA,0wx09B0), + (0wx09B2,0wx09B2), + (0wx09B6,0wx09B9), + (0wx09DC,0wx09DD), + (0wx09DF,0wx09E1), + (0wx09F0,0wx09F1), + (0wx0A05,0wx0A0A), + (0wx0A0F,0wx0A10), + (0wx0A13,0wx0A28), + (0wx0A2A,0wx0A30), + (0wx0A32,0wx0A33), + (0wx0A35,0wx0A36), + (0wx0A38,0wx0A39), + (0wx0A59,0wx0A5C), + (0wx0A5E,0wx0A5E), + (0wx0A72,0wx0A74), + (0wx0A85,0wx0A8B), + (0wx0A8D,0wx0A8D), + (0wx0A8F,0wx0A91), + (0wx0A93,0wx0AA8), + (0wx0AAA,0wx0AB0), + (0wx0AB2,0wx0AB3), + (0wx0AB5,0wx0AB9), + (0wx0ABD,0wx0ABD), + (0wx0AE0,0wx0AE0), + (0wx0B05,0wx0B0C), + (0wx0B0F,0wx0B10), + (0wx0B13,0wx0B28), + (0wx0B2A,0wx0B30), + (0wx0B32,0wx0B33), + (0wx0B36,0wx0B39), + (0wx0B3D,0wx0B3D), + (0wx0B5C,0wx0B5D), + (0wx0B5F,0wx0B61), + (0wx0B85,0wx0B8A), + (0wx0B8E,0wx0B90), + (0wx0B92,0wx0B95), + (0wx0B99,0wx0B9A), + (0wx0B9C,0wx0B9C), + (0wx0B9E,0wx0B9F), + (0wx0BA3,0wx0BA4), + (0wx0BA8,0wx0BAA), + (0wx0BAE,0wx0BB5), + (0wx0BB7,0wx0BB9), + (0wx0C05,0wx0C0C), + (0wx0C0E,0wx0C10), + (0wx0C12,0wx0C28), + (0wx0C2A,0wx0C33), + (0wx0C35,0wx0C39), + (0wx0C60,0wx0C61), + (0wx0C85,0wx0C8C), + (0wx0C8E,0wx0C90), + (0wx0C92,0wx0CA8), + (0wx0CAA,0wx0CB3), + (0wx0CB5,0wx0CB9), + (0wx0CDE,0wx0CDE), + (0wx0CE0,0wx0CE1), + (0wx0D05,0wx0D0C), + (0wx0D0E,0wx0D10), + (0wx0D12,0wx0D28), + (0wx0D2A,0wx0D39), + (0wx0D60,0wx0D61), + (0wx0E01,0wx0E2E), + (0wx0E30,0wx0E30), + (0wx0E32,0wx0E33), + (0wx0E40,0wx0E45), + (0wx0E81,0wx0E82), + (0wx0E84,0wx0E84), + (0wx0E87,0wx0E88), + (0wx0E8A,0wx0E8A), + (0wx0E8D,0wx0E8D), + (0wx0E94,0wx0E97), + (0wx0E99,0wx0E9F), + (0wx0EA1,0wx0EA3), + (0wx0EA5,0wx0EA5), + (0wx0EA7,0wx0EA7), + (0wx0EAA,0wx0EAB), + (0wx0EAD,0wx0EAE), + (0wx0EB0,0wx0EB0), + (0wx0EB2,0wx0EB3), + (0wx0EBD,0wx0EBD), + (0wx0EC0,0wx0EC4), + (0wx0F40,0wx0F47), + (0wx0F49,0wx0F69), + (0wx10A0,0wx10C5), + (0wx10D0,0wx10F6), + (0wx1100,0wx1100), + (0wx1102,0wx1103), + (0wx1105,0wx1107), + (0wx1109,0wx1109), + (0wx110B,0wx110C), + (0wx110E,0wx1112), + (0wx113C,0wx113C), + (0wx113E,0wx113E), + (0wx1140,0wx1140), + (0wx114C,0wx114C), + (0wx114E,0wx114E), + (0wx1150,0wx1150), + (0wx1154,0wx1155), + (0wx1159,0wx1159), + (0wx115F,0wx1161), + (0wx1163,0wx1163), + (0wx1165,0wx1165), + (0wx1167,0wx1167), + (0wx1169,0wx1169), + (0wx116D,0wx116E), + (0wx1172,0wx1173), + (0wx1175,0wx1175), + (0wx119E,0wx119E), + (0wx11A8,0wx11A8), + (0wx11AB,0wx11AB), + (0wx11AE,0wx11AF), + (0wx11B7,0wx11B8), + (0wx11BA,0wx11BA), + (0wx11BC,0wx11C2), + (0wx11EB,0wx11EB), + (0wx11F0,0wx11F0), + (0wx11F9,0wx11F9), + (0wx1E00,0wx1E9B), + (0wx1EA0,0wx1EF9), + (0wx1F00,0wx1F15), + (0wx1F18,0wx1F1D), + (0wx1F20,0wx1F45), + (0wx1F48,0wx1F4D), + (0wx1F50,0wx1F57), + (0wx1F59,0wx1F59), + (0wx1F5B,0wx1F5B), + (0wx1F5D,0wx1F5D), + (0wx1F5F,0wx1F7D), + (0wx1F80,0wx1FB4), + (0wx1FB6,0wx1FBC), + (0wx1FBE,0wx1FBE), + (0wx1FC2,0wx1FC4), + (0wx1FC6,0wx1FCC), + (0wx1FD0,0wx1FD3), + (0wx1FD6,0wx1FDB), + (0wx1FE0,0wx1FEC), + (0wx1FF2,0wx1FF4), + (0wx1FF6,0wx1FFC), + (0wx2126,0wx2126), + (0wx212A,0wx212B), + (0wx212E,0wx212E), + (0wx2180,0wx2182), + (0wx3041,0wx3094), + (0wx30A1,0wx30FA), + (0wx3105,0wx312C), + (0wxAC00,0wxD7A3) + ] : CharClasses.CharRange + + val ideoRange = [(0wx3007,0wx3007), + (0wx3021,0wx3029), + (0wx4E00,0wx9FA5) + ] : CharClasses.CharRange + + val combRange = [(0wx0300,0wx0345), + (0wx0360,0wx0361), + (0wx0483,0wx0486), + (0wx0591,0wx05A1), + (0wx05A3,0wx05B9), + (0wx05BB,0wx05BD), + (0wx05BF,0wx05BF), + (0wx05C1,0wx05C2), + (0wx05C4,0wx05C4), + (0wx064B,0wx0652), + (0wx0670,0wx0670), + (0wx06D6,0wx06DC), + (0wx06DD,0wx06DF), + (0wx06E0,0wx06E4), + (0wx06E7,0wx06E8), + (0wx06EA,0wx06ED), + (0wx0901,0wx0903), + (0wx093C,0wx093C), + (0wx093E,0wx094C), + (0wx094D,0wx094D), + (0wx0951,0wx0954), + (0wx0962,0wx0963), + (0wx0981,0wx0983), + (0wx09BC,0wx09BC), + (0wx09BE,0wx09BE), + (0wx09BF,0wx09BF), + (0wx09C0,0wx09C4), + (0wx09C7,0wx09C8), + (0wx09CB,0wx09CD), + (0wx09D7,0wx09D7), + (0wx09E2,0wx09E3), + (0wx0A02,0wx0A02), + (0wx0A3C,0wx0A3C), + (0wx0A3E,0wx0A3E), + (0wx0A3F,0wx0A3F), + (0wx0A40,0wx0A42), + (0wx0A47,0wx0A48), + (0wx0A4B,0wx0A4D), + (0wx0A70,0wx0A71), + (0wx0A81,0wx0A83), + (0wx0ABC,0wx0ABC), + (0wx0ABE,0wx0AC5), + (0wx0AC7,0wx0AC9), + (0wx0ACB,0wx0ACD), + (0wx0B01,0wx0B03), + (0wx0B3C,0wx0B3C), + (0wx0B3E,0wx0B43), + (0wx0B47,0wx0B48), + (0wx0B4B,0wx0B4D), + (0wx0B56,0wx0B57), + (0wx0B82,0wx0B83), + (0wx0BBE,0wx0BC2), + (0wx0BC6,0wx0BC8), + (0wx0BCA,0wx0BCD), + (0wx0BD7,0wx0BD7), + (0wx0C01,0wx0C03), + (0wx0C3E,0wx0C44), + (0wx0C46,0wx0C48), + (0wx0C4A,0wx0C4D), + (0wx0C55,0wx0C56), + (0wx0C82,0wx0C83), + (0wx0CBE,0wx0CC4), + (0wx0CC6,0wx0CC8), + (0wx0CCA,0wx0CCD), + (0wx0CD5,0wx0CD6), + (0wx0D02,0wx0D03), + (0wx0D3E,0wx0D43), + (0wx0D46,0wx0D48), + (0wx0D4A,0wx0D4D), + (0wx0D57,0wx0D57), + (0wx0E31,0wx0E31), + (0wx0E34,0wx0E3A), + (0wx0E47,0wx0E4E), + (0wx0EB1,0wx0EB1), + (0wx0EB4,0wx0EB9), + (0wx0EBB,0wx0EBC), + (0wx0EC8,0wx0ECD), + (0wx0F18,0wx0F19), + (0wx0F35,0wx0F35), + (0wx0F37,0wx0F37), + (0wx0F39,0wx0F39), + (0wx0F3E,0wx0F3E), + (0wx0F3F,0wx0F3F), + (0wx0F71,0wx0F84), + (0wx0F86,0wx0F8B), + (0wx0F90,0wx0F95), + (0wx0F97,0wx0F97), + (0wx0F99,0wx0FAD), + (0wx0FB1,0wx0FB7), + (0wx0FB9,0wx0FB9), + (0wx20D0,0wx20DC), + (0wx20E1,0wx20E1), + (0wx302A,0wx302F), + (0wx3099,0wx3099), + (0wx309A,0wx309A) + ] : CharClasses.CharRange + + val extRange = [(0wx00B7,0wx00B7), + (0wx02D0,0wx02D0), + (0wx02D1,0wx02D1), + (0wx0387,0wx0387), + (0wx0640,0wx0640), + (0wx0E46,0wx0E46), + (0wx0EC6,0wx0EC6), + (0wx3005,0wx3005), + (0wx3031,0wx3035), + (0wx309D,0wx309E), + (0wx30FC,0wx30FE) + ] : CharClasses.CharRange + + val nmsRange = List.concat + [[(0wx3A,0wx3A),(0wx5F,0wx5F)](* :_ *), + baseRange, + ideoRange] + + val nameRange = List.concat + [[(0wx2D,0wx2D),(0wx2E,0wx2E)](* -. *), + digitRange, + combRange, + extRange, + nmsRange] + + val pubidRange = List.concat + [map (fn c => (c,c)) [0wx0A,0wx0D,0wx20], (* space,cr,lf *) + map (fn c => (c,c)) (UniChar.String2Data "-'()+,./:=?;!*#@$_%"), + [(0wx0030,0wx0039),(0wx0041,0wx005A),(0wx0061,0wx007A)] (* [0-9A-Za-z] *) + ] : CharClasses.CharRange + + val encRange = + [(0wx002D,0wx002E), (* -. *) + (0wx0030,0wx0039), (* 0-9 *) + (0wx0041,0wx005A), (* A-Z *) + (0wx005F,0wx005F), (* _ *) + (0wx0061,0wx007A) (* a-z *) + ] : CharClasses.CharRange + end +(* stop of ../../Unicode/Chars/uniRanges.sml *) +(* start of ../../Unicode/Chars/uniClasses.sml *) + + + + +(*--------------------------------------------------------------------------*) +(* Structure: UniClasses *) +(* *) +(* Notes: *) +(* read CharClasses in order to understand how CharClasses are handled. *) +(* *) +(* Depends on: *) +(* UniChar *) +(* CharClasses *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* decValue : none *) +(* hexValue : none *) +(* isAsciiLetter : none *) +(* isEnc : none *) +(* isEncS : none *) +(* isName : none *) +(* isNms : none *) +(* isPubid : none *) +(* isS : none *) +(* isXml : none *) +(* isUnicode : none *) +(* isVers : none *) +(*--------------------------------------------------------------------------*) +signature UniClasses = + sig + val isName : UniChar.Char -> bool + val isNms : UniChar.Char -> bool + val isPubid : UniChar.Char -> bool + val isS : UniChar.Char -> bool + val isEnc : UniChar.Char -> bool + val isEncS : UniChar.Char -> bool + val isVers : UniChar.Char -> bool + val isDec : UniChar.Char -> bool + val isHex : UniChar.Char -> bool + val isXml : UniChar.Char -> bool + val isUnicode : UniChar.Char -> bool + + val decValue : UniChar.Char -> UniChar.Char option + val hexValue : UniChar.Char -> UniChar.Char option + + val isAsciiLetter : UniChar.Char -> bool + end + +structure UniClasses : UniClasses = + struct + open UniChar CharClasses UniRanges + + (*--------------------------------------------------------------------*) + (* initialize the character classes. *) + (*--------------------------------------------------------------------*) + local + val nmsTemp = initialize(0wx0000,0wx3FFF) + val restNms = addCharRange(nmsTemp,0wx0000,0wx3FFF,nmsRange) + val _ = if restNms=[(0wxAC00,0wxD7A3),(0wx4E00,0wx9FA5)] then () + else print ("Warning: extra characters after computing nms char class.\n") + + val nameTemp = initialize(0wx0000,0wxFFFF) + val restName = addCharRange(nameTemp,0wx0000,0wx3FFF,nameRange) + val _ = if restName=[(0wxAC00,0wxD7A3),(0wx4E00,0wx9FA5)] then () + else print ("Warning: extra characters after computing name char class.\n") + + val pubTemp = initialize(0wx0000,0wx007F) + val restPubid = addCharRange(pubTemp,0wx0000,0wx007F,pubidRange) + val _ = if restPubid=nil then () + else print ("Warning: extra characters after computing pubid char class.\n") + + val encTemp = initialize(0wx0000,0wx007F) + val restEnc = addCharRange(encTemp,0wx0000,0wx007F,encRange) + val _ = if restEnc=nil then () + else print ("Warning: extra characters after computing enc char class.\n") + in + val nmsClass = finalize nmsTemp + val nameClass = finalize nameTemp + val pubClass = finalize pubTemp + val encClass = finalize encTemp + end + + (*--------------------------------------------------------------------*) + (* is a character a name start char? *) + (*--------------------------------------------------------------------*) + fun isNms c = if c<0wx4000 then inCharClass(c,nmsClass) + else + c>=0wx4E00 andalso c<=0wx9FA5 orelse + c>=0wxAC00 andalso c<=0wxD7A3 + + (*--------------------------------------------------------------------*) + (* is a character a name char? *) + (*--------------------------------------------------------------------*) + fun isName c = if c<0wx4000 then inCharClass(c,nameClass) + else + c>=0wx4E00 andalso c<=0wx9FA5 orelse + c>=0wxAC00 andalso c<=0wxD7A3 + + (*--------------------------------------------------------------------*) + (* is a character a pubid char? *) + (*--------------------------------------------------------------------*) + fun isPubid c = c<0wx80 andalso inCharClass(c,pubClass) + + (*--------------------------------------------------------------------*) + (* is a character valid in an encoding name, at its start, or in a *) + (* version number? *) + (*--------------------------------------------------------------------*) + fun isEnc c = + c<0wx80 andalso inCharClass(c,encClass) + fun isEncS (c:UniChar.Char) = + c>=0wx41 andalso c<=0wx5A orelse + c>=0wx61 andalso c<=0wx7A + fun isVers c = + isEnc c orelse c=0wx3A (* #":" *) + + (*--------------------------------------------------------------------*) + (* these are the valid Unicode characters (including surrogates). *) + (*--------------------------------------------------------------------*) + fun isUnicode (c:UniChar.Char) = c<=0wx10FFFF + + (*--------------------------------------------------------------------*) + (* XML characters if not checked for Unicode char in advance. *) + (*--------------------------------------------------------------------*) + fun isXml (c:UniChar.Char) = + c>=0wx0020 andalso c<=0wxD7FF orelse + c>=0wxE000 andalso c<=0wxFFFD orelse + c>=0wx10000 andalso c<=0wx10FFFF orelse + c=0wx9 orelse c=0wxA orelse c=0wxD + + (*--------------------------------------------------------------------*) + (* the frontend supresses 0wxD (carriage return), but its is still *) + (* present when encoding is recognized. *) + (*--------------------------------------------------------------------*) + fun isS (c:UniChar.Char) = + case c + of 0wx09 => true + | 0wx0A => true + | 0wx0D => true + | 0wx20 => true + | _ => false + + (*--------------------------------------------------------------------*) + (* is this character an ascii decimal/hexadecimal digit? *) + (*--------------------------------------------------------------------*) + fun isDec (c:UniChar.Char) = + c>=0wx30 andalso c<=0wx39 + fun isHex (c:UniChar.Char) = + c>=0wx30 andalso c<=0wx39 orelse + c>=0wx41 andalso c<=0wx46 orelse + c>=0wx61 andalso c<=0wx66 + + (*--------------------------------------------------------------------*) + (* calculate the decimal/hexadecimal value of an ascii (hex-)digit. *) + (*--------------------------------------------------------------------*) + fun decValue (c:UniChar.Char) = + let val v = c-0wx30 + in if v<=0wx9 then SOME v else NONE + end + fun hexValue (c:UniChar.Char) = + let val v = c-0wx30 + in if v<=0wx9 then SOME v + else (if c>=0wx41 andalso c<=0wx46 then SOME(c-0wx37) + else if c>=0wx61 andalso c<=0wx66 then SOME(c-0wx57) + else NONE) + end + + (*--------------------------------------------------------------------*) + (* is c in [a-z]+[A-Z]? *) + (*--------------------------------------------------------------------*) + fun isAsciiLetter (c:UniChar.Char) = + c>=0wx41 andalso c<=0wx5A orelse + c>=0wx61 andalso c<=0wx7A + end +(* stop of ../../Unicode/Chars/uniClasses.sml *) +(* start of ../../Unicode/Uri/uriDecode.sml *) +signature UriDecode = + sig + val decodeUriLatin : string -> string + val decodeUriUtf8 : string -> string + end + +structure UriDecode : UriDecode = + struct + open UniChar UtilInt + + infix 8 << <<< + infix 7 && + infix 6 || ||| + + val op && = Word8.andb + val op << = Word8.<< + val op <<< = Chars.<< + val op || = Word8.orb + val op ||| = Chars.orb + + val Byte2Char = Chars.fromLargeWord o Word8.toLargeWord + + fun hexValue c = + if #"0"<=c andalso #"9">=c then SOME (Byte.charToByte c-0wx30) + else if #"A"<=c andalso #"F">=c then SOME (Byte.charToByte c-0wx37) + else if #"a"<=c andalso #"f">=c then SOME (Byte.charToByte c-0wx57) + else NONE + + exception Failed of char list + + fun getQuads cs = + case cs + of c1::c2::cs1 => (case (hexValue c1,hexValue c2) + of (SOME b1,SOME b2) => ((b1 << 0w4 || b2),cs1) + | _ => raise Failed cs1) + | _ => raise Failed nil + + (*--------------------------------------------------------------------*) + (* decode UTF-8 *) + (*--------------------------------------------------------------------*) + val byte1switch = Array.array(256,1) (* 1 byte *) + val _ = appInterval (fn i => Array.update(byte1switch,i,0)) (0x80,0xBF) (* Error *) + val _ = appInterval (fn i => Array.update(byte1switch,i,2)) (0xC0,0xDF) (* 2 bytes *) + val _ = appInterval (fn i => Array.update(byte1switch,i,3)) (0xE0,0xEF) (* 3 bytes *) + val _ = appInterval (fn i => Array.update(byte1switch,i,4)) (0xF0,0xF7) (* 4 bytes *) + val _ = appInterval (fn i => Array.update(byte1switch,i,5)) (0xF8,0xFB) (* 5 bytes *) + val _ = appInterval (fn i => Array.update(byte1switch,i,6)) (0xFC,0xFD) (* 6 bytes *) + + val diff2 = 0wx00003080 + val diff3 = diff2 <<< 0wx6 ||| 0wx00020080 + val diff4 = diff3 <<< 0wx6 ||| 0wx00400080 + val diff5 = diff4 <<< 0wx6 ||| 0wx08000080 + val diff6 = diff5 <<< 0wx6 ||| 0wx00000080 + val diffsByLen = Vector.fromList [0w0,0w0,diff2,diff3,diff4,diff5,diff6] + + fun getByte cs = + case cs + of #"%"::cs1 => getQuads cs1 + | c::cs1 => (Byte.charToByte c,cs1) + | nil => raise Failed nil + + fun getBytes(b,cs,n) = + let + fun do_err (cs,m) = + if n do_err(cs,m+1) + val w1 = if b && 0wxC0 = 0wx80 then w <<< 0w6 + Byte2Char b + else do_err(cs1,m+1) + in doit (w1,cs1,m+1) + end + val (w,cs1) = doit (Byte2Char b,cs,2) + val diff = Vector.sub(diffsByLen,n) + val c = w-diff + in + if c<0wx100 then (Char2char c,cs1) + else raise Failed cs1 + end + + fun getCharUtf8 cs = + let val (b,cs1) = getQuads cs + in case Array.sub(byte1switch,Word8.toInt b) + of 0 (* error *) => raise Failed cs1 + | 1 (* 1 byte *) => (Byte.byteToChar b,cs1) + | n (* n bytes *) => getBytes(b,cs1,n) + end + + fun decodeUriUtf8 str = + let + val cs = String.explode str + + fun doit yet nil = yet + | doit yet (c::cs) = + if #"%"<>c then doit (c::yet) cs + else let val (yet1,cs1) = let val (ch,cs1) = getCharUtf8 cs + in (ch::yet,cs1) + end + handle Failed cs => (yet,cs) + in doit yet1 cs1 + end + in + String.implode(rev(doit nil cs)) + end + + (*--------------------------------------------------------------------*) + (* decode Latin *) + (*--------------------------------------------------------------------*) + fun getChar cs = + case cs + of #"%"::cs1 => let val (b,cs2) = getQuads cs1 + in (Byte.byteToChar b,cs2) + end + | c::cs1 => (c,cs1) + | nil => raise Failed nil + + fun decodeUriLatin str = + let + val cs = String.explode str + + fun doit yet nil = yet + | doit yet (c::cs) = + let val (yet1,cs1) = let val (ch,cs1) = getChar cs + in (ch::yet,cs1) + end + handle Failed cs => (yet,cs) + in doit yet1 cs1 + end + in + String.implode(rev(doit nil cs)) + end + end +(* stop of ../../Unicode/Uri/uriDecode.sml *) +(* start of ../../Unicode/Uri/uriEncode.sml *) +signature UriEncode = + sig + val Data2UriUtf8 : UniChar.Data -> string + val Data2UriLatin : UniChar.Data -> string + + val Vector2UriUtf8 : UniChar.Vector -> string + val Vector2UriLatin : UniChar.Vector -> string + + val String2UriUtf8 : string -> string + val String2UriLatin : string -> string + end + +structure UriEncode : UriEncode = + struct + + open UniChar UniClasses + + infix 8 >> >>> + infix 7 && &&& + infix 6 || + + val op && = Word8.andb + val op &&& = Chars.andb + val op >> = Word8.>> + val op >>> = Chars.>> + val op || = Word8.orb + + val Char2Byte = Word8.fromLargeWord o Chars.toLargeWord + + fun encodeCharUtf8 c = + if c<0wx80 then [Char2Byte c] + else if c<0wx800 + then [0wxC0 || Char2Byte(c >>> 0w6), + 0wx80 || Char2Byte(c &&& 0wx3F)] + else if c<0wx10000 + then [0wxE0 || Char2Byte(c >>> 0w12), + 0wx80 || Char2Byte((c >>> 0w6) &&& 0wx3F), + 0wx80 || Char2Byte(c &&& 0wx3F)] + else if c<0wx200000 + then [0wxF0 || Char2Byte(c >>> 0w18), + 0wx80 || Char2Byte((c >>> 0w12) &&& 0wx3F), + 0wx80 || Char2Byte((c >>> 0w6) &&& 0wx3F), + 0wx80 || Char2Byte(c &&& 0wx3F)] + else if c<0wx4000000 + then [0wxF8 || Char2Byte(c >>> 0w24), + 0wx80 || Char2Byte((c >>> 0w18) &&& 0wx3F), + 0wx80 || Char2Byte((c >>> 0w12) &&& 0wx3F), + 0wx80 || Char2Byte((c >>> 0w6) &&& 0wx3F), + 0wx80 || Char2Byte(c &&& 0wx3F)] + else [0wxFC || Char2Byte(c >>> 0w30), + 0wx80 || Char2Byte((c >>> 0w24) &&& 0wx3F), + 0wx80 || Char2Byte((c >>> 0w18) &&& 0wx3F), + 0wx80 || Char2Byte((c >>> 0w12) &&& 0wx3F), + 0wx80 || Char2Byte((c >>> 0w6) &&& 0wx3F), + 0wx80 || Char2Byte(c &&& 0wx3F)] + + fun Byte2Cc b = + let fun Quad2C b = if b<0wxA then Byte.byteToChar(b+0wx30) else Byte.byteToChar(b+0wx37) + in (Quad2C(b >> 0w4),Quad2C(b && 0wx0F)) + end + + fun precedesHex (i,cv) = + if Vector.length cv <= i+2 then false + else let val (c1,c2) = (Vector.sub(cv,i+1),Vector.sub(cv,i+2)) + in isHex c1 andalso isHex c2 + end + + fun Vector2UriUtf8 cv = + let val revd = Vector.foldli + (fn (i,c,s) => if c<0wx80 andalso (c<>0wx25 orelse precedesHex(i,cv)) + then Char2char c::s + else foldl (fn (b,s) => let val (c1,c2) = Byte2Cc b + in c2::c1:: #"%"::s + end) + s (encodeCharUtf8 c)) + nil (cv,0,NONE) + in String.implode (rev revd) + end + + fun Vector2UriLatin cv = + let val revd = Vector.foldli + (fn (i,c,s) => if c<0wx80 andalso (c<>0wx25 orelse precedesHex(i,cv)) + then Char2char c::s + else (if c>= 0w100 then s + else let val (c1,c2) = Byte2Cc (Char2Byte c) + in c2::c1:: #"%"::s + end)) + nil (cv,0,NONE) + in String.implode (rev revd) + end + + val Data2UriUtf8 = Vector2UriUtf8 o Data2Vector + val Data2UriLatin = Vector2UriLatin o Data2Vector + + val String2UriUtf8 = Vector2UriUtf8 o String2Vector + val String2UriLatin = Vector2UriLatin o String2Vector + end + +(* stop of ../../Unicode/Uri/uriEncode.sml *) +(* start of ../../Unicode/Uri/uri.sml *) +(* +require "basis.__array"; +require "basis.__byte"; +require "basis.__string"; +require "basis.__vector"; +require "basis.__word"; +require "basis.__word8"; + +require "util.unsafe"; +require "util.utilInt"; + +require "chars"; +require "naming"; +*) +signature Uri = + sig + eqtype Uri + + val emptyUri : Uri + + val hashUri : Uri -> word + val compareUri : Uri * Uri -> order + + val uriJoin : Uri * Uri -> Uri + val uriSuffix : Uri -> string + + val Data2Uri : UniChar.Data -> Uri + val Vector2Uri : UniChar.Vector -> Uri + val String2Uri : string -> Uri + val Uri2String : Uri -> string + + val retrieveUri : Uri -> string * string * bool + end + +structure Uri :> Uri = + struct + open UniChar UniClasses UriDecode UriEncode UtilError UtilInt + + (*--------------------------------------------------------------------*) + (* decoding *) + (*--------------------------------------------------------------------*) + type Uri = string + + val emptyUri = "" + + val Vector2Uri = Vector2UriUtf8 + val Data2Uri = Data2UriUtf8 + val String2Uri = String2UriUtf8 + val Uri2String = decodeUriUtf8 + + val slash = "/" + + fun uriSuffix s = + let fun search i = if i<0 then NONE else case String.sub(s,i) + of #"." => SOME i + | #"/" => NONE + | _ => search (i-1) + in case search (String.size s-1) + of NONE => "" + | SOME i => String.extract(s,i+1,NONE) + end + + fun isScheme c = + Char.isAlphaNum c orelse #"+"=c orelse #"-"=c orelse #"."=c + + fun uriAbsolute uri = + let fun search i = + if i>=String.size uri then false + else let val c=String.sub(uri,i) + in if #":"=c then true else if isScheme c then search (i+1) + else false + end + in + if uri="" then false + else if Char.isAlpha (String.sub(uri,0)) then search 1 + else false + end + fun uriRelative uri = not (uriAbsolute uri) + + fun uriLocal uri = + if String.isPrefix "file:" uri + then SOME(String.extract(uri,5,NONE)) + else if uriRelative uri then SOME uri + else NONE + + fun uriPath s = + let + fun search (i,hadSlash) = + if i<0 then if hadSlash then SOME 0 else NONE + else case String.sub(s,i) + of #"/" => if hadSlash then NONE else search(i-1,true) + | _ => if hadSlash then SOME(i+1) else search(i-1,false) + val len = String.size s + val posOpt = search(len-1,false) + in case posOpt + of NONE => emptyUri + | SOME i => if i=0 then slash + else String.extract(s,0,SOME(i+1)) + end + + fun uriAuth uri = + let + fun searchScheme i = + if i>=String.size uri then NONE + else let val c=String.sub(uri,i) + in if #":"=c then SOME i else if isScheme c then searchScheme (i+1) + else NONE + end + fun searchSlash i = + if i>=String.size uri then NONE + else let val c=String.sub(uri,i) + in if #"/"=c then SOME i else searchSlash (i+1) + end + in + if uri="" then "" + else if not (Char.isAlpha(String.sub(uri,0))) then "" + else case searchScheme 1 + of NONE => "" + | SOME i => + if String.size uri<=i+2 then String.extract(uri,0,SOME(i+1)) + else if #"/"=String.sub(uri,i+1) andalso #"/"=String.sub(uri,i+2) + then case searchSlash (i+3) + of NONE => uri + | SOME j => String.extract(uri,0,SOME j) + else String.extract(uri,0,SOME(i+1)) + end + + fun uriScheme uri = + let + fun searchScheme i = + if i>=String.size uri then NONE + else let val c=String.sub(uri,i) + in if #":"=c then SOME i else if isScheme c then searchScheme (i+1) + else NONE + end + in + if uri="" then "" + else if not (Char.isAlpha(String.sub(uri,0))) then "" + else case searchScheme 1 + of NONE => "" + | SOME i => String.extract(uri,0,SOME(i+1)) + end + + fun uriJoin(abs,rel) = + if rel="" then uriPath abs + else if abs="" then rel + else if String.isPrefix "//" rel then uriScheme abs^rel + else if #"/"=String.sub(rel,0) then uriAuth abs^rel + else if uriAbsolute rel then rel + else uriPath abs^rel + + val compareUri = String.compare + val hashUri = UtilHash.hashString + + fun convertCommand str (src,dst) = + let + val s = Substring.all str + fun doit ss s = + if Substring.isEmpty s then ss + else let val (sl,sr) = Substring.splitr (fn c => #"%"<>c) s + in if Substring.isEmpty sl then sr::ss + else let val sl' = Substring.trimr 1 sl + in case Substring.first sr + of SOME #"1" => let val sr' = Substring.triml 1 sr + in doit (Substring.all src::sr'::ss) sl' + end + | SOME #"2" => let val sr' = Substring.triml 1 sr + in doit (Substring.all dst::sr'::ss) sl' + end + | _ => doit (Substring.all "%"::sr::ss) sl' + end + end + val ss = doit nil s + val s = Substring.concat ss + in s + end + + fun retrieveRemote uri = + let + val tmp = OS.FileSys.tmpName() + val cmd = convertCommand Config.retrieveCommand (uri,tmp) + val status = OS.Process.system cmd + val _ = if status = OS.Process.success then () + else let val _ = (OS.FileSys.remove tmp + handle OS.SysErr _ => ()) + val cmd = convertCommand + Config.retrieveCommand ("",tmp) + in raise NoSuchFile (uri,"command '"^cmd^"' failed") + end + in (Uri2String uri,tmp,true) + end + + fun retrieveUri uri = + case uriLocal uri + of SOME f => (Uri2String uri,Uri2String f,false) + | NONE => retrieveRemote uri + end +(* stop of ../../Unicode/Uri/uri.sml *) +(* start of ../../Parser/version.sml *) +structure Version = + struct + val FXP_VERSION = "1.4.4" + end +(* stop of ../../Parser/version.sml *) +(* start of ../../Util/utilList.sml *) + + + +(*--------------------------------------------------------------------------*) +(* Structure: UtilList *) +(* *) +(* Depends on: *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* member : none *) +(* findAndDelete : none *) +(*--------------------------------------------------------------------------*) +signature UtilList = + sig + val split : ('a -> bool) -> 'a list -> 'a list list + val member : ''a -> ''a list -> bool + val mapAllPairs : ('a * 'b -> 'c) -> 'a list * 'b list -> 'c list + val findAndMap : ('a -> 'b option) -> 'a list -> 'b option + val findAndDelete : ('a -> bool) -> 'a list -> ('a option * 'a list) + + val sort : ('a * 'a -> order) -> 'a list -> 'a list + val merge : ('a * 'a -> order) -> 'a list * 'a list -> 'a list + val diff : ('a * 'a -> order) -> 'a list * 'a list -> 'a list + val cap : ('a * 'a -> order) -> 'a list * 'a list -> 'a list + val sub : ('a * 'a -> order) -> 'a list * 'a list -> bool + val insert : ('a * 'a -> order) -> 'a * 'a list -> 'a list + val delete : ('a * 'a -> order) -> 'a * 'a list -> 'a list + val elem : ('a * 'a -> order) -> 'a * 'a list -> bool + end + +structure UtilList : UtilList = + struct + (*--------------------------------------------------------------------*) + (* split a list into a list of lists at each element fullfilling p. *) + (*--------------------------------------------------------------------*) + fun split p l = + let val (one,ls) = foldr + (fn (a,(curr,ls)) => if p a then (nil,curr::ls) else (a::curr,ls)) + (nil,nil) l + in one::ls + end + + (*--------------------------------------------------------------------*) + (* is x a member of l? *) + (*--------------------------------------------------------------------*) + fun member x l = List.exists (fn y => x=y) l + + (*--------------------------------------------------------------------*) + (* for [a1,...,an] and [b1,...,bk], generate *) + (* [f(a1,b1),f(a1,b2),...,f(an,bk-1),f(an,bk)]. *) + (*--------------------------------------------------------------------*) + fun mapAllPairs f (ass,bs) = + foldr + (fn (a,cs) => foldr (fn (b,cs) => f(a,b)::cs) cs bs) + nil ass + + (*--------------------------------------------------------------------*) + (* find the first element x of l such that f x = SOME y, and return *) + (* f x. If there is no such x, return NONE. *) + (*--------------------------------------------------------------------*) + fun findAndMap _ nil = NONE + | findAndMap f (x::xs) = case f x of NONE => findAndMap f xs | y => y + + (*--------------------------------------------------------------------*) + (* find the first element x of l such that f x = true, delete it from *) + (* l, and return SOME x with the modified list. If there is no such x *) + (* return (NONE,l). *) + (*--------------------------------------------------------------------*) + fun findAndDelete _ nil = (NONE,nil) + | findAndDelete f (x::xs) = + if f x then (SOME x,xs) + else let val (y,ys) = findAndDelete f xs in (y,x::ys) end + + (*--------------------------------------------------------------------*) + (* given a function that compares elements, merge two sorted lists. *) + (*--------------------------------------------------------------------*) + fun merge comp (l1,l2) = + let + fun go (nil,l) = l + | go (l,nil) = l + | go (l1 as (x1::r1),l2 as (x2::r2)) = + case comp(x1,x2) + of LESS => x1::go(r1,l2) + | EQUAL => go(l1,r2) + | GREATER => x2::go(l1,r2) + in go(l1,l2) + end + + (*--------------------------------------------------------------------*) + (* given a comparing function, compute the intersection of two *) + (* ordered lists. *) + (*--------------------------------------------------------------------*) + fun cap comp (l1,l2) = + let + fun go (nil,l) = nil + | go (l,nil) = nil + | go (l1 as (x1::r1),l2 as (x2::r2)) = + case comp(x1,x2) + of LESS => go(r1,l2) + | EQUAL => x1::go(r1,r2) + | GREATER => go(l1,r2) + in go(l1,l2) + end + + (*--------------------------------------------------------------------*) + (* given a comparing function, compute the difference of two *) + (* ordered lists. *) + (*--------------------------------------------------------------------*) + fun diff comp (l1,l2) = + let + fun go (nil,l) = nil + | go (l,nil) = l + | go (l1 as (x1::r1),l2 as (x2::r2)) = + case comp(x1,x2) + of LESS => x1::go(r1,l2) + | EQUAL => go(r1,r2) + | GREATER => go(l1,r2) + in go(l1,l2) + end + + (*--------------------------------------------------------------------*) + (* given a comparing function, find out whether an ordered list is *) + (* contained in an other ordered list. *) + (*--------------------------------------------------------------------*) + fun sub comp (l1,l2) = + let + fun go (nil,l) = true + | go (l,nil) = false + | go (l1 as (x1::r1),l2 as (x2::r2)) = + case comp(x1,x2) + of LESS => false + | EQUAL => go(r1,r2) + | GREATER => go(l1,r2) + in go(l1,l2) + end + + (*--------------------------------------------------------------------*) + (* given a function that compares elements, insert an element into an *) + (* ordered list. *) + (*--------------------------------------------------------------------*) + fun insert comp (x,l) = + let + fun go nil = [x] + | go (l as y::ys) = + case comp(x,y) + of LESS => x::l + | EQUAL => l + | GREATER => y::go ys + in go l + end + + (*--------------------------------------------------------------------*) + (* given a function that compares elements, delete an element from *) + (* an ordered list. *) + (*--------------------------------------------------------------------*) + fun delete comp (x,l) = + let + fun go nil = [x] + | go (l as y::ys) = + case comp(x,y) + of LESS => l + | EQUAL => ys + | GREATER => y::go ys + in go l + end + + (*--------------------------------------------------------------------*) + (* given a function that compares elements, insert an element into an *) + (* ordered list. *) + (*--------------------------------------------------------------------*) + fun elem comp (x,l) = + let + fun go nil = false + | go (l as y::ys) = + case comp(x,y) + of LESS => false + | EQUAL => true + | GREATER => go ys + in go l + end + + (*--------------------------------------------------------------------*) + (* merge-sort a list of elements comparable with the function in the *) + (* 1st argument. Preserve duplicate elements. *) + (*--------------------------------------------------------------------*) + fun sort _ nil = nil + | sort comp l = + let fun mergeOne (x::y::l) = merge comp (x,y)::mergeOne l + | mergeOne l = l + fun mergeAll [l] = l + | mergeAll ls = mergeAll (mergeOne ls) + val singles = map (fn x => [x]) l + in + mergeAll singles + end + + end + +(* stop of ../../Util/utilList.sml *) +(* start of ../../Parser/Dfa/dfaOptions.sml *) +signature DfaOptions = + sig + val O_DFA_INITIAL_WIDTH : int ref + val O_DFA_MAX_STATES : int ref + val O_DFA_WARN_TOO_LARGE : bool ref + + val setDfaDefaults : unit -> unit + val setDfaOptions : Options.Option list * (string -> unit) -> Options.Option list + + val dfaUsage : Options.Usage + end + +functor DfaOptions () : DfaOptions = + struct + open Options UtilInt + + val O_DFA_INITIAL_WIDTH = ref 4 + val O_DFA_MAX_STATES = ref 256 + val O_DFA_WARN_TOO_LARGE = ref true + + fun setDfaDefaults() = + let + val _ = O_DFA_INITIAL_WIDTH := 4 + val _ = O_DFA_MAX_STATES := 256 + val _ = O_DFA_WARN_TOO_LARGE := true + in () + end + + val dfaUsage = + [U_ITEM(["--dfa-initial-size=n"],"Initial size of DFA transition tables (16)"), + U_ITEM(["--dfa-initial-width=n"],"Same as --dfa-initial-size=2^n (4)"), + U_ITEM(["--dfa-max-size=n"],"Maximal size of DFAs for ambiguous content models (256)"), + U_ITEM(["--dfa-warn-size[=(yes|no)]"],"Warn about too large DFAs (yes)") + ] + + fun setDfaOptions(opts,doError) = + let + exception Failed of string option + + fun getNat str = + if str="" then raise Failed NONE + else let val cs = String.explode str + in foldl (fn (c,n) => if #"0">c orelse #"9" raise Failed + (SOME("number "^str^" is too large for this system")) + end + + val yesNo = "'yes' or 'no'" + fun tooLarge n = String.concat ["number ",n," is too large for this system"] + fun mustHave key = String.concat ["option --",key," must have an argument"] + fun mustBe key what = String.concat + ["the argument to option --",key," must be ",what] + + fun do_yesno(key,valOpt,flag) = + case valOpt + of NONE => flag := true + | SOME "yes" => flag := true + | SOME "no" => flag := false + | SOME s => doError (mustBe key yesNo) + + fun do_num(key,valOpt,flag) = + case valOpt + of NONE => doError (mustHave key) + | SOME s => flag := getNat s + handle Failed NONE => doError (mustBe key "a number") + | Failed (SOME s) => doError s + + fun do_dfa_ts(key,valOpt,toWidth) = + case valOpt + of NONE => doError (mustHave key) + | SOME s => O_DFA_INITIAL_WIDTH := toWidth (getNat s) + handle Failed NONE => doError (mustBe key "a number") + | Failed (SOME s) => doError s + + fun do_long(key,valOpt) = + case key + of "dfa-initial-size" => true before do_dfa_ts(key,valOpt,nextPowerTwo) + | "dfa-initial-width" => true before do_dfa_ts(key,valOpt,fn i => i) + | "dfa-max-size" => true before do_num(key,valOpt,O_DFA_MAX_STATES) + | "dfa-warn-size" => true before do_yesno(key,valOpt,O_DFA_WARN_TOO_LARGE) + | _ => false + + and doit nil = nil + | doit (opt::opts) = + case opt + of OPT_NOOPT => opts + | OPT_LONG(key,value) => if do_long(key,value) then doit opts + else opt::doit opts + | OPT_NEG _ => opt::doit opts + | OPT_SHORT _ => opt::doit opts + | OPT_STRING _ => opt::doit opts + in doit opts + end + end + + +(* stop of ../../Parser/Dfa/dfaOptions.sml *) +(* start of ../../Parser/Params/parserOptions.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: ParserOptions *) +(* *) +(* Depends on: none *) +(*--------------------------------------------------------------------------*) +signature ParserOptions = + sig + structure DfaOptions : DfaOptions + + val O_CHECK_ISO639 : bool ref + val O_CHECK_LANGID : bool ref + val O_CHECK_PREDEFINED : bool ref + val O_CHECK_RESERVED : bool ref + val O_CHECK_VERSION : bool ref + + val O_WARN_MULT_ENUM : bool ref + val O_WARN_XML_DECL : bool ref + val O_WARN_ATT_NO_ELEM : bool ref + val O_WARN_MULT_ENT_DECL : bool ref + val O_WARN_MULT_NOT_DECL : bool ref + val O_WARN_MULT_ATT_DEF : bool ref + val O_WARN_MULT_ATT_DECL : bool ref + val O_WARN_SHOULD_DECLARE : bool ref + val O_WARN_NON_ASCII_URI : bool ref + + val O_ERROR_MINIMIZE : bool ref + + val O_VALIDATE : bool ref + val O_COMPATIBILITY : bool ref + val O_INTEROPERABILITY : bool ref + + val O_INCLUDE_EXT_PARSED : bool ref + val O_INCLUDE_PARAM_ENTS : bool ref + + val setParserDefaults : unit -> unit + val setParserOptions : Options.Option list * (string -> unit) -> Options.Option list + + val parserUsage : Options.Usage + end + +functor ParserOptions () : ParserOptions = + struct + structure DfaOptions = DfaOptions () + + open DfaOptions Options UtilInt UtilList + + val O_CHECK_VERSION = ref true (* check for conforming xml version? *) + val O_CHECK_ISO639 = ref true (* check whether a two-letter LangCode *) + (* is acording to ISO 639? *) + val O_CHECK_LANGID = ref true (* check whether a LangCode fullfills *) + (* IETF RFC 1766? *) + val O_CHECK_RESERVED = ref false(* check for names starting with xml? *) + val O_CHECK_PREDEFINED = ref true (* check declarations of predefined *) + val O_WARN_MULT_ENUM = ref true (* check whether a token occurs *) + (* twice in the enumerated attribute *) + (* types of the same element *) + val O_WARN_XML_DECL = ref false (* warn if the XML decl is missing? *) + + val O_WARN_ATT_NO_ELEM = ref true (* warn for undeclared elements *) + (* in att def list declarations? *) + + val O_WARN_MULT_ENT_DECL = ref true (* warn about redefined entities *) + val O_WARN_MULT_NOT_DECL = ref true (* warn about redefined notations*) + val O_WARN_SHOULD_DECLARE = ref true (* warn if predefined entities *) + (* are not declared in the dtd *) + + val O_WARN_MULT_ATT_DEF = ref true (* warn if an attributes is defd *) + (* twice for the same element? *) + val O_WARN_MULT_ATT_DECL = ref true (* warn if there are multiple att *) + (* def lists for one element? *) + val O_WARN_NON_ASCII_URI = ref true (* warn about non-ascii chars in *) + (* system identifiers? *) + + val O_ERROR_MINIMIZE = ref true (* try to avoid repeating errors? *) + + val O_VALIDATE = ref true + val O_COMPATIBILITY = ref true + val O_INTEROPERABILITY = ref false + + val O_INCLUDE_EXT_PARSED = ref false + val O_INCLUDE_PARAM_ENTS = ref false + + fun setParserDefaults() = + let + val _ = setDfaDefaults() + + val _ = O_CHECK_ISO639 := false + val _ = O_CHECK_LANGID := false + val _ = O_CHECK_PREDEFINED := true + val _ = O_CHECK_RESERVED := false + val _ = O_CHECK_VERSION := true + + val _ = O_WARN_MULT_ENUM := true + val _ = O_WARN_XML_DECL := false + val _ = O_WARN_ATT_NO_ELEM := false + val _ = O_WARN_MULT_ENT_DECL := false + val _ = O_WARN_MULT_NOT_DECL := false + val _ = O_WARN_MULT_ATT_DEF := false + val _ = O_WARN_MULT_ATT_DECL := false + val _ = O_WARN_SHOULD_DECLARE := true + val _ = O_WARN_NON_ASCII_URI := true + + val _ = O_VALIDATE := true + val _ = O_COMPATIBILITY := true + val _ = O_INTEROPERABILITY := false + + val _ = O_ERROR_MINIMIZE := true + + val _ = O_INCLUDE_EXT_PARSED := false + val _ = O_INCLUDE_PARAM_ENTS := false + in () + end + + val parserUsage = + [U_ITEM(["-[n]v","--validate[=(yes|no)]"],"Turn on or off validation (yes)"), + U_ITEM(["-[n]c","--compat[=(yes|no)]","--compatibility[=(yes|no)]"], + "Turn on or off compatibility checking (yes)"), + U_ITEM(["-[n]i","--interop[=(yes|no)]","--interoperability[=(yes|no)]"], + "Turn on or off interoperability checking (no)"), + U_SEP, + U_ITEM(["--few-errors[=(yes|no)]"],"Report fewer errors (no)"), + U_ITEM(["--check-reserved[=(yes|no)]"], + "Checking for reserved names (no)"), + U_ITEM(["--check-predef[=(yes|no)]","--check-predefined[=(yes|no)]"], + "Check declaration of predefined entities (yes)"), + U_ITEM(["--check-lang-id[=(yes|no)]"],"Checking language identifiers (no)"), + U_ITEM(["--check-iso639[=(yes|no)]"],"Check ISO 639 language codes (no)"), + U_ITEM(["--check-xml-version[=(yes|no)]"], "Check XML version number (yes)"), + U_SEP, + U_ITEM(["--warn-xml-decl[=(yes|no)]"],"Warn if there is no XML declaration (no)"), + U_ITEM(["--warn-att-elem[=(yes|no)]"], + "Warn about attlist declarations for undeclared elements (no)"), + U_ITEM(["--warn-predefined[=(yes|no)]"], + "Warn if the predefined entities are not declared (no)"), + U_ITEM(["--warn-mult-decl[=]"],"Warn about multiple declarations (none)"), + U_ITEM(["--warn-uri[=(yes|no)]"],"Warn about non-ASCII characters in URIs (yes)"), + U_ITEM(["--warn[=all]"],"Warn about nearly everything"), + U_ITEM(["--warn=none"],"Do not print warnings"), + U_SEP, + U_ITEM(["--include-ext[=(yes|no)]","--include-external[=(yes|no)]"], + "Include external entities in non-validating mode (no)"), + U_ITEM(["--include-par[=(yes|no)]","--include-parameter[=(yes|no)]"], + "Include parameter entities and external subset in "^ + "non-validating mode (no)"), + U_SEP] + @dfaUsage + + fun setParserOptions(opts,doError) = + let + datatype What = ATT | ATTLIST | ENT | NOT + + exception Failed of string option + + fun getNat str = + if str="" then raise Failed NONE + else let val cs = String.explode str + in foldl (fn (c,n) => if #"0">c orelse #"9" raise Failed + (SOME("number "^str^" is too large for this system")) + end + + val allNone = "'all' or 'none'" + val yesNo = "'yes' or 'no'" + val yesNoWhat = "'yes', 'no' or a list of 'att', 'attlist', 'ent' and 'not'" + fun errorMustBe(key,what) = doError + (String.concat ["the argument to option --",key," must be ",what]) + fun errorNoArg key = doError + (String.concat ["option --",key," has no argument"]) + + fun do_mult_decl(key,valOpt) = + let + val all = [ATT,ATTLIST,ENT,NOT] + fun setFlags whats = app (fn (what,flag) => flag := member what whats) + [(ATT,O_WARN_MULT_ATT_DEF),(ATTLIST,O_WARN_MULT_ATT_DECL), + (ENT,O_WARN_MULT_ENT_DECL),(NOT,O_WARN_MULT_NOT_DECL)] + in case valOpt + of NONE => setFlags all + | SOME "yes" => setFlags all + | SOME "no" => setFlags nil + | SOME s => let val fields = String.fields (fn c => #","=c) s + val whats = map + (fn s => case s + of "att" => ATT + | "attlist" => ATTLIST + | "ent" => ENT + | "not" => NOT + | _ => raise Failed NONE) fields + in setFlags whats + end + handle Failed _ => errorMustBe(key,yesNoWhat) + end + + fun do_noarg(key,valOpt,flag) = + case valOpt + of NONE => flag := true + | SOME _ => errorNoArg key + + fun do_yesno(key,valOpt,flag) = + case valOpt + of NONE => flag := true + | SOME "yes" => flag := true + | SOME "no" => flag := false + | SOME s => errorMustBe(key,yesNo) + + fun do_num(key,valOpt,flag) = + case valOpt + of NONE => errorMustBe(key,"a number") + | SOME s => flag := getNat s + handle Failed NONE => errorMustBe(key,"a number") + | Failed (SOME s) => doError s + + fun do_warn(key,valOpt) = + let val all = [O_WARN_MULT_ENUM,O_WARN_ATT_NO_ELEM, + O_WARN_MULT_ENT_DECL,O_WARN_MULT_NOT_DECL,O_WARN_MULT_ATT_DEF, + O_WARN_MULT_ATT_DECL,O_WARN_SHOULD_DECLARE,O_WARN_XML_DECL] + fun setFlags value = app (fn flag => flag := value) all + in case valOpt + of NONE => setFlags true + | SOME "all" => setFlags true + | SOME "none" => setFlags false + | SOME _ => errorMustBe(key,allNone) + end + + fun do_long(key,valOpt) = + case key + of "validate" => true before do_yesno(key,valOpt,O_VALIDATE) + | "compat" => true before do_yesno(key,valOpt,O_COMPATIBILITY) + | "compatibility" => true before do_yesno(key,valOpt,O_COMPATIBILITY) + | "interop" => true before do_yesno(key,valOpt,O_INTEROPERABILITY) + | "interoperability" => true before do_yesno(key,valOpt,O_INTEROPERABILITY) + + | "few-errors" => true before do_yesno(key,valOpt,O_ERROR_MINIMIZE) + + | "check-reserved" => true before do_yesno(key,valOpt,O_CHECK_RESERVED) + | "check-predef" => true before do_yesno(key,valOpt,O_CHECK_PREDEFINED) + | "check-predefined" => true before do_yesno(key,valOpt,O_CHECK_PREDEFINED) + | "check-lang-id" => true before do_yesno(key,valOpt,O_CHECK_LANGID) + | "check-iso639" => true before do_yesno(key,valOpt,O_CHECK_ISO639) + | "check-xml-version" => true before do_yesno(key,valOpt,O_CHECK_VERSION) + + | "warn" => true before do_warn(key,valOpt) + | "warn-xml-decl" => true before do_yesno(key,valOpt,O_WARN_XML_DECL) + | "warn-att-elem" => true before do_yesno(key,valOpt,O_WARN_ATT_NO_ELEM) + | "warn-predefined" => true before do_yesno(key,valOpt,O_WARN_SHOULD_DECLARE) + | "warn-mult-decl" => true before do_mult_decl(key,valOpt) + | "warn-uri" => true before do_yesno(key,valOpt,O_WARN_NON_ASCII_URI) + + | "include-ext" => true before do_yesno(key,valOpt,O_INCLUDE_EXT_PARSED) + | "include-external" => true before do_yesno(key,valOpt,O_INCLUDE_EXT_PARSED) + | "include-par" => true before do_yesno(key,valOpt,O_INCLUDE_PARAM_ENTS) + | "include-parameter" => true before do_yesno(key,valOpt,O_INCLUDE_PARAM_ENTS) + + | _ => false + + fun do_short cs = + let fun doOne c = + case c + of #"v" => false before O_VALIDATE := true + | #"c" => false before O_COMPATIBILITY := true + | #"i" => false before O_INTEROPERABILITY := true + | _ => true + in List.filter doOne cs + end + + fun do_neg cs = + let fun doOne c = + case c + of #"v" => false before O_VALIDATE := false + | #"c" => false before O_COMPATIBILITY := false + | #"i" => false before O_INTEROPERABILITY := false + | _ => true + in List.filter doOne cs + end + + and doit nil = nil + | doit (opt::opts) = + case opt + of OPT_NOOPT => opts + | OPT_LONG(key,value) => if do_long(key,value) then doit opts + else opt::doit opts + | OPT_SHORT cs => (case do_short cs + of nil => doit opts + | rest => OPT_SHORT rest::doit opts) + | OPT_NEG cs => (case do_neg cs + of nil => doit opts + | rest => OPT_NEG rest::doit opts) + | OPT_STRING s => opt::doit opts + + val opts1 = setDfaOptions (opts,doError) + in + doit opts1 + end + end +(* stop of ../../Parser/Params/parserOptions.sml *) +(* start of ../../Util/intLists.sml *) +signature IntLists = + sig + type IntList = int list + + val emptyIntList : IntList + val singleIntList : int -> IntList + val fullIntList : int -> IntList + + val isEmptyIntList : IntList -> bool + val inIntList : int * IntList -> bool + val subIntList : IntList * IntList -> bool + + val compareIntLists: IntList * IntList -> order + val hashIntList : IntList -> word + + val addIntList : int * IntList -> IntList + val delIntList : int * IntList -> IntList + + val cupIntLists : IntList * IntList -> IntList + val capIntLists : IntList * IntList -> IntList + val diffIntLists : IntList * IntList -> IntList + + val IntList2String : IntList -> string + end + +structure IntLists : IntLists = + struct + open UtilCompare UtilHash UtilInt UtilList UtilString + + type IntList = int list + + val emptyIntList = nil : IntList + + fun fullIntList n = intervalList(0,n) + fun singleIntList n = [n] + val isEmptyIntList = null + + val inIntList = elem Int.compare + val subIntList = sub Int.compare + val addIntList = insert Int.compare + val delIntList = delete Int.compare + val capIntLists = cap Int.compare + val cupIntLists = merge Int.compare + val diffIntLists = diff Int.compare + val compareIntLists = compareList Int.compare + val hashIntList = hashList hashInt + + val IntList2String = List2String Int.toString + end +(* stop of ../../Util/intLists.sml *) +(* start of ../../Unicode/Chars/dataDict.sml *) + + + + + + + + +structure KeyData : Key = + struct + type Key = UniChar.Data + + val null = UniChar.nullData + val hash = UniChar.hashData + val compare = UniChar.compareData + val toString = UniChar.Data2String + end + +structure DataDict = Dict (structure Key = KeyData) +structure DataSymTab = SymTable (structure Key = KeyData) + + +(* stop of ../../Unicode/Chars/dataDict.sml *) +(* start of ../../Parser/Dfa/dfaData.sml *) + + + +(*--------------------------------------------------------------------------*) +(* Structure: DfaData *) +(* *) +(* Depends on: *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* boundsFollow : none *) +(* mergeFirst : ConflictFirst *) +(* mergeFollow : ConflictFollow *) +(*--------------------------------------------------------------------------*) +signature DfaData = + sig + type Dfa + + datatype ContentModel = + CM_ELEM of int + | CM_OPT of ContentModel + | CM_REP of ContentModel + | CM_PLUS of ContentModel + | CM_ALT of ContentModel list + | CM_SEQ of ContentModel list + end + +structure DfaBase = + struct + (*--- visible to the parser ---*) + datatype ContentModel = + CM_ELEM of int + | CM_OPT of ContentModel + | CM_REP of ContentModel + | CM_PLUS of ContentModel + | CM_ALT of ContentModel list + | CM_SEQ of ContentModel list + + type Sigma = int + type State = int + + val dfaDontCare = ~2 + val dfaError = ~1 + val dfaInitial = 0 + + exception DfaTooLarge of int + exception Ambiguous of Sigma * int * int + exception ConflictFirst of Sigma * State * State + exception ConflictFollow of Sigma * State * State + + type Empty = bool + type First = (State * Sigma) list + type Follow = First + + type Info = State * Empty * First + + datatype CM' = + ELEM of Sigma + | OPT of CM + | REP of CM + | PLUS of CM + | ALT of CM list + | SEQ of CM list + withtype CM = CM' * Info + + type Row = Sigma * Sigma * State vector * bool + val nullRow : Row = (1,0,Vector.fromList nil,false) + + type Dfa = Row vector + + val emptyDfa : Dfa = Vector.fromList [(1,0,Vector.fromList nil,true)] + end + +structure DfaData = DfaBase : DfaData +(* stop of ../../Parser/Dfa/dfaData.sml *) +(* start of ../../Unicode/Decode/decodeFile.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: DecodeBasic *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* closeFile : none *) +(* filePos : none *) +(* fileName : none *) +(* nextByte : EndOfFile *) +(* openFile : NoSuchFile *) +(*--------------------------------------------------------------------------*) +signature DecodeFile = + sig + structure Bytes : WORD + + type File + type Byte = Bytes.word + + exception EndOfFile of File + + val Char2Byte : UniChar.Char -> Byte + val Byte2Char : Byte -> UniChar.Char + val Byte2Hex : Byte -> string + + val openFile : Uri.Uri option -> File + val closeFile : File -> unit + + val getByte : File -> Byte * File + val ungetBytes : File * Byte list -> File + + val fileUri : File -> Uri.Uri + val fileName : File -> string + end + +structure DecodeFile : DecodeFile = + struct + open + UniChar Uri UtilError + + structure Bytes = Word8 + type Byte = Bytes.word + + fun Byte2Char b = Chars.fromLargeWord(Bytes.toLargeWord b) + fun Byte2Hex b = + "0x"^UtilString.toUpperString(StringCvt.padLeft #"0" 2 (Bytes.toString b)) + fun Char2Byte c = Bytes.fromLargeWord(Chars.toLargeWord c) + + type instream = TextIO.instream + val closeIn = TextIO.closeIn + val input = TextIO.input + val input1 = TextIO.input1 + val openIn = TextIO.openIn + val stdIn = TextIO.stdIn + + (*--------------------------------------------------------------------*) + (* a file type is stdin or a uri with its string representation and *) + (* the file it is mapped to. *) + (* a file position is a stream, an int position and a file type. *) + (* a file is a file position, a buffer, its size and current index. *) + (*--------------------------------------------------------------------*) + datatype FileType = STD | FNAME of (Uri * string * string * bool) + type FilePos = FileType * instream * int + type File = FilePos * Word8Vector.vector * int * int + + exception EndOfFile of File + val nullVec = Word8Vector.fromList nil + + (*--------------------------------------------------------------------*) + (* return the uri of a file. *) + (*--------------------------------------------------------------------*) + fun fileUri ((typ,_,_),_,_,_) = + case typ + of STD => emptyUri + | FNAME(uri,_,_,_) => uri + (*--------------------------------------------------------------------*) + (* return the uri string name of a file. *) + (*--------------------------------------------------------------------*) + fun fileName ((typ,_,_),_,_,_) = + case typ + of STD => "" + | FNAME(_,str,_,_) => str + (*--------------------------------------------------------------------*) + (* return the uri string and the position in the the file. *) + (*--------------------------------------------------------------------*) + fun filePos ((typ,_,p),_,s,i) = + case typ + of STD => ("",p+i-s) + | FNAME(_,str,_,_) => (str,p+i-s) + + (*--------------------------------------------------------------------*) + (* open a file; report IO errors by raising NoSuchFile. *) + (*--------------------------------------------------------------------*) + fun openFile uriOpt = + let val (typ,stream) = + case uriOpt + of NONE => (STD,stdIn) + | SOME uri => let val (str,fname,tmp) = retrieveUri uri + in (FNAME(uri,str,fname,tmp),openIn fname) + end + handle IO.Io {name,cause,...} + => raise NoSuchFile(name,exnMessage cause) + in ((typ,stream,0),nullVec,0,0) + end + + (*--------------------------------------------------------------------*) + (* close the file; ignore IO errors. *) + (*--------------------------------------------------------------------*) + fun closeStream (typ,stream,_) = + case typ + of STD => () + | FNAME(_,uri,fname,tmp) + => let val _ = closeIn stream handle IO.Io _ => () + val _ = (if tmp andalso OS.FileSys.access(fname,nil) + then OS.FileSys.remove fname else ()) + handle exn as OS.SysErr _ => + TextIO.output(TextIO.stdErr,String.concat + ["Error removing temporary file ",fname,"for URI",uri, + "(",exnMessage exn,")\n"]) + + in () + end + fun closeFile (tsp,_,_,_) = closeStream tsp + + (*--------------------------------------------------------------------*) + (* read a byte from the file; if at the end of buffer, reload it. *) + (* if a reload fails or returns an IO error, raise EndOfFile. --------*) + (*--------------------------------------------------------------------*) + fun getByte (tsp,vec,s,i) = + if i nullVec + val s = Word8Vector.length v + in if s=0 then let val _ = closeStream tsp + in raise EndOfFile(tsp,v,0,0) + end + else (Word8Vector.sub(v,0),((typ,stream,pos+s),v,s,1)) + end + + (*--------------------------------------------------------------------*) + (* un-get some bytes. this should only happen while checking for a *) + (* byte-order mark or xml/text declaration. It should be efficient in *) + (* that case, otherwise might be very space-consuming. *) + (*--------------------------------------------------------------------*) + fun ungetBytes ((tsp,vec,s,i),bs) = + let val len = length bs + in if len<=i then (tsp,vec,s,i-len) + else let val diff = len-i + val vec0 = Word8Vector.fromList(List.take(bs,diff)) + in (tsp,Word8Vector.concat [vec0,vec],s+diff,0) + end + end + end +(* stop of ../../Unicode/Decode/decodeFile.sml *) +(* start of ../../Unicode/Decode/decodeError.sml *) + + + + + +(*--------------------------------------------------------------------------*) +(* Structure: DecodeError *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* decodeMessage : none *) +(*--------------------------------------------------------------------------*) +signature DecodeError = + sig + datatype DecodeError = + ERR_ILLEGAL_CHAR of DecodeFile.Byte * string + | ERR_NON_UNI_UCS4 of UniChar.Char + | ERR_EOF_UCS4 of int * DecodeFile.Byte list + | ERR_NON_DIRECT_UTF7 of DecodeFile.Byte + | ERR_PADDING_UTF7 of UniChar.Char + | ERR_ILLFORMED_UTF8 of DecodeFile.Byte * int * int + | ERR_ILLEGAL_UTF8 of DecodeFile.Byte + | ERR_INVALID_UTF8_SEQ of DecodeFile.Byte list + | ERR_EOF_UTF8 of int * int + | ERR_NON_UNI_UTF8 of UniChar.Char * int + | ERR_EOF_UCS2 of DecodeFile.Byte + | ERR_EOF_UTF16 of DecodeFile.Byte + | ERR_LOW_SURROGATE of UniChar.Char + | ERR_HIGH_SURROGATE of UniChar.Char * UniChar.Char + | ERR_EOF_SURROGATE of UniChar.Char + | ERR_NO_ENC_DECL of string + | ERR_UNSUPPORTED_ENC of string + | ERR_INCOMPATIBLE_ENC of string * string + + val decodeMessage : DecodeError -> string list + + exception DecodeError of DecodeFile.File * bool * DecodeError + end + +structure DecodeError : DecodeError = + struct + open + DecodeFile UtilString UniChar + + datatype DecodeError = + ERR_ILLEGAL_CHAR of DecodeFile.Byte * string + | ERR_NON_UNI_UCS4 of UniChar.Char + | ERR_EOF_UCS4 of int * DecodeFile.Byte list + | ERR_NON_DIRECT_UTF7 of DecodeFile.Byte + | ERR_PADDING_UTF7 of UniChar.Char + | ERR_ILLFORMED_UTF8 of DecodeFile.Byte * int * int + | ERR_ILLEGAL_UTF8 of DecodeFile.Byte + | ERR_INVALID_UTF8_SEQ of DecodeFile.Byte list + | ERR_EOF_UTF8 of int * int + | ERR_NON_UNI_UTF8 of UniChar.Char * int + | ERR_EOF_UCS2 of DecodeFile.Byte + | ERR_EOF_UTF16 of DecodeFile.Byte + | ERR_LOW_SURROGATE of UniChar.Char + | ERR_HIGH_SURROGATE of UniChar.Char * UniChar.Char + | ERR_EOF_SURROGATE of UniChar.Char + | ERR_NO_ENC_DECL of string + | ERR_UNSUPPORTED_ENC of string + | ERR_INCOMPATIBLE_ENC of string * string + + fun Char2Hex c = "0x"^UtilString.toUpperString(StringCvt.padLeft #"0" 4 (Chars.toString c)) + + fun decodeMessage err = + case err + of ERR_ILLEGAL_CHAR(b,what) => + [Byte2Hex b,"is not",prependAnA what,"character"] + + | ERR_NON_UNI_UCS4 c => + ["UCS-4 coded non-Unicode character",Char2Uni c] + | ERR_EOF_UCS4(pos,bytes) => + ["End of file after",Int2String pos,"bytes of UCS-4 character", + "starting with ",List2String0 Byte2Hex bytes] + + | ERR_NON_DIRECT_UTF7 b => + ["Indirect UTF-7 character ",Byte2Hex b,"in non-shifted mode"] + | ERR_PADDING_UTF7 pad => + ["Non-zero padding",Char2Hex pad,"at end of UTF-7 shifted sequence"] + + | ERR_ILLFORMED_UTF8 (b,len,pos) => + [numberNth pos,"byte",Byte2Hex b,"of a",Int2String len^"-byte", + "UTF-8 sequence does not start with bits 10"] + | ERR_ILLEGAL_UTF8 b => + ["Byte",Byte2Hex b,"is neither ASCII nor does it start", + "a valid multi-byte UTF-8 sequence"] + | ERR_EOF_UTF8 (len,pos) => + ["End of file terminates a ",Int2String len^"-byte", + "UTF-8 sequence before the ",numberNth pos,"byte"] + | ERR_NON_UNI_UTF8 (c,len) => + [Int2String len^"-byte UTF-8 sequence decodes to non-Unicode character",Char2Uni c] + | ERR_INVALID_UTF8_SEQ bs => + ["Invalid UTF-8 sequence",List2xString (""," ","") Byte2Hex bs] + + | ERR_EOF_UCS2 b => + ["End of file before second byte of UCS-2 character starting with",Byte2Hex b] + | ERR_EOF_UTF16 b => + ["End of file before second byte of UTF-16 character starting with",Byte2Hex b] + + | ERR_LOW_SURROGATE c => + ["Low surrogate",Char2Uni c,"without preceding high surrogate"] + | ERR_HIGH_SURROGATE (c,c1) => + ["High surrogate",Char2Uni c,"followed by",Char2Uni c1,"instead of low surrogate"] + | ERR_EOF_SURROGATE c => + ["High surrogate",Char2Uni c,"followed by the end of file"] + + | ERR_NO_ENC_DECL auto => + ["Couldn't parse encoding declaration but auto-detected encoding",auto,"required so"] + | ERR_UNSUPPORTED_ENC enc => + ["Unsupported encoding",enc] + | ERR_INCOMPATIBLE_ENC (enc,auto) => + ["Encoding",enc,"is incompatible with auto-detected encoding",auto] + + exception DecodeError of File * bool * DecodeError + end + + +(* stop of ../../Unicode/Decode/decodeError.sml *) +(* start of ../../Unicode/Decode/decodeUtil.sml *) +(* +require "basis.__word"; +require "basis.__word8"; + +require "chars"; +require "decodeBasic"; +require "decodeError"; +*) + +(*--------------------------------------------------------------------------*) +(* Structure: DecodeUtil *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* combineSurrogates : none *) +(* combineUcs4big : none *) +(* combineUcs4little : none *) +(* combineUcs4strangeBig : none *) +(* combineUcs4strangeLittle : none *) +(* combineUtf16big : none *) +(* combineUtf16little : none *) +(* isLowSurrogate : none *) +(* isHighSurrogate : none *) +(* isSurrogate : none *) +(*--------------------------------------------------------------------------*) +signature DecodeUtil = + sig + val isSurrogate : UniChar.Char -> bool + val isLowSurrogate : UniChar.Char -> bool + val isHighSurrogate : UniChar.Char -> bool + val combineSurrogates : UniChar.Char * UniChar.Char -> UniChar.Char + end + +structure DecodeUtil : DecodeUtil = + struct + open UniChar DecodeFile DecodeError + + fun isSurrogate c = Chars.orb(c,0wx7FF)=0wxDFFF + fun isLowSurrogate c = Chars.orb(c,0wx3FF)=0wxDFFF + fun isHighSurrogate c = Chars.orb(c,0wx3FF)=0wxDBFF + fun combineSurrogates(hi,lo) = (hi-0wxD800)*0wx400+lo+0wx2400 : Char + end +(* stop of ../../Unicode/Decode/decodeUtil.sml *) +(* start of ../../Unicode/Decode/decodeUcs2.sml *) + + + + + + + +signature DecodeUcs2 = + sig + val getCharUcs2b : DecodeFile.File -> UniChar.Char * DecodeFile.File + val getCharUcs2l : DecodeFile.File -> UniChar.Char * DecodeFile.File + end + +structure DecodeUcs2 : DecodeUcs2 = + struct + open + UniChar Encoding + DecodeFile DecodeError DecodeUtil + + fun getCharUcs2b f = + let + val (b1,f1) = getByte f + val (b2,f2) = getByte f1 handle exn as EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS2 b1) + val c = Chars.orb(Chars.<<(Byte2Char b1,0w8),Byte2Char b2) + in (c,f2) + end + + fun getCharUcs2l f = + let + val (b1,f1) = getByte f + val (b2,f2) = getByte f1 handle exn as EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS2 b1) + val c = Chars.orb(Chars.<<(Byte2Char b2,0w8),Byte2Char b1) + in (c,f2) + end + end +(* stop of ../../Unicode/Decode/decodeUcs2.sml *) +(* start of ../../Unicode/Decode/decodeMisc.sml *) +signature DecodeMisc = + sig + val getCharAscii : DecodeFile.File -> UniChar.Char * DecodeFile.File + val getCharEbcdic : DecodeFile.File -> UniChar.Char * DecodeFile.File + val getCharEof : DecodeFile.File -> UniChar.Char * DecodeFile.File + val getCharLatin1 : DecodeFile.File -> UniChar.Char * DecodeFile.File + end + +structure DecodeMisc : DecodeMisc = + struct + open + UniChar DecodeFile DecodeError + + fun getCharEof f = raise EndOfFile f + + (*--------------------------------------------------------------------*) + (* ASCII characters must be lower than 0wx80 *) + (*--------------------------------------------------------------------*) + fun getCharAscii f = + let val (b,f1) = getByte f + in if b<0wx80 then (Byte2Char b,f1) + else raise DecodeError(f1,false,ERR_ILLEGAL_CHAR(b,"ASCII")) + end + + (*--------------------------------------------------------------------*) + (* LATIN-1 is the first plane of Unicode. *) + (*--------------------------------------------------------------------*) + fun getCharLatin1 f = let val (b,f1) = getByte f + in (Byte2Char b,f1) + end + + (*--------------------------------------------------------------------*) + (* EBCDIC is mapped to the first plane of Unicode. *) + (*--------------------------------------------------------------------*) + (* according to rfc-1345 (and gnu recode experiments) *) + val ebcdic2latinTab = Vector.fromList + [0wx00,0wx01,0wx02,0wx03,0wx9C,0wx09,0wx86,0wx7F, + 0wx97,0wx8D,0wx8E,0wx0B,0wx0C,0wx0D,0wx0E,0wx0F, + 0wx10,0wx11,0wx12,0wx13,0wx9D,0wx85,0wx08,0wx87, + 0wx18,0wx19,0wx92,0wx8F,0wx1C,0wx1D,0wx1E,0wx1F, + 0wx80,0wx81,0wx82,0wx83,0wx84,0wx0A,0wx17,0wx1B, + 0wx88,0wx89,0wx8A,0wx8B,0wx8C,0wx05,0wx06,0wx07, + 0wx90,0wx91,0wx16,0wx93,0wx94,0wx95,0wx96,0wx04, + 0wx98,0wx99,0wx9A,0wx9B,0wx14,0wx15,0wx9E,0wx1A, + 0wx20,0wxA0,0wxA1,0wxA2,0wxA3,0wxA4,0wxA5,0wxA6, + 0wxA7,0wxA8,0wx5B,0wx2E,0wx3C,0wx28,0wx2B,0wx21, + 0wx26,0wxA9,0wxAA,0wxAB,0wxAC,0wxAD,0wxAE,0wxAF, + 0wxB0,0wxB1,0wx5D,0wx24,0wx2A,0wx29,0wx3B,0wx5E, + 0wx2D,0wx2F,0wxB2,0wxB3,0wxB4,0wxB5,0wxB6,0wxB7, + 0wxB8,0wxB9,0wx7C,0wx2C,0wx25,0wx5F,0wx3E,0wx3F, + 0wxBA,0wxBB,0wxBC,0wxBD,0wxBE,0wxBF,0wxC0,0wxC1, + 0wxC2,0wx60,0wx3A,0wx23,0wx40,0wx27,0wx3D,0wx22, + 0wxC3,0wx61,0wx62,0wx63,0wx64,0wx65,0wx66,0wx67, + 0wx68,0wx69,0wxC4,0wxC5,0wxC6,0wxC7,0wxC8,0wxC9, + 0wxCA,0wx6A,0wx6B,0wx6C,0wx6D,0wx6E,0wx6F,0wx70, + 0wx71,0wx72,0wxCB,0wxCC,0wxCD,0wxCE,0wxCF,0wxD0, + 0wxD1,0wx7E,0wx73,0wx74,0wx75,0wx76,0wx77,0wx78, + 0wx79,0wx7A,0wxD2,0wxD3,0wxD4,0wxD5,0wxD6,0wxD7, + 0wxD8,0wxD9,0wxDA,0wxDB,0wxDC,0wxDD,0wxDE,0wxDF, + 0wxE0,0wxE1,0wxE2,0wxE3,0wxE4,0wxE5,0wxE6,0wxE7, + 0wx7B,0wx41,0wx42,0wx43,0wx44,0wx45,0wx46,0wx47, + 0wx48,0wx49,0wxE8,0wxE9,0wxEA,0wxEB,0wxEC,0wxED, + 0wx7D,0wx4A,0wx4B,0wx4C,0wx4D,0wx4E,0wx4F,0wx50, + 0wx51,0wx52,0wxEE,0wxEF,0wxF0,0wxF1,0wxF2,0wxF3, + 0wx5C,0wx9F,0wx53,0wx54,0wx55,0wx56,0wx57,0wx58, + 0wx59,0wx5A,0wxF4,0wxF5,0wxF6,0wxF7,0wxF8,0wxF9, + 0wx30,0wx31,0wx32,0wx33,0wx34,0wx35,0wx36,0wx37, + 0wx38,0wx39,0wxFA,0wxFB,0wxFC,0wxFD,0wxFE,0wxFF + ] + + fun ebcdic2latin b = Vector.sub(ebcdic2latinTab,Word8.toInt b) + + fun getCharEbcdic f = let val (b,f1) = getByte f + in (ebcdic2latin b,f1) + end + end +(* stop of ../../Unicode/Decode/decodeMisc.sml *) +(* start of ../../Unicode/Decode/decodeUcs4.sml *) + + + + + + + + +signature DecodeUcs4 = + sig + val getCharUcs4b : DecodeFile.File -> UniChar.Char * DecodeFile.File + val getCharUcs4l : DecodeFile.File -> UniChar.Char * DecodeFile.File + val getCharUcs4sb : DecodeFile.File -> UniChar.Char * DecodeFile.File + val getCharUcs4sl : DecodeFile.File -> UniChar.Char * DecodeFile.File + end + +structure DecodeUcs4 : DecodeUcs4 = + struct + open + UniChar UniClasses + DecodeFile DecodeError DecodeUtil + + fun getCharUcs4b f = + let + val (b1,f1) = getByte f + val (b2,f2) = getByte f1 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1])) + val (b3,f3) = getByte f2 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1,b2])) + val (b4,f4) = getByte f3 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1,b2,b3])) + val c = Chars.orb(Chars.orb(Chars.<<(Byte2Char b1,0w24), + Chars.<<(Byte2Char b2,0w16)), + Chars.orb(Chars.<<(Byte2Char b3,0w08), + Byte2Char b4)) + in if isUnicode c then (c,f4) + else raise DecodeError(f4,false,ERR_NON_UNI_UCS4 c) + end + + fun getCharUcs4l f = + let + val (b1,f1) = getByte f + val (b2,f2) = getByte f1 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1])) + val (b3,f3) = getByte f2 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1,b2])) + val (b4,f4) = getByte f3 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1,b2,b3])) + val c = Chars.orb(Chars.orb(Chars.<<(Byte2Char b4,0w24), + Chars.<<(Byte2Char b3,0w16)), + Chars.orb(Chars.<<(Byte2Char b2,0w08), + Byte2Char b1)) + in if isUnicode c then (c,f4) + else raise DecodeError(f4,false,ERR_NON_UNI_UCS4 c) + end + + fun getCharUcs4sb f = + let + val (b1,f1) = getByte f + val (b2,f2) = getByte f1 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1])) + val (b3,f3) = getByte f2 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1,b2])) + val (b4,f4) = getByte f3 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1,b2,b3])) + val c = Chars.orb(Chars.orb(Chars.<<(Byte2Char b2,0w24), + Chars.<<(Byte2Char b1,0w16)), + Chars.orb(Chars.<<(Byte2Char b4,0w08), + Byte2Char b3)) + in if isUnicode c then (c,f4) + else raise DecodeError(f4,false,ERR_NON_UNI_UCS4 c) + end + + fun getCharUcs4sl f = + let + val (b1,f1) = getByte f + val (b2,f2) = getByte f1 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1])) + val (b3,f3) = getByte f2 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1,b2])) + val (b4,f4) = getByte f3 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UCS4(1,[b1,b2,b3])) + val c = Chars.orb(Chars.orb(Chars.<<(Byte2Char b3,0w24), + Chars.<<(Byte2Char b4,0w16)), + Chars.orb(Chars.<<(Byte2Char b1,0w08), + Byte2Char b2)) + in if isUnicode c then (c,f4) + else raise DecodeError(f4,false,ERR_NON_UNI_UCS4 c) + end + end + +(* stop of ../../Unicode/Decode/decodeUcs4.sml *) +(* start of ../../Unicode/Decode/decodeUtf16.sml *) + + + + + + + +signature DecodeUtf16 = + sig + val getCharUtf16b : DecodeFile.File -> UniChar.Char * DecodeFile.File + val getCharUtf16l : DecodeFile.File -> UniChar.Char * DecodeFile.File + end + +structure DecodeUtf16 : DecodeUtf16 = + struct + open + UniChar Encoding + DecodeFile DecodeError DecodeUtil + + fun getCharUtf16b f = + let + val (b1,f1) = getByte f + val (b2,f2) = getByte f1 handle exn as EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF16 b1) + val c = Chars.orb(Chars.<<(Byte2Char b1,0w8),Byte2Char b2) + in + if isSurrogate c then (* Chars.orb(c,0wx7FF)=0wxDFFF *) + if isLowSurrogate c then raise DecodeError(f2,false,ERR_LOW_SURROGATE c) + else let + val (b3,f3) = getByte f2 handle exn as EndOfFile f + => raise DecodeError(f,true,ERR_EOF_SURROGATE c) + val (b4,f4) = getByte f3 handle exn as EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF16 b3) + val c1 = Chars.orb(Chars.<<(Byte2Char b3,0w8),Byte2Char b4) + in if isLowSurrogate c1 then (combineSurrogates(c,c1),f4) + else raise DecodeError(f4,false,ERR_HIGH_SURROGATE(c,c1)) + end + else (c,f2) + end + + fun getCharUtf16l f = + let + val (b1,f1) = getByte f + val (b2,f2) = getByte f1 handle exn as EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF16 b1) + val c = Chars.orb(Chars.<<(Byte2Char b2,0w8),Byte2Char b1) + in + if isSurrogate c then + if isLowSurrogate c then raise DecodeError(f2,false,ERR_LOW_SURROGATE c) + else let + val (b3,f3) = getByte f2 handle exn as EndOfFile f + => raise DecodeError(f,true,ERR_EOF_SURROGATE c) + val (b4,f4) = getByte f3 handle exn as EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF16 b3) + val c1 = Chars.orb(Chars.<<(Byte2Char b4,0w8),Byte2Char b3) + in if isLowSurrogate c1 then (combineSurrogates(c,c1),f4) + else raise DecodeError(f4,false,ERR_HIGH_SURROGATE(c,c1)) + end + else (c,f2) + end + end +(* stop of ../../Unicode/Decode/decodeUtf16.sml *) +(* start of ../../Unicode/Decode/decodeUtf8.sml *) +signature DecodeUtf8 = + sig + val getCharUtf8 : DecodeFile.File -> UniChar.Char * DecodeFile.File + end + +structure DecodeUtf8 : DecodeUtf8 = + struct + open + UniChar UniClasses UtilError UtilInt + DecodeFile DecodeError DecodeUtil + + val THIS_MODULE = "DecodeUtf8" + + infix 8 <<< + infix 7 && + infix 6 ||| + + val op && = Bytes.andb + val op <<< = Chars.<< + val op ||| = Chars.orb + + val byte1switch = Vector.tabulate + (256,fn i => + if i<0x80 then 1 + else if i<0xC0 then 0 + else if i<0xE0 then 2 + else if i<0xF0 then 3 + else if i<0xF8 then 4 + else if i<0xFC then 5 + else if i<0xFE then 6 + else 0) + + val diff2 : Char = 0wx00003080 + val diff3 : Char = diff2 <<< 0wx6 ||| 0wx00020080 + val diff4 : Char = diff3 <<< 0wx6 ||| 0wx00400080 + val diff5 : Char = diff4 <<< 0wx6 ||| 0wx08000080 + val diff6 : Char = diff5 <<< 0wx6 ||| 0wx00000080 + + fun getCharUtf8 f = + let val (b1,f1) = getByte f + in if b1<0wx80 then (Byte2Char b1,f1) + else let val n = Vector.sub(byte1switch,Word8.toInt b1) + in case n + of 0 (* error *) => raise DecodeError(f1,false,ERR_ILLEGAL_UTF8 b1) + | 1 => (Byte2Char b1,f1) + | 2 => + let + val (b2,f2) = getByte f1 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,2)) + in if b2 && 0wxC0 <> 0wx80 + then raise DecodeError(f2,false,ERR_ILLFORMED_UTF8(b2,n,2)) + else let val c = Byte2Char b1 <<< 0w6 + Byte2Char b2 - diff2 + in if c>=0wx80 then (c,f2) + else raise DecodeError(f2,false,ERR_INVALID_UTF8_SEQ [b1,b2]) + end + end + | 3 => + let + val (b2,f2) = getByte f1 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,2)) + val (b3,f3) = getByte f2 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,3)) + in + if b2 && 0wxC0 <> 0wx80 + then raise DecodeError(f3,false,ERR_ILLFORMED_UTF8(b2,n,2)) + else if b3 && 0wxC0 <> 0wx80 + then raise DecodeError(f3,false,ERR_ILLFORMED_UTF8(b2,n,3)) + else let val c = (Byte2Char b1 <<< 0w12 + + Byte2Char b2 <<< 0w06 + + Byte2Char b3 - diff3) + in if c>=0wx800 then (c,f3) + else raise DecodeError + (f3,false,ERR_INVALID_UTF8_SEQ [b1,b2,b3]) + end + end + | 4 => + let + val (b2,f2) = getByte f1 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,2)) + val (b3,f3) = getByte f2 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,3)) + val (b4,f4) = getByte f3 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,4)) + in + if b2 && 0wxC0 <> 0wx80 + then raise DecodeError(f4,false,ERR_ILLFORMED_UTF8(b2,n,2)) + else if b3 && 0wxC0 <> 0wx80 + then raise DecodeError(f4,false,ERR_ILLFORMED_UTF8(b2,n,3)) + else if b4 && 0wxC0 <> 0wx80 + then raise DecodeError(f4,false,ERR_ILLFORMED_UTF8(b2,n,4)) + else let val c = (Byte2Char b1 <<< 0w18 + + Byte2Char b2 <<< 0w12 + + Byte2Char b3 <<< 0w06 + + Byte2Char b4 - diff4) + in + if c>=0wx100000 andalso c<=0wx10FFFF then (c,f4) + else if c<0wx10000 + then raise DecodeError + (f4,false,ERR_INVALID_UTF8_SEQ [b1,b2,b3,b4]) + else raise DecodeError + (f4,false,ERR_NON_UNI_UTF8(c,n)) + end + end + | 5 => + let + val (b2,f2) = getByte f1 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,2)) + val (b3,f3) = getByte f2 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,3)) + val (b4,f4) = getByte f3 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,4)) + val (b5,f5) = getByte f4 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,5)) + in + if b2 && 0wxC0 <> 0wx80 + then raise DecodeError(f5,false,ERR_ILLFORMED_UTF8(b2,n,2)) + else if b3 && 0wxC0 <> 0wx80 + then raise DecodeError(f5,false,ERR_ILLFORMED_UTF8(b2,n,3)) + else if b4 && 0wxC0 <> 0wx80 + then raise DecodeError(f5,false,ERR_ILLFORMED_UTF8(b2,n,4)) + else if b5 && 0wxC0 <> 0wx80 + then raise DecodeError(f5,false,ERR_ILLFORMED_UTF8(b2,n,5)) + else let val c = (Byte2Char b1 <<< 0w24 + + Byte2Char b2 <<< 0w18 + + Byte2Char b3 <<< 0w12 + + Byte2Char b4 <<< 0w06 + + Byte2Char b5 - diff5) + in if c<0wx200000 + then raise DecodeError + (f5,false,ERR_INVALID_UTF8_SEQ [b1,b2,b3,b4,b5]) + else raise DecodeError + (f5,false,ERR_NON_UNI_UTF8(c,n)) + end + end + | 6 => + let + val (b2,f2) = getByte f1 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,2)) + val (b3,f3) = getByte f2 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,3)) + val (b4,f4) = getByte f3 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,4)) + val (b5,f5) = getByte f4 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,5)) + val (b6,f6) = getByte f5 handle EndOfFile f + => raise DecodeError(f,true,ERR_EOF_UTF8(n,6)) + in + if b2 && 0wxC0 <> 0wx80 + then raise DecodeError(f6,false,ERR_ILLFORMED_UTF8(b2,n,2)) + else if b3 && 0wxC0 <> 0wx80 + then raise DecodeError(f6,false,ERR_ILLFORMED_UTF8(b2,n,3)) + else if b4 && 0wxC0 <> 0wx80 + then raise DecodeError(f6,false,ERR_ILLFORMED_UTF8(b2,n,4)) + else if b5 && 0wxC0 <> 0wx80 + then raise DecodeError(f6,false,ERR_ILLFORMED_UTF8(b2,n,5)) + else if b6 && 0wxC0 <> 0wx80 + then raise DecodeError(f6,false,ERR_ILLFORMED_UTF8(b2,n,6)) + else let val c = (Byte2Char b1 <<< 0w30 + + Byte2Char b2 <<< 0w24 + + Byte2Char b3 <<< 0w18 + + Byte2Char b4 <<< 0w12 + + Byte2Char b5 <<< 0w06 + + Byte2Char b6 - diff6) + in if c<0wx4000000 + then raise DecodeError + (f6,false,ERR_INVALID_UTF8_SEQ [b1,b2,b3,b4,b5,b6]) + else raise DecodeError + (f6,false,ERR_NON_UNI_UTF8(c,n)) + end + end + | _ => raise InternalError(THIS_MODULE,"getCharUtf8", + "byte1switch holds "^Int.toString n^ + ">6 for byte "^Bytes.toString b1) + end + end + end +(* stop of ../../Unicode/Decode/decodeUtf8.sml *) +(* start of ../../Unicode/Decode/decode.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: Decode *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* checkEncoding : NoSuchFile *) +(* encCloseFile : none *) +(* encFileName : none *) +(*--------------------------------------------------------------------------*) +signature Decode = + sig + structure Error : DecodeError + + type DecFile + + exception DecEof of DecFile + exception DecError of DecFile * bool * Error.DecodeError + + val decUri : DecFile -> Uri.Uri + val decName : DecFile -> string + val decEncoding : DecFile -> Encoding.Encoding + + val decOpenXml : Uri.Uri option -> DecFile + val decOpenUni : Uri.Uri option * Encoding.Encoding -> DecFile + val decClose : DecFile -> DecFile + + val decCommit : DecFile -> unit + val decSwitch : DecFile * string -> DecFile + + val decGetChar : DecFile -> UniChar.Char * DecFile + val decGetArray : DecFile -> UniChar.Char array -> int * DecFile * Error.DecodeError option + end + +structure Decode : Decode = + struct + structure Error = DecodeError + open + UniChar Encoding Error + DecodeFile DecodeMisc DecodeUcs2 DecodeUcs4 + DecodeUtf16 DecodeUtf8 DecodeUtil + + type DecFile = Encoding * File + exception DecEof of DecFile + exception DecError of DecFile * bool * DecodeError + + (*--------------------------------------------------------------------*) + (* close an encoded entity. *) + (*--------------------------------------------------------------------*) + fun decClose (_,f) = (NOENC,f) before closeFile f + (*--------------------------------------------------------------------*) + (* get the uri string of an encoded entity. *) + (*--------------------------------------------------------------------*) + fun decName (_,f) = fileName f + (*--------------------------------------------------------------------*) + (* get the uri of an encoded entity. *) + (*--------------------------------------------------------------------*) + fun decUri (_,f) = fileUri f + (*--------------------------------------------------------------------*) + (* get the encoding of an encoded entity. *) + (*--------------------------------------------------------------------*) + fun decEncoding (enc,_) = enc + + (*--------------------------------------------------------------------*) + (* commit the auto-detected encoding. *) + (*--------------------------------------------------------------------*) + fun decCommit (enc,f) = + case enc + of UTF8 => () + | UTF16B => () + | UTF16L => () + | _ => raise DecError((enc,f),false,ERR_NO_ENC_DECL(encodingName enc)) + + (*--------------------------------------------------------------------*) + (* change to another - compatible - encoding. *) + (*--------------------------------------------------------------------*) + fun decSwitch ((enc,f),decl) = + let + val decEnc = isEncoding decl + val _ = if decEnc<>NOENC then () + else raise DecError((enc,f),false,ERR_UNSUPPORTED_ENC decl) + val newEnc = switchEncoding(enc,decEnc) + val _ = if decEnc<>NOENC orelse enc=NOENC then () + else raise DecError((enc,f),false,ERR_INCOMPATIBLE_ENC(encodingName enc,decl)) + in (newEnc,f) + end + + (*--------------------------------------------------------------------*) + (* get a character from an encoded entity. *) + (*--------------------------------------------------------------------*) + fun decGetChar (enc,f) = + let val (c,f1) = + case enc + of NOENC => raise EndOfFile f + | ASCII => getCharAscii f + | EBCDIC => getCharEbcdic f + | LATIN1 => getCharLatin1 f + | UCS2B => getCharUcs2b f + | UCS2L => getCharUcs2l f + | UCS4B => getCharUcs4b f + | UCS4L => getCharUcs4l f + | UCS4SB => getCharUcs4sb f + | UCS4SL => getCharUcs4sl f + | UTF8 => getCharUtf8 f + | UTF16B => getCharUtf16b f + | UTF16L => getCharUtf16l f + in (c,(enc,f1)) + end + handle EndOfFile f => raise DecEof(NOENC,f) + | DecodeError(f,eof,err) => raise DecError((enc,f),eof,err) + + (*--------------------------------------------------------------------*) + (* Load new characters, depending on the current entity's encoding. *) + (*--------------------------------------------------------------------*) + fun decGetArray (enc,f) arr = + let + (*--------------------------------------------------------------*) + (* Load the buffer with len new characters, or until the entity *) + (* end is reached. Close the current file in that case. *) + (* Local exception Ended is needed in order to preserve tail *) + (* recursion. *) + (*--------------------------------------------------------------*) + fun loadArray getChar = + let + val ende = Array.length arr + exception Error of int * exn + fun doit (idx,f) = + if idx=ende then (ende,(enc,f),NONE) + else let val (c,f1) = getChar f handle exn => raise Error (idx,exn) + val _ = Array.update(arr,idx,c) + in doit (idx+1,f1) + end + in doit (0,f) handle Error(idx,exn) + => case exn + of EndOfFile f => (idx,(NOENC,f),NONE) + | DecodeError (f,_,err) => (idx,(enc,f),SOME err) + | _ => raise exn + end + in case enc + of NOENC => (0,(NOENC,f),NONE) + | ASCII => loadArray getCharAscii + | EBCDIC => loadArray getCharEbcdic + | LATIN1 => loadArray getCharLatin1 + | UCS2B => loadArray getCharUcs2b + | UCS2L => loadArray getCharUcs2l + | UCS4B => loadArray getCharUcs4b + | UCS4L => loadArray getCharUcs4l + | UCS4SB => loadArray getCharUcs4sb + | UCS4SL => loadArray getCharUcs4sl + | UTF8 => loadArray getCharUtf8 + | UTF16B => loadArray getCharUtf16b + | UTF16L => loadArray getCharUtf16l + end + + + (*--------------------------------------------------------------------*) + (* open an XML file and try to auto-detect its encoding. *) + (*--------------------------------------------------------------------*) + (* Auto-detection of the encoding of XML entities according to App. F *) + (* of the XML recommendation. *) + (* *) + (* The file is opened in basic mode and upto four bytes are read from *) + (* it in order to detect the encoding: if they constitute a prefix of *) + (* " (nil,f) + + fun detect bs = + case bs + of + [0wx0,0wx0,0wxFE,0wxFF] => (UCS4B,nil) + | [0wxFF,0wxFE,0wx0,0wx0] => (UCS4L,nil) + | [0wxFE,0wxFF,0wx0,b4] => + if b4 <> 0wx0 then (UTF16B,[0wx0,b4]) + else (UTF8,bs) + | [0wxFF,0wxFE,b3,0wx0] => + if b3 <> 0wx0 then (UTF16L,[b3,0wx0]) + else (UTF8,bs) + | [0wxEF,0wxBB,0wxBF,b4] => (UTF8,[b4]) + | [0wx0,0wx0,0wx0,0wx3C] => (UCS4B,bs) + | [0wx3C,0wx0,0wx0,0wx0] => (UCS4L,bs) + | [0wx0,0wx0,0wx3C,0wx0] => (UCS4SB,bs) + | [0wx0,0wx3C,0wx0,0wx0] => (UCS4SL,bs) + | [0wx0,b2,b3,b4] => + if (b2=0wx3C orelse b2=0wx25 orelse b2=0wx20 + orelse b2=0wx09 orelse b2=0wx0D orelse b2=0wx0A) + andalso (b3<>0wx0 orelse b4<>0wx0) then (UTF16B,bs) + else (UTF8,bs) + | [b1,0wx0,b3,b4] => + if (b1=0wx3C orelse b1=0wx25 orelse b1=0wx20 + orelse b1=0wx09 orelse b1=0wx0D orelse b1=0wx0A) + andalso (b3<>0wx0 orelse b4<>0wx0) then (UTF16L,bs) + else (UTF8,bs) + | [0wx4C,0wx6F,0wxA7,0wx94] => (EBCDIC,bs) + | _ => (UTF8,bs) + + val f = openFile uri + val (bs,f1) = get4Bytes(0,f) + val (enc,unget) = detect bs + in (enc,ungetBytes(f1,unget)) + end + + (*--------------------------------------------------------------------*) + (* open a Unicode file. Check whether it starts with a byte order *) + (* mark. If yes, chose UTF16 encoding, otherwise use the default that *) + (* is provided as second argument. *) + (* *) + (* return the encoded file, a list of bytes looked ahead and the *) + (* encoding. *) + (*--------------------------------------------------------------------*) + fun decOpenUni (uri,default) = + let + fun def(f,bs) = + (default,ungetBytes(f,bs)) + fun detect f = + let val (b1,f1) = getByte f + in case b1 + of 0wxFE => (let val (b2,f2) = getByte f1 + in if b2 = 0wxFF then (UTF16B,f2) + else def(f2,[b1,b2]) + end handle EndOfFile f => def(f,[b1])) + | 0wxFF => (let val (b2,f2) = getByte f1 + in if b2 = 0wxFE then (UTF16L,f2) + else def(f2,[b1,b2]) + end handle EndOfFile f => def(f,[b1])) + | _ => def(f1,[b1]) + end handle EndOfFile f => def(f,nil) + val f = openFile uri + val (enc,f1) = detect f + in (enc,f1) + end + end + +(* stop of ../../Unicode/Decode/decode.sml *) +(* start of ../../Parser/Error/errorData.sml *) +structure ErrorData = + struct + (*--------------------------------------------------------------------*) + (* a position holds the filename, line and column number. *) + (*--------------------------------------------------------------------*) + type Position = string * int * int + val nullPosition = ("",0,0) + + datatype ExpItem = + EXP_CHAR of UniChar.Char + | EXP_DATA of UniChar.Data + | EXP_STRING of string + type Expected = ExpItem list + type Found = UniChar.Data + + datatype Location = + LOC_NONE + | LOC_AFTER_DTD + | LOC_ATT_DECL + | LOC_ATT_DEFAULT of Position + | LOC_ATT_VALUE + | LOC_CDATA + | LOC_CHOICE + | LOC_COMMENT + | LOC_CONTENT + | LOC_DECL + | LOC_DOC_DECL + | LOC_ELEM_DECL + | LOC_ENCODING + | LOC_ENT_DECL + | LOC_ENT_VALUE + | LOC_EPILOG + | LOC_ETAG + | LOC_IGNORED + | LOC_INCLUDED + | LOC_INT_DECL + | LOC_INT_SUBSET + | LOC_LITERAL + | LOC_MIXED + | LOC_NOT_DECL + | LOC_OUT_COND + | LOC_PROC + | LOC_PROLOG + | LOC_PUB_LIT + | LOC_SEQ + | LOC_STAG + | LOC_SUBSET + | LOC_SYS_LIT + | LOC_TEXT_DECL + | LOC_VERSION + | LOC_XML_DECL + + datatype EntityClass = + ENT_GENERAL + | ENT_PARAMETER + | ENT_EXTERNAL + | ENT_UNPARSED + + datatype Item = + IT_ATT_NAME + | IT_CDATA + | IT_CHAR of UniChar.Char + | IT_CHAR_REF + | IT_COND + | IT_DATA of UniChar.Data + | IT_DECL + | IT_DTD + | IT_ELEM + | IT_ENT_NAME + | IT_ETAG + | IT_GEN_ENT + | IT_ID_NAME + | IT_LANG_ID + | IT_NAME + | IT_NMTOKEN + | IT_NOT_NAME + | IT_NOTATION + | IT_PAR_ENT + | IT_PAR_REF + | IT_REF + | IT_STAG + | IT_TARGET + + datatype Error = + (* syntax errors *) + ERR_EMPTY of Location + | ERR_ENDED_BY_EE of Location + | ERR_EXPECTED of Expected * Found + | ERR_NON_XML_CHAR of UniChar.Char + | ERR_MISSING_WHITE + | ERR_NON_XML_CHARREF of UniChar.Char + + (* other well-formedness errors *) + | ERR_CANT_PARSE of Location + | ERR_ELEM_ENT_NESTING of UniChar.Data + | ERR_ELEM_TYPE_MATCH of UniChar.Data * UniChar.Data + | ERR_OMITTED_END_TAG of UniChar.Data + | ERR_IGNORED_END_TAG of UniChar.Data * UniChar.Data + | ERR_ENDED_IN_PROLOG + | ERR_FORBIDDEN_HERE of Item * Location + | ERR_ILLEGAL_ENTITY of EntityClass * UniChar.Data * Location + | ERR_MULTIPLE_DTD + | ERR_MULT_ATT_SPEC of UniChar.Data + | ERR_RECURSIVE_ENTITY of EntityClass * UniChar.Data + | ERR_UNDEC_ENTITY of EntityClass * UniChar.Data + + (* validity errors concerning attributes *) + | ERR_AT_LEAST_ONE of Item + | ERR_AT_MOST_ONE of Item + | ERR_ATT_IS_NOT of UniChar.Data * Item + | ERR_EXACTLY_ONE of Item + | ERR_FIXED_VALUE of UniChar.Data * UniChar.Vector * UniChar.Vector + | ERR_ID_DEFAULT + | ERR_MISSING_ATT of UniChar.Data + | ERR_MULT_ID_ELEM of UniChar.Data + | ERR_MUST_BE_AMONG of Item * UniChar.Data * UniChar.Data list + | ERR_MUST_BE_UNPARSED of UniChar.Data * Location + | ERR_REPEATED_ID of UniChar.Data + | ERR_UNDECL_ATT of UniChar.Data * UniChar.Data + | ERR_UNDECL_ID of UniChar.Data * Position list + + (* validity errors concerning elements *) + | ERR_BAD_ELEM of UniChar.Data * UniChar.Data + | ERR_ELEM_CONTENT of Item + | ERR_EMPTY_TAG of UniChar.Data + | ERR_ENDED_EARLY of UniChar.Data + | ERR_MULT_MIXED of UniChar.Data + | ERR_NONEMPTY of UniChar.Data + | ERR_REDEC_ELEM of UniChar.Data + | ERR_ROOT_ELEM of UniChar.Data * UniChar.Data + + (* other validity errors *) + | ERR_DECL_ENT_NESTING of Location + | ERR_EE_INT_SUBSET + | ERR_GROUP_ENT_NESTING of Location + | ERR_NO_DTD + | ERR_STANDALONE_DEF of UniChar.Data + | ERR_STANDALONE_ELEM of UniChar.Data + | ERR_STANDALONE_ENT of EntityClass *UniChar.Data + | ERR_STANDALONE_NORM of UniChar.Data + | ERR_UNDECLARED of Item * UniChar.Data * Location + + (* miscellaneous errors *) + | ERR_DECL_PREDEF of UniChar.Data * UniChar.Vector + | ERR_NO_SUCH_FILE of string * string + | ERR_RESERVED of UniChar.Data * Item + | ERR_VERSION of string + | ERR_XML_SPACE + + (* compatibility errors *) + | ERR_AMBIGUOUS of UniChar.Data * int * int + | ERR_MUST_ESCAPE of UniChar.Char + + (* interoperability errors *) + | ERR_EMPTY_TAG_INTER of UniChar.Data + | ERR_MUST_BE_EMPTY of UniChar.Data + + (* decoding errors *) + | ERR_DECODE_ERROR of Decode.Error.DecodeError + + datatype Warning = + WARN_NO_XML_DECL + + | WARN_MULT_DECL of Item * UniChar.Data + | WARN_SHOULD_DECLARE of UniChar.Data list + + | WARN_ATT_UNDEC_ELEM of UniChar.Data + | WARN_MULT_ATT_DECL of UniChar.Data + | WARN_MULT_ATT_DEF of UniChar.Data * UniChar.Data + | WARN_ENUM_ATTS of UniChar.Data * UniChar.Data list + + | WARN_DFA_TOO_LARGE of UniChar.Data * int + + | WARN_NON_ASCII_URI of UniChar.Char + end +(* stop of ../../Parser/Error/errorData.sml *) +(* start of ../../Parser/Error/errorString.sml *) + + + + + + + + + + + + +signature ErrorString = + sig + val errorChar2String : UniChar.Char -> string + val errorData2String : UniChar.Data -> string + val errorVector2String : UniChar.Vector -> string + + val quoteErrorChar0 : UniChar.Char -> string + val quoteErrorChar : UniChar.Char -> string + val quoteErrorData : UniChar.Data -> string + val quoteErrorString : string -> string + val quoteErrorVector : UniChar.Vector -> string + + val Position2String : ErrorData.Position -> string + + val Expected2String : ErrorData.Expected -> string + val Found2String : ErrorData.Found -> string + + val Item2String : ErrorData.Item -> string + val AnItem2String : ErrorData.Item -> string + + val Location2String : ErrorData.Location -> string + val InLocation2String : ErrorData.Location -> string + + val EntityClass2String : ErrorData.EntityClass -> string + end + +structure ErrorString : ErrorString = + struct + open + ErrorData UniChar UtilString + + + fun errorChar2String c = + case c + of 0wx9 => "\\t" + | 0wxA => "\\n" + | _ => if c>=0wx20 andalso c<0wx100 then String.implode [Char2char c] + else "U+"^UtilString.toUpperString + (StringCvt.padLeft #"0" 4 (Chars.toString c)) + + fun errorData2String cs = + String.concat (map errorChar2String cs) + fun errorVector2String vec = + errorData2String (Vector.foldr (op ::) nil vec) + + val QUOTE = "'" + fun quoteErrorChar0 c = QUOTE^errorChar2String c^QUOTE + fun quoteErrorChar c = if c=0wx0 then "entity end" else QUOTE^errorChar2String c^QUOTE + fun quoteErrorData cs = QUOTE^errorData2String cs^QUOTE + fun quoteErrorString s = QUOTE^s^QUOTE + fun quoteErrorVector v = QUOTE^errorVector2String v^QUOTE + + fun Position2String (fname,l,c) = + if fname="" then "" + else String.concat ["[",fname,":",Int2String l,".",Int2String c,"]"] + + fun ExpItem2String exp = + case exp + of EXP_CHAR c => quoteErrorChar c + | EXP_DATA cs => quoteErrorData cs + | EXP_STRING s => s + + fun Expected2String exp = + case exp + of nil => "nothing" + | [one] => ExpItem2String one + | _ => let val l=List.length exp + in List2xString ("",", ","") ExpItem2String (List.take (exp,l-1)) + ^" or "^ExpItem2String (List.last exp) + end + fun Found2String fnd = + case fnd + of [0wx0] => "entity end" + | cs => quoteErrorData cs + + fun Location2String loc = + case loc + of LOC_NONE => "nothing" + | LOC_AFTER_DTD => "document instance" + | LOC_ATT_DECL => "attribute list declaration" + | LOC_ATT_DEFAULT pos => "default value declared at "^Position2String pos + | LOC_ATT_VALUE => "attribute value" + | LOC_CDATA => "CDATA section" + | LOC_CHOICE => "choice list" + | LOC_COMMENT => "comment" + | LOC_CONTENT => "content" + | LOC_DECL => "declaration" + | LOC_DOC_DECL => "document type declaration" + | LOC_ELEM_DECL => "element type declaration" + | LOC_ENCODING => "encoding name" + | LOC_ENT_DECL => "entity declaration" + | LOC_ENT_VALUE => "entity value" + | LOC_EPILOG => "epilog" + | LOC_ETAG => "end-tag" + | LOC_IGNORED => "ignored section" + | LOC_INCLUDED => "included section" + | LOC_INT_DECL => "declaration in the internal subset" + | LOC_INT_SUBSET => "internal subset" + | LOC_LITERAL => "literal" + | LOC_MIXED => "Mixed list" + | LOC_NOT_DECL => "notation declaration" + | LOC_OUT_COND => "outside a conditional section" + | LOC_PROLOG => "prolog" + | LOC_PROC => "processing instruction" + | LOC_PUB_LIT => "public identifier" + | LOC_SEQ => "sequence list" + | LOC_STAG => "start-tag" + | LOC_SUBSET => "declaration subset" + | LOC_SYS_LIT => "system identifier" + | LOC_TEXT_DECL => "text declaration" + | LOC_VERSION => "version number" + | LOC_XML_DECL => "XML declaration" + fun InLocation2String loc = + case loc + of LOC_NONE => "" + | LOC_AFTER_DTD => "after the DTD" + | LOC_CONTENT => "in content" + | LOC_ATT_DEFAULT pos => "in default value declared at "^Position2String pos + | LOC_DOC_DECL => "in the document type declaration" + | LOC_EPILOG => "after the root element" + | LOC_INT_SUBSET => "in the internal subset" + | LOC_OUT_COND => "outside a conditional section" + | LOC_PROLOG => "in prolog" + | LOC_SUBSET => "in the declaration subset" + | LOC_XML_DECL => "in the XML declaration" + | _ => "in "^prependAnA (Location2String loc) + + fun EntityClass2String ent = + case ent + of ENT_GENERAL => "general" + | ENT_PARAMETER => "parameter" + | ENT_UNPARSED => "unparsed" + | ENT_EXTERNAL => "external" + + fun Item2String item = + case item + of IT_ATT_NAME => "attribute name" + | IT_CDATA => "CDATA section" + | IT_CHAR c => "character "^quoteErrorChar c + | IT_CHAR_REF => "character reference" + | IT_COND => "conditional section" + | IT_DATA cs => if null cs then "character data" else quoteErrorData cs + | IT_DECL => "declaration" + | IT_DTD => "document type declaration" + | IT_ELEM => "element type" + | IT_ENT_NAME => "entity name" + | IT_ETAG => "end-tag" + | IT_GEN_ENT => "general entity" + | IT_ID_NAME => "ID name" + | IT_LANG_ID => "language identifier" + | IT_NAME => "name" + | IT_NMTOKEN => "name token" + | IT_NOT_NAME => "notation name" + | IT_NOTATION => "notation" + | IT_PAR_ENT => "parameter entity" + | IT_PAR_REF => "parameter entity reference" + | IT_REF => "reference" + | IT_STAG => "start-tag" + | IT_TARGET => "target name" + + fun AnItem2String item = + case item + of IT_CHAR c => Item2String item + | IT_DATA cs => Item2String item + | _ => prependAnA (Item2String item) + end + +(* stop of ../../Parser/Error/errorString.sml *) +(* start of ../../Parser/Error/errorMessage.sml *) + + + + + + + + +signature ErrorMessage = + sig + val errorMessage : ErrorData.Error -> string list + val warningMessage : ErrorData.Warning -> string list + end + +structure ErrorMessage : ErrorMessage = + struct + open + Decode + UtilString + ErrorData ErrorString + + val quoteChar0 = quoteErrorChar0 + val quoteChar = quoteErrorChar + val quoteData = quoteErrorData + val quoteString = quoteErrorString + val quoteVector = quoteErrorVector + + fun errorMessage err = + case err + (* syntax errors *) + of ERR_EMPTY loc => ["Empty",Location2String loc] + | ERR_ENDED_BY_EE loc => [toUpperFirst (Location2String loc),"ended by entity end"] + | ERR_EXPECTED (exp,found) => + ["Expected",Expected2String exp,"but found",Found2String found] + | ERR_MISSING_WHITE => ["Missing white space"] + | ERR_NON_XML_CHAR c => ["Non-XML character",quoteChar0 c] + | ERR_NON_XML_CHARREF c => ["Reference to non-XML character",quoteChar0 c] + + (* other well-formedness errors *) + | ERR_CANT_PARSE loc => ["Cannot parse",Location2String loc] + | ERR_ELEM_ENT_NESTING elem => + ["The first and last character of element",quoteData elem, + "are in different entities"] + | ERR_ELEM_TYPE_MATCH (elem,other) => + ["Element",quoteData elem,"was ended by an end-tag for",quoteData other] + | ERR_IGNORED_END_TAG(elem,other) => + ["An end-tag for element type",quoteData other,"is not allowed in the", + "content of element",quoteData elem] + | ERR_OMITTED_END_TAG elem => + ["Element",quoteData elem,"has no end-tag"] + | ERR_ENDED_IN_PROLOG => ["Document entity ended in prolog"] + | ERR_FORBIDDEN_HERE(what,loc) => + [AnItem2String what,"is not allowed",InLocation2String loc] + | ERR_ILLEGAL_ENTITY(what,ent,loc) => + ["Reference to",EntityClass2String what,"entity",quoteData ent,InLocation2String loc] + | ERR_MULTIPLE_DTD => ["Repeated document type declaration"] + | ERR_MULT_ATT_SPEC att => + ["A value for attribute",quoteData att,"was already specified in this tag"] + | ERR_RECURSIVE_ENTITY(what,ent) => + ["Reference to",EntityClass2String what,"entity",quoteData ent, + "that is already open"] + | ERR_UNDEC_ENTITY(what,ent) => + ["Reference to undeclared",EntityClass2String what,"entity",quoteData ent] + + (* validity errors concerning attributes *) + | ERR_AT_LEAST_ONE what => ["At least one",Item2String what,"must be specified"] + | ERR_AT_MOST_ONE what => ["Only one",Item2String what,"may be specified"] + | ERR_ATT_IS_NOT(cs,what) => [quoteData cs,"is not",AnItem2String what] + | ERR_EXACTLY_ONE what => [toUpperFirst (AnItem2String what),"must be specified"] + | ERR_FIXED_VALUE(att,value,fixed) => + ["Attribute",quoteData att,"has the value",quoteVector value, + "but was declared with a fixed default value of",quoteVector fixed] + | ERR_ID_DEFAULT => + ["An ID attribute must have a default value of #IMPLIED or #REQUIRED"] + | ERR_MISSING_ATT att => + ["No value was specified for required attribute",quoteData att] + | ERR_MULT_ID_ELEM elem => + ["Element type",quoteData elem,"already has an ID attribute"] + | ERR_MUST_BE_AMONG (what,x,ys) => + [toUpperFirst (Item2String what),quoteData x,"is none of", + List2xString ("",",","") quoteData ys] + | ERR_MUST_BE_UNPARSED (name,loc) => + [quoteData name,InLocation2String loc,"is not the name of an unparsed entity"] + | ERR_REPEATED_ID name => + ["ID name",quoteData name,"already occurred as an attribute value"] + | ERR_UNDECL_ATT(att,elem) => + ["Attribute",quoteData att,"was not declared for element type",quoteData elem] + | ERR_UNDECL_ID(name,refs) => + (if null refs then ["Reference to non-existent ID",quoteData name] + else ["Reference to non-existent ID",quoteData name, + "(also referenced at",List2xString ("",", ",")") Position2String refs]) + + (* validity errors concerning elements *) + | ERR_BAD_ELEM (curr,elem) => + ["Element type",quoteData elem,"not allowed at this point", + "in the content of element",quoteData curr] + | ERR_ELEM_CONTENT what => + [toUpperFirst (AnItem2String what),"is not allowed in element content"] + | ERR_EMPTY_TAG elem => + ["Empty-element tag for element type",quoteData elem, + "whose content model requires non-empty content"] + | ERR_ENDED_EARLY elem => + ["Element",quoteData elem,"ended before its content was completed"] + | ERR_MULT_MIXED elem => + ["Element type",quoteData elem,"already occurred in this mixed-content declaration"] + | ERR_NONEMPTY elem => + ["The end-tag for element",quoteData elem,"with declared EMPTY content", + "must follow immediately after its start-tag"] + | ERR_REDEC_ELEM elem => ["Element type",quoteData elem,"was already declared"] + | ERR_ROOT_ELEM (dec,root) => + ["Document element",quoteData root,"does not match the name", + quoteData dec,"in the document type declaration"] + + (* other validity errors *) + | ERR_DECL_ENT_NESTING loc => + ["The first and last character of this",Location2String loc, + "are not in the same entity replacement text"] + | ERR_EE_INT_SUBSET => + ["An entity end is not allowed in a declaration in the internal subset"] + | ERR_GROUP_ENT_NESTING loc => + ["The opening and closing parentheses of this",Location2String loc, + "are not in the same entity replacement text"] + | ERR_NO_DTD => + ["There is no document type declaration. Switching to semi-validating mode", + "(will not check for declaredness of entities, elements, etc.)"] + | ERR_STANDALONE_DEF att => + ["Externally declared attribute",quoteData att,"was defaulted,", + "although the standalone declaration is",quoteString "yes"] + | ERR_STANDALONE_ELEM elem => + ["White space occurred in the content of externally declared", + "element",quoteData elem,"with declared element content", + "although the standalone declaration is",quoteString "yes"] + | ERR_STANDALONE_ENT(what,ent) => + ["Reference to externally declared",EntityClass2String what,"entity", + quoteData ent^",","although the standalone declaration is",quoteString "yes"] + | ERR_STANDALONE_NORM att => + ["The value for externally declared attribute", + quoteData att,"was changed as a result of normalization,", + "although the standalone declaration is",quoteString "yes"] + | ERR_UNDECLARED (what,x,loc) => + ["Undeclared",Item2String what,quoteData x,InLocation2String loc] + + (* miscellaneous errors *) + | ERR_DECL_PREDEF(ent,def) => + ["General entity",quoteData ent,"must be declared as internal entity", + "with replacement text",quoteVector def] + | ERR_NO_SUCH_FILE(f,msg) => ["Could not open file",quoteString f,"("^msg^")"] + | ERR_RESERVED(name,what) => + [quoteData name,"is reserved for standardization and therefore not allowed as", + AnItem2String what] + | ERR_VERSION version => + ["XML version",quoteString version,"is not supported"] + | ERR_XML_SPACE => + ["Attribute",quoteString "xml:space","must be given an enumeration type", + "with values",quoteString "default","and",quoteString "preserve","only"] + + (* compatibility errors *) + | ERR_AMBIGUOUS(a,n1,n2) => + ["Content model is ambiguous: conflict between the",numberNth n1, + "and the",numberNth n2,"occurrence of element",quoteData a^".", + "Using an approximation instead"] + | ERR_MUST_ESCAPE c => ["Character",quoteChar c,"must be escaped for compatibility"] + + (* interoperability errors *) + | ERR_EMPTY_TAG_INTER elem => + ["Empty-element tag for element",quoteData elem,"with non-EMPTY declared content"] + | ERR_MUST_BE_EMPTY elem => + ["An empty-element tag must be used for element type", + quoteData elem,"with EMPTY declared content"] + + (* decoding errors *) + | ERR_DECODE_ERROR err => "Decoding error:"::Decode.Error.decodeMessage err + + fun warningMessage warn = + case warn + of WARN_NO_XML_DECL => ["Document entity has no XML declaration"] + + | WARN_MULT_DECL(what,name) => + ["Repeated declaration for",Item2String what,quoteData name] + | WARN_SHOULD_DECLARE(ents) => + let val (one,more) = (hd ents,tl ents) + in case more + of nil => ["The predefined entity",quoteData one,"should have been declared"] + | _ => ["The predefined entities",List2xString ("",", ","") quoteData more, + "and",quoteData one,"should have been declared"] + end + + | WARN_ATT_UNDEC_ELEM elem => + ["Attribute-list declaration for undeclared element type",quoteData elem] + | WARN_MULT_ATT_DECL elem => + ["Repeated attribute-list declaration for element type",quoteData elem] + | WARN_MULT_ATT_DEF(elem,att) => + ["Repeated definition of attribute",quoteData att,"for element type",quoteData elem] + | WARN_ENUM_ATTS(elem,names) => + ["The following name tokens occur more than once in the enumerated attribute", + "types of element",quoteData elem^":",List2xString ("",", ","") quoteData names] + + | WARN_DFA_TOO_LARGE (elem,max) => + ["The finite state machine for the content model of element type", + quoteData elem,"would have more than the maximal allowed number of", + Int2String max,"states. Using an approximation instead"] + + | WARN_NON_ASCII_URI c => + ["System identifier contains non-ASCII character",quoteChar c] + + end +(* stop of ../../Parser/Error/errorMessage.sml *) +(* start of ../../Parser/Error/errorUtil.sml *) + + +signature ErrorUtil = + sig + val isFatalError : ErrorData.Error -> bool + val isDecodeError : ErrorData.Error -> bool + val isSyntaxError : ErrorData.Error -> bool + val isValidityError : ErrorData.Error -> bool + val isWellFormedError : ErrorData.Error -> bool + end + +structure ErrorUtil : ErrorUtil = + struct + open ErrorData + + fun isDecodeError err = + case err + of ERR_DECODE_ERROR _ => true + | _ => false + + fun isSyntaxError err = + case err + of ERR_EMPTY _ => true + | ERR_ENDED_BY_EE _ => true + | ERR_EXPECTED _ => true + | ERR_MISSING_WHITE => true + | ERR_NON_XML_CHAR _ => true + | ERR_NON_XML_CHARREF _ => true + | _ => false + + fun isWellFormedError err = + case err + of ERR_CANT_PARSE _ => true + | ERR_ELEM_ENT_NESTING _ => true + | ERR_ELEM_TYPE_MATCH _ => true + | ERR_OMITTED_END_TAG _ => true + | ERR_IGNORED_END_TAG _ => true + | ERR_ENDED_IN_PROLOG => true + | ERR_FORBIDDEN_HERE _ => true + | ERR_ILLEGAL_ENTITY _ => true + | ERR_MULTIPLE_DTD => true + | ERR_MULT_ATT_SPEC _ => true + | ERR_RECURSIVE_ENTITY _ => true + | ERR_UNDEC_ENTITY _ => true + | _ => isSyntaxError err + + fun isFatalError err = + case err + of ERR_NO_SUCH_FILE _ => true + | _ => isWellFormedError err + + fun isValidityError err = + case err + of ERR_AT_LEAST_ONE _ => true + | ERR_AT_MOST_ONE _ => true + | ERR_ATT_IS_NOT _ => true + | ERR_EXACTLY_ONE _ => true + | ERR_FIXED_VALUE _ => true + | ERR_ID_DEFAULT => true + | ERR_MISSING_ATT _ => true + | ERR_MULT_ID_ELEM _ => true + | ERR_MUST_BE_AMONG _ => true + | ERR_MUST_BE_UNPARSED _ => true + | ERR_REPEATED_ID _ => true + | ERR_UNDECL_ATT _ => true + | ERR_UNDECL_ID _ => true + | ERR_BAD_ELEM _ => true + | ERR_ELEM_CONTENT _ => true + | ERR_EMPTY_TAG _ => true + | ERR_ENDED_EARLY _ => true + | ERR_MULT_MIXED _ => true + | ERR_NONEMPTY _ => true + | ERR_REDEC_ELEM _ => true + | ERR_ROOT_ELEM _ => true + | ERR_DECL_ENT_NESTING _ => true + | ERR_EE_INT_SUBSET => true + | ERR_GROUP_ENT_NESTING _ => true + | ERR_NO_DTD => true + | ERR_STANDALONE_DEF _ => true + | ERR_STANDALONE_ELEM _ => true + | ERR_STANDALONE_ENT _ => true + | ERR_STANDALONE_NORM _ => true + | ERR_UNDECLARED _ => true + | _ => false + end +(* stop of ../../Parser/Error/errorUtil.sml *) +(* start of ../../Parser/Error/expected.sml *) + + + + +structure Expected = + struct + local + open UniChar ErrorData + in + val expAnElemName = [EXP_STRING "an element name"] + val expAnEntName = [EXP_STRING "an entity name"] + val expAName = [EXP_STRING "a name"] + val expANameToken = [EXP_STRING "a name token"] + val expANotName = [EXP_STRING "a notation name"] + val expATarget = [EXP_STRING "a target name"] + val expAttDefKey = [EXP_DATA (String2Data "REQUIRED"),EXP_DATA (String2Data "IMPLIED"), + EXP_DATA (String2Data "FIXED")] + val expAttNameGt = [EXP_STRING "an attribute name",EXP_CHAR 0wx3E] + val expAttSTagEnd = [EXP_STRING "an attribute name",EXP_CHAR 0wx3E, + EXP_DATA(String2Data "/>")] + val expAttType = [EXP_CHAR 0wx28,EXP_DATA (String2Data "CDATA"), + EXP_DATA (String2Data "ID"),EXP_DATA (String2Data "IDREF"), + EXP_DATA (String2Data "IDREFS"),EXP_DATA (String2Data "ENTITY"), + EXP_DATA (String2Data "ENTITIES"),EXP_DATA (String2Data "NMTOKEN"), + EXP_DATA (String2Data "NMTOKENS"),EXP_DATA (String2Data "NOTATION")] + val expBarRpar = [EXP_CHAR 0wx29,EXP_CHAR 0wx7C] + val expCdata = [EXP_DATA (String2Data "CDATA")] + fun expConCRpar c = [EXP_CHAR 0wx29,EXP_CHAR c] + val expConRpar = [EXP_CHAR 0wx29,EXP_CHAR 0wx2C,EXP_CHAR 0wx7C] + val expCondStatus = [EXP_DATA (String2Data "IGNORE"),EXP_DATA (String2Data "INCLUDE")] + val expContSpec = [EXP_CHAR 0wx28,EXP_DATA (String2Data "ANY"), + EXP_DATA (String2Data "EMPTY")] + val expElemLpar = [EXP_STRING "an element name",EXP_CHAR 0wx28] + val expEncStand = [EXP_DATA (String2Data "encoding"), + EXP_DATA (String2Data "standalone")] + val expDash = [EXP_CHAR 0wx2D] + val expDashDocLbrk = [EXP_CHAR 0wx2D,EXP_CHAR 0wx5B,EXP_DATA (String2Data "DOCTYPE")] + val expDashLbrack = [EXP_CHAR 0wx2D,EXP_CHAR 0wx5B] + val expDigitX = [EXP_STRING "a digit",EXP_CHAR 0wx78] + val expEncoding = [EXP_DATA (String2Data "encoding")] + val expEncVers = [EXP_DATA (String2Data "encoding"),EXP_DATA (String2Data "version")] + val expEntNamePero = [EXP_STRING "an entity name",EXP_CHAR 0wx25] + val expEq = [EXP_CHAR 0wx3D] + val expExclQuest = [EXP_CHAR 0wx21,EXP_CHAR 0wx3F] + val expExtId = [EXP_DATA (String2Data "PUBLIC"),EXP_DATA (String2Data "SYSTEM")] + val expGt = [EXP_CHAR 0wx3E] + val expGtNdata = [EXP_CHAR 0wx3E,EXP_DATA (String2Data "NDATA")] + val expHexDigit = [EXP_STRING "a hexadecimal digit"] + val expInSubset = [EXP_CHAR 0wx3C,EXP_CHAR 0wx5D,EXP_CHAR 0wx25, + EXP_STRING "white space"] + val expLbrack = [EXP_CHAR 0wx5B] + val expLitQuote = [EXP_CHAR 0wx22,EXP_CHAR 0wx27] + val expLitQuotExt = [EXP_CHAR 0wx22,EXP_CHAR 0wx27, + EXP_DATA (String2Data "PUBLIC"),EXP_DATA (String2Data "SYSTEM")] + val expLpar = [EXP_CHAR 0wx28] + val expNoYes = [EXP_DATA (String2Data "no"),EXP_DATA (String2Data "yes")] + val expPcdata = [EXP_DATA (String2Data "PCDATA")] + val expProcEnd = [EXP_DATA (String2Data "?>")] + val expQuoteRni = [EXP_CHAR 0wx22,EXP_CHAR 0wx27,EXP_CHAR 0wx23] + val expRbrack = [EXP_CHAR 0wx5D] + val expRep = [EXP_CHAR 0wx2A] + val expSemi = [EXP_CHAR 0wx3B] + val expStandOpt = [EXP_DATA (String2Data "standalone"),EXP_DATA (String2Data "?>")] + val expStartEnc = [EXP_STRING "a letter"] + val expStartMarkup = [EXP_DATA (String2Data "--"),EXP_DATA (String2Data "ATTLIST"), + EXP_DATA (String2Data "ELEMENT"),EXP_DATA (String2Data "ENTITY"), + EXP_DATA (String2Data "NOTATION")] + val expVersion = [EXP_DATA (String2Data "version")] + end + end +(* stop of ../../Parser/Error/expected.sml *) +(* start of ../../Parser/Error/errors.sml *) +structure Errors = + struct + open + UtilError + ErrorData ErrorMessage ErrorString ErrorUtil Expected + end +(* stop of ../../Parser/Error/errors.sml *) +(* start of ../../Parser/Base/baseData.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: BaseData *) +(*--------------------------------------------------------------------------*) + +structure BaseData = + struct + open DfaData + + (*--- external ids may have a public id and must have a system id ---*) + (*--- for notations, however, also the system id can be optional ----*) + datatype ExternalId = + EXTID of (string * UniChar.Char) option * (Uri.Uri * Uri.Uri * UniChar.Char) option + + (*--- external ids may have a public id and must have a system id ---*) + type NotationInfo = ExternalId option + + (*--- replacement of a general entity ---*) + datatype GenEntity = + GE_NULL + | GE_INTERN of UniChar.Vector * UniChar.Vector + | GE_EXTERN of ExternalId + | GE_UNPARSED of ExternalId * int * Errors.Position + type GenEntInfo = GenEntity * bool + + fun isExtGen (GE_EXTERN _) = true + | isExtGen _ = false + + (*--- replacement of a parameter entity ---*) + datatype ParEntity = + PE_NULL + | PE_INTERN of UniChar.Vector * UniChar.Vector + | PE_EXTERN of ExternalId + type ParEntInfo = ParEntity * bool + + fun isExtPar (PE_EXTERN _) = true + | isExtPar _ = false + + (*--- declared type of an attribute ---*) + datatype AttType = + AT_CDATA + | AT_NMTOKEN + | AT_NMTOKENS + | AT_ID + | AT_IDREF + | AT_IDREFS + | AT_ENTITY + | AT_ENTITIES + | AT_GROUP of int list + | AT_NOTATION of int list + + (*--- typed attribute value ---*) + datatype AttValue = + AV_CDATA of UniChar.Vector + | AV_NMTOKEN of UniChar.Data + | AV_NMTOKENS of UniChar.Data list + | AV_ID of int + | AV_IDREF of int + | AV_IDREFS of int list + | AV_ENTITY of int + | AV_ENTITIES of int list + | AV_GROUP of int list * int + | AV_NOTATION of int list * int + + fun isIdType at = at=AT_ID + + (*--- default values of attributes ---*) + datatype AttDefault = + AD_IMPLIED + | AD_REQUIRED + | AD_DEFAULT of (UniChar.Vector * UniChar.Vector * AttValue option) + * (Errors.Position * bool ref) + | AD_FIXED of (UniChar.Vector * UniChar.Vector * AttValue option) + * (Errors.Position * bool ref) + + (*--- attribute definition (list) ---*) + (*--- the boolean says whether it was externally declared ---*) + type AttDef = int * AttType * AttDefault * bool + type AttDefList = AttDef list + + (*--- content specification ---*) + fun defaultAttDef idx = (idx,AT_CDATA,AD_IMPLIED,false) + + (*--- content specification ---*) + datatype ContentSpec = + CT_ANY + | CT_EMPTY + | CT_MIXED of int list + | CT_ELEMENT of DfaData.ContentModel * DfaData.Dfa + + fun isMixed ct = + case ct + of CT_ANY => true + | CT_MIXED _ => true + | _ => false + + type ElemInfo = {decl : (ContentSpec * bool) option, + atts : (AttDefList * bool) option, + errAtts : int list} + + val nullElemInfo : ElemInfo = {decl=NONE, + atts=NONE, + errAtts=nil} + + (*--------------------------------------------------------------------*) + (* the id info tells whether an id value has occurred for a name and *) + (* the list of all positions where it occurred as an idref value. *) + (*--------------------------------------------------------------------*) + type IdInfo = bool * Errors.Position list + val nullIdInfo : IdInfo = (false,nil) + end +(* stop of ../../Parser/Base/baseData.sml *) +(* start of ../../Parser/Dfa/dfaString.sml *) + + + + + +(*--------------------------------------------------------------------------*) +(* Structure: DfaString *) +(* *) +(* Notes: *) +(* This structure is needed for debugging of content models and tables. *) +(* *) +(* Depends on: *) +(* DfaData *) +(* UtilString *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* Table2String : none *) +(* ContentModel2String : none *) +(*--------------------------------------------------------------------------*) +signature DfaString = + sig + val ContentModel2String : (int -> string) -> DfaData.ContentModel -> string + val Dfa2String : (int -> string) -> DfaData.Dfa -> string + end + +structure DfaString : DfaString = + struct + open DfaBase UtilString + + fun State2String q = if q=dfaError then "Error" else Int2String q + + fun Info2String Elem2String (q,mt,fst) = String.concat + (State2String q::Bool2xString ("[empty]","") mt + ::map (fn (q,a) => " "^Elem2String a^"->"^State2String q) fst) + + fun ContentModel2String Elem2String cm = + case cm + of CM_ELEM i => Elem2String i + | CM_OPT cm => ContentModel2String Elem2String cm^"?" + | CM_REP cm => ContentModel2String Elem2String cm^"*" + | CM_PLUS cm => ContentModel2String Elem2String cm^"+" + | CM_ALT cms => List2xString ("(","|",")") (ContentModel2String Elem2String) cms + | CM_SEQ cms => List2xString ("(",",",")") (ContentModel2String Elem2String) cms + + fun CM2String Elem2String = + let fun cm2s indent cm = + case cm + of (ELEM a,info) => String.concat + [indent,Elem2String a," ",Info2String Elem2String info,"\n"] + | (OPT cm',info) => String.concat + [indent,"? ",Info2String Elem2String info,"\n",cm2s (indent^" ") cm'] + | (REP cm',info) => String.concat + [indent,"* ",Info2String Elem2String info,"\n",cm2s (indent^" ") cm'] + | (PLUS cm',info) => String.concat + [indent,"+ ",Info2String Elem2String info,"\n",cm2s (indent^" ") cm'] + | (ALT cms,info) => String.concat + (indent^"| "::Info2String Elem2String info::"\n" + ::map (cm2s (indent^" ")) cms) + | (SEQ cms,info) => String.concat + (indent^", "::Info2String Elem2String info::"\n" + ::map (cm2s (indent^" ")) cms) + in cm2s "" + end + + fun Row2String Elem2String (lo,hi,tab,fin) = + String.concat + (Vector.foldri + (fn (i,q,yet) => if q<0 then yet + else " "::Elem2String (i+lo)::"->"::State2String q::yet) + (if fin then [" [Final]"] else nil) + (tab,0,NONE)) + + fun Dfa2String Elem2String tab = + String.concat + (Vector.foldri + (fn (q,row,yet) => State2String q::":"::Row2String Elem2String row::yet) + nil (tab,0,NONE)) + end +(* stop of ../../Parser/Dfa/dfaString.sml *) +(* start of ../../Parser/Base/baseString.sml *) + + + + + + + + + + + + +(*--------------------------------------------------------------------------*) +(* Structure: BaseString *) +(* *) +(* Depends on: *) +(* UniChar *) +(* Dfa *) +(* BaseData *) +(* UtilString *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* ElemInfo2xString : InternalError *) +(* ExternalId2String : none *) +(* GenEntity2xString : none *) +(* Notation2String : none *) +(* IdInfo2String : none *) +(* ParEntity2String : none *) +(*--------------------------------------------------------------------------*) +signature BaseString = + sig + val ExternalId2String : BaseData.ExternalId -> string + val NotationInfo2String : BaseData.NotationInfo -> string + + val GenEntity2xString : (int -> string) -> BaseData.GenEntity -> string + val ParEntity2String : BaseData.ParEntity -> string + + val ElemInfo2xString : (int -> string) * (int -> string) * (int -> string) + * (int -> string) * (int -> string) -> BaseData.ElemInfo -> string + + val IdInfo2String : BaseData.IdInfo -> string + end + +structure BaseString : BaseString = + struct + open + UtilString Uri + Errors UniChar DfaString + BaseData + + val THIS_MODULE = "BaseString" + + fun ExternalId2String (EXTID id) = + case id + of (SOME(p,pq),SOME(rel,s,sq)) => String.concat + ["PUBLIC ",quoteUni pq p, + " ",quoteUni sq (Uri2String rel), + " @ ",quoteUni sq (Uri2String s)] + | (SOME(p,pq),NONE) => String.concat + ["PUBLIC ",quoteUni pq p] + | (NONE,SOME(rel,s,sq)) => String.concat + ["SYSTEM ",quoteUni sq (Uri2String rel), + " @ ",quoteUni sq (Uri2String s)] + | (NONE,NONE) => "" + fun NotationInfo2String not = + case not + of NONE => "undeclared" + | SOME extId => ExternalId2String extId + + fun GenEntity2xString NotIdx2String ge = + case ge + of GE_NULL => "NULL" + | GE_INTERN(lit,cv) => let val quote = Vector.sub(lit,0) + in String.concat ["INTERN ",Vector2String lit, + " - ",quoteVector quote cv] + end + | GE_EXTERN id => "EXTERN "^ExternalId2String id + | GE_UNPARSED(id,not,_) => "UNPARSED "^ExternalId2String id^" "^NotIdx2String not + + fun ParEntity2String pe = + case pe + of PE_NULL => "NULL" + | PE_INTERN(lit,cv) => let val quote = Vector.sub(lit,0) + in String.concat ["INTERN ",Vector2String lit, + " - ",quoteVector quote cv] + end + | PE_EXTERN id => "EXTERN "^ExternalId2String id + + fun ContentSpec2String Elem2String cs = + case cs + of CT_ANY => "ANY" + | CT_EMPTY => "EMPTY" + | CT_MIXED is => List2xString ("MIXED (","|",")") Elem2String is + | CT_ELEMENT(cm,_) => "ELEMENT "^ContentModel2String Elem2String cm + + fun AttValue2xString (Att2String,Ent2String,Id2String,Not2String) quote av = + quoteUni quote (case av + of AV_CDATA buf => Vector2String buf + | AV_NMTOKEN cs => Data2String cs + | AV_NMTOKENS css => List2xString (""," ","") Data2String css + | AV_ID idx => Id2String idx + | AV_IDREF idx => Id2String idx + | AV_IDREFS idxs => List2xString (""," ","") Id2String idxs + | AV_ENTITY idx => Ent2String idx + | AV_ENTITIES idxs => List2xString (""," ","") Ent2String idxs + | AV_GROUP(_,idx) => Att2String idx + | AV_NOTATION(_,idx) => Not2String idx) + + fun AttDefault2xString funs ad = + case ad + of AD_DEFAULT ((lit,cv,av),_) => + let val quote = Vector.sub(lit,0) + in String.concat [quoteVector quote cv," ", + Option2String0 (AttValue2xString funs quote) av] + end + | AD_FIXED ((lit,cv,av),_) => + let val quote = Vector.sub(lit,0) + in String.concat ["#FIXED ",quoteVector quote cv," ", + Option2String0 (AttValue2xString funs quote) av] + end + | AD_IMPLIED => "#IMPLIED" + | AD_REQUIRED => "#REQUIRED" + + fun AttType2xString (Att2String,Not2String) at = + case at + of AT_CDATA => "CDATA" + | AT_NMTOKEN => "NMTOKEN" + | AT_NMTOKENS => "NMTOKENS" + | AT_ID => "ID" + | AT_IDREF => "IDREF" + | AT_IDREFS => "IDREFS" + | AT_ENTITY => "ENTITY" + | AT_ENTITIES => "ENTITIES" + | AT_GROUP idxs => List2xString ("(","|",")") Att2String idxs + | AT_NOTATION idxs => List2xString ("NOTATION(","|",")") Not2String idxs + + fun AttDef2xString (funs as (Att2String,_,_,Not2String)) (idx,attType,default,ext) = + String.concat [Att2String idx," ", + AttType2xString (Att2String,Not2String) attType," ", + AttDefault2xString funs default, + Bool2xString ("[external]","") ext] + + fun AttDefList2xString funs adl = List2xString ("",",","") (AttDef2xString funs) adl + + fun ElemInfo2xString (Att2String,Elem2String,Ent2String,Id2String,Not2String) + ({decl,atts,...}:ElemInfo) = + let val dec = case decl + of NONE => "elem undeclared" + | SOME(cont,ext) => String.concat + ["elem declared ",if ext then "ex" else "in","ternally: ", + ContentSpec2String Elem2String cont] + val att = case atts + of NONE => "no atts declared" + | SOME(defs,hadId) => String.concat + ["atts were declared",if hadId then "(has id attribute): " else ": ", + AttDefList2xString (Att2String,Ent2String,Id2String,Not2String) defs] + in dec^att + end + + fun IdInfo2String (decl,refs) = + Bool2xString ("declared","undeclared") decl^"/"^ + (if null refs then "no references" + else List2xString ("references: ",", ","") Position2String refs) + end + +(* stop of ../../Parser/Base/baseString.sml *) +(* start of ../../Parser/Base/base.sml *) + + + +structure Base = + struct + open + BaseData + BaseString + end +(* stop of ../../Parser/Base/base.sml *) +(* start of ../../Parser/Params/dtd.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: Dtd *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* AttNot2Index : none *) +(* Element2Index : none *) +(* GenEnt2Index : none *) +(* Id2Index : none *) +(* Index2AttNot : NoSuchIndex *) +(* Index2Element : NoSuchIndex *) +(* Index2GenEnt : NoSuchIndex *) +(* Index2Id : NoSuchIndex *) +(* Index2ParEnt : NoSuchIndex *) +(* ParEnt2Index : none *) +(* entitiesWellformed : none *) +(* getElement : NoSuchIndex *) +(* getGenEnt : NoSuchIndex *) +(* getId : NoSuchIndex *) +(* getNotation : NoSuchIndex *) +(* getParEnt : NoSuchIndex *) +(* hasNotation : NoSuchIndex *) +(* initDtdTables : none *) +(* maxUsedElem : none *) +(* maxUsedId : none *) +(* printAttNotTable : none *) +(* printIdTable : none *) +(* printParEntTable : none *) +(* printxElementTable : none *) +(* printxGenEntTable : none *) +(* setElement : NoSuchIndex *) +(* setGenEnt : NoSuchIndex *) +(* setId : NoSuchIndex *) +(* setNotation : NoSuchIndex *) +(* setParEnt : NoSuchIndex *) +(*--------------------------------------------------------------------------*) +signature Dtd = + sig + type Dtd + + val hasDtd : Dtd -> bool + val hasExternal : Dtd -> bool + val standsAlone : Dtd -> bool + + val setHasDtd : Dtd -> unit + val setExternal : Dtd -> unit + val setStandAlone : Dtd -> bool -> unit + + val entitiesWellformed : Dtd -> bool + + val validPredef : int -> UniChar.Vector + val isRedefined : Dtd -> int -> bool + val setRedefined : Dtd -> int -> unit + val notRedefined : Dtd -> UniChar.Data list + + val AttNot2Index : Dtd -> UniChar.Data -> int + val Element2Index : Dtd -> UniChar.Data -> int + val Id2Index : Dtd -> UniChar.Data -> int + val GenEnt2Index : Dtd -> UniChar.Data -> int + val ParEnt2Index : Dtd -> UniChar.Data -> int + + val Index2Element : Dtd -> int -> UniChar.Data + val Index2Id : Dtd -> int -> UniChar.Data + val Index2GenEnt : Dtd -> int -> UniChar.Data + val Index2AttNot : Dtd -> int -> UniChar.Data + val Index2ParEnt : Dtd -> int -> UniChar.Data + + val getId : Dtd -> int -> Base.IdInfo + val getElement : Dtd -> int -> Base.ElemInfo + val getGenEnt : Dtd -> int -> Base.GenEntInfo + val getNotation : Dtd -> int -> Base.NotationInfo + val getParEnt : Dtd -> int -> Base.ParEntInfo + + val hasNotation : Dtd -> int -> bool + + val setId : Dtd -> int * Base.IdInfo -> unit + val setElement : Dtd -> int * Base.ElemInfo -> unit + val setGenEnt : Dtd -> int * Base.GenEntInfo -> unit + val setNotation : Dtd -> int * Base.ExternalId -> unit + val setParEnt : Dtd -> int * Base.ParEntInfo -> unit + + val maxUsedId : Dtd -> int + val maxUsedElem : Dtd -> int + val maxUsedGen : Dtd -> int + + val initDtdTables : unit -> Dtd + val printDtdTables : Dtd -> unit + + val printAttNotTable : Dtd -> unit + val printIdTable : Dtd -> unit + val printElementTable : Dtd -> unit + val printGenEntTable : Dtd -> unit + val printParEntTable : Dtd -> unit + + val defaultIdx : int + val preserveIdx : int + val xmlLangIdx : int + val xmlSpaceIdx : int + val xmlSpaceType : Base.AttType + end + +structure Dtd :> Dtd = + struct + open + UtilInt + Base UniChar + DataDict DataSymTab + + val O_TS_ELEM = ref 6 (* Initial size of element table *) + val O_TS_GEN_ENT = ref 6 (* Initial size of general entity table *) + val O_TS_ID = ref 6 (* Initial size of id attribute table *) + val O_TS_ATT_NOT = ref 6 (* Initial size of notation table *) + val O_TS_PAR_ENT = ref 6 (* Initial size of parameter entity table *) + + (*--------------------------------------------------------------------*) + (* this is how the predefined entities must be declared. *) + (*--------------------------------------------------------------------*) + val predefined = Vector.fromList + (map (fn (x,y,z) => (String2Data x,String2Vector y,String2Vector z)) + [("","",""), + ("amp" ,"'&'","&"), + ("lt" ,"'<'","<"), + ("gt" ,"'>'",">"), + ("apos","\"'\"" ,"'" ), + ("quot","'\"'" ,"\"" )]) + fun validPredef i = #3(Vector.sub(predefined,i)) + + (*--------------------------------------------------------------------*) + (* this type holds all information relevent to the DTD. *) + (*--------------------------------------------------------------------*) + type Dtd = {hasDtdFlag : bool ref, + standAloneFlag : bool ref, + externalFlag : bool ref, + elDict : ElemInfo DataDict.Dict, + genDict : GenEntInfo DataDict.Dict, + idDict : IdInfo DataDict.Dict, + notDict : NotationInfo DataDict.Dict, + parDict : ParEntInfo DataDict.Dict, + preRedef : bool array + } + + fun newDtd() = {hasDtdFlag = ref false, + standAloneFlag = ref false, + externalFlag = ref false, + elDict = nullDict ("element",nullElemInfo), + idDict = nullDict ("ID name",nullIdInfo), + genDict = nullDict ("general entity",(GE_NULL,false)), + notDict = nullDict ("attribute and notation",NONE:NotationInfo), + parDict = nullDict ("parameter entity",(PE_NULL,false)), + preRedef = Array.array(6,false) + } : Dtd + + val default = String2Data "default" + val preserve = String2Data "preserve" + val xmlLang = String2Data "xml:lang" + val xmlSpace = String2Data "xml:space" + + (*--------------------------------------------------------------------*) + (* standalone status, existance of a DTD and of external declarations *) + (* externalFlag is true if there is an external subset or a (not nece-*) + (* ssarily external) parameter entity reference in the DTD. (cf. 4.1) *) + (*--------------------------------------------------------------------*) + fun standsAlone (dtd:Dtd) = !(#standAloneFlag dtd) + fun hasExternal (dtd:Dtd) = !(#externalFlag dtd) + fun hasDtd (dtd:Dtd) = !(#hasDtdFlag dtd) + + fun setHasDtd (dtd:Dtd) = #hasDtdFlag dtd := true + fun setExternal (dtd:Dtd) = #externalFlag dtd := true + fun setStandAlone (dtd:Dtd) x = #standAloneFlag dtd := x + + + (*--------------------------------------------------------------------*) + (* 4.1: *) + (* Well-Formedness Constraint: Entity Declared *) + (* In a document without any DTD, a document with only an internal *) + (* DTD subset which contains no parameter entity references, or a *) + (* document with "standalone='yes'", the Name given in the entity *) + (* reference must match that in an entity declaration ... Note that *) + (* if entities are declared in the external subset or in external *) + (* parameter entities, a non-validating processor is not obligated *) + (* to read and process their declarations; for such documents, the *) + (* rule that an entity must be declared is a well-formedness *) + (* constraint only if standalone='yes'. *) + (* *) + (* Thus a reference to an undeclared entity is a well-formedness *) + (* error if either #hasDtdFlag or #externalFlag is false, or if *) + (* #standaloneFlag is true *) + (*--------------------------------------------------------------------*) + (* bug fixed 080600: changed !hasDtdFlag to not(!hasDtdFlag) *) + (*--------------------------------------------------------------------*) + fun entitiesWellformed ({hasDtdFlag,standAloneFlag,externalFlag,...}:Dtd) = + not (!hasDtdFlag andalso !externalFlag) orelse !standAloneFlag + + fun initStandalone ({hasDtdFlag,standAloneFlag,externalFlag,...}:Dtd) = + (hasDtdFlag := false; standAloneFlag := false; externalFlag := false) + + (*--------------------------------------------------------------------*) + (* this array tells whether the predefined entities (index 1-5) have *) + (* been declared in the dtd. *) + (*--------------------------------------------------------------------*) + fun isRedefined (dtd:Dtd) i = Array.sub(#preRedef dtd,i) + fun setRedefined (dtd:Dtd) i = Array.update(#preRedef dtd,i,true) + fun notRedefined dtd = List.mapPartial + (fn i => if isRedefined dtd i then NONE else SOME(#1(Vector.sub(predefined,i)))) + [1,2,3,4,5] + + fun AttNot2Index (dtd:Dtd) name = getIndex(#notDict dtd,name) + fun Element2Index (dtd:Dtd) name = getIndex(#elDict dtd,name) + fun GenEnt2Index (dtd:Dtd) name = getIndex(#genDict dtd,name) + fun Id2Index (dtd:Dtd) name = getIndex(#idDict dtd,name) + fun ParEnt2Index (dtd:Dtd) name = getIndex(#parDict dtd,name) + + fun Index2AttNot (dtd:Dtd) idx = getKey(#notDict dtd,idx) + fun Index2Element (dtd:Dtd) idx = getKey(#elDict dtd,idx) + fun Index2GenEnt (dtd:Dtd) idx = getKey(#genDict dtd,idx) + fun Index2Id (dtd:Dtd) idx = getKey(#idDict dtd,idx) + fun Index2ParEnt (dtd:Dtd) idx = getKey(#parDict dtd,idx) + + fun getElement (dtd:Dtd) idx = getByIndex(#elDict dtd,idx) + fun getGenEnt (dtd:Dtd) idx = getByIndex(#genDict dtd,idx) + fun getId (dtd:Dtd) idx = getByIndex(#idDict dtd,idx) + fun getNotation (dtd:Dtd) idx = getByIndex(#notDict dtd,idx) + fun getParEnt (dtd:Dtd) idx = getByIndex(#parDict dtd,idx) + + fun hasNotation (dtd:Dtd) idx = isSome(getByIndex(#notDict dtd,idx)) + + fun setElement (dtd:Dtd) (idx,el) = setByIndex(#elDict dtd,idx,el) + fun setGenEnt (dtd:Dtd) (idx,ge) = setByIndex(#genDict dtd,idx,ge) + fun setId (dtd:Dtd) (idx,a) = setByIndex(#idDict dtd,idx,a) + fun setNotation (dtd:Dtd) (idx,nt) = setByIndex(#notDict dtd,idx,SOME nt) + fun setParEnt (dtd:Dtd) (idx,pe) = setByIndex(#parDict dtd,idx,pe) + + fun maxUsedElem (dtd:Dtd) = usedIndices(#elDict dtd)-1 + fun maxUsedGen (dtd:Dtd) = usedIndices(#genDict dtd)-1 + fun maxUsedId (dtd:Dtd) = usedIndices(#idDict dtd)-1 + + (*--------------------------------------------------------------------*) + (* initialize the attribute tables. Make sure that indices 0...3 are *) + (* assigned to "default", "preserve", "xml:lang" and "xml:space". *) + (*--------------------------------------------------------------------*) + fun initAttNotTable (dtd as {idDict,notDict,...}:Dtd) = + let + val _ = clearDict(notDict,SOME(!O_TS_ATT_NOT)) + val _ = clearDict(idDict,SOME(!O_TS_ID)) + val _ = AttNot2Index dtd default + val _ = AttNot2Index dtd preserve + val _ = AttNot2Index dtd xmlLang + val _ = AttNot2Index dtd xmlSpace + in () + end + fun initElementTable (dtd:Dtd) = clearDict(#elDict dtd,SOME(!O_TS_ELEM)) + (*--------------------------------------------------------------------*) + (* reserve 0 for gen entity -, i.e., the document entity. *) + (* reserve 1 for gen entity amp, i.e., "&#38;" *) + (* reserve 2 for gen entity lt, i.e., "&#60;" *) + (* reserve 3 for gen entity gt, i.e., ">" *) + (* reserve 4 for gen entity apos, i.e., "'" *) + (* reserve 5 for gen entity quot, i.e., """ *) + (* reserve 0 for par entity -, i.e., the external dtd subset. *) + (* *) + (* Cf. 4.1: *) + (* *) + (* ... except that well-formed documents need not declare any of *) + (* the following entities: amp, lt, gt, apos, quot. *) + (* *) + (* and 4.6: *) + (* *) + (* *) + (* *) + (* *) + (* *) + (* *) + (*--------------------------------------------------------------------*) + fun initEntityTables (dtd as {genDict,parDict,preRedef,...}:Dtd) = + let + val _ = clearDict(genDict,SOME(!O_TS_GEN_ENT)) + val _ = clearDict(parDict,SOME(!O_TS_PAR_ENT)) + val _ = map (fn i => Array.update(preRedef,i,false)) [1,2,3,4,5] + val _ = GenEnt2Index dtd [0wx2D] (* "-" *) + val _ = ParEnt2Index dtd [0wx2D] (* "-" *) + val _ = Vector.appi + (fn (_,(name,lit,cs)) + => (setGenEnt dtd (GenEnt2Index dtd name,(GE_INTERN(lit,cs),false)))) + (predefined,1,NONE) + in () + end + + fun initDtdTables() = + let + val dtd = newDtd() + val _ = initAttNotTable dtd + val _ = initElementTable dtd + val _ = initEntityTables dtd + val _ = initStandalone dtd + in dtd + end + + local + val dtd = initDtdTables() + in + val defaultIdx = AttNot2Index dtd default + val preserveIdx = AttNot2Index dtd preserve + val xmlLangIdx = AttNot2Index dtd xmlLang + val xmlSpaceIdx = AttNot2Index dtd xmlSpace + val xmlSpaceType = AT_GROUP (IntLists.addIntList (preserveIdx,[defaultIdx])) + end + + fun printAttNotTable (dtd:Dtd) = + printDict NotationInfo2String (#notDict dtd) + fun printElementTable dtd = + printDict (ElemInfo2xString (UniChar.Data2String o (Index2AttNot dtd), + UniChar.Data2String o (Index2Element dtd), + UniChar.Data2String o (Index2GenEnt dtd), + UniChar.Data2String o (Index2Id dtd), + UniChar.Data2String o (Index2AttNot dtd))) (#elDict dtd) + fun printGenEntTable dtd = + printDict (fn (ent,ext) => GenEntity2xString (Data2String o (Index2AttNot dtd)) ent + ^(if ext then "[external]" else "")) (#genDict dtd) + fun printIdTable (dtd:Dtd) = printDict (IdInfo2String) (#idDict dtd) + fun printParEntTable (dtd:Dtd) = + printDict (fn (ent,ext) => ParEntity2String ent + ^(if ext then "[external]" else "")) (#parDict dtd) + + fun printDtdTables dtd = (printAttNotTable dtd; + printElementTable dtd; + printGenEntTable dtd; + printIdTable dtd; + printParEntTable dtd) + end +(* stop of ../../Parser/Params/dtd.sml *) +(* start of ../../Parser/Params/hookData.sml *) +structure HookData = + struct + type StartEnd = Errors.Position * Errors.Position + (*--------------------------------------------------------------------*) + (* a text declaration consists of a version info and an encoding decl.*) + (* an xml declaration has an additional standalone decl. *) + (*--------------------------------------------------------------------*) + type TextDecl = string option * string option + type XmlDecl = string option * string option * bool option + + type XmlInfo = Uri.Uri * Encoding.Encoding * XmlDecl option + type ExtSubsetInfo = Uri.Uri * Encoding.Encoding * TextDecl option + type SubsetInfo = Errors.Position + type EndDtdInfo = Errors.Position + + type ErrorInfo = Errors.Position * Errors.Error + type WarningInfo = Errors.Position * Errors.Warning + type NoFileInfo = string * string + + type CommentInfo = StartEnd * UniChar.Vector + type ProcInstInfo = StartEnd * UniChar.Data * Errors.Position * UniChar.Vector + + type DtdInfo = int * Base.ExternalId option + + datatype AttPresent = + AP_IMPLIED + | AP_MISSING + | AP_DEFAULT of UniChar.Vector * UniChar.Vector * Base.AttValue option + | AP_PRESENT of UniChar.Vector * UniChar.Vector * Base.AttValue option + + type AttSpec = int * AttPresent * (UniChar.Data * UniChar.Data) option + type AttSpecList = AttSpec list + + type EndTagInfo = StartEnd * int * (int * UniChar.Data) option + type StartTagInfo = StartEnd * int * AttSpecList * UniChar.Data * bool + type WhiteInfo = UniChar.Vector + type CDataInfo = StartEnd * UniChar.Vector + type DataInfo = StartEnd * UniChar.Vector * bool + + type CharRefInfo = StartEnd * UniChar.Char * UniChar.Vector + type GenRefInfo = StartEnd * int * Base.GenEntity * bool + type ParRefInfo = StartEnd * int * Base.ParEntity * bool + type EntEndInfo = Errors.Position + + datatype MarkupDecl = + DEC_ATTLIST of int * (int * Base.AttType * Base.AttDefault) list * bool + | DEC_ELEMENT of int * Base.ContentSpec * bool + | DEC_GEN_ENT of int * Base.GenEntity * bool + | DEC_PAR_ENT of int * Base.ParEntity * bool + | DEC_NOTATION of int * Base.ExternalId * bool + type DeclInfo = StartEnd * MarkupDecl + + fun isExtDecl decl = + case decl + of DEC_ATTLIST(_,_,ext) => ext + | DEC_ELEMENT(_,_,ext) => ext + | DEC_GEN_ENT(_,_,ext) => ext + | DEC_PAR_ENT(_,_,ext) => ext + | DEC_NOTATION(_,_,ext) => ext + end +(* stop of ../../Parser/Params/hookData.sml *) +(* start of ../../Parser/Params/hooks.sml *) + + + +signature Hooks = + sig + type AppData + type AppFinal + + val hookXml : AppData * HookData.XmlInfo -> AppData + val hookFinish : AppData -> AppFinal + + val hookError : AppData * HookData.ErrorInfo -> AppData + val hookWarning : AppData * HookData.WarningInfo -> AppData + + val hookProcInst : AppData * HookData.ProcInstInfo -> AppData + val hookComment : AppData * HookData.CommentInfo -> AppData + val hookWhite : AppData * HookData.WhiteInfo -> AppData + val hookDecl : AppData * HookData.DeclInfo -> AppData + + val hookStartTag : AppData * HookData.StartTagInfo -> AppData + val hookEndTag : AppData * HookData.EndTagInfo -> AppData + val hookCData : AppData * HookData.CDataInfo -> AppData + val hookData : AppData * HookData.DataInfo -> AppData + + val hookCharRef : AppData * HookData.CharRefInfo -> AppData + val hookGenRef : AppData * HookData.GenRefInfo -> AppData + val hookParRef : AppData * HookData.ParRefInfo -> AppData + val hookEntEnd : AppData * HookData.EntEndInfo -> AppData + + val hookDocType : AppData * HookData.DtdInfo -> AppData + val hookSubset : AppData * HookData.SubsetInfo -> AppData + val hookExtSubset : AppData * HookData.ExtSubsetInfo -> AppData + val hookEndDtd : AppData * HookData.EndDtdInfo -> AppData + end +(* stop of ../../Parser/Params/hooks.sml *) +(* start of ../../Parser/Params/resolve.sml *) + + + + +signature Resolve = + sig + val resolveExtId : Base.ExternalId -> Uri.Uri + end + +structure ResolveNull : Resolve = + struct + open Base Errors Uri + + fun resolveExtId (EXTID(_,sys)) = + case sys + of NONE => raise NoSuchFile ("","Could not generate system identifier") + | SOME (base,file,_) => uriJoin(base,file) + end +(* stop of ../../Parser/Params/resolve.sml *) +(* start of ../../Parser/Dfa/dfaUtil.sml *) + + + + + + +(*--------------------------------------------------------------------------*) +(* Structure: DfaUtil *) +(* *) +(* Depends on: *) +(* DfaData *) +(* UtilInt *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* boundsFollow : none *) +(* cmSymbols : none *) +(* makeRow : none *) +(* mergeFirst : ConflictFirst *) +(* mergeFollow : ConflictFollow *) +(*--------------------------------------------------------------------------*) +signature DfaUtil = + sig + val mergeFirst : bool -> DfaBase.First * DfaBase.First -> DfaBase.First + val mergeFollow : bool -> DfaBase.Follow * DfaBase.Follow -> DfaBase.Follow + val boundsFollow : DfaBase.Follow -> DfaBase.Sigma * DfaBase.Sigma + val cmSymbols : DfaBase.ContentModel -> DfaBase.Sigma list + val makeRow : DfaBase.Follow * bool -> DfaBase.Row + end + +structure DfaUtil : DfaUtil = + struct + open UtilInt DfaBase + + (*--------------------------------------------------------------------*) + (* merge two First sets, raise ConflictFirst at conflict: there may *) + (* not be two entries (q1,a) and (q2,a) in the same First set, if *) + (* nondet is false. *) + (*--------------------------------------------------------------------*) + fun mergeFirst nondet ll = + let + fun go_det (nil,l) = l + | go_det (l,nil) = l + | go_det (l1 as (x1 as (q1,a1))::r1,l2 as (x2 as (q2,a2))::r2) = + case Int.compare(a1,a2) + of LESS => x1::go_det(r1,l2) + | GREATER => x2::go_det(l1,r2) + | EQUAL => raise ConflictFirst(a1,q1,q2) + + fun go_nondet (nil,l) = l + | go_nondet (l,nil) = l + | go_nondet (l1 as (x1 as (q1,a1))::r1,l2 as (x2 as (q2,a2))::r2) = + case Int.compare(a1,a2) + of LESS => x1::go_nondet(r1,l2) + | GREATER => x2::go_nondet(l1,r2) + | EQUAL => case Int.compare(q1,q2) + of LESS => x1::go_nondet(r1,l2) + | GREATER => x2::go_nondet(l1,r2) + | EQUAL => go_nondet(l1,r2) + in + if nondet then go_nondet ll else go_det ll + end + + (*--------------------------------------------------------------------*) + (* merge two Follow sets, raise ConflictFollow at conflict. there may *) + (* not be two entries (q1,a) and (q2,a) with q1<>q2 in the same Follow*) + (* set, if nondet is false. Note that, e.g. for (a+)+, Follow(a) = *) + (* Follow(a+) U First(a+), so duplicate occurrences of the same (q,a) *) + (* are possible (as opposed to First). *) + (*--------------------------------------------------------------------*) + fun mergeFollow nondet ll = + let + fun go_det (nil,l) = l + | go_det (l,nil) = l + | go_det (l1 as (x1 as (q1,a1))::r1,l2 as (x2 as (q2,a2))::r2) = + case Int.compare(a1,a2) + of LESS => x1::go_det(r1,l2) + | GREATER => x2::go_det(l1,r2) + | EQUAL => if q1=q2 then go_det(l1,r2) + else raise ConflictFollow(a1,q1,q2) + + fun go_nondet (nil,l) = l + | go_nondet (l,nil) = l + | go_nondet (l1 as (x1 as (q1,a1))::r1,l2 as (x2 as (q2,a2))::r2) = + case Int.compare(a1,a2) + of LESS => x1::go_nondet(r1,l2) + | GREATER => x2::go_nondet(l1,r2) + | EQUAL => case Int.compare(q1,q2) + of LESS => x1::go_nondet(r1,l2) + | GREATER => x2::go_nondet(l1,r2) + | EQUAL => go_nondet(l1,r2) + in + if nondet then go_nondet ll else go_det ll + end + + (*--------------------------------------------------------------------*) + (* what are the least and largest symbol occurring in a Follow set? *) + (*--------------------------------------------------------------------*) + fun boundsFollow (nil:Follow) = (1,0) + | boundsFollow [(q,a)] = (a,a) + | boundsFollow ((q,a)::xs) = (a,#2(List.last xs)) + + (*--------------------------------------------------------------------*) + (* return the list of all symbols occurring in a content model. *) + (*--------------------------------------------------------------------*) + fun cmSymbols cm = + let + fun do_cm(cm,yet) = + case cm + of CM_ELEM a => insertInt(a,yet) + | CM_OPT cm => do_cm(cm,yet) + | CM_REP cm => do_cm(cm,yet) + | CM_PLUS cm => do_cm(cm,yet) + | CM_ALT cms => foldr do_cm yet cms + | CM_SEQ cms => foldr do_cm yet cms + in do_cm(cm,nil) + end + + (*--------------------------------------------------------------------*) + (* given the follow set and the final flag, make a row in the dfa. *) + (*--------------------------------------------------------------------*) + fun makeRow (flw,fin) = + let + val (lo,hi) = boundsFollow flw + val tab = Array.array(hi-lo+1,dfaError) + val _ = app (fn (q,a) => Array.update (tab,a-lo,q)) flw + in + (lo,hi,Array.extract (tab,0,NONE),fin) + end + + end +(* stop of ../../Parser/Dfa/dfaUtil.sml *) +(* start of ../../Util/intSets.sml *) + + + + + + + +signature IntSets = + sig + eqtype IntSet + + val emptyIntSet : IntSet + val singleIntSet : int -> IntSet + val fullIntSet : int -> IntSet + + val isEmptyIntSet : IntSet -> bool + val inIntSet : int * IntSet -> bool + + val compareIntSets: IntSet * IntSet -> order + val hashIntSet : IntSet -> word + + val addIntSet : int * IntSet -> IntSet + val delIntSet : int * IntSet -> IntSet + + val cupIntSets : IntSet * IntSet -> IntSet + val capIntSets : IntSet * IntSet -> IntSet + val diffIntSets : IntSet * IntSet -> IntSet + + val IntSet2List : IntSet -> int list + val IntList2Set : int list -> IntSet + end + +structure IntSets : IntSets = + struct + structure W = Word32 + val wordSize = W.wordSize + + type IntSet = W.word vector + + infix 7 << >> + infix 6 && + infix 5 || + + val op >> = W.>> + val op << = W.<< + val op && = W.andb + val op || = W.orb + val !! = W.notb + + fun normalize (vec:IntSet) = + let val max = Vector.foldli + (fn (i,w,max) => if w=0wx0 then i else max) 0 (vec,0,NONE) + in Vector.extract (vec,0,SOME max) + end + + val emptyIntSet = Vector.fromList nil : IntSet + + fun fullIntSet n = let val size = (n+wordSize-1) div wordSize + val full = 0w0-0w1:W.word + val bits = (n-1) mod wordSize+1 + val last = full >> (Word.fromInt (wordSize-bits)) + in Vector.tabulate(n div wordSize+1, + fn i => if i if i=idx then mask else 0w0):IntSet + end + + fun isEmptyIntSet vec = Vector.length vec=0 + + fun inIntSet(n,vec) = + let val idx = n div wordSize + in if idx>=Vector.length vec then false + else let val mask = 0w1 << (Word.fromInt (n mod wordSize)) + in Vector.sub(vec,idx) && mask <> 0w0 + end + end + + fun addIntSet(n,vec) = + let + val idx = n div wordSize + val mask = 0w1 << (Word.fromInt (n mod wordSize)) + val size = Vector.length vec + in + if size>idx + then Vector.mapi (fn (i,x) => if i=idx then x||mask else x) (vec,0,NONE) + else Vector.tabulate + (idx+1,fn i => if i if i=idx then x && mask else x) (vec,0,NONE) + end + in normalize vec1 + end + + fun capIntSets(vec1,vec2) = + let + val l12 = Int.min(Vector.length vec1,Vector.length vec2) + val v12 = Vector.tabulate(l12,fn i => Vector.sub(vec1,i) && Vector.sub(vec2,i)) + in + normalize v12 + end + + fun cupIntSets(vec1,vec2) = + let + val (l1,l2) = (Vector.length vec1,Vector.length vec2) + val (shorter,longer,v) = if l1<=l2 then (l1,l2,vec2) else (l2,l1,vec1) + in + Vector.tabulate (longer,fn i => if i>=shorter then Vector.sub(v,i) + else Vector.sub(vec1,i) || Vector.sub(vec2,i)) + end + + fun diffIntSets(vec1,vec2) = + let + val (l1,l2) = (Vector.length vec1,Vector.length vec2) + val vec1 = Vector.tabulate + (l1,fn i => if i>=l2 then Vector.sub(vec1,i) + else Vector.sub(vec1,i) && !!(Vector.sub(vec2,i))) + in normalize vec1 + end + + fun IntList2Set l = List.foldl addIntSet emptyIntSet l + + fun IntSet2List vec = + let + val size = Vector.length vec + fun doOne (w,off,yet) = + let fun doit (i,mask) = + if i=wordSize then yet + else if w&&mask=0w0 then doit(i+1,mask<<0wx1) + else (off+i)::doit(i+1,mask<<0wx1) + in doit(0,0wx1) + end + fun doAll i = if i>=size then nil + else doOne(Vector.sub(vec,i),wordSize*i,(doAll (i+1))) + in doAll 0 + end + + fun compareIntSets (vec1,vec2:IntSet) = + let + val (l1,l2) = (Vector.length vec1,Vector.length vec2) + val (l12,ifEq) = case Int.compare(l1,l2) + of LESS => (l1,LESS) + | order => (l2,order) + fun doit i = if i>=l12 then ifEq + else case W.compare(Vector.sub(vec1,i),Vector.sub(vec2,i)) + of EQUAL => doit (i+1) + | order => order + in doit 0 + end + + val intShift = case Int.precision + of NONE => 0w0 + | SOME x => Word.fromInt(Int.max(wordSize-x+1,0)) + + fun hashIntSet vec = + case Vector.length vec + of 0 => 0w0 + | 1 => Word.fromInt(W.toInt(W.>>(Vector.sub(vec,0),intShift))) + | l => Word.fromInt(W.toInt(W.>>(Vector.sub(vec,0)+Vector.sub(vec,l-1),intShift))) + end +(* stop of ../../Util/intSets.sml *) +(* start of ../../Util/SymDict/intSetDict.sml *) + + + + + + + +structure KeyIntSet : Key = + struct + open IntSets UtilString + + type Key = IntSet + + val null = emptyIntSet + val hash = hashIntSet + val compare = compareIntSets + val toString = (List2xString ("{",",","}") Int2String) o IntSet2List + end + +structure IntSetDict = Dict (structure Key = KeyIntSet) +structure IntSetSymTab = SymTable (structure Key = KeyIntSet) + + +(* stop of ../../Util/SymDict/intSetDict.sml *) +(* start of ../../Parser/Dfa/dfaPassThree.sml *) + + + + + + + + + + + +(*--------------------------------------------------------------------------*) +(* Structure: DfaPassThree *) +(* *) +(* Depends on: *) +(* DfaData *) +(* DfaUtil *) +(* IntSets *) +(* IntSetDict *) +(* ParseOptions *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* passThree : TooLarge *) +(*--------------------------------------------------------------------------*) +signature DfaPassThree = + sig + val passThree: bool -> (DfaBase.Follow * bool) vector -> DfaBase.Dfa + end + +functor DfaPassThree (structure DfaOptions : DfaOptions) : DfaPassThree = + struct + open + IntSets IntSetDict DfaBase DfaOptions DfaUtil + + (*--------------------------------------------------------------------*) + (* do the subset construction. *) + (*--------------------------------------------------------------------*) + (* given an automaton (Q,q0,F,delta), the subset automaton is *) + (* (Q',q0',F',delta') with: *) + (* - Q' = 2^Q *) + (* - q0'= {q0} *) + (* - F' = {S | S cap F <> empty} *) + (* - delta'(S,a) = {p | (q,a,p) in delta, q in S} *) + (*--------------------------------------------------------------------*) + fun makeDet tab = + let + (* the new start state is the singleton of the old start state *) + val sNull = singleIntSet 0 + + (* create a dictionary for the subsets, make sNull get index 0 *) + val tau = makeDict("",!O_DFA_INITIAL_WIDTH,(nil:Follow,false)) + val pInitial = getIndex(tau,sNull) + + (* enter a new set state. raise DfaTooLarge if the new state *) + (* would have a too large index *) + fun makeState s = + let val (max,i) = (!O_DFA_MAX_STATES,getIndex(tau,s)) + in if max>i then i else raise DfaTooLarge max + end + + (* compute the follow set for a set state from the follow sets *) + (* of its members *) + fun makeFollow NONE nil = nil + | makeFollow (SOME(s,a)) nil = [(makeState s,a)] + | makeFollow NONE ((q,a)::qas) = makeFollow (SOME(singleIntSet q,a)) qas + | makeFollow (SOME(s,a)) ((q,b)::qas) = + if a=b then makeFollow (SOME(addIntSet(q,s),a)) qas + else (makeState s,a)::makeFollow (SOME(singleIntSet q,b)) qas + + (* continue until all entries in the state dictionary are done -*) + fun doit i = + if i>=usedIndices tau then i + else let val sI = getKey(tau,i) + val lI = IntSet2List sI + val ffs = map (fn j => Vector.sub(tab,j)) lI + val (followJs,finI) = foldl + (fn ((flwJ,finJ),(flw,fin)) => (mergeFollow true (flwJ,flw), + finJ orelse fin)) + (nil,false) ffs + val followI = makeFollow NONE followJs + val _ = setByIndex(tau,i,(followI,finI)) + in doit (i+1) + end + + val size = doit 0 + in (* finally create a vector holding the new follow/fin pairs *) + Vector.tabulate (size,fn i => getByIndex(tau,i)) + end + + (*--------------------------------------------------------------------*) + (* given a vector of Follow and boolean final condition, make a dfa *) + (* out of it. if the first arg is true, then the content model was *) + (* ambiguous; in this case we must first apply a subset construction *) + (* in order to obtain a deterministic finite machine. *) + (*--------------------------------------------------------------------*) + fun passThree nondet tab = + let + val det = if nondet then makeDet tab else tab + in Vector.map makeRow det + end + end +(* stop of ../../Parser/Dfa/dfaPassThree.sml *) +(* start of ../../Parser/Dfa/dfaError.sml *) + + +(*--------------------------------------------------------------------------*) +(* Structure: DfaError *) +(* *) +(* Note: *) +(* The function in this structure is for producing good error messages *) +(* for ambiguous content models. It numbers the nodes of a cm exactly *) +(* like passOne does, but counts the occurrences of symbol a in order to *) +(* indicate which are in conflict. It is only executed in case of error. *) +(* *) +(* Depends on: *) +(* DfaData *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* countOccs : none *) +(*--------------------------------------------------------------------------*) +signature DfaError = + sig + val countOccs : DfaBase.Sigma * DfaBase.State * DfaBase.State + -> DfaBase.ContentModel -> DfaBase.Sigma * int * int + end + +structure DfaError : DfaError = + struct + open DfaBase + + fun countOccs (a,q1,q2) cm = + let + val (q1,q2) = if q1>q2 then (q2,q1) else (q1,q2) + + fun next a nil = (1,[(a,2)]) + | next a ((b,n)::rest) = + if a=b then (n,(b,n+1)::rest) + else if a insert a yet + | CM_OPT cmi => doit (cmi,yet) + | CM_REP cmi => doit (cmi,yet) + | CM_PLUS cmi => doit (cmi,yet) + | CM_ALT cmis => foldl doit yet cmis + | CM_SEQ cmis => foldl doit yet cmis + + val (_,_,n1,n2) = doit (cm,(1,nil,0,0)) + in + (a,n1,n2) + end + end +(* stop of ../../Parser/Dfa/dfaError.sml *) +(* start of ../../Parser/Dfa/dfaPassOne.sml *) + + + +(*--------------------------------------------------------------------------*) +(* Structure: DfaPassOne *) +(* *) +(* Depends on: *) +(* DfaData *) +(* DfaUtil *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* passOne : ConflictFirst *) +(*--------------------------------------------------------------------------*) +signature DfaPassOne = + sig + val passOne : bool -> DfaBase.ContentModel -> DfaBase.CM + end + +structure DfaPassOne : DfaPassOne = + struct + open DfaBase DfaUtil + + (*--------------------------------------------------------------------*) + (* Given a content model, number the leafs, compute Empty and First *) + (* for each node, and construct a corresponding CM annotated with *) + (* these informations. *) + (* *) + (* Numbering: *) + (* The leafs are numbered in left-to-right, depth-first order, *) + (* starting with 1 (0 will be the start state of the DFA). *) + (* *) + (* Empty a = false *) + (* Empty e? = Empty e* = true *) + (* Empty e+ = Empty e *) + (* Empty e1|...|eN = Empty e1 \/ ... \/ Empty eN *) + (* Empty e1,...,eN = Empty e1 /\ ... /\ Empty eN *) + (* *) + (* First a = {q,a}, where q is the number of this leaf. *) + (* First e? = First e* = First e+ = First e *) + (* First e1|...|eN = First e1 ++ ... ++ First eN *) + (* First e1,...,eN = ++{First eI | Empty eJ=False forall ja1 forall (q1,a1) in F1, (q1,a1) in F1} *) + (* error, if exist (q1,a) in F1, (q2,a) in F2 *) + (* then raise ConflictFirst(a,q1,q2) *) + (*--------------------------------------------------------------------*) + fun passOne nondet cm = + let + fun und(a,b) = a andalso b + fun oder(a,b) = a orelse b + + fun op_fst_seq (fst,fsts,mt) = if mt then mergeFirst nondet (fst,fsts) else fst + fun op_fst_or (fst,fsts,_) = mergeFirst nondet (fst,fsts) + + fun do_cm cm q = + case cm + of CM_ELEM a => (ELEM a,(q+1,false,[(q+1,a)])) + | CM_OPT cm => let val cmi as (_,(q1,_,fst)) = do_cm cm q + in (OPT cmi,(q1,true,fst)) + end + | CM_REP cm => let val cmi as (_,(q1,_,fst)) = do_cm cm q + in (REP cmi,(q1,true,fst)) + end + | CM_PLUS cm => let val cmi as (_,info1) = do_cm cm q + in (PLUS cmi,info1) + end + | CM_ALT cms => do_cms (ALT,false,oder,op_fst_or) cms q + | CM_SEQ cms => do_cms (SEQ,true,und,op_fst_seq) cms q + + and do_cms(con,null_mt,op_mt,op_fst) cms q = + let + fun doit [] q = ([],(q,null_mt,[])) + | doit (cm::cms) q = + let + val cmi as (_,(q1,mt1,fst1)) = do_cm cm q + val (cmis,(q2,mt2,fst2)) = doit cms q1 + in (cmi::cmis,(q2,op_mt(mt1,mt2),op_fst(fst1,fst2,mt1))) + end + val (cmis,info1) = doit cms q + in (con cmis,info1) + end + + in do_cm cm 0 + end + end +(* stop of ../../Parser/Dfa/dfaPassOne.sml *) +(* start of ../../Parser/Dfa/dfaPassTwo.sml *) + + + + + +(*--------------------------------------------------------------------------*) +(* Structure: DfaPassTwo *) +(* *) +(* Depends on: *) +(* DfaData *) +(* DfaUtil *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* passTwo : ConflictFollow *) +(*--------------------------------------------------------------------------*) +signature DfaPassTwo = + sig + val passTwo: bool -> DfaBase.CM -> (DfaBase.Follow * bool) vector + end + +structure DfaPassTwo : DfaPassTwo = + struct + open DfaBase DfaUtil + + (*--------------------------------------------------------------------*) + (* Given a CM annotated with leaf numbers (states), Empty and First, *) + (* compute Follow and Fin foreach node, and generate the transition *) + (* row if node is a leaf. Follow and Fin are computed top-down: *) + (* *) + (* (Top-Level): *) + (* Follow e = {}, Fin e = true *) + (* *) + (* (e=e1?): *) + (* Follow e1 = Follow e, Fin e1 = Fin e *) + (* *) + (* (e=e1*, e=e1+) *) + (* Follow e1 = Follow e1 ++ First e1, Fin e1 = Fin e *) + (* *) + (* (e=e1|...|eN) = *) + (* Follow eI = Follow e, Fin eI = Fin e for i=0...n *) + (* *) + (* (e=e1,...,eN) = *) + (* Follow eN = Follow e, Fin eN = Fin e *) + (* Follow eI = First eI+1, if Empty eI+1 = false, ia1 forall (q1,a1) in F1, (q1,a1) in F1} *) + (* error, if exist (q1,a) in F1, (q2,a) in F2 *) + (* then raise ConflictFirst(a,q1,q2) *) + (*--------------------------------------------------------------------*) + fun passTwo nondet (cmi as (_,(n,mt,fst))) = + let + val table = Array.array(n+1,(nil,false)) + + val _ = Array.update(table,0,(fst,mt)) + + fun do_cm (ff as (flw,fin)) (cm,(q,mt,fst)) = + case cm + of ELEM a => Array.update(table,q,ff) + | OPT cmi => do_cm ff cmi + | REP cmi => do_cm (mergeFollow nondet (fst,flw),fin) cmi + | PLUS cmi => do_cm (mergeFollow nondet (fst,flw),fin) cmi + | ALT cmis => app (do_cm ff) cmis + | SEQ cmis => ignore (do_seq ff cmis) + and do_seq ff cmis = foldr + (fn (cmi as (_,(_,mt,fst)),ff as (flw,fin)) + => (do_cm ff cmi; + if mt then (mergeFollow nondet (fst,flw),fin) else (fst,false))) + ff cmis + + val _ = do_cm (nil,true) cmi + + in Array.extract (table,0,NONE) + end + end +(* stop of ../../Parser/Dfa/dfaPassTwo.sml *) +(* start of ../../Parser/Dfa/dfa.sml *) + + + + + + + + + + +(*--------------------------------------------------------------------------*) +(* Structure: Dfa *) +(* *) +(* Depends on: *) +(* DfaData *) +(* DfaError *) +(* DfaPassOne *) +(* DfaPassTwo *) +(* DfaString *) +(* DfaUtil *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* ContentModel2String : none *) +(* dfaFinal : none *) +(* dfaTrans : none *) +(* makeAmbiguous : DfaTooLarge *) +(* makeChoiceDfa : none *) +(* makeDfa : Ambiguous *) +(* Dfa2String : none *) +(*--------------------------------------------------------------------------*) +signature Dfa = + sig + eqtype DfaState + + val dfaError : DfaState + val dfaInitial : DfaState + + exception DfaTooLarge of int + exception Ambiguous of int * int * int + + val emptyDfa : DfaData.Dfa + + val makeDfa : DfaData.ContentModel -> DfaData.Dfa + val makeAmbiguous : DfaData.ContentModel -> DfaData.Dfa + val makeChoiceDfa : DfaData.ContentModel -> DfaData.Dfa + + val dfaFinal : DfaData.Dfa * DfaState -> bool + val dfaTrans : DfaData.Dfa * DfaState * int -> DfaState + end + +functor Dfa (structure DfaOptions : DfaOptions) : Dfa = + struct + structure DfaPassThree = DfaPassThree (structure DfaOptions = DfaOptions) + + open + DfaBase DfaError DfaPassOne DfaPassTwo DfaString DfaUtil + + type DfaState = State + + (*--------------------------------------------------------------------*) + (* Create a dfa for the content model (a1|...|aN)*, where a1,...,aN *) + (* are the symbols occurring in the input dfa. *) + (*--------------------------------------------------------------------*) + fun makeChoiceDfa cm = + let + val syms = cmSymbols cm + val flw = map (fn a => (dfaInitial,a)) syms + in + Vector.fromList [makeRow(flw,true)] + end + + (*--------------------------------------------------------------------*) + (* create a dfa for an ambiguous content model. Raise DfaTooLarge if *) + (* the subset construction yields too many states. *) + (*--------------------------------------------------------------------*) + fun makeAmbiguous cm = + let + val cmi = DfaPassOne.passOne true cm + val tab = DfaPassTwo.passTwo true cmi + val dfa = DfaPassThree.passThree true tab + in dfa + end + + (*--------------------------------------------------------------------*) + (* generate a dfa for a content model. Raise Ambiguous if the content *) + (* model is ambiguous. *) + (*--------------------------------------------------------------------*) + fun makeDfa cm = + let + val cmi = DfaPassOne.passOne false cm + val tab = DfaPassTwo.passTwo false cmi + val dfa = DfaPassThree.passThree false tab + in dfa + end + handle ConflictFirst aqq => raise Ambiguous (countOccs aqq cm) + | ConflictFollow aqq => raise Ambiguous (countOccs aqq cm) + + (*--------------------------------------------------------------------*) + (* make one transitions in the dfa. *) + (*--------------------------------------------------------------------*) + fun dfaTrans(tab,q,a) = + if q<0 then dfaDontCare + else let val (lo,hi,tab,_) = Vector.sub(tab,q) + in if a>=lo andalso a<=hi then Vector.sub(tab,a-lo) else dfaError + end + + (*--------------------------------------------------------------------*) + (* check whether a dfa's state is an accepting state. *) + (*--------------------------------------------------------------------*) + fun dfaFinal (tab,q) = + q<0 orelse #4(Vector.sub(tab,q):Row) + end +(* stop of ../../Parser/Dfa/dfa.sml *) +(* start of ../../Parser/entities.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: Entities *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* closeAll : none *) +(* getChar : none *) +(* getEntId : none *) +(* getPos : none *) +(* inInternalSubset : none *) +(* isOpenEntity : none *) +(* isSpecialEnd : none *) +(* Position2String : none *) +(* pushDummy : none *) +(* pushExtern : NoSuchFile *) +(* pushIntern : none *) +(* pushSpecial : NoSuchFile *) +(* statePos : none *) +(*--------------------------------------------------------------------------*) +(* This module maintains the entity stack. For each open entity it holds a *) +(* buffer to read characters from. When the buffer is exceeded, it gets re- *) +(* filled with new characters, depending on the entity's encoding. *) +(* *) +(* End-of-line handling as specified in 2.11 is performed: *) +(* *) +(* ... To simplify the tasks of applications, wherever an external parsed *) +(* entity or the literal entity value of an internal parsed entity *) +(* contains either the literal two-character sequence "#xD#xA" or a *) +(* standalone literal #xD, an XML processor must pass to the application *) +(* the single character #xA. *) +(* (This behavior can conveniently be produced by normalizing all line *) +(* breaks to #xA on input, before parsing.) *) +(* *) +(* It also checks for illegal characters, cf. 2.2: *) +(* *) +(* [2] Char ::= #x9 | #xA | #xD /* any Unicode character, *) +(* | [#x20-#xD7FF] excluding the surrogate *) +(* | [#xE000-#xFFFD] blocks, FFFE, and FFFF. */ *) +(* | [#x10000-#x10FFFF] *) +(* *) +(* More precisely, it assumes that all decoded characters are valid Unicode *) +(* characters. It thus only checks for control characters other than #x9, *) +(* #xA or #xD. *) +(*--------------------------------------------------------------------------*) +signature Entities = + sig + include Hooks + + type State + eqtype EntId + datatype Special = DOC_ENTITY | EXT_SUBSET + + exception CantOpenFile of (string * string) * AppData + + val pushIntern : State * int * bool * UniChar.Vector -> State + val pushExtern : State * int * bool * Uri.Uri -> State * Encoding.Encoding + val pushSpecial : Special * Uri.Uri option -> State * Encoding.Encoding + + val closeAll : State -> unit + + val commitAuto : AppData * State -> AppData * State + val changeAuto : AppData * State * string -> AppData * State * Encoding.Encoding + + val getEntId : State -> EntId + val getPos : State -> Errors.Position + val getUri : State -> Uri.Uri + + val getChar : AppData * State -> UniChar.Char * AppData * State + val ungetChars : State * UniChar.Data -> State + + val isOpen : int * bool * State -> bool + val isSpecial : State -> bool + val inDocEntity : State -> bool + end + +functor Entities (structure Hooks : Hooks) : Entities = + struct + open + UniChar Decode Decode.Error Errors Hooks Uri UtilError + + val THIS_MODULE = "Entities" + val BUFSIZE = 1024 + type CharBuffer = UniChar.Char array + + (*--------------------------------------------------------------------*) + (* A special entity can not be popped from the stack by getChar, so *) + (* it must be popped explicitly. This is for the document entity and *) + (* the external subset. *) + (*--------------------------------------------------------------------*) + datatype Special = DOC_ENTITY | EXT_SUBSET + (*--------------------------------------------------------------------*) + (* In order to distinguish a general entity from a paramter entity, *) + (* entity idxs are marked with this datatype. *) + (*--------------------------------------------------------------------*) + datatype EntId = GENERAL of int | PARAMETER of int + + (*--------------------------------------------------------------------*) + (* Make an EntId from the entity's index. *) + (*--------------------------------------------------------------------*) + fun makeEntId(idx,isParam) = + if isParam then PARAMETER idx else GENERAL idx + + (*--------------------------------------------------------------------*) + (* A non-empty stack is: *) + (* *) + (* an internal entity INT(buf,size,idx,(id,other)): *) + (* - (vec,idx,size) is a buffer,current index and its size; *) + (* - id is the index of the entity's name in the entity table. *) + (* - other contains the underlying entities (the rest of the stack). *) + (* The components are nested according to access frequency. *) + (* *) + (* an external entity has three forms: *) + (* EXT2(buf,size,idx,line,col,break,(dec,err,typ)) *) + (* - (buf,size,idx) is a buffer, its size and current index; *) + (* - (line,col) are the line and column; *) + (* - break is a boolean indicating whether the last character was a *) + (* carriage return (0xD) (then a succeeding line feed (0xA) must be *) + (* supressed); *) + (* - err is an option: if it is SOME(f,ee,err) then it indicates that *) + (* the array was finished by a decoding error err, with the basic *) + (* file f; f was at end of file if ee is true. Otherwise there was *) + (* no error when loading the array. *) + (* - dec describies the encoding of the entity and thus, how more *) + (* data can be loaded; *) + (* - typ is either of the form SPECIAL spec indicating a special *) + (* entity; then this is the only entity on the stack. Otherwise it *) + (* is NORMAL(id,other) for a normal external entity, with: *) + (* + id is the index of the entity's name in the DTD; *) + (* + other is the underlying stack. *) + (* The components are nested according to access frequency. *) + (* *) + (* The second form of an external entity is *) + (* EXT1(dec,line,col,break,typ). This is an unbuffered *) + (* entity whose encoding declaration is being read. We may not load *) + (* an array of characters as a whole because the encoding might still *) + (* change. The components have the same meaning as for EXT2. *) + (* *) + (* A closed entity remains on the stack until the next getChar, for *) + (* purposes of error printing. A closed external entity has the form *) + (* CLOSED(dec,l,col,typ); components have the same meaning *) + (* as for open external entities. A closed internal entity has the *) + (* form ENDED(id,other) with components as above. *) + (* *) + (* Sometimes (for parsing xml/decl declarations) we need a lookahead. *) + (* LOOKING(cs,q) is a state remembering all chars cs looked ahead up *) + (* to state q, in reverse order. LOOKED(cs,q) is an undone lookahead, *) + (* the looked-ahead chars now in the right order. *) + (*--------------------------------------------------------------------*) + datatype ExtType = SPECIAL of Special | NORMAL of EntId * State + and State = + LOOKED of Data * State + | ENDED of EntId * State + | CLOSED of DecFile * int * int * ExtType + | INT of Vector * int * int * (EntId * State) + | EXT1 of DecFile * int * int * bool * ExtType + | EXT2 of CharBuffer * int * int * int * int * bool + * (DecFile * DecodeError option * ExtType) + + exception CantOpenFile of (string * string) * AppData + + (*--------------------------------------------------------------------*) + (* Extract the unique number from a state. *) + (*--------------------------------------------------------------------*) + fun getExtEntId extType = + case extType + of SPECIAL DOC_ENTITY => GENERAL 0 + | SPECIAL EXT_SUBSET => PARAMETER 0 + | NORMAL(id,_) => id + fun getEntId q = + case q + of LOOKED (_,q) => getEntId q + | ENDED(id,_) => id + | CLOSED(_,_,_,extType) => getExtEntId extType + | INT(_,_,_,(id,_)) => id + | EXT1(_,_,_,_,extType) => getExtEntId extType + | EXT2(_,_,_,_,_,_,(_,_,extType)) => getExtEntId extType + + (*--------------------------------------------------------------------*) + (* Find the nearest enclosing external entity, and return its *) + (* filename, line and column number. *) + (*--------------------------------------------------------------------*) + fun getPos q = + case q + of ENDED(_,other) => getPos other + | INT(_,_,_,(_,other)) => getPos other + | CLOSED(dec,l,col,_) => (decName dec,l,col) + | EXT1(dec,l,col,_,_) => (decName dec,l,col) + | EXT2(_,_,_,l,col,_,(dec,_,_)) => (decName dec,l,col) + | LOOKED (cs,q) => let val (f,l,c) = getPos q + val k = length cs + in if c>=k then (f,l,c-k) else (f,l,0) + end + + (*--------------------------------------------------------------------*) + (* get the path of the nearest enclosing external entity. *) + (*--------------------------------------------------------------------*) + fun getUri q = + case q + of LOOKED (_,q) => getUri q + | ENDED(_,other) => getUri other + | INT(_,_,_,(_,other)) => getUri other + | CLOSED(dec,l,col,_) => decUri dec + | EXT1(dec,l,col,_,_) => decUri dec + | EXT2(_,_,_,l,col,_,(dec,_,_)) => decUri dec + + (*--------------------------------------------------------------------*) + (* close all files, return nothing. *) + (*--------------------------------------------------------------------*) + fun closeAll q = + case q + of LOOKED(_,other) => closeAll other + | ENDED(_,other) => closeAll other + | CLOSED(_,_,_,SPECIAL _) => () + | CLOSED(_,_,_,NORMAL(_,other)) => closeAll other + | INT(_,_,_,(_,other)) => closeAll other + | EXT1(dec,_,_,_,SPECIAL _) => ignore(decClose dec) + | EXT1(dec,_,_,_,NORMAL(_,other)) => (decClose dec; closeAll other) + | EXT2(_,_,_,_,_,_,(dec,_,SPECIAL _)) => ignore(decClose dec) + | EXT2(_,_,_,_,_,_,(dec,_,NORMAL(_,other))) => (decClose dec; closeAll other) + + (*--------------------------------------------------------------------*) + (* is this entity already on the stack? *) + (*--------------------------------------------------------------------*) + fun isOpen (idx,isParam,q) = + let val id = makeEntId(idx,isParam) + fun doit q = + case q + of LOOKED (_,other) => doit other + | ENDED(id',other) => id=id' orelse doit other + | CLOSED(_,_,_,SPECIAL _) => false + | CLOSED(_,_,_,NORMAL(id',other)) => id=id' orelse doit other + | INT(_,_,_,(id',other)) => id=id' orelse doit other + | EXT1(_,_,_,_,SPECIAL _) => false + | EXT1(_,_,_,_,NORMAL(id',other)) => id=id' orelse doit other + | EXT2(_,_,_,_,_,_,(_,_,SPECIAL _)) => false + | EXT2(_,_,_,_,_,_,(_,_,NORMAL(id',other))) => id=id' orelse doit other + in doit q + end + + (*--------------------------------------------------------------------*) + (* are we in the internal subset, i.e., in the document entity? *) + (* The internal subset can only be in the document entity, since no *) + (* parameter entities are declared prior to it. The document entity *) + (* is then the only entity on the stack. *) + (*--------------------------------------------------------------------*) + fun inDocEntity q = + case q + of LOOKED (_,q) => inDocEntity q + | ENDED(_,other) => inDocEntity other + | INT(_,_,_,(_,other)) => inDocEntity other + | CLOSED(_,_,_,NORMAL _) => false + | CLOSED(_,_,_,SPECIAL what) => what=DOC_ENTITY + | EXT1(_,_,_,_,NORMAL _) => false + | EXT1(_,_,_,_,SPECIAL what) => what=DOC_ENTITY + | EXT2(_,_,_,_,_,_,(_,_,NORMAL _)) => false + | EXT2(_,_,_,_,_,_,(_,_,SPECIAL what)) => what=DOC_ENTITY + + (*--------------------------------------------------------------------*) + (* is this state the document end, i.e., are all entities closed? *) + (*--------------------------------------------------------------------*) + fun isSpecial q = + case q + of LOOKED (_,q) => isSpecial q + | CLOSED(_,_,_,SPECIAL _) => true + | EXT1(_,_,_,_,SPECIAL _) => true + | EXT2(_,_,_,_,_,_,(_,_,SPECIAL _)) => true + | _ => false + + (*--------------------------------------------------------------------*) + (* Initialize and load a new buffer when opening an external entity. *) + (*--------------------------------------------------------------------*) + fun initArray dec = + let + val arr = Array.array(BUFSIZE,0wx0) + val (n,dec1,err) = decGetArray dec arr + in (arr,n,dec1,err) + end + + (*--------------------------------------------------------------------*) + (* Open an external/internal entity. *) + (*--------------------------------------------------------------------*) + fun pushIntern(q,id,isParam,vec) = + INT(vec,Vector.length vec,0,(makeEntId(id,isParam),q)) + fun pushExtern(q,id,isParam,uri) = + let + val dec = decOpenXml (SOME uri) + val auto = decEncoding dec + val q1 = EXT1(dec,1,0,false,NORMAL(makeEntId(id,isParam),q)) + in (q1,auto) + end + fun pushSpecial(what,uri) = + let + val dec = decOpenXml uri + val auto = decEncoding dec + val q = EXT1(dec,1,0,false,SPECIAL what) + in (q,auto) + end + + (*--------------------------------------------------------------------*) + (* confirm the autodetected encoding of an external entity. *) + (*--------------------------------------------------------------------*) + fun commitAuto(a,q) = + case q + of EXT1(dec,l,col,brk,typ) => + let + val a1 = a before decCommit dec + handle DecError(_,_,err) + => hookError(a,(getPos q,ERR_DECODE_ERROR err)) + val (arr,n,dec1,err) = initArray dec + in (a1,EXT2(arr,n,0,l,col,brk,(dec1,err,typ))) + end +(* + in (a1,EXT1(dec,l,col,brk,typ)) + end +*) + | LOOKED(cs,q1) => let val (a1,q2) = commitAuto (a,q1) + in (a1,LOOKED(cs,q2)) + end + | CLOSED _ => (a,q) + | _ => raise InternalError(THIS_MODULE,"commitAuto", + "entity is neither EXT1 nor CLOSED nor LOOKED") + + (*--------------------------------------------------------------------*) + (* change from the autodetected encoding to the declared one. *) + (*--------------------------------------------------------------------*) + fun changeAuto (a,q,decl) = + case q + of EXT1(dec,l,col,brk,typ) => + let + val dec1 = decSwitch(dec,decl) + handle DecError(dec,_,err) + => let val a1 = hookError(a,(getPos q,ERR_DECODE_ERROR err)) + val _ = decClose dec + val uri = decName dec + val msg = case err + of ERR_UNSUPPORTED_ENC _ => "Unsupported encoding" + | _ => "Declared encoding incompatible" + ^"with auto-detected encoding" + in raise CantOpenFile ((uri,msg),a1) + end + val newEnc = decEncoding dec1 + val (arr,n,dec2,err) = initArray dec1 + in (a,EXT2(arr,n,0,l,col,brk,(dec2,err,typ)),newEnc) + end +(* + in (a,EXT1(dec1,l,col,brk,typ),newEnc) + end +*) + + | LOOKED(cs,q1) => let val (a2,q2,enc2) = changeAuto(a,q1,decl) + in (a2,LOOKED(cs,q2),enc2) + end + | CLOSED(dec,_,_,_) => (a,q,decEncoding dec) + | _ => raise InternalError(THIS_MODULE,"changeAuto", + "entity is neither EXT1 nor CLOSED nor LOOKED") + + (*--------------------------------------------------------------------*) + (* Get one character from the current entity. Possibly reload buffer. *) + (* Return 0wx0 at entity end. Otherwise check whether the character *) + (* is valid (cf. 2.2). If the last character was a carriage return *) + (* (0xD) supress a line feed (0xA). *) + (*--------------------------------------------------------------------*) + fun getChar (a,q) = + case q + of ENDED(_,other) => getChar(a,other) + | CLOSED(_,_,_,typ) => + (case typ + of SPECIAL _ => raise InternalError (THIS_MODULE,"getChar", + "attempt to read beyond special entity end") + | NORMAL(_,other) => getChar(a,other)) + | INT(vec,s,i,io) => + if i>=s then (0wx0,a,ENDED io) + else (Vector.sub(vec,i),a,INT(vec,s,i+1,io)) + | EXT1(dec,l,col,br,typ) => + (let + val (c,dec1) = decGetChar dec + in + if (* c>=0wx20 orelse c=0wx09 *) + c>=0wx0020 + andalso (c<=0wxD7FF + orelse c>=0wxE000 andalso (c<=0wxFFFD + orelse c>=0wx10000)) + orelse c=0wx9 + then (c,a,EXT1(dec1,l,col+1,false,typ)) + else if c=0wxA + then if br then getChar(a,EXT1(dec1,l,col,false,typ)) + else (c,a,EXT1(dec1,l+1,0,false,typ)) + else (if c=0wxD then (0wxA,a,EXT1(dec1,l+1,0,true,typ)) + else let val a1 = hookError(a,(getPos q,ERR_NON_XML_CHAR c)) + in getChar(a1,EXT1(dec1,l,col+1,false,typ)) + end) + end + handle DecEof dec => (0wx0,a,CLOSED(dec,l,col,typ)) + | DecError(dec,eof,err) => + let val err = ERR_DECODE_ERROR err + val a1 = hookError(a,(getPos q,err)) + in if eof then (0wx0,a,CLOSED(dec,l,col,typ)) + else getChar(a1,EXT1(dec,col,l,br,typ)) + end) + | EXT2(arr,s,i,l,col,br,det) => + if i=0wx20 orelse c=0wx09 *) + (* c>=0wx0020 andalso c<=0wxD7FF orelse c=0wx9 orelse *) + (* c>=0wxE000 andalso c<=0wxFFFD orelse c>=0wx10000 *) + c>=0wx0020 + andalso (c<=0wxD7FF + orelse c>=0wxE000 andalso (c<=0wxFFFD + orelse c>=0wx10000)) + orelse c=0wx9 + then (c,a,EXT2(arr,s,i+1,l,col+1,false,det)) + else if c=0wxA + then if br then getChar(a,EXT2(arr,s,i+1,l,col,false,det)) + else (c,a,EXT2(arr,s,i+1,l+1,0,false,det)) + else (if c=0wxD then (0wxA,a,EXT2(arr,s,i+1,l+1,0,true,det)) + else let val a1 = hookError(a,(getPos q,ERR_NON_XML_CHAR c)) + in getChar(a1,EXT2(arr,s,i+1,l,col+1,false,det)) + end) + end + else let val (dec,err,typ) = det + val (a1,(n,dec1,err1)) = + case err + of NONE => if s=BUFSIZE then (a,decGetArray dec arr) + else (a,(0,dec,NONE)) + | SOME err => (hookError(a,(getPos q,ERR_DECODE_ERROR err)), + decGetArray dec arr) + in if n=0 andalso not (isSome err1) + then (0wx0,a1,CLOSED(dec1,l,col,typ)) + else getChar(a1,EXT2(arr,n,0,l,col,br,(dec1,err1,typ))) + end + | LOOKED(nil,q) => getChar(a,q) + | LOOKED(c::cs,q) => (c,a,LOOKED(cs,q)) + + (*--------------------------------------------------------------------*) + (* unget a list of characters. *) + (*--------------------------------------------------------------------*) + fun ungetChars (q,cs) = LOOKED(cs,q) + end +(* stop of ../../Parser/entities.sml *) +(* start of ../../Parser/Dtd/dtdDeclare.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: DtdDeclare *) +(* *) +(*--------------------------------------------------------------------------*) +(* Functor: DtdDeclare *) +(*--------------------------------------------------------------------------*) +(* This module provides functions for adding declarations to the DTD tables *) +(* and for doing checks on components of declarations. *) +(*--------------------------------------------------------------------------*) +functor DtdDeclare (structure Dtd : Dtd + structure Entities : Entities + structure ParserOptions : ParserOptions) = + struct + open + UtilInt UtilList + Base Dtd Errors Entities ParserOptions UniChar UniClasses + + (*--------------------------------------------------------------------*) + (* check whether a sequence a chars is the b-adic representation of a *) + (* character's code, terminated by ";". base will be 10 or 16, isBase *) + (* will check for a character being a decimal/hexadecimal number. *) + (*--------------------------------------------------------------------*) + fun checkBasimal (base,baseValue) (ch:Char,cs) = + let fun doit _ (nil:Data) = false + | doit yet [0wx3B] = yet=ch + | doit yet (c::cs) = case baseValue c + of NONE => false + | SOME v => doit (base*yet+v) cs + in doit 0w0 cs + end + val checkDecimal = checkBasimal (0w10,decValue) + val checkHeximal = checkBasimal (0wx10,hexValue) + + (*--------------------------------------------------------------------*) + (* check a character reference for identifying a character. *) + (*--------------------------------------------------------------------*) + fun checkRef (ch,0wx26::0wx23::0wx78::cs) (* "&#x..." *) = checkHeximal(ch,cs) + | checkRef (ch,0wx26::0wx23::cs) (* "&#..." *) = checkDecimal(ch,cs) + | checkRef _ = false + + (*--------------------------------------------------------------------*) + (* check for a single character ch. *) + (*--------------------------------------------------------------------*) + fun checkSingle (ch,[c]) = c=ch + | checkSingle _ = false + + (*--------------------------------------------------------------------*) + (* check a predefined entity for being well defined. Note that both *) + (* a single char and a char ref representation are allowed, except *) + (* for 'amp' which must be escaped. *) + (*--------------------------------------------------------------------*) + fun checkPredef (idx,cs) = + case idx + of 1 => checkRef(0wx26,cs) + | 2 => checkSingle(0wx3C,cs) orelse checkRef(0wx3C,cs) + | 3 => checkSingle(0wx3E,cs) orelse checkRef(0wx3E,cs) + | 4 => checkSingle(0wx27,cs) orelse checkRef(0wx27,cs) + | 5 => checkSingle(0wx22,cs) orelse checkRef(0wx22,cs) + | _ => true + + (*--------------------------------------------------------------------*) + (* Given the declaration of an entity check whether it is predefined. *) + (* If no return false. If yes, check whether is was already declared *) + (* and whether it is correctly declared. See 4.6: *) + (* *) + (* All XML processors must recognize these entities whether they *) + (* are declared or not. For interoperability, valid XML documents *) + (* should declare these entities, like any others, before using *) + (* them. If the entities in question are declared, they must be *) + (* declared as internal entities whose replacement text is the *) + (* single character being escaped or a character reference to that *) + (* character, as shown below. *) + (* *) + (* *) + (* *) + (* *) + (* *) + (* *) + (* *) + (* Note that the < and & characters in the declarations of "lt" and *) + (* "amp" are doubly escaped to meet the requirement that entity *) + (* replacement be well-formed. *) + (* *) + (* print an error if the entity was already declared. *) + (* print an error if the declaration is not correct. *) + (*--------------------------------------------------------------------*) + fun checkPredefined dtd (a,q) (idx,ent) = + if !O_VALIDATE andalso idx>=1 andalso idx<=5 then + let + val a1 = if !O_WARN_MULT_ENT_DECL andalso isRedefined dtd idx + then let val warn = WARN_MULT_DECL(IT_GEN_ENT,Index2GenEnt dtd idx) + in hookWarning(a,(getPos q,warn)) + end + else a before setRedefined dtd idx + val a2 = + if !O_CHECK_PREDEFINED then + let val correct = + case ent + of GE_INTERN(_,rep) => checkPredef (idx,Vector2Data rep) + | _ => false + in if correct then a1 + else let val err = ERR_DECL_PREDEF(Index2GenEnt dtd idx,validPredef idx) + in hookError(a1,(getPos q,err)) + end + end + else a1 + in (true,a2) + end + else (false,a) + + (*--------------------------------------------------------------------*) + (* add an entity declaration to the DTD tables. 4.2 *) + (* *) + (* ... If the same entity is declared more than once, the first *) + (* declaration encountered is binding; at user option, an XML *) + (* processor may issue a warning if entities are declared multiple *) + (* times. *) + (* *) + (* For general entities, check whether it is a predefined entity and *) + (* if so, whether it is declared correctly. *) + (*--------------------------------------------------------------------*) + (* print a warning and ignore the declaration if the notation was *) + (* declared previously. *) + (*--------------------------------------------------------------------*) + fun addGenEnt dtd (a,q) (idx,ent,ext) = + case getGenEnt dtd idx + of (GE_NULL,_) => a before setGenEnt dtd (idx,(ent,ext)) + | _ => let val (pre,a1) = checkPredefined dtd (a,q) (idx,ent) + in if pre orelse not (!O_WARN_MULT_ENT_DECL) then a1 + else hookWarning(a1,(getPos q,WARN_MULT_DECL + (IT_GEN_ENT,Index2GenEnt dtd idx))) + end + + fun addParEnt dtd (a,q) (idx,ent,ext) = + case getParEnt dtd idx + of (PE_NULL,_) => a before setParEnt dtd (idx,(ent,ext)) + | _ => if !O_WARN_MULT_ENT_DECL + then hookWarning(a,(getPos q,WARN_MULT_DECL + (IT_PAR_ENT,Index2ParEnt dtd idx))) + else a + + (*--------------------------------------------------------------------*) + (* at option print a warning if not all predefined entities have been *) + (* declared. Cf. 4.1: *) + (* *) + (* For interoperability, valid documents should declare the *) + (* entities amp, lt, gt, apos, quot, in the form specified in *) + (* "4.6 Predefined Entities". *) + (*--------------------------------------------------------------------*) + fun checkPreDefined dtd (a,q) = + if !O_VALIDATE andalso !O_INTEROPERABILITY andalso + !O_WARN_SHOULD_DECLARE andalso hasDtd dtd + then case notRedefined dtd + of nil => a + | ents => hookWarning(a,(getPos q,WARN_SHOULD_DECLARE ents)) + else a + + (*--------------------------------------------------------------------*) + (* add a notation declaration to the DTD tables. *) + (* *) + (* though the rec. says nothing about repeated notation declarations, *) + (* I assume that the intention is to treat them like entities, i.e. *) + (* ignore repeated declarations with an optional warning. *) + (* *) + (* print a warning and ignore the declaration if the notation was *) + (* declared previously. *) + (*--------------------------------------------------------------------*) + fun addNotation dtd (a,q) (idx,nt) = + if hasNotation dtd idx + then if !O_WARN_MULT_NOT_DECL + then hookWarning(a,(getPos q,WARN_MULT_DECL + (IT_NOTATION,Index2AttNot dtd idx))) + else a + else a before setNotation dtd (idx,nt) + + (*--------------------------------------------------------------------*) + (* add an element declaration to the element table. Only the content *) + (* part of the element info is updated. 3.2: *) + (* *) + (* Validity Constraint: Unique Element Type Declaration *) + (* No element type may be declared more than once. *) + (* *) + (* print an error and ignore the declaration if the element was *) + (* declared previously. *) + (*--------------------------------------------------------------------*) + fun addElement dtd (a,q) (idx,cont,ext) = + let val {decl,atts,errAtts,...} = getElement dtd idx + in case decl + of NONE => a before setElement dtd (idx,{decl = SOME(cont,ext), + atts = atts, + errAtts = errAtts}) + | SOME _ => if !O_VALIDATE + then hookError(a,(getPos q,ERR_REDEC_ELEM(Index2Element dtd idx))) + else a + end + + (*--------------------------------------------------------------------*) + (* at option, pretend an element is declared by adding a default *) + (* declaration. Only the decl flag of the element info is updated. *) + (*--------------------------------------------------------------------*) + fun handleUndeclElement dtd idx = + let + val {atts,errAtts,...} = getElement dtd idx + val newInfo = {decl = SOME(CT_ANY,false), + atts = atts, + errAtts = errAtts} + in newInfo before setElement dtd (idx,newInfo) + end + + (*--------------------------------------------------------------------*) + (* check whether an element is declared and whether it already had an *) + (* attribute list declaration. Cf. 3.3: *) + (* *) + (* At user option, an XML processor may issue a warning if *) + (* attributes are declared for an element type not itself declared, *) + (* but this is not an error. *) + (* *) + (* ... an XML processor may at user option issue a warning when *) + (* more than one attribute-list declaration is provided for a given *) + (* element type, ... *) + (* *) + (* print a warning if the element is not declared or already had an *) + (* attribute list declaration. *) + (*--------------------------------------------------------------------*) + fun enterAttList dtd (a,q) idx = + let + val {decl,atts,errAtts,...} = getElement dtd idx + val a1 = if isSome decl orelse not (!O_WARN_ATT_NO_ELEM) then a + else hookWarning(a,(getPos q,WARN_ATT_UNDEC_ELEM(Index2Element dtd idx))) + in + case atts + of NONE => a1 before + setElement dtd (idx,{decl=decl,atts=SOME(nil,false),errAtts=errAtts}) + | _ => if !O_INTEROPERABILITY andalso !O_WARN_MULT_ATT_DECL + then hookWarning(a1,(getPos q,WARN_MULT_ATT_DECL(Index2Element dtd idx))) + else a1 + end + + (*--------------------------------------------------------------------*) + (* check whether attribute "xml:space" is declared correctly. 2.10: *) + (* *) + (* A special attribute named xml:space may be attached ... In valid *) + (* documents, this attribute, like any other, must be declared if *) + (* it is used. When declared, it must be given as an enumerated *) + (* type whose only possible values are "default" and "preserve". *) + (*--------------------------------------------------------------------*) + fun checkAttDef (a,q) (aidx,attType,_,_) = + if aidx<>xmlSpaceIdx orelse attType=xmlSpaceType then a + else hookError(a,(getPos q,ERR_XML_SPACE)) + + (*--------------------------------------------------------------------*) + (* enter a definition of a single attribute to the element table. *) + (* ignore the definition if the attribute is already defined for that *) + (* element. Cf. 3.3: *) + (* *) + (* When more than one AttlistDecl is provided for a given element *) + (* type, the contents of all those provided are merged. When more *) + (* than one definition is provided for the same attribute of a *) + (* given element type, the first declaration is binding and later *) + (* declarations are ignored. For interoperability, an XML processor *) + (* may at user option issue a warning when ... more than one *) + (* attribute definition is provided for a given attribute, but this *) + (* is not an error. *) + (* *) + (* If the attribute type is ID, check whether an element already has *) + (* an attribute of that type. 3.3.1: *) + (* *) + (* Validity Constraint: One ID per Element Type *) + (* No element type may have more than one ID attribute specified. *) + (*--------------------------------------------------------------------*) + (* print an error if the element already has an ID attribute. *) + (* print a warning if the attr. is already defined for this element. *) + (*--------------------------------------------------------------------*) + (* return the new application data. *) + (*--------------------------------------------------------------------*) + fun addAttribute dtd (a,q) (eidx,attDef as (att,attType,attDefault,_)) = + let + val a1 = checkAttDef (a,q) attDef + + fun doit nil = (false,[attDef],a) + | doit (atts as (ad as (aidx,_,_,_))::rest) = + if aidx=att + then let val a1 = if !O_INTEROPERABILITY andalso !O_WARN_MULT_ATT_DEF + then let val warn = WARN_MULT_ATT_DEF + (Index2Element dtd eidx,Index2AttNot dtd att) + in hookWarning(a,(getPos q,warn)) + end + else a + in (true,atts,a1) + end + else (if aidx (c1=0wx58 orelse c1=0wx78) andalso + (c2=0wx4D orelse c2=0wx6D) andalso (c3=0wx4C orelse c3=0wx6C) + | _ => false + fun checkAttName (a,q) name = + if !O_CHECK_RESERVED andalso startsWithXml name then + case name + of [0wx78,0wx6d,0wx6c,0wx3a,0wx6c,0wx61,0wx6e,0wx67] (* ":lang" *) => a + | [0wx78,0wx6d,0wx6c,0wx3a,0wx73,0wx70,0wx61,0wx63,0wx65] (* ":space" *) => a + | _ => hookError(a,(getPos q,ERR_RESERVED(name,IT_ATT_NAME))) + else a + fun checkElemName (a,q) name = + if !O_CHECK_RESERVED andalso startsWithXml name + then hookError(a,(getPos q,ERR_RESERVED(name,IT_ELEM))) + else a + + (*--------------------------------------------------------------------*) + (* check for each element in the dtd, whether a name token occurs *) + (* more than once in its enumerated attribute types. *) + (* *) + (* print a warning for each element where this is true. *) + (* *) + (* return nothing. *) + (*--------------------------------------------------------------------*) + fun checkMultEnum dtd (a,q) = + if !O_INTEROPERABILITY andalso !O_WARN_MULT_ENUM then + let + fun doElem a idx = + let + (*-----------------------------------------------------*) + (* for each i, add i to yet if it not in that list. *) + (* otherwise add it to dup. *) + (*-----------------------------------------------------*) + fun do_list yd nil = yd + | do_list (yet,dup) (i::is) = + let val yd' = case insertNewInt (i,yet) + of NONE => (yet,insertInt (i,dup)) + | SOME new => (new,dup) + in do_list yd' is + end + (*-----------------------------------------------------*) + (* For each enumerated attribute type call the appro- *) + (* priate function. *) + (*-----------------------------------------------------*) + fun doit (yet,dup) nil = dup + | doit (yet,dup) ((_,attType,_,_)::rest) = + case attType + of AT_GROUP is => doit (do_list (yet,dup) is) rest + | AT_NOTATION is => doit (do_list (yet,dup) is) rest + | _ => doit (yet,dup) rest + + val defs = case #atts(getElement dtd idx) + of NONE => nil + | SOME(defs,_) => defs + val dup = doit (nil,nil) defs + in + if null dup then a + else hookWarning(a,(getPos q,WARN_ENUM_ATTS + (Index2Element dtd idx,map (Index2AttNot dtd) dup))) + end + (*-----------------------------------------------------------*) + (* the highest used index is usedIndices-1. *) + (*-----------------------------------------------------------*) + val maxIdx = maxUsedElem dtd + + fun doit a i = if i>maxIdx then a else doit (doElem a i) (i+1) + in + doit a 0 + end + else a + + (*--------------------------------------------------------------------*) + (* check for all id names refereneced by some IDREF attribute whether *) + (* it was also declared by an ID attribute. *) + (* *) + (* print an error if a referenced ID name was not defined. *) + (* *) + (* return nothing. *) + (*--------------------------------------------------------------------*) + fun checkDefinedIds dtd (a,q) = + if !O_VALIDATE then + let + val maxId = maxUsedId dtd + + fun doOne a i = let val (decl,refs) = getId dtd i + in if decl orelse null refs then a + else hookError(a,(hd refs,ERR_UNDECL_ID(Index2Id dtd i,tl refs))) + end + fun doAll a i = if i>maxId then a else doAll (doOne a i) (i+1) + in + doAll a 0 + end + else a + + (*--------------------------------------------------------------------*) + (* check for all declared unparsed entities, whether their notations *) + (* have been declared. *) + (* *) + (* print an error if a notation was not declared. *) + (* *) + (* return nothing. *) + (*--------------------------------------------------------------------*) + fun checkUnparsed dtd a = + if !O_VALIDATE then + let + val maxGen = maxUsedGen dtd + + fun doOne a i = + case getGenEnt dtd i + of (GE_UNPARSED(_,nidx,pos),_) => + if hasNotation dtd nidx then a + else hookError(a,(pos,ERR_UNDECLARED + (IT_NOTATION,Index2AttNot dtd nidx,LOC_NONE))) + | _ => a + fun doAll a i = if i>maxGen then a else doAll (doOne a i) (i+1) + in + doAll a 0 + end + else a + end +(* stop of ../../Parser/Dtd/dtdDeclare.sml *) +(* start of ../../Parser/Dtd/dtdAttributes.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: DtdAttributes *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* checkAttValue : AttValue InternalError *) +(* checkDefinedIds : none *) +(* genMissingAtts : none *) +(* makeAttValue : AttValue InternalError *) +(*--------------------------------------------------------------------------*) +functor DtdAttributes (structure Dtd : Dtd + structure Entities : Entities + structure ParserOptions : ParserOptions) = + struct + structure DtdDeclare = DtdDeclare (structure Dtd = Dtd + structure Entities = Entities + structure ParserOptions = ParserOptions) + open + UniChar UniClasses UtilList + Base Dtd DtdDeclare Errors Entities HookData ParserOptions + + val THIS_MODULE = "DtdAttributes" + + exception AttValue of AppData + + (*--------------------------------------------------------------------*) + (* this is the list of language codes in ISO 639. *) + (*--------------------------------------------------------------------*) + val iso639codes = + Vector.fromList + ["AA","AB","AF","AM","AR","AS","AY","AZ", + "BA","BE","BG","BH","BI","BN","BO","BR", + "CA","CO","CS","CY", + "DA","DE","DZ", + "EL","EN","EO","ES","ET","EU", + "FA","FI","FJ","FO","FR","FY", + "GA","GD","GL","GN","GU", + "HA","HE","HI","HR","HU","HY", + "IA","ID","IE","IK","IN","IS","IT","IU","IW", + "JA","JI","JW", + "KA","KK","KL","KM","KN","KO","KS","KU","KY", + "LA","LN","LO","LT","LV", + "MG","MI","MK","ML","MN","MO","MR","MS","MT","MY", + "NA","NE","NL","NO", + "OC","OM","OR", + "PA","PL","PS","PT", + "QU", + "RM","RN","RO","RU","RW", + "SA","SD","SG","SH","SI","SK","SL","SM","SN","SO","SQ","SR","SS","ST","SU","SV","SW", + "TA","TE","TG","TH","TI","TK","TL","TN","TO","TR","TS","TT","TW", + "UG","UK","UR","UZ", + "VI","VO", + "WO", + "XH", + "YI","YO", + "ZA","ZH","ZU"] + + (*--------------------------------------------------------------------*) + (* a two-dimensional field [0..25][0..25] of booleans for ISO 639. *) + (*--------------------------------------------------------------------*) + val iso639field = + let + val arr = Array.tabulate(26,fn _ => Array.array(26,false)) + val _ = Vector.map + (fn s => Array.update(Array.sub(arr,ord(String.sub(s,0))-65), + ord(String.sub(s,1))-65, + true)) + iso639codes + in Vector.tabulate(26,fn i => Array.extract (Array.sub(arr,i),0,NONE)) + end + + (*--------------------------------------------------------------------*) + (* for a letter, compute ord(toUpper c)-ord(#"A"), for subscripting. *) + (*--------------------------------------------------------------------*) + val toUpperMask = Chars.notb(0wx20) + fun cIndex c = Chars.toInt(Chars.andb(c,toUpperMask)-0wx41) + + (*--------------------------------------------------------------------*) + (* are these two letters an ISO 639 code? *) + (*--------------------------------------------------------------------*) + fun isIso639 (c1,c2) = + if !O_CHECK_ISO639 then + Vector.sub(Vector.sub(iso639field,cIndex c1),cIndex c2) + handle Subscript => false + else isAsciiLetter c1 andalso isAsciiLetter c2 + + (*--------------------------------------------------------------------*) + (* does this match Subcode ('-' Subcode)* ? *) + (* is this a sequence of ('-' Subcode) ? *) + (* Iana codes and user codes also end on ([a-z] | [A-Z])+ *) + (*--------------------------------------------------------------------*) + fun isSubcode' nil = false + | isSubcode' (c::cs) = + let fun doit nil = true + | doit (c::cs) = if c=0wx2D then isSubcode' cs + else isAsciiLetter c andalso doit cs + in isAsciiLetter c andalso doit cs + end + fun isSubcode nil = true + | isSubcode (c::cs) = c=0wx2D andalso isSubcode' cs + val isIanaUser = isSubcode' + + (*--------------------------------------------------------------------*) + (* Check whether a "xml:lang" attribute matches the LanguageID *) + (* production. 2.12: *) + (* *) + (* [33] LanguageID ::= Langcode ('-' Subcode)* *) + (* [34] Langcode ::= ISO639Code | IanaCode | UserCode *) + (* [35] ISO639Code ::= ([a-z] | [A-Z]) ([a-z] | [A-Z]) *) + (* [36] IanaCode ::= ('i' | 'I') '-' ([a-z] | [A-Z])+ *) + (* [37] UserCode ::= ('x' | 'X') '-' ([a-z] | [A-Z])+ *) + (* [38] Subcode ::= ([a-z] | [A-Z])+ *) + (* *) + (* print an error and raise AttValue if the "xml:lang" attribute does *) + (* not have a valid value. *) + (*--------------------------------------------------------------------*) + fun checkAttSpec (a,q) (aidx,cs) = + if !O_CHECK_LANGID andalso aidx=xmlLangIdx + then let val valid = case cs + of c::0wx2D::cs' => (c=0wx49 orelse + c=0wx69 orelse + c=0wx58 orelse + c=0wx78) andalso isIanaUser cs' + | c1::c2::cs' => isIso639 (c1,c2) andalso isSubcode cs' + | _ => false + in + if valid then a + else raise AttValue(hookError(a,(getPos q,ERR_ATT_IS_NOT(cs,IT_LANG_ID)))) + end + else a + + (*--------------------------------------------------------------------*) + (* Normalize an attribute value of type other than CDATA, and split *) + (* it into tokens at space characters. Cf. 3.3.3: *) + (* *) + (* ... If the declared value is not CDATA, then the XML processor *) + (* must further process the normalized attribute value by dis- *) + (* carding any leading and trailing space (#x20) characters, and by *) + (* replacing sequences of space (#x20) characters by a single space *) + (* (#x20) character. *) + (* *) + (* replacement of references is already done when parsing the literal,*) + (* thus we need only do whitespace normalization. we don't need to *) + (* take care of the 3rd rule since replacement of sequences of #x20 *) + (* and then splitting subsumes its effect. *) + (* *) + (* return the list of tokens as character lists and the normalized *) + (* value as a char vector. *) + (*--------------------------------------------------------------------*) + fun splitAttValue av = + let + fun doOne nil = (nil,nil,nil) + | doOne (c::cs) = if c=0wx20 then let val (toks,ys) = doAll true cs + in (nil,toks,ys) + end + else let val (tok,toks,ys) = doOne cs + in ((c::tok),toks,c::ys) + end + and doAll addS nil = (nil,nil) + | doAll addS (c::cs) = if c=0wx20 then doAll addS cs + else let val (tok,toks,ys) = doOne cs + in ((c::tok)::toks, + if addS then 0wx20::c::ys else c::ys) + end + + val (tokens,normed) = doAll false av + in (Data2Vector normed,tokens) + end + (*--------------------------------------------------------------------*) + (* normalize an attribute value other than CDATA according to 3.3.3. *) + (* *) + (* return the normalized att value as a Vector. *) + (*--------------------------------------------------------------------*) + fun normAttValue av = + let fun doOne nil = nil + | doOne (c::cs) = if c=0wx20 then doAll true cs + else c::doOne cs + and doAll addS nil = nil + | doAll addS (c::cs) = if c=0wx20 then doAll addS cs + else let val ys = doOne cs + in if addS then 0wx20::c::ys else c::ys + end + val normed = doAll false av + in Data2Vector normed + end + + (*--------------------------------------------------------------------*) + (* Check whether a sequence of chars forms a name (token). *) + (*--------------------------------------------------------------------*) + fun isNmToken cs = List.all isName cs + fun isaName nil = false + | isaName (c::cs) = isNms c andalso List.all isName cs + + (*--------------------------------------------------------------------*) + (* Check whether a list of tokens is a single what fulfilling isWhat. *) + (* print an error and raise AttValue if it is not. *) + (*--------------------------------------------------------------------*) + fun checkOne (isWhat,what,detail) (a,q) toks = + case toks + of nil => raise AttValue (hookError(a,(getPos q,ERR_EXACTLY_ONE detail))) + | [one] => if isWhat one then one + else raise AttValue(hookError(a,(getPos q,ERR_ATT_IS_NOT(one,what)))) + | more => raise AttValue(hookError(a,(getPos q,ERR_AT_MOST_ONE detail))) + (*--------------------------------------------------------------------*) + (* Check whether a list of tokens is non-empty and all elements ful- *) + (* fil isWhat. *) + (* print an error and raise AttValue if not. *) + (*--------------------------------------------------------------------*) + fun checkList (isWhat,what,detail) (a,q) toks = + case toks + of nil => raise AttValue (hookError(a,(getPos q,ERR_AT_LEAST_ONE detail))) + | _ => app (fn one => if isWhat one then () + else let val err = ERR_ATT_IS_NOT(one,what) + in raise AttValue(hookError(a,(getPos q,err))) + end) toks + (*--------------------------------------------------------------------*) + (* Convert a list of tokens into an ID att value. 3.3.1: *) + (* *) + (* Validity Constraint: ID *) + (* Values of type ID must match the Name production. *) + (* *) + (* Validity Constraint: ID *) + (* ... A name must not appear more than once in an XML document as *) + (* a value of this type; i.e., ID values must uniquely identify the *) + (* elements which bear them. *) + (* *) + (* mark the value as used, print an error and raise AttValue if it *) + (* was already used. *) + (* print an error and raise AttValue if it is not a name. *) + (*--------------------------------------------------------------------*) + fun takeId (dtd,inDtd) (a,q) toks = + let val one = checkOne (isaName,IT_NAME,IT_ID_NAME) (a,q) toks + val idx = Id2Index dtd one + val _ = if inDtd then () + else let val (decl,refs) = getId dtd idx + in if decl then let val err = ERR_REPEATED_ID one + in raise AttValue (hookError(a,(getPos q,err))) + end + else setId dtd (idx,(true,refs)) + end + in (SOME(AV_ID idx),a) + end + + (*--------------------------------------------------------------------*) + (* Convert a list of tokens into an IDREF/IDREFS att value. 3.3.1: *) + (* *) + (* Validity Constraint: IDREF *) + (* Values of type IDREF must match the Name production. *) + (* *) + (* print an error an raise AttValue if it is not a (list of) name(s). *) + (*--------------------------------------------------------------------*) + fun setIdRef (dtd,q) idx = + let val (decl,refs) = getId dtd idx + in setId dtd (idx,(decl,getPos q::refs)) + end + fun takeIdref (dtd,_) (a,q) toks = + let val one = checkOne (isaName,IT_NAME,IT_ID_NAME) (a,q) toks + val idx=Id2Index dtd one + val _ = setIdRef (dtd,q) idx + in (SOME(AV_IDREF idx),a) + end + fun takeIdrefs (dtd,_) (a,q) toks = + let val _ = checkList (isaName,IT_NAME,IT_ID_NAME) (a,q) toks + val idxs = map (Id2Index dtd) toks + val _ = app (setIdRef (dtd,q)) idxs + in (SOME(AV_IDREFS idxs),a) + end + + (*--------------------------------------------------------------------*) + (* Convert a list of tokens into an ENTITY/IES att value. 3.3.1: *) + (* *) + (* Validity Constraint: Entity Name *) + (* Values of type ENTITY must match the Name production... *) + (* must match the name of an unparsed entity declared in the DTD. *) + (* *) + (* print an error and raise AttValue if a token is not a name. *) + (* print an error and raise AttValue if an entity is undeclared or a *) + (* parsed entity. *) + (*--------------------------------------------------------------------*) + fun checkEntity (dtd,inDtd) (a,q) name = + let val idx = GenEnt2Index dtd name + val (ent,_) = getGenEnt dtd idx + val _ = if inDtd then () + else case ent + of GE_UNPARSED _ => () + | GE_NULL => let val err = ERR_UNDECLARED(IT_GEN_ENT,name,LOC_NONE) + in raise AttValue (hookError(a,(getPos q,err))) + end + | _ => let val err = ERR_MUST_BE_UNPARSED(name,LOC_NONE) + in raise AttValue (hookError(a,(getPos q,err))) + end + in idx + end + fun takeEntity (dtd,inDtd) (aq as (a,_)) toks = + let val one = checkOne (isaName,IT_NAME,IT_ENT_NAME) aq toks + val idx = checkEntity (dtd,inDtd) aq one + in (SOME(AV_ENTITY idx),a) + end + fun takeEntities (dtd,inDtd) (aq as (a,_)) toks = + let val _ = checkList (isaName,IT_NAME,IT_ENT_NAME) aq toks + val idxs = map (checkEntity (dtd,inDtd) aq) toks + in (SOME(AV_ENTITIES idxs),a) + end + + (*--------------------------------------------------------------------*) + (* Convert a list of tokens into a NOTATION att value. 3.3.1: *) + (* *) + (* Validity Constraint: Notation Attributes *) + (* Values of this type must match one of the notation names *) + (* included in the declaration. *) + (* *) + (* print an error and raise AttValue if it is not a single name. *) + (* print an error and raise AttValue if the notation's index is not *) + (* in the list given as 1st arg. *) + (*--------------------------------------------------------------------*) + fun takeNotation is (dtd,inDtd) (aq as (a,q)) toks = + let val one = checkOne (isaName,IT_NAME,IT_NOT_NAME) aq toks + val idx = AttNot2Index dtd one + val _ = if member idx is then () + else let val nots = map (Index2AttNot dtd) is + val err = ERR_MUST_BE_AMONG(IT_NOT_NAME,one,nots) + in raise AttValue (hookError(a,(getPos q,err))) + end + in (SOME(AV_NOTATION(is,idx)),a) + end + + (*--------------------------------------------------------------------*) + (* Convert a list of tokens into an enumerated att value. 3.3.1: *) + (* *) + (* Validity Constraint: Enumeration *) + (* Values of this type must match one of the Nmtoken tokens in *) + (* the declaration. *) + (* *) + (* print an error and raise AttValue if it is not a single name token.*) + (* print an error and raise AttValue if the token's index is not *) + (* in the list given as 1st arg. *) + (*--------------------------------------------------------------------*) + fun takeGroup is (dtd,_) (aq as (a,q)) toks = + let val one = checkOne (isNmToken,IT_NMTOKEN,IT_NMTOKEN) aq toks + val idx = AttNot2Index dtd one + val _ = if member idx is then () + else let val toks = map (Index2AttNot dtd) is + val err = ERR_MUST_BE_AMONG(IT_NMTOKEN,one,toks) + in raise AttValue (hookError(a,(getPos q,err))) + end + in (SOME(AV_GROUP(is,idx)),a) + end + + (*--------------------------------------------------------------------*) + (* Given an attribute type and a list of characters, construct the *) + (* corresponding AttValue. *) + (* *) + (* print an error (and possibly raise AttValue) if the attribute *) + (* is ill-formed. *) + (*--------------------------------------------------------------------*) + fun makeAttValue dtd (a,q) (aidx,attType,ext,inDtd,cs) = + if attType=AT_CDATA + then let val cv = Data2Vector cs + in if !O_VALIDATE andalso hasDtd dtd + then (cv,(SOME(AV_CDATA cv),checkAttSpec (a,q) (aidx,cs))) + else (cv,(NONE,a)) + end + else + if !O_VALIDATE andalso hasDtd dtd then + let + val a1 = checkAttSpec (a,q) (aidx,cs) + val (cv,toks) = splitAttValue cs + val a2 = + if ext andalso standsAlone dtd + then let val cdata = Data2Vector cs + in if cdata=cv then a1 + else let val err = ERR_STANDALONE_NORM(Index2AttNot dtd aidx) + val _ = setStandAlone dtd (not (!O_ERROR_MINIMIZE)) + in hookError(a1,(getPos q,err)) + end + end + else a1 + in case attType + of AT_NMTOKEN => (cv,(SOME(AV_NMTOKEN(checkOne(isNmToken,IT_NMTOKEN, + IT_NMTOKEN) (a2,q) toks)),a2)) + | AT_NMTOKENS => (cv,(SOME(AV_NMTOKENS toks),a2)) before + checkList(isNmToken,IT_NMTOKEN,IT_NMTOKEN) (a2,q) toks + | AT_ID => (cv,takeId (dtd,inDtd) (a2,q) toks) + | AT_IDREF => (cv,takeIdref (dtd,inDtd) (a2,q) toks) + | AT_IDREFS => (cv,takeIdrefs (dtd,inDtd) (a2,q) toks) + | AT_ENTITY => (cv,takeEntity (dtd,inDtd) (a2,q) toks) + | AT_ENTITIES => (cv,takeEntities (dtd,inDtd) (a2,q) toks) + | AT_GROUP is => (cv,takeGroup is (dtd,inDtd) (a2,q) toks) + | AT_NOTATION is => (cv,takeNotation is (dtd,inDtd) (a2,q) toks) + | AT_CDATA => raise InternalError(THIS_MODULE,"makeAttValue", + "AT_CDATA in the innermost case") + end + else (normAttValue cs,(NONE,a)) + + (*--------------------------------------------------------------------*) + (* given an attribute value literal and the attribute type, generate *) + (* the AttValue, and check whether it complies with its default value.*) + (* If yes, make an AttPresent value out of it. *) + (* See 3.3.2: *) + (* *) + (* Validity Constraint: Fixed Attribute Default *) + (* If an attribute has a default value declared with the #FIXED *) + (* keyword, instances of that attribute must match the default *) + (* value. *) + (* *) + (* print an error and raise AttValue if the attribute value doesn't *) + (* comply. *) + (* *) + (* return the value as a AttPresent value. *) + (*--------------------------------------------------------------------*) + fun checkAttValue dtd (a,q) ((aidx,attType,defVal,ext),literal,cs) = + let val (cv,(av,a1)) = makeAttValue dtd (a,q) (aidx,attType,ext,false,cs) + in if !O_VALIDATE andalso hasDtd dtd then + case defVal + of AD_FIXED((def,cv',_),_) => + if cv=cv' then (AP_PRESENT(literal,cv,av),a1) + else raise AttValue + (hookError(a1,(getPos q,ERR_FIXED_VALUE(Index2AttNot dtd aidx,cv,cv')))) + | _ => (AP_PRESENT(literal,cv,av),a1) + else (AP_PRESENT(literal,cv,av),a1) + end + + (*--------------------------------------------------------------------*) + (* check a defaulted attribute value for validity. *) + (* *) + (* since the lexical constraints are checked when the default is *) + (* declared we only need to check whether notations are declared and *) + (* entities are declared and unparsed. An ID attribute cannot be *) + (* defaulted, so no need to check for duplicate ID attributes. *) + (*--------------------------------------------------------------------*) + fun checkDefaultValue dtd (a,q,pos) av = + let + fun checkEntity (idx,a) = + let val (ent,_) = getGenEnt dtd idx + in case ent + of GE_UNPARSED _ => a + | GE_NULL => hookError(a,(getPos q,ERR_UNDECLARED + (IT_GEN_ENT,Index2GenEnt dtd idx, + LOC_ATT_DEFAULT pos))) + | _ => hookError(a,(getPos q,ERR_MUST_BE_UNPARSED + (Index2GenEnt dtd idx,LOC_ATT_DEFAULT pos))) + end + + fun checkNotation (idx,a) = + if hasNotation dtd idx then a + else hookError(a,(getPos q,ERR_UNDECLARED + (IT_NOTATION,Index2AttNot dtd idx,LOC_ATT_DEFAULT pos))) + in + case av + of SOME(AV_ENTITY i) => checkEntity (i,a) + | SOME(AV_ENTITIES is) => foldl checkEntity a is + | SOME(AV_NOTATION(_,i)) => checkNotation(i,a) + | _ => a + end + + (*--------------------------------------------------------------------*) + (* Generate the attributes not specified in a start-tag, the defs of *) + (* these atts and the specified atts given as argument. 3.3.2: *) + (* *) + (* If the declaration is neither #REQUIRED nor #IMPLIED, then the *) + (* AttValue value contains the declared default value; ... If a *) + (* default value is declared, when an XML processor encounters an *) + (* omitted attribute, it is to behave as though the attribute were *) + (* present with the declared default value. *) + (* *) + (* Validity Constraint: Required Attribute *) + (* If the default declaration is the keyword #REQUIRED, then the *) + (* attribute must be specified for all elements of the type in the *) + (* attribute-list declaration. *) + (* *) + (* print an error if a required attribute was omitted. *) + (* *) + (* return the AttSpecList of all attributes for this tag. *) + (*--------------------------------------------------------------------*) + fun genMissingAtts dtd (a,q) (defs,specd) = + let + fun default a (idx,(v as (_,_,av),(pos,checked)),ext) = + let val a1 = if ext andalso !O_VALIDATE andalso standsAlone dtd + then let val err = ERR_STANDALONE_DEF(Index2AttNot dtd idx) + val _ = setStandAlone dtd (not (!O_ERROR_MINIMIZE)) + in hookError(a,(getPos q,err)) + end + else a + val a2 = if !O_VALIDATE andalso not (!checked andalso !O_ERROR_MINIMIZE) + then checkDefaultValue dtd (a1,q,pos) av before checked := true + else a1 + in (AP_DEFAULT v,a1) + end + fun doit a nil = (specd,a) + | doit a ((idx,_,dv,ext)::rest) = + let val (value,a1) = + case dv + of AD_DEFAULT v => default a (idx,v,ext) + | AD_FIXED v => default a (idx,v,ext) + | AD_IMPLIED => (AP_IMPLIED,a) + | AD_REQUIRED => + let val a1 = if not (!O_VALIDATE) then a + else hookError(a,(getPos q, + ERR_MISSING_ATT(Index2AttNot dtd idx))) + in (AP_MISSING,a1) + end + val (other,a2) = doit a1 rest + in ((idx,value,NONE)::other,a2) + end + in doit a defs + end + + (*--------------------------------------------------------------------*) + (* process an undeclared attribute in a start-tag. *) + (* At option, an error message is generated only once for the same *) + (* attribute and element. *) + (* *) + (* possibly print an error. *) + (* *) + (* return nothing. *) + (*--------------------------------------------------------------------*) + fun handleUndeclAtt dtd (a,q) (aidx,att,eidx,elem) = + if !O_ERROR_MINIMIZE then + let val {decl,atts,errAtts} = getElement dtd eidx + in if member aidx errAtts then a + else let val a1 = if !O_VALIDATE andalso hasDtd dtd + then let val err = ERR_UNDECL_ATT(att,elem) + in hookError(a,(getPos q,err)) + end + else a + val a2 = checkAttName (a1,q) att + val _ = setElement dtd (eidx,{decl = decl, + atts = atts, + errAtts = aidx::errAtts}) + in a2 + end + end + else let val a1 = if !O_VALIDATE andalso hasDtd dtd + then hookError(a,(getPos q,ERR_UNDECL_ATT(att,elem))) + else a + in checkAttName (a1,q) att + end + + end +(* stop of ../../Parser/Dtd/dtdAttributes.sml *) +(* start of ../../Parser/Dtd/dtdManager.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: Dtd *) +(* *) +(* Depends on: *) +(* UniChar *) +(* DtdAttributes *) +(* DtdElements *) +(* DtdEntities *) +(* DtdNotations *) +(* DtdStandalone *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* initDtdTables : none *) +(* AttIdx2String : NoSuchSymbol *) +(* ElemIdx2String : NoSuchIndex *) +(* GenEntIdx2String : NoSuchIndex *) +(* IdIdx2String : NoSuchIndex *) +(* NotIdx2String : NoSuchIndex *) +(* GenEntity2String : NoSuchIndex *) +(* ElemInfo2String : NoSuchIndex NoSuchSymbol *) +(* printGenEntTable : NoSuchIndex *) +(* printElementTable : NoSuchIndex NoSuchSymbol *) +(* printDtdTables : NoSuchIndex NoSuchSymbol *) +(*--------------------------------------------------------------------------*) +signature DtdManager = + sig + include Entities + include Dtd + + exception AttValue of AppData + + val makeAttValue : Dtd -> AppData * State + -> int * Base.AttType * bool * bool * UniChar.Data + -> UniChar.Vector * (Base.AttValue option * AppData) + val checkAttValue : Dtd -> AppData * State + -> Base.AttDef * UniChar.Vector * UniChar.Data + -> HookData.AttPresent * AppData + val genMissingAtts : Dtd -> AppData * State + -> Base.AttDefList * HookData.AttSpecList -> HookData.AttSpecList * AppData + val handleUndeclAtt : Dtd -> AppData * State + -> int * UniChar.Data * int * UniChar.Data -> AppData + val handleUndeclElement : Dtd -> int -> Base.ElemInfo + + val checkAttName : AppData * State -> UniChar.Data -> AppData + val checkElemName : AppData * State -> UniChar.Data -> AppData + val checkDefinedIds : Dtd -> AppData * State -> AppData + val checkMultEnum : Dtd -> AppData * State -> AppData + val checkPreDefined : Dtd -> AppData * State -> AppData + val checkUnparsed : Dtd -> AppData -> AppData + + val enterAttList : Dtd -> AppData * State -> int -> AppData + + val addAttribute : Dtd -> AppData * State -> int * Base.AttDef -> AppData + val addElement : Dtd -> AppData * State -> int * Base.ContentSpec * bool -> AppData + val addGenEnt : Dtd -> AppData * State -> int * Base.GenEntity * bool -> AppData + val addNotation : Dtd -> AppData * State -> int * Base.ExternalId -> AppData + val addParEnt : Dtd -> AppData * State -> int * Base.ParEntity * bool -> AppData + end + +functor DtdManager (structure Dtd : Dtd + structure Hooks : Hooks + structure ParserOptions : ParserOptions) : DtdManager = + struct + structure Entities = Entities (structure Hooks = Hooks) + structure DtdAttributes = DtdAttributes (structure Dtd = Dtd + structure Entities = Entities + structure ParserOptions = ParserOptions) + open + Dtd + DtdAttributes + end +(* stop of ../../Parser/Dtd/dtdManager.sml *) +(* start of ../../Parser/Parse/parseBase.sml *) +signature ParseBase = + sig + include Dfa DtdManager Resolve DfaOptions ParserOptions + + exception NoSuchChar of AppData * State + exception NoSuchEntity of AppData * State + exception NotFound of UniChar.Char * AppData * State + exception SyntaxError of UniChar.Char * AppData * State + + val expectedOrEnded : Errors.Expected * Errors.Location -> UniChar.Char -> Errors.Error + + val recoverXml : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val recoverETag : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val recoverSTag : UniChar.Char * AppData * State -> bool * (UniChar.Char * AppData * State) + val recoverDecl : bool -> UniChar.Char * AppData * State -> (UniChar.Char * AppData * State) + + val useParamEnts : unit -> bool + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseBase *) +(*--------------------------------------------------------------------------*) +(* This structure provides exceptions for the Parse functions, and strings *) +(* for error generation (these strings don't really need to reside in their *) +(* own structure, but like this the code is more easier to read). *) +(*--------------------------------------------------------------------------*) +functor ParseBase (structure Dtd : Dtd + structure Hooks : Hooks + structure Resolve : Resolve + structure ParserOptions : ParserOptions) : ParseBase = + struct + structure DfaOptions = ParserOptions.DfaOptions + structure Dfa = Dfa (structure DfaOptions = DfaOptions) + structure DtdManager = DtdManager (structure Dtd = Dtd + structure Hooks = Hooks + structure ParserOptions = ParserOptions) + open + Base DtdManager DfaOptions Dfa Errors ParserOptions Resolve UniChar + + exception NoSuchChar of AppData * State + exception NoSuchEntity of AppData * State + exception NotFound of UniChar.Char * AppData * State + exception SyntaxError of UniChar.Char * AppData * State + + fun expectedOrEnded (exp,ended) c = + if c=0wx00 then ERR_ENDED_BY_EE ended + else ERR_EXPECTED(exp,[c]) + + (*--------------------------------------------------------------------*) + (* Besides "?>" also recognize ">" as end delimiter, because the typo *) + (* might be an omitted "?". Also stop on "<"; then the entire "?>" *) + (* was omitted; the "<" may not be consumed then. *) + (* Within literals dont recognize ">" and "<", but only "?>"; then *) + (* the typo is an omitted quote character. *) + (*--------------------------------------------------------------------*) + fun recoverXml caq = + let + fun do_lit ch (c,a,q) = + case c + of 0wx00 => (c,a,q) + | 0wx3F (* #"?" *) => + let val (c1,a1,q1) = getChar (a,q) + in if c1=0wx3E (* #">" *) then (c1,a1,q1) + else do_lit ch (c1,a1,q1) + end + | _ => if c=ch then (getChar (a,q)) + else do_lit ch (getChar (a,q)) + fun doit (c,a,q) = + case c + of 0wx00 => (c,a,q) + | 0wx22 (* #""""*) => doit (do_lit c (getChar (a,q))) + | 0wx25 (* #"%" *) => (c,a,q) + | 0wx26 (* #"&" *) => (c,a,q) + | 0wx27 (* #"'" *) => doit (do_lit c (getChar (a,q))) + | 0wx3C (* #"<" *) => (c,a,q) + | 0wx3E (* #">" *) => (getChar (a,q)) + | _ => doit (getChar (a,q)) + in + doit caq + end + + fun recoverETag caq = + let + fun do_lit ch (c,a,q) = + case c + of 0wx00 => (c,a,q) + | _ => if c=ch then (getChar (a,q)) + else do_lit ch (getChar (a,q)) + fun doit (c,a,q) = + case c + of 0wx00 => (c,a,q) + | 0wx22 (* #""""*) => doit (do_lit c (getChar (a,q))) + | 0wx26 (* #"&" *) => (c,a,q) + | 0wx27 (* #"'" *) => doit (do_lit c (getChar (a,q))) + | 0wx3E (* #">" *) => (getChar (a,q)) + | 0wx3C (* #"<" *) => (c,a,q) + | _ => doit (getChar (a,q)) + in + doit caq + end + + fun recoverSTag caq = + let + fun do_lit ch (c,a,q) = + case c + of 0wx00 => (c,a,q) + | _ => if c=ch then (getChar (a,q)) + else do_lit ch (getChar (a,q)) + fun doit (c,a,q) = + case c + of 0wx00 => (false,(c,a,q)) + | 0wx22 (* #""""*) => doit (do_lit c (getChar (a,q))) + | 0wx26 (* #"&" *) => (false,(c,a,q)) + | 0wx27 (* #"'" *) => doit (do_lit c (getChar (a,q))) + | 0wx2F (* #"/" *) => let val (c1,a1,q1) = getChar (a,q) + in if c1=0wx3E (* #">" *) then (true,(c1,a1,q1)) + else doit (c1,a1,q1) + end + | 0wx3E (* #">" *) => (false,getChar (a,q)) + | 0wx3C (* #"<" *) => (false,(c,a,q)) + | _ => doit (getChar (a,q)) + in + doit caq + end + + fun recoverDecl hasSubset caq = + let + fun do_lit ch (c,a,q) = + if c=0wx00 then (c,a,q) + else if c=ch then getChar (a,q) + else do_lit ch (getChar(a,q)) + fun do_decl (c,a,q) = + case c + of 0wx00 => (c,a,q) + | 0wx22 (* #"\""*) => do_decl (do_lit c (getChar (a,q))) + | 0wx27 (* #"'" *) => do_decl (do_lit c (getChar (a,q))) + | 0wx3E (* #">" *) => getChar (a,q) + | _ => do_decl (getChar (a,q)) + fun do_subset (c,a,q) = + case c + of 0wx00 => (c,a,q) + | 0wx3C (* #"<" *) => do_subset (do_decl (getChar (a,q))) + | 0wx5D (* #"]" *) => getChar (a,q) + | _ => do_subset (getChar (a,q)) + fun doit (c,a,q) = + case c + of 0wx00 => if isSpecial q then (c,a,q) else doit (getChar (a,q)) + | 0wx22 (* #"\""*) => doit (do_lit c (getChar (a,q))) + | 0wx25 (* #"%" *) => if hasSubset then (c,a,q) else doit (getChar (a,q)) + | 0wx27 (* #"'" *) => doit (do_lit c (getChar (a,q))) + | 0wx3C (* #"<" *) => (c,a,q) + | 0wx3E (* #">" *) => getChar (a,q) + | 0wx5B (* #"[" *) => if hasSubset then doit (do_subset (getChar (a,q))) + else doit (getChar (a,q)) + | _ => doit (getChar (a,q)) + in doit caq + end + + fun useParamEnts() = !O_VALIDATE orelse !O_INCLUDE_PARAM_ENTS + end +(* stop of ../../Parser/Parse/parseBase.sml *) +(* start of ../../Parser/Parse/parseNames.sml *) + + + + + + + +signature ParseNames = + sig + include ParseBase + + val parseName : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseNmtoken : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val parseNameLit : UniChar.Data -> UniChar.Char * AppData * State + -> UniChar.Data * UniChar.Data * (UniChar.Char * AppData * State) + val parseEntName : UniChar.Data * UniChar.Data -> UniChar.Char * AppData * State + -> bool * UniChar.Data * UniChar.Data * (UniChar.Char * AppData * State) + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseNames *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* parseEntName : none *) +(* parseName : NotFound *) +(* parseNmtoken : NotFound *) +(*--------------------------------------------------------------------------*) +functor ParseNames (structure ParseBase : ParseBase) + : ParseNames = +struct + open + Errors ParseBase UniClasses + + (*--------------------------------------------------------------------*) + (* parse (the remainder of) a name or nmtoken. *) + (* *) + (* [5] Name ::= (Letter | '_' | ':') (NameChar)* *) + (* *) + (* raise NotFound if no name/name start character comes first. *) + (* *) + (* return the name as a list of characters, together with the next *) + (* character and the remaining state. *) + (*--------------------------------------------------------------------*) + fun parseName' (c,a,q) = + if isName c + then let val (cs,caq1) = parseName'(getChar(a,q)) + in (c::cs,caq1) + end + else (nil,(c,a,q)) + fun parseName (c,a,q) = + if isNms c + then let val (cs,caq1) = parseName'(getChar(a,q)) + in (c::cs,caq1) + end + else raise NotFound(c,a,q) + fun parseNmtoken (c,a,q) = + if isName c + then let val (cs,caq1) = parseName'(getChar(a,q)) + in (c::cs,caq1) + end + else raise NotFound(c,a,q) + + (*--------------------------------------------------------------------*) + (* parse a name, additionally accumulating its characters in reverse *) + (* order to the first argument. *) + (* *) + (* raise NotFound if no name/name start character comes first. *) + (*--------------------------------------------------------------------*) + fun parseNameLit cs (c,a,q) = + let fun doit (cs,ns) (c,a,q) = + if isName c then doit (c::cs,c::ns) (getChar(a,q)) + else (cs,rev ns,(c,a,q)) + in + if isNms c then doit (c::cs,[c]) (getChar(a,q)) + else raise NotFound(c,a,q) + end + (*--------------------------------------------------------------------*) + (* parse a name, accumulating its reverse in the first arg text. This *) + (* is useful for parsing of entity values, where entity references *) + (* are parsed but bypassed, and must thus be accumulated together *) + (* the other literal text. *) + (* *) + (* print an error if no name/name start character comes first. *) + (* *) + (* return a boolean indicating whether a name was found, the reverse *) + (* name as a list of characters, concatenated with the text in the *) + (* first arg, together with the next character and remaining state. *) + (*--------------------------------------------------------------------*) + fun parseEntName (lit,text) (c,a,q) = + let + fun doit (lit,text) (c,a,q) = + if isName c then doit (c::lit,c::text) (getChar (a,q)) + else (true,lit,text,(c,a,q)) + in + if isNms c then doit (c::lit,c::text) (getChar (a,q)) + else let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expAnEntName,[c]))) + in (false,lit,text,(c,a1,q)) + end + end + + end + +(* stop of ../../Parser/Parse/parseNames.sml *) +(* start of ../../Parser/Parse/parseMisc.sml *) + + + + + + + + + + +signature ParseMisc = + sig + (*---------------------------------------------------------------------- + include ParseBase + + val parseName : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseNmtoken : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseNameLit : UniChar.Data -> UniChar.Char * AppData * State + -> UniChar.Data * UniChar.Data * (UniChar.Char * AppData * State) + val parseEntName : UniChar.Data * UniChar.Data -> UniChar.Char * AppData * State + -> bool * UniChar.Data * UniChar.Data * (UniChar.Char * AppData * State) + ----------------------------------------------------------------------*) + include ParseNames + + val skipS : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSopt : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSmay : UniChar.Char * AppData * State -> bool * (UniChar.Char * AppData * State) + + val parseSopt : UniChar.Data -> UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseSmay : UniChar.Data -> UniChar.Char * AppData * State + -> bool * (UniChar.Data * (UniChar.Char * AppData * State)) + + val skipEq : UniChar.Char * AppData * State + -> UniChar.Char * AppData * State + val parseEq : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val parseComment : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val parseProcInstr : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseMisc *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* skipS : none *) +(* skipSopt : none *) +(* skipSmay : none *) +(* skipEq : SyntaxError *) +(* skipComment : none *) +(* parseComment : none *) +(* parseProcInstr : none *) +(*--------------------------------------------------------------------------*) +functor ParseMisc (structure ParseBase : ParseBase) + : ParseMisc = +struct + structure ParseNames = ParseNames (structure ParseBase = ParseBase) + + open + UniChar Errors ParseNames + + (*--------------------------------------------------------------------*) + (* parse a sequence of white space. 2.3: *) + (* *) + (* [3] S ::= (#x20 | #x9 | #xD | #xA)+ *) + (*--------------------------------------------------------------------*) + (* parse optional white space. *) + (*--------------------------------------------------------------------*) + (* Return type: Char * AppData * State *) + (*--------------------------------------------------------------------*) + fun skipSopt (c,a,q) = + case c + of 0wx09 => skipSopt (getChar (a,q)) + | 0wx0A => skipSopt (getChar (a,q)) + | 0wx20 => skipSopt (getChar (a,q)) + | _ => (c,a,q) + fun parseSopt cs (c,a,q) = + case c + of 0wx09 => parseSopt (c::cs) (getChar (a,q)) + | 0wx0A => parseSopt (c::cs) (getChar (a,q)) + | 0wx20 => parseSopt (c::cs) (getChar (a,q)) + | _ => (cs,(c,a,q)) + (*--------------------------------------------------------------------*) + (* parse optional white space. *) + (*--------------------------------------------------------------------*) + (* Return type: bool * (Char * AppData * State) *) + (* the bool indicates whether white space was found or not. *) + (*--------------------------------------------------------------------*) + fun skipSmay (c,a,q) = + case c + of 0wx09 => (true,skipSopt (getChar (a,q))) + | 0wx0A => (true,skipSopt (getChar (a,q))) + | 0wx20 => (true,skipSopt (getChar (a,q))) + | _ => (false,(c,a,q)) + fun parseSmay cs (c,a,q) = + case c + of 0wx09 => (true,parseSopt (c::cs) (getChar (a,q))) + | 0wx0A => (true,parseSopt (c::cs) (getChar (a,q))) + | 0wx20 => (true,parseSopt (c::cs) (getChar (a,q))) + | _ => (false,(cs,(c,a,q))) + (*--------------------------------------------------------------------*) + (* parse required white space. *) + (*--------------------------------------------------------------------*) + (* print an error if no white space character is found. *) + (*--------------------------------------------------------------------*) + (* Return type: Char * AppData * State *) + (*--------------------------------------------------------------------*) + fun skipS (c,a,q) = + case c + of 0wx09 => skipSopt (getChar (a,q)) + | 0wx0A => skipSopt (getChar (a,q)) + | 0wx20 => skipSopt (getChar (a,q)) + | _ => (c,hookError(a,(getPos q,ERR_MISSING_WHITE)),q) + + (*--------------------------------------------------------------------*) + (* parse a "=" together with surrounding white space. Cf. 28: *) + (* *) + (* [25] Eq ::= S? '=' S? *) + (*--------------------------------------------------------------------*) + (* Raises: *) + (* SyntaxError if no "=" is found. *) + (*--------------------------------------------------------------------*) + (* Return type: Char * AppData * State *) + (*--------------------------------------------------------------------*) + fun skipEq caq = + let val (c1,a1,q1) = skipSopt caq + in if c1=0wx3D then skipSopt (getChar (a1,q1)) + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expEq,[c1]))) + in raise SyntaxError(c1,a2,q1) + end + end + fun parseEq caq = + let val (cs1,(c1,a1,q1)) = parseSopt nil caq + in if c1=0wx3D + then let val (cs2,caq2)= parseSopt (c1::cs1) (getChar (a1,q1)) + in (rev cs2,caq2) + end + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expEq,[c1]))) + in raise SyntaxError(c1,a2,q1) + end + end + + (*--------------------------------------------------------------------*) + (* parse a comment, the initial "<--" already consumed. cf. 2.5: *) + (* *) + (* They are not part of the document's character data; an XML *) + (* processor may, but need not, make it possible for an application *) + (* to retrieve the text of comments. For compatibility, the string *) + (* "--" (double-hyphen) must not occur within comments. *) + (* *) + (* [15] Comment ::= '' *) + (*--------------------------------------------------------------------*) + (* print an error and end the comment if an entity end is found. *) + (* print an error if the comment contains "--". *) + (*--------------------------------------------------------------------*) + (* add the comment to the user data. *) + (*--------------------------------------------------------------------*) + (* Return type: Char * AppData * State *) + (*--------------------------------------------------------------------*) + fun parseComment startPos aq = + let + fun check_end yet (a0,q0) = + let val (c,a,q) = getChar (a0,q0) + in if c=0wx2D (* #"-" *) + then let val (c1,a1,q1) = getChar (a,q) + in if c1=0wx3E (* #">" *) + then let val cs = Data2Vector(rev yet) + val a2 = hookComment(a1,((startPos,getPos q1),cs)) + in getChar(a2,q1) + end + else let val a2 = if not (!O_COMPATIBILITY) then a1 + else hookError(a1,(getPos q0,ERR_FORBIDDEN_HERE + (IT_DATA [c,c],LOC_COMMENT))) + in doit (c::c::yet) (c1,a2,q1) + end + end + else doit (0wx2D::yet) (c,a,q) + end + and doit yet (c,a,q) = + if c=0wx2D (* #"-" *) then check_end yet (a,q) + else if c<>0wx00 then doit (c::yet) (getChar (a,q)) + else let val err = ERR_ENDED_BY_EE LOC_COMMENT + val a1 = hookError(a,(getPos q,err)) + val cs = Data2Vector(rev yet) + val a2 = hookComment(a1,((startPos,getPos q),cs)) + in (c,a2,q) + end + in doit nil (getChar aq) + end + + (*--------------------------------------------------------------------*) + (* check whether a name matches "xml", disregarding case, cf. 2.6: *) + (* *) + (* [17] PITarget ::= Name - (('X' | 'x') ('M' | 'm') ('L' | 'l')) *) + (* *) + (* The target names "XML", "xml", and so on are reserved for *) + (* standardization in this or future versions of this specification.*) + (*--------------------------------------------------------------------*) + (* print an error if it does match. *) + (*--------------------------------------------------------------------*) + (* Return type: AppData *) + (*--------------------------------------------------------------------*) + fun checkPiTarget (a,q) name = + case name + of [c1,c2,c3] => if ((c1=0wx58 orelse c1=0wx78) andalso + (c2=0wx4D orelse c2=0wx6D) andalso + (c3=0wx4C orelse c3=0wx6C)) + then hookError(a,(getPos q,ERR_RESERVED(name,IT_TARGET))) + else a + | _ => a + (*--------------------------------------------------------------------*) + (* parse a processing instruction, the initial "' Char* )))? '?>'*) + (* *) + (* The first arg consists of the target and the (reversed) list of *) + (* leading characters of the text that have been looked ahead. *) + (*--------------------------------------------------------------------*) + (* print an error and end the proc. instr. if an entity end is found. *) + (*--------------------------------------------------------------------*) + (* add the processing instruction to the user data. *) + (*--------------------------------------------------------------------*) + (* Return type: Char * AppData * State *) + (*--------------------------------------------------------------------*) + fun parseProcInstr' (startPos,target,txtPos,yetText) caq = + let + fun doit text (c1,a1,q1) = + case c1 + of 0wx00 => let val a2 = hookError(a1,(getPos q1,ERR_ENDED_BY_EE LOC_PROC)) + in (text,getPos q1,(c1,a2,q1)) + end + | 0wx3F => (* #"?" *) + let val (c2,a2,q2) = getChar (a1,q1) + in case c2 + of 0wx3E => (* #">" *) (text,getPos q2,getChar(a2,q2)) + | _ => doit (c1::text) (c2,a2,q2) + end + | _ => doit (c1::text) (getChar (a1,q1)) + + val (cs,endPos,(c2,a2,q2)) = doit yetText caq + val text = Data2Vector(rev cs) + val a3 = hookProcInst(a2,((startPos,endPos),target,txtPos,text)) + in + (c2,a3,q2) + end + (*--------------------------------------------------------------------*) + (* parse a processing instruction, the initial "' Char* )))? '?>'*) + (*--------------------------------------------------------------------*) + (* print an error and end the proc. instr. if an entity end is found. *) + (* print an error if no target name is found. *) + (* print an error if no whitespace follows the target. *) + (*--------------------------------------------------------------------*) + (* add the processing instruction to the user data. *) + (*--------------------------------------------------------------------*) + (* Return type: Char * AppData * State *) + (*--------------------------------------------------------------------*) + fun parseProcInstr startPos (a,q) = + let + (* NotFound is handled after the 'in .. end' *) + val (target,(c1,a1,q1)) = parseName (getChar(a,q)) + val a1 = checkPiTarget (a1,q) target + in + case c1 + of 0wx00 => + let + val a2 = hookError(a1,(getPos q1,ERR_ENDED_BY_EE LOC_PROC)) + val a3 = hookProcInst(a2,((startPos,getPos q1),target,getPos q1,nullVector)) + in (c1,a3,q1) + end + | 0wx3F => (* #"?" *) + let val (c2,a2,q2) = getChar (a1,q1) + in case c2 + of 0wx3E => (* #">" *) + let val a3 = hookProcInst(a2,((startPos,getPos q2),target, + getPos q1,nullVector)) + in getChar (a3,q2) + end + | _ => let val a3 = hookError(a2,(getPos q1,ERR_MISSING_WHITE)) + in parseProcInstr' (startPos,target,getPos q1,[c1]) (c2,a3,q2) + end + end + | _ => let val (hadS,(c2,a2,q2)) = skipSmay (c1,a1,q1) + val a3 = if hadS then a2 + else hookError(a2,(getPos q2,ERR_MISSING_WHITE)) + in parseProcInstr' (startPos,target,getPos q2,nil) (c2,a3,q2) + end + end + handle NotFound(c,a,q) => + let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expATarget,[c]))) + in parseProcInstr' (startPos,nullData,getPos q,nil) (c,a1,q) + end +end +(* stop of ../../Parser/Parse/parseMisc.sml *) +(* start of ../../Parser/Parse/parseXml.sml *) +signature ParseXml = + sig + (*---------------------------------------------------------------------- + include ParseBase + + val parseName : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseNmtoken : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseNameLit : UniChar.Data -> UniChar.Char * AppData * State + -> UniChar.Data * UniChar.Data * (UniChar.Char * AppData * State) + val parseEntName : UniChar.Data * UniChar.Data -> UniChar.Char * AppData * State + -> bool * UniChar.Data * UniChar.Data * (UniChar.Char * AppData * State) + + val parseComment : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val parseProcInstr : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val skipS : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSopt : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSmay : UniChar.Char * AppData * State -> bool * (UniChar.Char * AppData * State) + val parseSopt : UniChar.Data -> UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseSmay : UniChar.Data -> UniChar.Char * AppData * State + -> bool * (UniChar.Data * (UniChar.Char * AppData * State)) + val parseEq : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + ----------------------------------------------------------------------*) + include ParseMisc + + val openDocument : Uri.Uri option -> AppData + -> Encoding.Encoding * HookData.XmlDecl option * (UniChar.Char * AppData * State) + val openSubset : Uri.Uri -> AppData + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + val openExtern : int * bool * Uri.Uri -> AppData * State + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseXml *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* openDocument : NoSuchFile *) +(* openExtern : none *) +(* openSubset : NoSuchFile *) +(*--------------------------------------------------------------------------*) +functor ParseXml (structure ParseBase : ParseBase) + : ParseXml = +struct + structure ParseMisc = ParseMisc (structure ParseBase = ParseBase) + + open + Errors UniChar UniClasses UtilString + ParseMisc + + fun checkVersionNum (a,q) version = + if not (!O_CHECK_VERSION) orelse version="1.0" then a + else hookError(a,(getPos q,ERR_VERSION version)) + + (*--------------------------------------------------------------------*) + (* parse a version number, the quote character ("'" or '"') passed as *) + (* first argument. cf. 2.8: *) + (* *) + (* [24] VersionInfo ::= S 'version' Eq (' VersionNum ' *) + (* | " VersionNum ") *) + (* [26] VersionNum ::= ([a-zA-Z0-9_.:] | '-')+ *) + (* *) + (* print an error and end the literal if an entity end is found. *) + (* print an error if a disallowed character is found. *) + (* *) + (* return the version number as a string option, together with the *) + (* next character and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseVersionNum quote aq = + let + fun doit text (c,a,q) = + if c=quote then (text,getChar (a,q)) + else if isVers c then doit (c::text) (getChar (a,q)) + else if c=0wx0 + then let val a1 = hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_VERSION)) + in (text,(c,a1,q)) + end + else let val err = ERR_FORBIDDEN_HERE(IT_CHAR c,LOC_VERSION) + val a1 = hookError(a,(getPos q,err)) + in doit text (getChar (a1,q)) + end + + val (c1,a1,q1) = getChar aq + + val (text,(c2,a2,q2)) = + if isVers c1 then doit [c1] (getChar (a1,q1)) + else if c1=quote + then let val a2 = hookError(a1,(getPos q1,ERR_EMPTY LOC_VERSION)) + in (nil,getChar (a2,q1)) + end + else if c1=0wx00 + then let val a2 = hookError(a1,(getPos q1,ERR_ENDED_BY_EE LOC_VERSION)) + val a3 = hookError(a2,(getPos q1,ERR_EMPTY LOC_VERSION)) + in (nil,(c1,a3,q1)) + end + else let val err = ERR_FORBIDDEN_HERE(IT_CHAR c1,LOC_VERSION) + val a2 = hookError(a1,(getPos q1,err)) + in doit nil (getChar (a2,q1)) + end + val version = Latin2String (rev text) + val a3 = checkVersionNum (a2,q1) version + in + (SOME version,(c2,a3,q2)) + end + (*--------------------------------------------------------------------*) + (* parse a version info starting after 'version'. Cf. 2.8: *) + (* *) + (* [24] VersionInfo ::= S 'version' Eq (' VersionNum ' *) + (* | " VersionNum ") *) + (* *) + (* print an error and raise SyntaxState if no '=' is found. *) + (* print an error and raise SyntaxState if no quote sign is found. *) + (* *) + (* return the version number as a string option, together with the *) + (* next char and the remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseVersionInfo caq = + let val (c1,a1,q1) = skipEq caq + in case c1 + of 0wx22 (* '""' *) => parseVersionNum c1 (a1,q1) + | 0wx27 (* "'" *) => parseVersionNum c1 (a1,q1) + | _ => let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expLitQuote,[c1]))) + in raise SyntaxError(c1,a2,q1) + end + end + + (*--------------------------------------------------------------------*) + (* parse an encoding name, the quote character ("'" or '"') passed as *) + (* first argument. cf. 4.3.3: *) + (* *) + (* [80] EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' *) + (* |"'" EncName "'") *) + (* *) + (* [81] EncName ::= [A-Za-z] /* Encoding name *) + (* ([A-Za-z0-9._] | '-')* contains only Latin *) + (* characters */ *) + (* *) + (* print an error and end the literal if an entity end is found. *) + (* print an error if a disallowed character is found. *) + (* *) + (* return the encoding name as a string option, together with the *) + (* next character and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseEncName quote aq = + let + fun doit text (c,a,q) = + if c=quote then (text,getChar (a,q)) + else if isEnc c then doit (c::text) (getChar (a,q)) + else if c=0wx00 + then let val a1 = hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_ENCODING)) + in (text,(c,a1,q)) + end + else let val err = ERR_FORBIDDEN_HERE(IT_CHAR c,LOC_ENCODING) + val a1 = hookError(a,(getPos q,err)) + in doit text (getChar (a,q)) + end + + val (c1,a1,q1) = getChar aq + + val (text,caq2) = + if isEncS c1 then doit [c1] (getChar (a1,q1)) + else if c1=quote + then let val a2 = hookError(a1,(getPos q1,ERR_EMPTY LOC_ENCODING)) + in (nil,getChar (a2,q1)) + end + else if c1=0wx00 + then let val a2 = hookError(a1,(getPos q1,ERR_ENDED_BY_EE LOC_ENCODING)) + val a3 = hookError(a2,(getPos q1,ERR_EMPTY LOC_ENCODING)) + in (nil,(c1,a3,q1)) + end + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expStartEnc,[c1]))) + in doit nil (getChar (a2,q1)) + end + + val enc = toUpperString (Latin2String (rev text)) + in + (enc,caq2) + end + (*--------------------------------------------------------------------*) + (* parse an encoding decl starting after 'encoding'. Cf. 4.3.3: *) + (* *) + (* *) + (* [80] EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' *) + (* |"'" EncName "'") *) + (* *) + (* print an error and raise SyntaxState if no '=' is found. *) + (* print an error and raise SyntaxState if no quote sign is found. *) + (* *) + (* return the encoding name as a string option, together with the *) + (* next char and the remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseEncodingDecl caq = + let val (c1,a1,q1) = skipEq caq + in case c1 + of 0wx22 (* '""' *) => parseEncName c1 (a1,q1) + | 0wx27 (* "'" *) => parseEncName c1 (a1,q1) + | _ => let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expLitQuote,[c1]))) + in raise SyntaxError(c1,a2,q1) + end + end + + (*--------------------------------------------------------------------*) + (* parse a standalone declaration starting after 'standalone'. *) + (* Cf. 2.9: *) + (* *) + (* [32] SDDecl ::= S 'standalone' Eq [ VC: Standalone *) + (* ( ("'" ('yes' | 'no') "'") Document *) + (* | ('"' ('yes' | 'no') '"')) Declaration ] *) + (* *) + (* print an error and raise SyntaxState if no '=' is found. *) + (* print an error and raise SyntaxState if no literal is found. *) + (* print an error and end the literal if an entity end is found. *) + (* print an error if the literal is neither 'yes' nor 'no'. *) + (* *) + (* return the standalone status as a boolean option, together with *) + (* the next character and the remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseStandaloneDecl caq0 = + let + val (quote,a,q) = skipEq caq0 + + fun doit text (c,a,q) = + if c=quote then (text,getChar (a,q)) + else if c<>0wx0 then doit (c::text) (getChar (a,q)) + else let val a1 = hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_LITERAL)) + in (text,(c,a1,q)) + end + + val caq1 as (_,_,q1) = + case quote + of 0wx22 (* '""' *) => (getChar (a,q)) + | 0wx27 (* "'" *) => (getChar (a,q)) + | _ => let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expLitQuote,[quote]))) + in raise SyntaxError(quote,a1,q) + end + val (text,caq2) = doit nil caq1 + in + case text + of [0wx73,0wx65,0wx79] (* reversed "yes" *) => (SOME true,caq2) + | [0wx6f,0wx6e] (* reversed "no" *) => (SOME false,caq2) + | revd => let val (c2,a2,q2) = caq2 + val a3 = hookError(a2,(getPos q1,ERR_EXPECTED(expNoYes,revd))) + in (NONE,(c2,a3,q2)) + end + end + + (*--------------------------------------------------------------------*) + (* parse an xml declaration starting after 'xml ' (i.e. the first *) + (* white space character is already consumed). Cf. 2.8: *) + (* *) + (* [23] XMLDecl ::= ''*) + (* *) + (* [24] VersionInfo ::= S 'version' Eq (' VersionNum ' *) + (* | " VersionNum ") *) + (* *) + (* [32] SDDecl ::= S 'standalone' Eq [ VC: Standalone *) + (* ( ("'" ('yes' | 'no') "'") Document *) + (* | ('"' ('yes' | 'no') '"')) Declaration ] *) + (* *) + (* [80] EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' *) + (* |"'" EncName "'") *) + (* *) + (* default version, encoding and standalone status to NONE. *) + (* *) + (* print an error if no leading white space is found. *) + (* print an error whenever a wrong name is encountered. *) + (* print an Error if no VersionInfo is found. *) + (* print an Error if no '?>' is found at the end. *) + (* print an error and raise SyntaxState if no '=' or no literal is *) + (* found in VersionInfo, EncodingDecl or SDDecl. *) + (* print an error if a literal does not have a correct value. *) + (* *) + (* return the corresponding XmlDecl option and the next char & state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseXmlDecl auto caq = + let + (*-----------------------------------------------------------------*) + (* skip the '?>' at the end of the xml declaration. *) + (* *) + (* print an error and raise SyntaxState if no '?>' is found. *) + (* *) + (* return the info passed as first arg, and the next char & state. *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + fun skipXmlDeclEnd enc res (c,a,q) = + if c=0wx3F (* "#?" *) + then let val (c1,a1,q1) = getChar (a,q) + in if c1=0wx3E (* #">" *) then (enc,SOME res,getChar (a1,q1)) + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expGt,[c1]))) + in raise SyntaxError (c1,a2,q1) + end + end + else let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expProcEnd,[c]))) + in raise SyntaxError (c,a1,q) + end + (*-----------------------------------------------------------------*) + (* parse the remainder after the keyword 'standalone', the version *) + (* and encoding already parsed and given in the first arg. *) + (* *) + (* pass the version,encoding and sd status to skipXmlDeclEnd *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + fun parseXmlDeclAfterS enc (v,e) caq = + let + val (alone,caq1) = parseStandaloneDecl caq + val caq2 = skipSopt caq1 + in skipXmlDeclEnd enc (v,e,alone) caq2 + end + (*-----------------------------------------------------------------*) + (* parse the remainder after the encoding declaration, the version *) + (* and encoding already parsed and given in the first arg. *) + (* *) + (* print an error if a name other than 'standalone' is found. *) + (* *) + (* pass the version and encoding to parseXmlDeclAfterS. *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + fun parseXmlDeclBeforeS enc (v,e) caq = + let + val (hadS,caq1 as (_,_,q1)) = skipSmay caq + val (name,(c2,a2,q2)) = parseName caq1 (* NotFound handled below *) + val a3 = if hadS then a2 + else hookError(a2,(getPos q1,ERR_MISSING_WHITE)) + in case name + of [0wx73,0wx74,0wx61,0wx6e,0wx64,0wx61,0wx6c,0wx6f,0wx6e,0wx65] => + (* "standalone" *) parseXmlDeclAfterS enc (v,e) (c2,a3,q2) + | _ => let val a4 = hookError(a3,(getPos q1,ERR_EXPECTED(expStandOpt,name))) + in parseXmlDeclAfterS enc (v,e) (c2,a4,q2) + end + end + handle NotFound caq => (* exception raised by parseName *) + skipXmlDeclEnd enc (v,e,NONE) caq + (*-----------------------------------------------------------------*) + (* parse the remainder after the keyword 'encoding', the version *) + (* already parsed and given in the first arg. *) + (* *) + (* pass the version and encoding and to parseXmlDeclBeforeS *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + fun parseXmlDeclAfterE ver caq = + let + val (enc,(c1,a1,q1)) = parseEncodingDecl caq + val (a2,q2,enc1) = changeAuto(a1,q1,enc) + in + parseXmlDeclBeforeS enc1 (ver,SOME enc) (c1,a2,q2) + end + (*-----------------------------------------------------------------*) + (* parse the remainder after the version info, the version already *) + (* parsed and given in the first arg. *) + (* *) + (* print an error if a name other than 'encoding' or 'standalone' *) + (* is found. *) + (* *) + (* pass obtained/default values to parseXmlDeclAfter[E|S] or to *) + (* skipXmlDeclEnd. *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + fun parseXmlDeclBeforeE ver caq = + let + val (hadS,caq1 as (_,_,q1)) = skipSmay caq + val (name,(c2,a2,q2)) = parseName caq1 (* NotFound handled below *) + val a3 = if hadS then a2 + else hookError(a2,(getPos q1,ERR_MISSING_WHITE)) + in + case name + of [0wx65,0wx6e,0wx63,0wx6f,0wx64,0wx69,0wx6e,0wx67] => + (* "encoding" *) parseXmlDeclAfterE ver (c2,a3,q2) + | [0wx73,0wx74,0wx61,0wx6e,0wx64,0wx61,0wx6c,0wx6f,0wx6e,0wx65] => + (* "standalone" *) parseXmlDeclAfterS auto (ver,NONE) (c2,a3,q2) + | _ => let val a4 = hookError(a3,(getPos q1,ERR_EXPECTED(expEncStand,name))) + in parseXmlDeclAfterE ver (c2,a4,q2) + end + end + handle NotFound caq => (* exception raised by parseName *) + skipXmlDeclEnd auto (ver,NONE,NONE) caq + + (*-----------------------------------------------------------------*) + (* do the main work. if the first name is not 'version' then it *) + (* might be 'encoding' or 'standalone'. Then take the default *) + (* NONE for version and - if needed - encoding and call the *) + (* appropriate function. otherwise assume a typo and parse the *) + (* version number, then call parseXmlDeclBeforeE. if no name is *) + (* found at all, proceed with skipXmlDeclEnd. *) + (* *) + (* print an error and raise SyntaxState if an entity end is found. *) + (* print an error and raise SyntaxState if appropriate. *) + (* print an error if a name other than 'version' is found. *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + val caq1 as (_,_,q1) = skipSopt caq + val (name,(caq2 as (c2,a2,q2))) = parseName caq1 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expVersion,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError (c,a1,q) + end + in + if name=[0wx76,0wx65,0wx72,0wx73,0wx69,0wx6f,0wx6e] (* "version" *) + then let val (ver,caq3) = parseVersionInfo caq2 + in parseXmlDeclBeforeE ver caq3 + end + else let val a3 = hookError(a2,(getPos q1,ERR_EXPECTED(expVersion,name))) + in case name + of [0wx65,0wx6e,0wx63,0wx6f,0wx64,0wx69,0wx6e,0wx67] => + (* "encoding" *) parseXmlDeclAfterE NONE (c2,a3,q2) + | [0wx73,0wx74,0wx61,0wx6e,0wx64,0wx61,0wx6c,0wx6f,0wx6e,0wx65] => + (* "standalone" *) parseXmlDeclAfterS auto (NONE,NONE) (c2,a3,q2) + | _ => let val (ver,caq3) = parseVersionInfo (c2,a3,q2) + in parseXmlDeclBeforeE ver caq3 + end + end + end + (*----------------------------------------------------------------*) + (* catch entity end exceptions raised by subfunctions, print an *) + (* error and re-raise the exception. *) + (*----------------------------------------------------------------*) + handle SyntaxError(c,a,q) => + let val err = if c=0wx0 then ERR_ENDED_BY_EE LOC_XML_DECL + else ERR_CANT_PARSE LOC_XML_DECL + val a1 = hookError(a,(getPos q,err)) + in (auto,NONE,recoverXml(c,a1,q)) + end + + (*--------------------------------------------------------------------*) + (* parse a text declaration starting after 'xml ' (i.e. the first *) + (* white space character is already consumed). Cf. 2.8: *) + (* *) + (* [77] TextDecl ::= '' *) + (* *) + (* [24] VersionInfo ::= S 'version' Eq (' VersionNum ' *) + (* | " VersionNum ") *) + (* *) + (* [80] EncodingDecl ::= S 'encoding' Eq ('"' EncName '"' *) + (* |"'" EncName "'") *) + (* *) + (* default version and encoding to NONE. *) + (* *) + (* print an error if no leading white space is found. *) + (* print an error whenever a wrong name is encountered. *) + (* print an Error if no EncodingDecl is found. *) + (* print an Error if '?>' is found at the end. *) + (* print an error and raise SyntaxState if no '=' or no literal is *) + (* found in VersionInfo or EncodingDecl. *) + (* print an error if a literal does not have a correct value. *) + (* *) + (* return the corresponding TextDecl option and the next char & state.*) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseTextDecl auto caq = + let + (*-----------------------------------------------------------------*) + (* skip the '?>' at the end of the text declaration. *) + (* *) + (* print an error and raise SyntaxState if no '?>' is found. *) + (* *) + (* return the info passed as first arg, and the next char & state. *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + fun skipTextDeclEnd enc res (c,a,q) = + if c=0wx3F (* "#?" *) + then let val (c1,a1,q1) = getChar (a,q) + in if c1=0wx3E (* #">" *) then (enc,SOME res,getChar (a1,q1)) + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expGt,[c1]))) + in raise SyntaxError(c1,a2,q1) + end + end + else let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expProcEnd,[c]))) + in raise SyntaxError(c,a1,q) + end + (*-----------------------------------------------------------------*) + (* parse the remainder after the keyword 'encoding', the version *) + (* already parsed and given in the first arg. *) + (* *) + (* pass the version and encoding and to skipTextDeclEnd. *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + fun parseTextDeclAfterE ver caq = + let + val (enc,(c1,a1,q1)) = parseEncodingDecl caq + val (a2,q2,enc1) = changeAuto(a1,q1,enc) + val caq3 = skipSopt (c1,a2,q2) + in skipTextDeclEnd enc1 (ver,SOME enc) caq3 + end + (*-----------------------------------------------------------------*) + (* parse the remainder after the version info, the version given *) + (* as first argument. *) + (* *) + (* print an error and raise SyntaxState is no name is found. *) + (* print an error if a name other than 'encoding' is found. *) + (* *) + (* pass obtained/default values to parseTextDeclAfterE. *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + fun parseTextDeclBeforeE ver caq = + let + val caq1 as (_,_,q1) = skipS caq + val (name,caq2) = parseName caq1 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expEncoding,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError (c,a1,q) + end + in + if name=[0wx65,0wx6e,0wx63,0wx6f,0wx64,0wx69,0wx6e,0wx67] (* "encoding" *) + then parseTextDeclAfterE ver caq2 + else let val (c2,a2,q2) = caq2 + val a3 = hookError(a2,(getPos q1,ERR_EXPECTED(expEncoding,name))) + in parseTextDeclAfterE ver (c2,a3,q2) + end + end + (*-----------------------------------------------------------------*) + (* do the main work. if the first name is neither 'version' nor *) + (* 'encoding' then assume typo of 'version'. Then parse the *) + (* version number, call parseTextDeclBeforeE. if no name is found *) + (* at all, proceed with skipTextDeclEnd. *) + (* *) + (* print an error and raise SyntaxState if appropriate. *) + (* print an error if a name other than 'version' or 'encoding' is *) + (* found. *) + (*-----------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*-----------------------------------------------------------------*) + val caq1 as (_,_,q1) = skipSopt caq + val (name,caq2) = parseName caq1 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expEncVers,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError(c,a1,q) + end + in case name + of [0wx76,0wx65,0wx72,0wx73,0wx69,0wx6f,0wx6e] => (* "version" *) + let val (ver,caq3) = parseVersionInfo caq2 + in parseTextDeclBeforeE ver caq3 + end + | [0wx65,0wx6e,0wx63,0wx6f,0wx64,0wx69,0wx6e,0wx67] => (* "encoding" *) + parseTextDeclAfterE NONE caq2 + | _ => let val (c2,a2,q2) = caq2 + val a3 = hookError(a2,(getPos q1,ERR_EXPECTED(expEncVers,name))) + val (ver,caq3) = parseVersionInfo (c2,a3,q2) + in parseTextDeclBeforeE ver caq3 + end + end + (*----------------------------------------------------------------*) + (* catch entity end exceptions raised by subfunctions, print an *) + (* error and re-raise the exception. *) + (*----------------------------------------------------------------*) + handle SyntaxError(c,a,q) => + let val err = if c=0wx0 then ERR_ENDED_BY_EE LOC_TEXT_DECL + else ERR_CANT_PARSE LOC_TEXT_DECL + val a1 = hookError(a,(getPos q,err)) + in (auto,NONE,recoverXml(c,a1,q)) + end + + (*--------------------------------------------------------------------*) + (* check for the string " if isS c1 then (true,(a1,q1)) + else (false,(a1,ungetChars(q1,rev(c1::seen)))) + | c::cs => if c1=c then doit (c1::seen,cs) (a1,q1) + else (false,(a1,ungetChars(q1,rev(c1::seen)))) + end + in doit (nil,unseen) aq + end + + (*--------------------------------------------------------------------*) + (* consume the text/xml declaration. The first parameter is a pair of *) + (* the function that parses the declaration and a boolean indicating *) + (* whether a warning should we produced if the declaration is missing.*) + (* The second parameter is a pair (seen,auto), where auto is the *) + (* auto-detected encoding, and seen is SOME cs, if auto-detection *) + (* found some initial characters cs of the string " raise CantOpenFile(fmsg,a) + + (*--------------------------------------------------------------------*) + (* open the external subset; consume its text declaration if present. *) + (* See 2.8: *) + (* *) + (* [30] extSubset ::= TextDecl? extSubsetDecl *) + (* *) + (* return the optional text declaration and the first char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: NoSuchFile *) + (*--------------------------------------------------------------------*) + fun openSubset uri a = + let val (q,auto) = pushSpecial (EXT_SUBSET,SOME uri) + in findTextDecl (parseTextDecl,false) auto (a,q) + end + handle NoSuchFile fmsg => raise CantOpenFile(fmsg,a) + + (*--------------------------------------------------------------------*) + (* open the document entity; consume its xml declaration if present. *) + (* See 2.8: *) + (* *) + (* [1] document ::= prolog element Misc* *) + (* [22] prolog ::= XMLDecl? Misc* (doctypedecl Misc* )? *) + (* *) + (* return the optional xml declaration and the first char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: NoSuchFile *) + (*--------------------------------------------------------------------*) + fun openDocument uri a = + let val (q,auto) = pushSpecial (DOC_ENTITY,uri) + in findTextDecl (parseXmlDecl,!O_WARN_XML_DECL) auto (a,q) + end + handle NoSuchFile fmsg => raise CantOpenFile(fmsg,a) +end +(* stop of ../../Parser/Parse/parseXml.sml *) +(* start of ../../Parser/Parse/parseRefs.sml *) +signature ParseRefs = + sig + (*---------------------------------------------------------------------- + include ParseBase + + val parseName : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseNmtoken : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseEntName : UniChar.Data * UniChar.Data -> UniChar.Char * AppData * State + -> bool * UniChar.Data * UniChar.Data * (UniChar.Char * AppData * State) + + val parseComment : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val parseProcInstr : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val skipS : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSopt : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSmay : UniChar.Char * AppData * State -> bool * (UniChar.Char * AppData * State) + val parseSopt : UniChar.Data -> UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseSmay : UniChar.Data -> UniChar.Char * AppData * State + -> bool * (UniChar.Data * (UniChar.Char * AppData * State)) + val parseEq : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val openExtern : int * Uri.Uri -> AppData * State + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + val openDocument : Uri.Uri option -> AppData + -> Encoding.Encoding * HookData.XmlDecl option * (UniChar.Char * AppData * State) + val openSubset : Uri.Uri -> AppData + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + ----------------------------------------------------------------------*) + include ParseXml + + val parseCharRef : AppData * State -> UniChar.Char * AppData * State + val parseGenRef : Dtd -> UniChar.Char * AppData * State + -> (int * Base.GenEntity) * (AppData * State) + val parseParRef : Dtd -> UniChar.Char * AppData * State + -> (int * Base.ParEntity) * (AppData * State) + + val parseCharRefLit : UniChar.Data -> AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseGenRefLit : Dtd -> UniChar.Data -> UniChar.Char * AppData * State + -> UniChar.Data * ((int * Base.GenEntity) * (AppData * State)) + val parseParRefLit : Dtd -> UniChar.Data -> UniChar.Char * AppData * State + -> UniChar.Data * ((int * Base.ParEntity) * (AppData * State)) + + val skipCharRef : AppData * State -> (UniChar.Char * AppData * State) + val skipReference : UniChar.Char * AppData * State -> (UniChar.Char * AppData * State) + + val skipPS : Dtd -> UniChar.Char * AppData * State + -> UniChar.Char * AppData * State + val skipPSopt : Dtd -> UniChar.Char * AppData * State + -> UniChar.Char * AppData * State + val skipPSmay : Dtd -> UniChar.Char * AppData * State + -> bool * (UniChar.Char * AppData * State) + val skipPSdec : Dtd -> UniChar.Char * AppData * State + -> bool * (UniChar.Char * AppData * State) + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseRefs *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* parseCharRef : NoSuchChar SyntaxError *) +(* parseGenRef : NoSuchEntity SyntaxState *) +(* parseParRef : NoSuchEntity SyntaxState *) +(* skipCharRef : none *) +(* skipPS : none *) +(* skipPSdec : none *) +(* skipPSmay : none *) +(* skipPSopt : none *) +(* skipReference : none *) +(*--------------------------------------------------------------------------*) +functor ParseRefs (structure ParseBase : ParseBase) + : ParseRefs = +struct + structure ParseXml = ParseXml (structure ParseBase = ParseBase) + + open + Base Errors UniClasses + ParseXml + + (*--------------------------------------------------------------------*) + (* parse a character reference, the "&#" already read. See 4.1: *) + (* *) + (* [66] CharRef ::= '&#' [0-9]+ ';' *) + (* | '&#x' [0-9a-fA-F]+ ';' [ WFC: Legal Character ] *) + (* *) + (* Well-Formedness Constraint: Legal Character *) + (* Characters referred to using character references must match the *) + (* production for Char. *) + (* *) + (* If the character reference begins with "&#x", the digits and *) + (* letters up to the terminating ; provide a hexadecimal *) + (* representation of the character's code point in ISO/IEC 10646. *) + (* If it begins just with "&#", the digits up to the terminating ; *) + (* provide a decimal representation of the character's code point. *) + (* *) + (* raise SyntaxError if no number or x plus hexnum is found, or if no *) + (* semicolon follows it. *) + (* raise NoSuchChar if the reference is to a non-XML character. *) + (* *) + (* return the character referred to, and the remaining state. *) + (*--------------------------------------------------------------------*) + fun parseCharRef aq = + let + (*--------------------------------------------------------------*) + (* parse a (hexa)decimal number, accumulating the value in the *) + (* first parameter. *) + (* *) + (* return the numbers value as a Char. *) + (*--------------------------------------------------------------*) + fun do_hex_n yet (c,a,q) = + case hexValue c + of NONE => (yet,(c,a,q)) + | SOME v => do_hex_n (0wx10*yet+v) (getChar (a,q)) + fun do_dec_n yet (c,a,q) = + case decValue c + of NONE => (yet,(c,a,q)) + | SOME v => do_dec_n (0wx0A*yet+v) (getChar (a,q)) + (*--------------------------------------------------------------*) + (* Parse a (hexa)decimal number of at least one digit. *) + (* *) + (* raise SyntaxError if no hexdigit is found first. *) + (* *) + (* return the numbers value as a Char. *) + (*--------------------------------------------------------------*) + fun do_hex_1 (c,a,q) = + case hexValue c + of SOME v => do_hex_n v (getChar (a,q)) + | NONE => let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expHexDigit,[c]))) + in raise SyntaxError(c,a1,q) + end + (*--------------------------------------------------------------*) + (* Parse a decimal number of at least one digit, or a hexnumber *) + (* if the first character is 'x'. *) + (* *) + (* raise SyntaxError if neither 'x' nor digit is found first. *) + (* *) + (* return the number's value as a Char. *) + (*--------------------------------------------------------------*) + fun do_dec_1 (c,a,q) = + case decValue c + of SOME v => do_dec_n v (getChar (a,q)) + | NONE => if c=0wx78 (* #"x" *) + then do_hex_1 (getChar (a,q)) + else let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expDigitX,[c]))) + in raise SyntaxError(c,a1,q) + end + + val (ch,(c1,a1,q1)) = do_dec_1 (getChar aq) + + val _ = if c1=0wx3B then () + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expSemi,[c1]))) + in raise SyntaxError(c1,a2,q1) + end + + val _ = if isXml ch then () + else let val a2 = hookError(a1,(getPos q1,ERR_NON_XML_CHARREF ch)) + in raise NoSuchChar (a2,q1) + end + in (ch,a1,q1) + end + fun parseCharRefLit cs aq = + let + (*--------------------------------------------------------------*) + (* parse a (hexa)decimal number, accumulating the value in the *) + (* first parameter. *) + (* *) + (* return the numbers value as a Char. *) + (*--------------------------------------------------------------*) + fun do_hex_n (cs,yet) (c,a,q) = + case hexValue c + of NONE => (cs,yet,(c,a,q)) + | SOME v => do_hex_n (c::cs,0wx10*yet+v) (getChar (a,q)) + fun do_dec_n (cs,yet) (c,a,q) = + case decValue c + of NONE => (cs,yet,(c,a,q)) + | SOME v => do_dec_n (c::cs,0wx0A*yet+v) (getChar (a,q)) + (*--------------------------------------------------------------*) + (* Parse a (hexa)decimal number of at least one digit. *) + (* *) + (* raise SyntaxError if no hexdigit is found first. *) + (* *) + (* return the numbers value as a Char. *) + (*--------------------------------------------------------------*) + fun do_hex_1 cs (c,a,q) = + case hexValue c + of SOME v => do_hex_n (c::cs,v) (getChar (a,q)) + | NONE => let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expHexDigit,[c]))) + in raise SyntaxError(c,a1,q) + end + (*--------------------------------------------------------------*) + (* Parse a decimal number of at least one digit, or a hexnumber *) + (* if the first character is 'x'. *) + (* *) + (* raise SyntaxError if neither 'x' nor digit is found first. *) + (* *) + (* return the number's value as a Char. *) + (*--------------------------------------------------------------*) + fun do_dec_1 cs (c,a,q) = + case decValue c + of SOME v => do_dec_n (c::cs,v) (getChar (a,q)) + | NONE => if c=0wx78 (* #"x" *) + then do_hex_1 (c::cs) (getChar (a,q)) + else let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expDigitX,[c]))) + in raise SyntaxError(c,a1,q) + end + + val (cs1,ch,(c1,a1,q1)) = do_dec_1 cs (getChar aq) + + val _ = if c1=0wx3B then () + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expSemi,[c1]))) + in raise SyntaxError(c1,a2,q1) + end + + val _ = if isXml ch then () + else let val a2 = hookError(a1,(getPos q1,ERR_NON_XML_CHARREF ch)) + in raise NoSuchChar (a2,q1) + end + in (c1::cs1,(ch,a1,q1)) + end + + (*--------------------------------------------------------------------*) + (* parse a general entity reference, the "&" already read. See 4.1: *) + (* *) + (* [68] EntityRef ::= '&' Name ';' [ WFC: Entity Declared ] *) + (* [ VC: Entity Declared ] *) + (* [ WFC: Parsed Entity ] *) + (* [ WFC: No Recursion ] *) + (* *) + (* Well-Formedness Constraint: Entity Declared *) + (* In a document without any DTD, a document with only an internal *) + (* DTD subset which contains no parameter entity references, or a *) + (* document with "standalone='yes'", the Name given in the entity *) + (* reference must match that in an entity declaration, ... *) + (* ... the declaration of a general entity must precede any *) + (* reference to it which appears in a default value in an *) + (* attribute-list declaration. *) + (* *) + (* Validity Constraint: Entity Declared *) + (* In a document with an external subset or external parameter *) + (* entities with "standalone='no'", the Name given in the entity *) + (* reference must match that in an entity declaration. ... *) + (* ... the declaration of a general entity must precede any *) + (* reference to it which appears in a default value in an *) + (* attribute-list declaration. *) + (* *) + (* Thus: in both cases it is an error if the entity is not declared. *) + (* The only difference is the impact on well-formednes/validity. *) + (* *) + (* There are three contexts in which a general entity reference can *) + (* appear: in content, in attribute value, in entity value. This *) + (* passage states that it need not be declared prior to a reference *) + (* in an entity value. But in this context, it is bypassed and not *) + (* included, i.e., it need not be recognized. *) + (* *) + (* Well-Formedness Constraint: Parsed Entity *) + (* An entity reference must not contain the name of an unparsed *) + (* entity. Unparsed entities may be referred to only in attribute *) + (* values ... *) + (* *) + (* Well-Formedness Constraint: No Recursion *) + (* A parsed entity must not contain a recursive reference to *) + (* itself, either directly or indirectly. *) + (* *) + (* print an error and raise SyntaxState if no name is found, or if no *) + (* semicolon follows it. *) + (* print an error and return GE_NULL if the reference is to an *) + (* undeclared, unparsed or open entity. *) + (* *) + (* return the entity referred to, and the remaining state. *) + (*--------------------------------------------------------------------*) + fun parseGenRef dtd (caq as (_,_,q)) = + let + val (name,(c1,a1,q1)) = parseName caq + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expAnEntName,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError(c,a1,q) + end + val _ = if c1=0wx3B then () + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expSemi,[c1]))) + in raise SyntaxError(c1,a2,q1) + end + + val idx = GenEnt2Index dtd name + val (ent,ext) = getGenEnt dtd idx + + val _ = (* check whether entity is undeclared/unparsed/open *) + case ent + of GE_NULL => + if entitiesWellformed dtd + then let val err = ERR_UNDEC_ENTITY(ENT_GENERAL,name) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else if useParamEnts() + then let val err = ERR_UNDECLARED(IT_GEN_ENT,name,LOC_NONE) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else () + | GE_UNPARSED _ => let val err = ERR_ILLEGAL_ENTITY(ENT_UNPARSED,name,LOC_NONE) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + | _ => if isOpen(idx,false,q1) + then let val err = ERR_RECURSIVE_ENTITY(ENT_GENERAL,name) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else () + + val a2 = + if ext andalso !O_VALIDATE andalso standsAlone dtd andalso inDocEntity q1 + then let val _ = if !O_ERROR_MINIMIZE then setStandAlone dtd false else () + in hookError(a1,(getPos q,ERR_STANDALONE_ENT(ENT_GENERAL,name))) + end + else a1 + + in ((idx,ent),(a2,q1)) + end + fun parseGenRefLit dtd cs (caq as (_,_,q)) = + let + val (cs1,name,(c1,a1,q1)) = parseNameLit cs caq + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expAnEntName,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError(c,a1,q) + end + val _ = if c1=0wx3B then () + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expSemi,[c1]))) + in raise SyntaxError(c1,a2,q1) + end + + val idx = GenEnt2Index dtd name + val (ent,ext) = getGenEnt dtd idx + + val _ = (* check whether entity is undeclared/unparsed/open *) + case ent + of GE_NULL => + if entitiesWellformed dtd + then let val err = ERR_UNDEC_ENTITY(ENT_GENERAL,name) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else if useParamEnts() + then let val err = ERR_UNDECLARED(IT_GEN_ENT,name,LOC_NONE) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else () + | GE_UNPARSED _ => let val err = ERR_ILLEGAL_ENTITY(ENT_UNPARSED,name,LOC_NONE) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + | _ => if isOpen(idx,false,q1) + then let val err = ERR_RECURSIVE_ENTITY(ENT_GENERAL,name) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else () + + val a2 = + if ext andalso !O_VALIDATE andalso standsAlone dtd andalso inDocEntity q1 + then let val _ = if !O_ERROR_MINIMIZE then setStandAlone dtd false else () + in hookError(a1,(getPos q,ERR_STANDALONE_ENT(ENT_GENERAL,name))) + end + else a1 + + in (c1::cs1,((idx,ent),(a2,q1))) + end + + (*--------------------------------------------------------------------*) + (* parse a parameter entity reference, the "%" already read. See 4.1: *) + (* *) + (* [69] PEReference ::= '%' Name ';' [ VC: Entity Declared ] *) + (* [ WFC: No Recursion ] *) + (* [ WFC: In DTD ] *) + (* *) + (* Well-Formedness Constraint: Entity Declared *) + (* In a document without any DTD, a document with only an internal *) + (* DTD subset which contains no parameter entity references, or a *) + (* document with "standalone='yes'", the Name given in the entity *) + (* reference must match that in an entity declaration, ... *) + (* The declaration of a parameter entity must precede any reference *) + (* to it... *) + (* *) + (* Validity Constraint: Entity Declared *) + (* In a document with an external subset or external parameter *) + (* entities with "standalone='no'", the Name given in the entity *) + (* reference must match that in an entity declaration. ... *) + (* The declaration of a parameter entity must precede any reference *) + (* to it... *) + (* *) + (* Thus: in both cases it is an error if the entity is not declared. *) + (* The only difference is the impact on well-formednes/validity. *) + (* Because the thing to be parsed is a parameter entity reference, *) + (* this DTD has references, and thus an undeclared entity is probably *) + (* a validity and not a well-formedness error. Thus setExternal must *) + (* be called before determining a possible error! *) + (* *) + (* Well-Formedness Constraint: No Recursion *) + (* A parsed entity must not contain a recursive reference to *) + (* itself, either directly or indirectly. *) + (* *) + (* print an error and raise SyntaxError if no name is found, or if no *) + (* semicolon follows it. *) + (* print an error and return PE_NULL if the reference is to an *) + (* undeclared or open entity. *) + (* *) + (* return the entity referred to, and the remaining state. *) + (*--------------------------------------------------------------------*) + fun parseParRef dtd (caq as (_,_,q)) = + let + val (name,(c1,a1,q1)) = parseName caq + handle NotFound(c,a,q) => let val err = ERR_EXPECTED(expAnEntName,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError(c,a1,q) + end + + val _ = if c1=0wx3B then () + else let val err = ERR_EXPECTED(expSemi,[c1]) + val a2 = hookError(a1,(getPos q1,err)) + in raise SyntaxError(c1,a2,q1) + end + + val _ = setExternal dtd; + val idx = ParEnt2Index dtd name + val (ent,ext) = getParEnt dtd idx + + val _ = (* check whether entity is declared *) + case ent + of PE_NULL => + if entitiesWellformed dtd + then let val err = ERR_UNDEC_ENTITY(ENT_PARAMETER,name) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else if useParamEnts() + then let val err = ERR_UNDECLARED(IT_PAR_ENT,name,LOC_NONE) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else () + (* check whether the entity is already open *) + | _ => if isOpen(idx,true,q1) + then let val err = ERR_RECURSIVE_ENTITY(ENT_PARAMETER,name) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else () + in ((idx,ent),(a1,q1)) + end + fun parseParRefLit dtd cs (caq as (_,_,q)) = + let + val (cs1,name,(c1,a1,q1)) = parseNameLit cs caq + handle NotFound(c,a,q) => let val err = ERR_EXPECTED(expAnEntName,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError(c,a1,q) + end + + val _ = if c1=0wx3B then () + else let val err = ERR_EXPECTED(expSemi,[c1]) + val a2 = hookError(a1,(getPos q1,err)) + in raise SyntaxError(c1,a2,q1) + end + + val _ = setExternal dtd; + val idx = ParEnt2Index dtd name + val (ent,ext) = getParEnt dtd idx + + val _ = (* check whether entity is declared *) + case ent + of PE_NULL => + if entitiesWellformed dtd + then let val err = ERR_UNDEC_ENTITY(ENT_PARAMETER,name) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else if useParamEnts() + then let val err = ERR_UNDECLARED(IT_PAR_ENT,name,LOC_NONE) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else () + (* check whether the entity is already open *) + | _ => if isOpen(idx,true,q1) + then let val err = ERR_RECURSIVE_ENTITY(ENT_PARAMETER,name) + val a2 = hookError(a1,(getPos q,err)) + in raise NoSuchEntity (a2,q1) + end + else () + in (c1::cs1,((idx,ent),(a1,q1))) + end + + (*--------------------------------------------------------------------*) + (* skip a general/parameter entity reference, the "&/%" already read. *) + (* *) + (* print an error if no name is found, or if no semicolon follows it. *) + (* *) + (* handle any SyntaxState by returning its char and state. *) + (* *) + (* return the remaining state. *) + (*--------------------------------------------------------------------*) + fun skipReference caq = + let val (_,(c1,a1,q1)) = parseName caq + in if c1=0wx3B then getChar (a1,q1) + else let val err = ERR_EXPECTED(expSemi,[c1]) + val a2 = hookError(a1,(getPos q1,err)) + in (c1,a2,q1) + end + end + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expAnEntName,[c]) + val a1 = hookError(a,(getPos q,err)) + in (c,a1,q) + end + + (*--------------------------------------------------------------------*) + (* skip a character reference, the "&#" already read. See 4.1: *) + (* *) + (* print an error if no number or x plus hexnum is found, or if no *) + (* semicolon follows it. *) + (* *) + (* handle any SyntaxState by returning its char and state. *) + (* *) + (* return the remaining char and state. *) + (*--------------------------------------------------------------------*) + fun skipCharRef aq = + let + (*--------------------------------------------------------------*) + (* skip a (hexa)decimal number. *) + (*--------------------------------------------------------------*) + fun skip_ximal isX (c,a,q) = + if isX c then skip_ximal isX (getChar (a,q)) else (c,a,q) + + val (c1,a1,q1) = getChar aq + val (c2,a2,q2) = + if isDec c1 then skip_ximal isDec (getChar (a1,q1)) + else if c1=0wx78 (* #"x" *) + then let val (c2,a2,q2) = getChar (a1,q1) + in if isHex c2 then skip_ximal isHex (getChar (a2,q2)) + else let val err = ERR_EXPECTED(expHexDigit,[c2]) + val a3 = hookError(a2,(getPos q2,err)) + in raise SyntaxError(c2,a3,q2) + end + end + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expDigitX,[c1]))) + in raise SyntaxError (c1,a2,q1) + end + + in if c2=0wx3B then getChar (a2,q2) + else (c2,hookError(a2,(getPos q2,ERR_EXPECTED(expSemi,[c2]))),q2) + end + handle SyntaxError caq => caq + + (*--------------------------------------------------------------------*) + (* parse a sequence of white space in markup declarations. Cf. 2.3: *) + (* *) + (* [3] S ::= (#x20 | #x9 | #xD | #xA)+ *) + (* *) + (* and 2.8 states: *) + (* *) + (* The markup declarations may be made up in whole or in part of *) + (* the replacement text of parameter entities. The productions *) + (* later in this specification for individual nonterminals *) + (* (elementdecl, AttlistDecl, and so on) describe the declarations *) + (* after all the parameter entities have been included. *) + (* *) + (* in markup declarations, we thus have to include entity references *) + (* and skip entity ends, except for the document end. *) + (* *) + (* Well-Formedness Constraint: PEs in Internal Subset *) + (* In the internal DTD subset, parameter-entity references can *) + (* occur only where markup declarations can occur, not within *) + (* markup declarations. (This does not apply to references that *) + (* occur in external parameter entities or to the external subset.) *) + (* *) + (* we therefore always check whether we are in the internal subset *) + (* before including a parameter entity. *) + (*--------------------------------------------------------------------*) + (* handle a parameter entity reference *) + (*--------------------------------------------------------------------*) + fun doParRef dtd (caq as (c,a,q)) = + if inDocEntity q + then let val err = ERR_FORBIDDEN_HERE(IT_PAR_REF,LOC_INT_DECL) + val a1 = hookError(a,(getPos q,err)) + in skipReference (c,a1,q) + end + else let val ((id,ent),(a1,q1)) = parseParRef dtd caq + in case ent + of PE_NULL => getChar (a1,q1) + | PE_INTERN (_,rep) => getChar(a1,(pushIntern(q1,id,true,rep))) + | PE_EXTERN extId => #3(openExtern(id,true,resolveExtId extId) (a1,q1)) + handle CantOpenFile(fmsg,a) + => let val err = ERR_NO_SUCH_FILE fmsg + val a1 = hookError(a,(getPos q1,err)) + in (getChar(a1,q1)) + end + end + handle SyntaxError caq => caq + | NoSuchEntity aq => getChar aq + (*--------------------------------------------------------------------*) + (* parse optional white space. *) + (* *) + (* catch SyntaxState exceptions from parameter refs. *) + (* *) + (* print an error if a parameter entity reference or an entity end is *) + (* found inside the internal subset. *) + (* *) + (* return the following character and the remaining state. *) + (*--------------------------------------------------------------------*) + fun skipPSopt dtd caq = + let fun doit (c,a,q) = + case c + of 0wx00 => + if isSpecial q then (c,a,q) + else let val a1 = if !O_VALIDATE andalso inDocEntity q + then hookError(a,(getPos q,ERR_EE_INT_SUBSET)) + else a + in doit (getChar (a1,q)) + end + | 0wx09 => doit (getChar (a,q)) + | 0wx0A => doit (getChar (a,q)) + | 0wx20 => doit (getChar (a,q)) + | 0wx25 (* #"%" *) => doit (doParRef dtd (getChar (a,q))) + | _ => (c,a,q) + in doit caq + end + (*--------------------------------------------------------------------*) + (* parse optional white space. *) + (* *) + (* catch SyntaxState exceptions from parameter refs. *) + (* *) + (* print an error if a parameter entity reference or an entity end is *) + (* found inside the internal subset. *) + (* *) + (* return a boolean whether white space was actually found, and the *) + (* following character with the remaining state. *) + (*--------------------------------------------------------------------*) + fun skipPSmay dtd (c,a,q) = + case c + of 0wx00 => + if isSpecial q then (false,(c,a,q)) + else let val a1 = if !O_VALIDATE andalso inDocEntity q + then hookError(a,(getPos q,ERR_EE_INT_SUBSET)) + else a + in (true,skipPSopt dtd (getChar (a1,q))) + end + | 0wx09 => (true,skipPSopt dtd (getChar (a,q))) + | 0wx0A => (true,skipPSopt dtd (getChar (a,q))) + | 0wx20 => (true,skipPSopt dtd (getChar (a,q))) + | 0wx25 (* #"%" *) => (true,skipPSopt dtd (doParRef dtd (getChar (a,q)))) + | _ => (false,(c,a,q)) + (*--------------------------------------------------------------------*) + (* parse required white space. *) + (* *) + (* catch SyntaxState exceptions from parameter refs. *) + (* *) + (* print an error and return if no white space character is found. *) + (* print an error if a parameter entity reference or an entity end is *) + (* found inside the internal subset. *) + (* *) + (* return the following character and the remaining state. *) + (*--------------------------------------------------------------------*) + fun skipPS dtd (c,a,q) = + case c + of 0wx00 => + if isSpecial q then (c,hookError(a,(getPos q,ERR_MISSING_WHITE)),q) + else let val a1 = if !O_VALIDATE andalso inDocEntity q + then hookError(a,(getPos q,ERR_EE_INT_SUBSET)) + else a + in skipPSopt dtd (getChar (a1,q)) + end + | 0wx09 => skipPSopt dtd (getChar (a,q)) + | 0wx0A => skipPSopt dtd (getChar (a,q)) + | 0wx20 => skipPSopt dtd (getChar (a,q)) + | 0wx25 (* #"%" *) => skipPSopt dtd (doParRef dtd (getChar (a,q))) + | _ => (c,hookError(a,(getPos q,ERR_MISSING_WHITE)),q) + (*--------------------------------------------------------------------*) + (* parse required white space, taking care of a single '%' character. *) + (* this is only needed before the entity name in an entity decl. *) + (* *) + (* catch SyntaxState exceptions from parameter refs. *) + (* *) + (* print an error if no white space character is found. *) + (* print an error if a parameter entity reference or an entity end is *) + (* found inside the internal subset. *) + (* *) + (* return a boolean whether a '%' was found, the following character *) + (* and the remaining state. *) + (*--------------------------------------------------------------------*) + fun skipPSdec dtd caq = + let fun doit req (c,a,q) = + case c + of 0wx00 => + if isSpecial q then (false,(c,a,q)) + else let val a1 = if !O_VALIDATE andalso inDocEntity q + then hookError(a,(getPos q,ERR_EE_INT_SUBSET)) + else a + in doit false (getChar (a1,q)) + end + | 0wx09 => doit false (getChar (a,q)) + | 0wx0A => doit false (getChar (a,q)) + | 0wx20 => doit false (getChar (a,q)) + | 0wx25 => (* #"%" *) + let val (c1,a1,q1) = getChar (a,q) + in if isNms c1 then doit false (doParRef dtd (c1,a1,q1)) + else let val a2 = if req then hookError(a1,(getPos q,ERR_MISSING_WHITE)) + else a1 + in (true,(c1,a2,q1)) + end + end + | _ => let val a1 = if req then hookError(a,(getPos q,ERR_MISSING_WHITE)) + else a + in (false,(c,a1,q)) + end + in + doit true caq + end +end +(* stop of ../../Parser/Parse/parseRefs.sml *) +(* start of ../../Parser/Parse/parseLiterals.sml *) +signature ParseLiterals = + sig + (*---------------------------------------------------------------------- + include ParseBase + + val parseName : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseNmtoken : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val parseComment : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val parseProcInstr : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val skipS : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSopt : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSmay : UniChar.Char * AppData * State -> bool * (UniChar.Char * AppData * State) + val parseSopt : UniChar.Data -> UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseSmay : UniChar.Data -> UniChar.Char * AppData * State + -> bool * (UniChar.Data * (UniChar.Char * AppData * State)) + val parseEq : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val openExtern : int * Uri.Uri -> AppData * State + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + val openDocument : Uri.Uri option -> AppData + -> Encoding.Encoding * HookData.XmlDecl option * (UniChar.Char * AppData * State) + val openSubset : Uri.Uri -> AppData + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + + val skipCharRef : AppData * State -> (UniChar.Char * AppData * State) + val skipReference : UniChar.Char * AppData * State -> (UniChar.Char * AppData * State) + val parseGenRef : Dtd -> UniChar.Char * AppData * State + -> (int * Base.GenEntity) * (AppData * State) + val parseParRef : Dtd -> UniChar.Char * AppData * State + -> (int * Base.ParEntity) * (AppData * State) + val parseCharRefLit : UniChar.Data -> AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val skipPS : Dtd -> UniChar.Char * AppData * State + -> UniChar.Char * AppData * State + val skipPSopt : Dtd -> UniChar.Char * AppData * State + -> UniChar.Char * AppData * State + val skipPSmay : Dtd -> UniChar.Char * AppData * State + -> bool * (UniChar.Char * AppData * State) + val skipPSdec : Dtd -> UniChar.Char * AppData * State + -> bool * (UniChar.Char * AppData * State) + ----------------------------------------------------------------------*) + include ParseRefs + + val parseSystemLiteral : UniChar.Char * AppData * State + -> Uri.Uri * UniChar.Char * (UniChar.Char * AppData * State) + val parsePubidLiteral : UniChar.Char * AppData * State + -> string * UniChar.Char * (UniChar.Char * AppData * State) + + val parseAttValue : Dtd -> UniChar.Char * AppData * State + -> UniChar.Vector * UniChar.Data * (UniChar.Char * AppData * State) + val parseEntityValue : Dtd -> (UniChar.Vector * UniChar.Vector -> 'a) + -> UniChar.Char * AppData * State + -> 'a * (UniChar.Char * AppData * State) + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseLiterals *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* parseSystemLiteral : NotFound *) +(* parsePubidLiteral : NotFound *) +(* parseAttValue : NotFound *) +(* parseEntityValue : NotFound *) +(*--------------------------------------------------------------------------*) +functor ParseLiterals (structure ParseBase : ParseBase) + : ParseLiterals = +struct + structure ParseRefs = ParseRefs (structure ParseBase = ParseBase) + + open + Base UniChar Errors UniClasses Uri + ParseRefs + + val THIS_MODULE = "ParseLiterals" + + (*--------------------------------------------------------------------*) + (* parse a system literal, the quote character ("'" or '"') already --*) + (* read and passed as first argument. cf. 2.3: *) + (* *) + (* ... Note that a SystemLiteral can be parsed without scanning *) + (* for markup. *) + (* *) + (* [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") *) + (* *) + (* print an error and end the literal if an entity end is found. *) + (* *) + (* return the literal as a string together with the next character *) + (* and remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseSystemLiteral' quote aq = + let + fun doit text (c,a,q) = + if c=quote then (text,getChar (a,q)) + else if c=0wx0 + then let val a1 = hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_SYS_LIT)) + in (text,(c,a1,q)) + end + else if c>0wx7F andalso !O_WARN_NON_ASCII_URI + then let val a1 = hookWarning(a,(getPos q,WARN_NON_ASCII_URI c)) + in doit (c::text) (getChar(a1,q)) + end + else doit (c::text) (getChar(a,q)) + + val (text,caq1) = doit nil (getChar aq) + in + (Data2Uri(rev text),quote,caq1) + end + (*--------------------------------------------------------------------*) + (* parse a system literal. *) + (* *) + (* [11] SystemLiteral ::= ('"' [^"]* '"') | ("'" [^']* "'") *) + (* *) + (* raise NotFound if neither '"' nor "'" comes first. *) + (* *) + (* return the literal as a string together with the next character *) + (* and remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: NotFound *) + (*--------------------------------------------------------------------*) + fun parseSystemLiteral (c,a,q) = + if c=0wx22 (* "'" *) orelse + c=0wx27 (* '"' *) + then parseSystemLiteral' c (a,q) + else raise NotFound (c,a,q) + + (*--------------------------------------------------------------------*) + (* parse a pubid literal, the quote character ("'" or '"') already ---*) + (* read and passed as first argument. cf. 2.3: *) + (* *) + (* [12] PubidLiteral ::= '"' PubidChar* '"' *) + (* | "'" (PubidChar - "'")* "'" *) + (* *) + (* print an error and end the literal if an entity end is found. *) + (* print an error if a non-pubid character is found. *) + (* *) + (* return the literal as a string together with the next character *) + (* and remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parsePubidLiteral' quote aq = + let + fun doit (hadSpace,atStart,text) aq = + let val (c1,a1,q1) = getChar aq + in case c1 + of 0wx00 => let val a2 = hookError(a1,(getPos q1,ERR_ENDED_BY_EE LOC_PUB_LIT)) + in (text,(c1,a2,q1)) + end + | 0wx0A => doit (true,atStart,text) (a1,q1) + | 0wx20 => doit (true,atStart,text) (a1,q1) + | _ => + if c1=quote then (text,getChar (a1,q1)) + else if not (isPubid c1) + then let val err = ERR_FORBIDDEN_HERE(IT_CHAR c1,LOC_PUB_LIT) + val a2 = hookError(a1,(getPos q1,err)) + in doit (hadSpace,atStart,text) (a2,q1) + end + else if hadSpace andalso not atStart + then doit (false,false,c1::0wx20::text) (a1,q1) + else doit (false,false,c1::text) (a1,q1) + end + val (text,caq1) = doit (false,true,nil) aq + in + (Latin2String(rev text),quote,caq1) + end + (*--------------------------------------------------------------------*) + (* parse a pubid literal. *) + (* *) + (* [12] PubidLiteral ::= '"' PubidChar* '"' *) + (* | "'" (PubidChar - "'")* "'" *) + (* *) + (* raise NotFound if neither '"' nor "'" comes first. *) + (* *) + (* return the literal as a string together with the next character *) + (* and remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: NotFound *) + (*--------------------------------------------------------------------*) + fun parsePubidLiteral (c,a,q) = + if c=0wx22 (* "'" *) orelse + c=0wx27 (* '"' *) + then parsePubidLiteral' c (a,q) + else raise NotFound (c,a,q) + + (*--------------------------------------------------------------------*) + (* parse an entity value and the quote character ("'" or '"') passed *) + (* as first argument. Cf. 2.3: *) + (* *) + (* [9] EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"'*) + (* | "'" ([^%&'] | PEReference | Reference)* "'"*) + (* See also 4.4.5: *) + (* *) + (* When ... a parameter entity reference appears in a literal *) + (* entity value, its replacement text is processed in place of the *) + (* reference itself as though it were part of the document at the *) + (* location the reference was recognized, except that a single or *) + (* double quote character in the replacement text is always treated *) + (* as a normal data character and will not terminate the literal. *) + (* *) + (* and 4.4.7: *) + (* *) + (* When a general entity reference appears in the EntityValue in an *) + (* entity declaration, it is bypassed and left as is. *) + (* *) + (* A bypassed entity ref must, however, be checked for syntactic *) + (* validity, as opposed to SGML, where it is not even recognized. *) + (* *) + (* print an error and end the literal if an entity end is found at *) + (* the toplevel. *) + (* print an error if a general entity reference is ill-formed. *) + (* *) + (* handle any errors in references by ignoring them syntactically. *) + (* *) + (* return argument con applied to the entity value as a char buffer, *) + (* and the remaining char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseEntityValue' dtd (quote,con) aq = + let fun doit (level,hadCr,lit,text) (c1,a1,q1) = + case c1 + of 0wx00 => if level=0 then let val err = ERR_ENDED_BY_EE LOC_ENT_VALUE + val a2 = hookError(a1,(getPos q1,err)) + in (lit,text,(c1,a2,q1)) + end + else doit (level-1,false,lit,text) (getChar (a1,q1)) + | 0wx25 => (* #"%" *) + let val (level1,lit1,caq2) = + if inDocEntity q1 + then let val err = ERR_FORBIDDEN_HERE(IT_PAR_REF,LOC_INT_DECL) + val a2 = hookError(a1,(getPos q1,err)) + in (level,lit,skipReference (getChar(a2,q1))) + end + else + let val (lit1,((id,ent),(a2,q2))) = + if level=0 then parseParRefLit dtd (c1::lit) (getChar(a1,q1)) + else (lit,parseParRef dtd (getChar(a1,q1))) + in case ent + of PE_NULL => (level,lit1,getChar(a2,q2)) + | PE_INTERN(_,rep) => + let val q3 = pushIntern(q2,id,true,rep) + in (level+1,lit1,getChar(a2,q3)) + end + | PE_EXTERN extId => + let + val fname = resolveExtId extId + val caq3 = #3(openExtern (id,true,fname) (a2,q2)) + in (level+1,lit1,caq3) + end handle CantOpenFile(fmsg,a) + => let val err = ERR_NO_SUCH_FILE fmsg + val a1 = hookError(a,(getPos q1,err)) + in (level,lit1,getChar(a1,q1)) + end + end (* ignore syntax errors in references *) + handle SyntaxError caq => (level,lit,caq) + | NoSuchEntity aq => (level,lit,getChar aq) + in doit (level1,false,lit1,text) caq2 + end + | 0wx26 => (* #"&" *) + let val (c2,a2,q2) = getChar (a1,q1) + in (if c2=0wx23 (* #"#" *) + (*--------------------------------------------------*) + (* it's a character reference. *) + (*--------------------------------------------------*) + then (if level=0 + then + let val (lit3,(ch,a3,q3)) = + parseCharRefLit (c2::c1::lit) (a2,q2) + in doit (level,false,lit3,ch::text) (getChar(a3,q3)) + end + else let val (ch,a3,q3) = parseCharRef (a2,q2) + in doit (level,false,lit,ch::text) (getChar(a3,q3)) + end) + (* ignore errors in char references *) + handle SyntaxError caq => doit (level,false,lit,text) caq + | NoSuchChar aq => doit (level,false,lit,text) (getChar aq) + (*-----------------------------------------------------*) + (* it's a general entity reference. *) + (*-----------------------------------------------------*) + else let + val (fnd,lit3,text3,(c3,a3,q3)) = + parseEntName (c1::lit,c1::text) (c2,a2,q2) + val (lit4,text4,caq4) = + if not fnd then (lit,text,(c3,a3,q3)) + else if c3=0wx3B (* #";" *) + then (c3::lit3,c3::text3,(getChar(a3,q3))) + else let val err = ERR_EXPECTED(expSemi,[c3]) + val a4 = hookError(a3,(getPos q3,err)) + in (lit,text,(c3,a4,q3)) + end + in doit (level,false,lit4,text4) caq4 + end + ) + end + | 0wx0A => doit (level,false,if level=0 then c1::lit else lit, + if hadCr then text else c1::text) (getChar (a1,q1)) + | 0wx0D => doit (level,true,if level=0 then c1::lit else lit,0wx0A::text) + (getChar (a1,q1)) + | _ => if c1=quote andalso level=0 then (lit,text,getChar(a1,q1)) + else doit (level,false,if level=0 then c1::lit else lit,c1::text) + (getChar (a1,q1)) + + val (lit,text,caq1) = doit (0,false,nil,nil) (getChar aq) + val literal = Data2Vector(quote::rev(quote::lit)) + val repText = Data2Vector(rev text) + in + (con(literal,repText),caq1) + end + (*--------------------------------------------------------------------*) + (* parse an entity value. *) + (* *) + (* [9] EntityValue ::= '"' ([^%&"] | PEReference | Reference)* '"'*) + (* | "'" ([^%&'] | PEReference | Reference)* "'"*) + (* *) + (* raise NotFound if neither '"' nor "'" comes first. *) + (* *) + (* return the entity value as a char buffer, and the remaining char *) + (* and state. *) + (*--------------------------------------------------------------------*) + (* might raise: NotFound *) + (*--------------------------------------------------------------------*) + fun parseEntityValue dtd con (c,a,q) = + if c=0wx22 (* "'" *) orelse + c=0wx27 (* '"' *) + then parseEntityValue' dtd (c,con) (a,q) + else raise NotFound (c,a,q) + + (*--------------------------------------------------------------------*) + (* parse and normalize an attribute value, consume the final quote *) + (* character ("'" or '""') passed in the argument. Cf. 2.3: *) + (* *) + (* [10] AttValue ::= '"' ([^<&""] | Reference)* '"' *) + (* | "'" ([^<&'] | Reference)* "'" *) + (* See also 4.4.5: *) + (* *) + (* When an entity reference appears in an attribute value ..., *) + (* its replacement text is processed in place of the reference *) + (* itself as though it were part of the document at the location *) + (* the reference was recognized, except that a single or double *) + (* quote character in the replacement text is always treated as a *) + (* normal data character and will not terminate the literal. *) + (* *) + (* and 3.3.3: *) + (* *) + (* Before the value of an attribute is passed to the application *) + (* or checked for validity, the XML processor must normalize it as *) + (* follows: *) + (* *) + (* * a character reference is processed by appending the referenced *) + (* character to the attribute value *) + (* * an entity reference is processed by recursively processing the *) + (* replacement text of the entity *) + (* * a whitespace character (#x20, #xD, #xA, #x9) is processed by *) + (* appending #x20 to the normalized value, except that only a *) + (* single #x20 is appended for a "#xD#xA" sequence that is part *) + (* of an external parsed entity or the literal entity value of *) + (* an internal parsed entity *) + (* * other characters are processed by appending them to the *) + (* normalized value *) + (* *) + (* since #xD#xA are normalized by the parseEntityValue (internal) and *) + (* getChar (external entities), we don't need to care about that. *) + (*--------------------------------------------------------------------*) + (* print an error and end the literal if an entity end is found. *) + (* print an error if a general entity reference is ill-formed. *) + (* print an error if a reference to an external or unparsed entity is *) + (* found. *) + (* print an error if character '<' appears literally. *) + (* *) + (* handle any errors in references by ignoring them syntactically. *) + (* raise NotFound if neither '"' nor "'" comes first. *) + (* *) + (* return the list of chars in the value, and the next char and state *) + (*--------------------------------------------------------------------*) + (* might raise: NotFound *) + (*--------------------------------------------------------------------*) + fun parseAttValue dtd (quote,a,q) = + let fun doit (lhlt as (level,lit,text)) (c1,a1,q1) = + case c1 + of 0wx00 => if level=0 then let val err = ERR_ENDED_BY_EE LOC_ATT_VALUE + val a2 = hookError(a1,(getPos q1,err)) + in (lit,text,(c1,a2,q1)) + end + else doit (level-1,lit,text) (getChar (a1,q1)) + | 0wx26 => (* #"&" *) + let + val (c2,a2,q2) = getChar (a1,q1) + val ((level1,lit1,text1),caq3) = + (if c2=0wx23 (* #"#" *) + (*--------------------------------------------------*) + (* it's a character reference. *) + (*--------------------------------------------------*) + then if level=0 + then + let val (lit3,(ch,a3,q3)) = + parseCharRefLit (c2::c1::lit) (a2,q2) + in ((level,lit3,ch::text),getChar(a3,q3)) + end + else let val (ch,a3,q3) = parseCharRef (a2,q2) + in ((level,lit,ch::text),getChar (a3,q3)) + end + (*-----------------------------------------------------*) + (* it's a general entity reference. *) + (*-----------------------------------------------------*) + else + let val (lit3,((id,ent),(a3,q3))) = + if level=0 then parseGenRefLit dtd (c1::lit) (c2,a2,q2) + else (nil,parseGenRef dtd (c2,a2,q2)) + in case ent + of GE_NULL => ((level,lit3,text),getChar(a3,q3)) + | GE_INTERN(_,rep) => + let val q4 = pushIntern(q3,id,false,rep) + in ((level+1,lit3,text),getChar (a3,q4)) + end + | GE_EXTERN _ => + let val err = ERR_ILLEGAL_ENTITY + (ENT_EXTERNAL,Index2GenEnt dtd id,LOC_ATT_VALUE) + val a4 = hookError(a3,(getPos q2,err)) + in ((level,lit,text),getChar (a4,q3)) + end + | GE_UNPARSED _ => raise InternalError + (THIS_MODULE,"parseAttValue'", + "parseGenRef returned GE_UNPARSED") + end) + (*------------------------------------------------------*) + (* handle any errors in references by ignoring them. *) + (*------------------------------------------------------*) + handle SyntaxError caq => ((level,lit,text),caq) + | NoSuchEntity aq => ((level,lit,text),getChar aq) + | NoSuchChar aq => ((level,lit,text),getChar aq) + in doit (level1,lit1,text1) caq3 + end + | 0wx3C => let val err = ERR_FORBIDDEN_HERE(IT_CHAR c1,LOC_ATT_VALUE) + val a2 = hookError(a1,(getPos q1,err)) + val lit1 = if level=0 then c1::lit else lit + in doit (level,lit1,c1::text) (getChar (a2,q1)) + end + | _ => if isS c1 then doit (level,if level=0 then c1::lit else lit,0wx20::text) + (getChar (a1,q1)) + else (if c1=quote andalso level=0 then (lit,text,getChar (a1,q1)) + else doit (level,if level=0 then c1::lit else lit,c1::text) + (getChar (a1,q1))) + + + val _ = if quote=0wx22 orelse quote=0wx27 (* "'",'"' *) then () + else raise NotFound (quote,a,q) + val (lit,text,caq1) = doit (0,nil,nil) (getChar(a,q)) + in + (Data2Vector(quote::rev(quote::lit)),rev text,caq1) + end + end +(* stop of ../../Parser/Parse/parseLiterals.sml *) +(* start of ../../Parser/Parse/parseTags.sml *) +signature ParseTags = + sig + (*---------------------------------------------------------------------- + include ParseBase + + val parseName : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val parseNmtoken : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val parseComment : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val parseProcInstr : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val skipS : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSopt : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSmay : UniChar.Char * AppData * State -> bool * (UniChar.Char * AppData * State) + + val openExtern : int * Uri.Uri -> AppData * State + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + val openDocument : Uri.Uri option -> AppData + -> Encoding.Encoding * HookData.XmlDecl option * (UniChar.Char * AppData * State) + val openSubset : Uri.Uri -> AppData + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + + val skipCharRef : AppData * State -> (UniChar.Char * AppData * State) + val skipReference : UniChar.Char * AppData * State -> (UniChar.Char * AppData * State) + val parseGenRef : Dtd -> UniChar.Char * AppData * State + -> (int * Base.GenEntity) * (AppData * State) + val parseParRef : Dtd -> UniChar.Char * AppData * State + -> (int * Base.ParEntity) * (AppData * State) + val parseCharRefLit : UniChar.Data -> AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val skipPS : Dtd -> UniChar.Char * AppData * State + -> UniChar.Char * AppData * State + val skipPSopt : Dtd -> UniChar.Char * AppData * State + -> UniChar.Char * AppData * State + val skipPSmay : Dtd -> UniChar.Char * AppData * State + -> bool * (UniChar.Char * AppData * State) + val skipPSdec : Dtd -> UniChar.Char * AppData * State + -> bool * (UniChar.Char * AppData * State) + + val parseSystemLiteral : UniChar.Char * AppData * State + -> Uri.Uri * UniChar.Char * (UniChar.Char * AppData * State) + val parsePubidLiteral : UniChar.Char * AppData * State + -> string * UniChar.Char * (UniChar.Char * AppData * State) + val parseAttValue : Dtd -> UniChar.Char * AppData * State + -> UniChar.Vector * UniChar.Data * (UniChar.Char * AppData * State) + val parseEntityValue : Dtd -> (UniChar.Vector * UniChar.Vector -> 'a) + -> UniChar.Char * AppData * State + -> 'a * (UniChar.Char * AppData * State) + ----------------------------------------------------------------------*) + include ParseLiterals + + val skipTag : Errors.Location -> AppData * State -> (UniChar.Char * AppData * State) + + val parseETag : Dtd -> AppData * State + -> int * UniChar.Data * Errors.Position * (UniChar.Char * AppData * State) + val parseSTag : Dtd -> Errors.Position -> UniChar.Char * AppData * State + -> (HookData.StartTagInfo * Base.ElemInfo) * (UniChar.Char * AppData * State) + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseTags *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* skipTag : none *) +(* parseETag : SyntaxState *) +(* parseSTag : SyntaxState *) +(*--------------------------------------------------------------------------*) +functor ParseTags (structure ParseBase : ParseBase) + : ParseTags = +struct + structure ParseLiterals = ParseLiterals (structure ParseBase = ParseBase) + + open + UtilList + Base Errors UniClasses + ParseLiterals + + (*--------------------------------------------------------------------*) + (* parse an end-tag, the "' *) + (* *) + (* and 3. states: *) + (* *) + (* Validity Constraint: Element Valid *) + (* An element is valid if there is a declaration matching elementdecl *) + (* where the Name matches the element type, and ... *) + (* *) + (* print an error, recover and raise SyntaxState if no name is found. *) + (* print an error and recover if no ">" is found. *) + (* print an error if the element is not declared. *) + (* *) + (* return the index of the element, and the next char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseETag dtd aq = + let + val caq0 as (_,_,q0) = getChar aq + val (elem,(c1,a1,q1)) = parseName caq0 + handle NotFound (c,a,q) => let val err = expectedOrEnded (expAName,LOC_ETAG) c + val a1 = hookError(a,(getPos q,err)) + val caq1 = recoverETag (c,a1,q) + in raise SyntaxError caq1 + end + val idx = Element2Index dtd elem + val elemInfo as {decl,...} = getElement dtd idx + val a1' = if isSome decl then a1 + else let val a2 = if not (!O_VALIDATE andalso hasDtd dtd) then a1 + else let val err = ERR_UNDECLARED(IT_ELEM,elem,LOC_ETAG) + val a1' = hookError(a1,(getPos q0,err)) + val _ = if not (!O_ERROR_MINIMIZE) then () + else ignore (handleUndeclElement dtd idx) + in a1' + end + in checkElemName (a2,q0) elem + end + + val (cs,(c2,a2,q2)) = parseSopt nil (c1,a1',q1) + val space = rev cs + in + if c2=0wx3E (* #">" *) then (idx,space,getPos q2,getChar(a2,q2)) + else let val err = expectedOrEnded (expGt,LOC_ETAG) c2 + val a3 = hookError(a2,(getPos q2,err)) + val caq3 = recoverETag(c2,a3,q2) + in (idx,space,getPos q2,caq3) + end + end + + (*--------------------------------------------------------------------*) + (* parse a start-tag or an empty-element-tag, the "<" already read. *) + (* 3.1: *) + (* *) + (* [40] STag ::= '<' Name (S Attribute)* S? '>' *) + (* [ WFC: Unique Att Spec ] *) + (* [41] Attribute ::= Name Eq AttValue [ VC: Attribute Value Type ] *) + (* *) + (* Well-Formedness Constraint: Unique Att Spec *) + (* No attribute name may appear more than once in the same *) + (* start-tag or empty-element tag. *) + (* *) + (* Validity Constraint: Attribute Value Type *) + (* The attribute must have been declared; the value must be of the *) + (* type declared for it. *) + (* *) + (* [44] EmptyElemTag ::= '<' Name (S Attribute)* S? '/>' *) + (* [ WFC: Unique Att Spec ] *) + (* *) + (* and 3. states: *) + (* *) + (* Validity Constraint: Element Valid *) + (* An element is valid if there is a declaration matching elementdecl *) + (* where the Name matches the element type, and ... *) + (* *) + (* catch entity end exceptions in subfunctions by printing an error *) + (* and re-raising the exception. *) + (* *) + (* print an error, recover and raise SyntaxState if no element name *) + (* is found. *) + (* print an error and recover if no ">" or "/>" is found. *) + (* print an error and continue if no "=" is found after an att name. *) + (* print an error and recover if no literal is found after the "=". *) + (* print an error if white space is missing. *) + (* print an error if the element is not declared. *) + (* print an error and ignore the attribute if an attribute is *) + (* specified twice. *) + (* print an error if an attribute is not declared. *) + (* *) + (* return the index of the element, its ElemInfo, the list of *) + (* AttSpecs (specified and omitted atts) and a boolean whether it was *) + (* an empty-element-tag, together with the next char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseSTag dtd startPos (caq as (_,_,q)) = + let + val (elem,(c1,a1,q1)) = parseName caq + handle NotFound (c,a,q) => let val err = expectedOrEnded (expAName,LOC_STAG) c + val a1 = hookError(a,(getPos q,err)) + val (_,caq1) = recoverSTag (c,a1,q) + in raise SyntaxError (c,a1,q) + end + val eidx = Element2Index dtd elem + val elemInfo as {atts,decl,...} = getElement dtd eidx + val defs = case atts + of NONE => nil + | SOME (defs,_) => defs + val (a1',elemInfo) = + if isSome decl then (a1,elemInfo) + else + let val (a2,newInfo) = + if not (!O_VALIDATE andalso hasDtd dtd) then (a1,elemInfo) + else let val err = ERR_UNDECLARED(IT_ELEM,elem,LOC_STAG) + val a1' = hookError(a1,(getPos q,err)) + val newInfo = if not (!O_ERROR_MINIMIZE) then elemInfo + else handleUndeclElement dtd eidx + in (a1',newInfo) + end + in (checkElemName (a2,q) elem,newInfo) + end + + val hscaq2 = parseSmay nil (c1,a1',q1) + + (*--------------------------------------------------------------*) + (* yet are the indices of attributes encountered yet, old are *) + (* the valid attributes specified yet, and todo are the defs of *) + (* attributes yet to be specified. hadS indicates whether white *) + (* space preceded. *) + (*--------------------------------------------------------------*) + fun doit (yet,old,todo) (hadS,(sp,(c,a,q))) = + case c + of 0wx3E (* #">" *) => (old,todo,sp,false,q,getChar(a,q)) + | 0wx2F (* #"/" *) => + let val (c1,a1,q1) = getChar(a,q) + in if c1=0wx3E (* #">" *) then (old,todo,sp,true,q1,getChar(a1,q1)) + else let val err = expectedOrEnded (expGt,LOC_STAG) c1 + val a2 = hookError(a1,(getPos q1,err)) + val (mt,caq2) = recoverSTag (c1,a2,q1) + in (old,todo,sp,mt,q,caq2) + end + end + | _ => + if not (isNms c) + then let val err = expectedOrEnded (expAttSTagEnd,LOC_STAG) c + val a1 = hookError(a,(getPos q,err)) + val (mt,caq1) = recoverSTag (c,a1,q) + in (old,todo,sp,mt,q,caq1) + end + else + let(* first parse the name of the attribute *) + val (att,(c1,a1,q1)) = parseName (c,a,q) + val a2 = if hadS then a1 + else hookError(a1,(getPos q,ERR_MISSING_WHITE)) + + (* now get its index, check whether it already *) + (* occurred and get its definition. *) + val aidx = AttNot2Index dtd att + val (hadIt,a3) = + if member aidx yet + then (true,hookError(a2,(getPos q,ERR_MULT_ATT_SPEC att))) + else (false,a2) + + val (def,rest) = findAndDelete (fn (i,_,_,_) => i=aidx) todo + val a4 = if isSome def orelse hadIt then a3 + else handleUndeclAtt dtd (a3,q) (aidx,att,eidx,elem) + + (* consume the " = ", ignore errors *) + val (eq,caq5 as (_,_,q5)) = parseEq (c1,a4,q1) + handle SyntaxError caq => ([0wx3D],caq) + + (* now parse the attribute value *) + val (literal,value,(c6,a6,q6)) = parseAttValue dtd caq5 + + (* possibly make a new AttSpec *) + val space = rev sp + val (new,a7) = + if hadIt then (old,a6) + else case def + of NONE => + if !O_VALIDATE andalso hasDtd dtd then (old,a6) + else (let val (attVal,a7) = checkAttValue dtd (a6,q5) + (defaultAttDef aidx,literal,value) + in ((aidx,attVal,SOME(space,eq))::old,a7) + end + handle AttValue a => (old,a)) + | SOME ad => + let val (attVal,a7) = checkAttValue dtd (a6,q5) + (ad,literal,value) + in ((aidx,attVal,SOME(space,eq))::old,a7) + end + handle AttValue a => (old,a) + val hscaq8 = parseSmay nil (c6,a7,q6) + in + doit (aidx::yet,new,rest) hscaq8 + end + handle NotFound (c,a,q) (* raised by parseAttValue above *) + => let val err = expectedOrEnded (expLitQuote,LOC_STAG) c + val a1 = hookError(a,(getPos q,err)) + val (mt,caq1) = recoverSTag (c,a1,q) + in (old,todo,sp,mt,q,caq1) + end + + val (specd,todo,sp,empty,qe,(c3,a3,q3)) = doit (nil,nil,defs) hscaq2 + val space = rev sp + + (* generate the defaults for unspecified attributes *) + val (all,a4) = genMissingAtts dtd (a3,qe) (todo,rev specd) + in + ((((startPos,getPos q3),eidx,all,space,empty),elemInfo),(c3,a4,q3)) + end + + (*--------------------------------------------------------------------*) + (* skip a tag, the initial "<" or "" and *) + (* "/>" if within a literal. *) + (* *) + (* print an error and finish if an entity end is found. *) + (* *) + (* return the remaining char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun skipTag loc aq = + let + fun do_lit ch (c,a,q) = + if c=0wx00 then let val a1 = hookError(a,(getPos q,ERR_ENDED_BY_EE loc)) + in (c,a1,q) + end + else if c=ch then doit (getChar(a,q)) + else do_lit ch (getChar(a,q)) + + and doit (c,a,q) = + case c + of 0wx00 => let val a1 = hookError(a,(getPos q,ERR_ENDED_BY_EE loc)) + in (c,a1,q) + end + | 0wx22 (* #"\""*) => do_lit c (getChar(a,q)) + | 0wx27 (* #"'" *) => do_lit c (getChar(a,q)) + | 0wx2F (* #"/" *) => (case getChar(a,q) + of (0wx3E,a1,q1) (* #">" *) => getChar(a1,q1) + | caq1 => doit caq1) + | 0wx3E (* #">" *) => getChar(a,q) + | _ => doit(getChar(a,q)) + in doit (getChar aq) + end +end + +(* stop of ../../Parser/Parse/parseTags.sml *) +(* start of ../../Parser/Parse/parseDecl.sml *) +signature ParseDecl = + sig + (*---------------------------------------------------------------------- + include ParseBase + + val parseName : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val parseComment : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val parseProcInstr : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val skipS : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSopt : UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val skipSmay : UniChar.Char * AppData * State -> bool * (UniChar.Char * AppData * State) + + val openExtern : int * Uri.Uri -> AppData * State + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + val openDocument : Uri.Uri option -> AppData + -> Encoding.Encoding * HookData.XmlDecl option * (UniChar.Char * AppData * State) + val openSubset : Uri.Uri -> AppData + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + + val skipCharRef : AppData * State -> (UniChar.Char * AppData * State) + val skipReference : UniChar.Char * AppData * State -> (UniChar.Char * AppData * State) + val parseGenRef : Dtd -> UniChar.Char * AppData * State + -> (int * Base.GenEntity) * (AppData * State) + val parseParRef : Dtd -> UniChar.Char * AppData * State + -> (int * Base.ParEntity) * (AppData * State) + val parseCharRefLit : UniChar.Data -> AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + val skipPSopt : Dtd -> UniChar.Char * AppData * State + -> UniChar.Char * AppData * State + + val skipTag : Errors.Location -> AppData * State -> (UniChar.Char * AppData * State) + val parseETag : Dtd -> AppData * State + -> int * UniChar.Data * Errors.Position * (UniChar.Char * AppData * State) + val parseSTag : Dtd -> Errors.Position -> UniChar.Char * AppData * State + -> (HookData.StartTagInfo * Base.ElemInfo) * (UniChar.Char * AppData * State) + ----------------------------------------------------------------------*) + include ParseTags + + val skipDecl : bool -> UniChar.Char * AppData * State -> UniChar.Char * AppData * State + + val parseExtIdSub : Dtd -> UniChar.Char * AppData * State + -> Base.ExternalId * bool * (UniChar.Char * AppData * State) + + val parseEntityDecl : Dtd -> EntId * Errors.Position * bool + -> UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val parseElementDecl : Dtd -> EntId * Errors.Position * bool + -> UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val parseNotationDecl : Dtd -> EntId * Errors.Position * bool + -> UniChar.Char * AppData * State -> UniChar.Char * AppData * State + val parseAttListDecl : Dtd -> EntId * Errors.Position * bool + -> UniChar.Char * AppData * State -> UniChar.Char * AppData * State + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseDecl *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* skipDecl : none *) +(* parseExtIdSub : NotFound SyntaxError *) +(* parseEntityDecl : none *) +(* parseElementDecl : none *) +(* parseNotationDecl : none *) +(* parseAttListDecl : none *) +(*--------------------------------------------------------------------------*) +functor ParseDecl (structure ParseBase : ParseBase) + : ParseDecl = +struct + structure ParseTags = ParseTags (structure ParseBase = ParseBase) + + open + UtilInt UtilList + Base Errors HookData + ParseTags + + (*--------------------------------------------------------------------*) + (* skip a markup declaration, the initial "" if within a literal. yake care of internal subset if *) + (* the first arg is true. *) + (* *) + (* print an error and finish if an entity end is found. *) + (* *) + (* return the remaining char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun skipDecl hasSubset caq = + let + fun do_lit ch (c,a,q) = + if c=0wx00 then (c,a,q) + else if c=ch then getChar (a,q) + else do_lit ch (getChar(a,q)) + fun do_decl (c,a,q) = + case c + of 0wx00 => (c,a,q) + | 0wx22 (* #"\""" *) => do_decl (do_lit c (getChar(a,q))) + | 0wx27 (* #"'" *) => do_decl (do_lit c (getChar(a,q))) + | 0wx3E (* #">" *) => getChar(a,q) + | _ => do_decl (getChar(a,q)) + fun do_subset (c,a,q) = + case c + of 0wx00 => (c,a,q) + | 0wx3C (* #"<" *) => do_subset (do_decl (getChar(a,q))) + | 0wx5D (* #"]" *) => getChar(a,q) + | _ => do_subset (getChar(a,q)) + fun doit (c,a,q) = + case c + of 0wx00 => (c,hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_DECL)),q) + | 0wx22 (* #"\"""*) => doit (do_lit c (getChar(a,q))) + | 0wx27 (* #"'" *) => doit (do_lit c (getChar(a,q))) + | 0wx3E (* #">" *) => getChar(a,q) + | 0wx5B (* #"[" *) => if hasSubset then doit (do_subset (getChar(a,q))) + else doit (getChar(a,q)) + | _ => doit (getChar(a,q)) + in doit caq + end + + (*--------------------------------------------------------------------*) + (* parse an external id, or a public id if the first arg is true. *) + (* Cf. 4.2.2 and 4.7: *) + (* *) + (* [75] ExternalID ::= 'SYSTEM' S SystemLiteral *) + (* | 'PUBLIC' S PubidLiteral S SystemLiteral *) + (* *) + (* [83] PublicID ::= 'PUBLIC' S PubidLiteral *) + (* *) + (* raise NotFound if no name is found first. *) + (* print an error if white space is missing. *) + (* print an error and raise SyntaxState if a wrong name is found. *) + (* print an Error and raise SyntaxState if a required literal is not *) + (* found (depends on optSys). *) + (* *) + (* return the public and system identifiers as string options, *) + (* a boolean, whether whit space followed the external id, *) + (* and the next character and the remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: NotFound SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseExternalId dtd optSys (caq as (_,_,q))= + let + (* do not handle NotFound: in this case no extId was found *) + val (name,caq1) = parseName caq + val caq2 as (_,_,q2)= skipPS dtd caq1 + in + case name + of [0wx50,0wx55,0wx42,0wx4c,0wx49,0wx43] => (* "PUBLIC" *) + let + val (pub,pquote,caq3) = parsePubidLiteral caq2 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expLitQuote,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError (c,a1,q) + end + val (hadS,caq4 as (_,_,q4)) = skipPSmay dtd caq3 + in let + val (sys,squote,(c5,a5,q5)) = parseSystemLiteral caq4 + val base = getUri q4 + val a6 = if hadS then a5 else hookError(a5,(getPos q4,ERR_MISSING_WHITE)) + val (hadS6,caq6) = skipPSmay dtd (c5,a6,q5) + in + (EXTID(SOME(pub,pquote),SOME(base,sys,squote)),hadS6,caq6) + end + handle NotFound (c,a,q) => (* no system id *) + if optSys then (EXTID(SOME(pub,pquote),NONE),hadS,(c,a,q)) + else let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expLitQuote,[c]))) + in raise SyntaxError (c,a1,q) + end + end + + | [0wx53,0wx59,0wx53,0wx54,0wx45,0wx4d] => (* "SYSTEM" *) + let + val (sys,squote,caq3) = parseSystemLiteral caq2 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expLitQuote,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError (c,a1,q) + end + val base = getUri q2 + val (hadS,caq4) = skipPSmay dtd caq3 + in + (EXTID(NONE,SOME(base,sys,squote)),hadS,caq4) + end + + | _ => let val (c2,a2,q2) = caq2 + val a3 = hookError(a2,(getPos q,ERR_EXPECTED(expExtId,name))) + in raise SyntaxError (c2,a3,q2) + end + end + (*--------------------------------------------------------------------*) + (* parse an external id in an entity definition. Cf. 4.2.2: *) + (* *) + (* print an Error and raise SyntaxState if no external id is found. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseExtIdEnt dtd caq = parseExternalId dtd false caq + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expLitQuotExt,[c]) + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + (*--------------------------------------------------------------------*) + (* parse an external or public id in a notation declaration. *) + (* *) + (* print an Error and raise SyntaxState if neither external nor *) + (* public id is found. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseExtIdNot dtd caq = parseExternalId dtd true caq + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expExtId,[c]) + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + (*--------------------------------------------------------------------*) + (* parse an external id for the external subset. *) + (* *) + (* raise NotFound if no external id is found. *) + (*--------------------------------------------------------------------*) + (* might raise: NotFound SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseExtIdSub dtd caq = parseExternalId dtd false caq + + (*--------------------------------------------------------------------*) + (* parse a parameter entity declaration, starting after the '%'. The *) + (* unique entity id of the initial '<' is given as first arg. 4.2: *) + (* *) + (* [72] PEDecl ::= '' *) + (* [74] PEDef ::= EntityValue | ExternalID *) + (* *) + (* (see also the comments for ParseDtd.parseMarkupDecl). *) + (* *) + (* print an error if white space is missing. *) + (* print an error and raise SyntaxState if neither entity value nor *) + (* external identifier is found. *) + (* print an error and raise SyntaxState if the closing '>' is missing.*) + (* print an error if the '>' is not in the same entity as the ' let val err = ERR_EXPECTED(expAnEntName,[c]) + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + val idx = ParEnt2Index dtd name + val caq3 = skipPS dtd caq2 + + val (ent,(c4,a4,q4)) = + let val (ent,caq4) = parseEntityValue dtd PE_INTERN caq3 + val caq5 = skipPSopt dtd caq4 + in (ent,caq5) + end + handle NotFound caq => + let val (extId,_,caq1) = parseExtIdEnt dtd caq + in (PE_EXTERN extId,caq1) + end + + val a5 = if useParamEnts() orelse not ext then addParEnt dtd (a4,q1) (idx,ent,ext) else a4 + val a6 = hookDecl(a5,((startPos,getPos q4),DEC_PAR_ENT(idx,ent,ext))) + in + if c4<>0wx3E (* #">" *) + then let val a7 = hookError(a6,(getPos q4,ERR_EXPECTED(expGt,[c4]))) + in raise SyntaxError(c4,a7,q4) + end + else let val a7 = if not (!O_VALIDATE) orelse getEntId q4=startEnt then a6 + else hookError(a6,(getPos q4,ERR_DECL_ENT_NESTING LOC_ENT_DECL)) + in getChar(a7,q4) + end + end + + (*--------------------------------------------------------------------*) + (* parse a general entity declaration, starting with the name. The *) + (* unique entity id of the initial '<' is given as first arg. 4.2: *) + (* *) + (* [71] GEDecl ::= '' *) + (* [73] EntityDef ::= EntityValue | (ExternalID NDataDecl?) *) + (* *) + (* [76] NDataDecl ::= S 'NDATA' S Name [ VC: Notation *) + (* Declared ] *) + (* *) + (* If the NDataDecl is present, this is a general unparsed entity; *) + (* otherwise it is a parsed entity. *) + (* *) + (* Validity Constraint: Notation Declared *) + (* The Name must match the declared name of a notation. *) + (* *) + (* (see also the comments for ParseDtd.parseMarkupDecl). *) + (* *) + (* print an error if white space is missing. *) + (* print an error and raise SyntaxState if neither entity value nor *) + (* external identifier is found. *) + (* print an error if name other then 'NDATA' is found after ext. id. *) + (* print an error and raise SyntaxState if no name is found after the *) + (* 'NDATA'. *) + (* print an error if the notation is not declared. *) + (* print an error and raise SyntaxState if the closing '>' is missing.*) + (* print an error if the '>' is not in the same entity as the ' let val err = ERR_EXPECTED(expEntNamePero,[c]) + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + val idx = GenEnt2Index dtd name + val caq2 = skipPS dtd caq1 + + val (ent,expEnd,(c3,a3,q3)) = + (*-----------------------------------------------------------*) + (* Try for an internal entity. Then '>' must follow. *) + (*-----------------------------------------------------------*) + let + val (ent,caq3) = parseEntityValue dtd GE_INTERN caq2 + val caq4 = skipPSopt dtd caq3 + in + (ent,expGt,caq4) + end + handle NotFound cq => (* raised by parseEntityValue *) + (*-----------------------------------------------------------*) + (* Must be external. First parse the external identifier. *) + (*-----------------------------------------------------------*) + let + val (extId,hadS,caq1 as (_,_,q1)) = parseExtIdEnt dtd caq2 + in let + (*-----------------------------------------------------*) + (* Does a name follow? Then is must be 'NDATA' and the *) + (* notation name follows. Thus the entity is unparsed. *) + (* Also, only '>' may come next. *) + (* NotFound is handled at the end of the let. *) + (*-----------------------------------------------------*) + val (key,(c2,a2,q2)) = parseName caq1 + val a3 = if hadS then a2 else hookError(a2,(getPos q1,ERR_MISSING_WHITE)) + val a4 = if key = [0wx4e,0wx44,0wx41,0wx54,0wx41] (* "NDATA" *) then a3 + else hookError(a3,(getPos q1,ERR_EXPECTED(expGtNdata,key))) + + val caq5 as (_,_,q5) = skipPS dtd (c2,a4,q2) + + val (not,caq6) = parseName caq5 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expANotName,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError (c,a1,q) + end + val notIdx = AttNot2Index dtd not + val caq7 = skipPSopt dtd caq6 + in + (GE_UNPARSED(extId,notIdx,getPos q5),expGt,caq7) + end + handle NotFound caq => + (*--------------------------------------------------------*) + (* No 'NDATA' present, so it's parsed external entity. *) + (* A 'NDATA' might have followed. *) + (*--------------------------------------------------------*) + (GE_EXTERN extId,expGtNdata,caq) + end + + val a4 = if useParamEnts() orelse not ext then addGenEnt dtd (a3,q) (idx,ent,ext) else a3 + val a5 = hookDecl(a4,((startPos,getPos q3),DEC_GEN_ENT(idx,ent,ext))) + in + if c3<>0wx3E (* #">" *) + then let val a6 = hookError(a5,(getPos q3,ERR_EXPECTED(expGt,[c3]))) + in raise SyntaxError(c3,a6,q3) + end + else let val a6 = if not (!O_VALIDATE) orelse getEntId q3=startEnt then a5 + else hookError(a5,(getPos q3,ERR_DECL_ENT_NESTING LOC_ENT_DECL)) + in getChar(a6,q3) + end + end + + (*--------------------------------------------------------------------*) + (* parse an entity declaration, the initial '' *) + (* [72] PEDecl ::= '' *) + (* *) + (* (see also the comments for ParseDtd.parseMarkupDecl). *) + (* *) + (* raise SyntaxState in case of a syntax error. *) + (* print an error if white space is missing. *) + (* *) + (* print an error for entity end exceptions in subfunctions. *) + (* catch syntax errors by recovering to the next possible state. *) + (* *) + (* pass control to parseParEntDecl or parseGenEntDecl, depending on *) + (* whether the S is followed by a '%'. *) + (* return the remaining char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseEntityDecl dtd pars caq = + let + val (hadPero,caq1) = skipPSdec dtd caq + in + if hadPero then parseParEntDecl dtd pars caq1 + else parseGenEntDecl dtd pars caq1 + end + handle exn as SyntaxError (c,a,q) => + let val a1 = if c=0wx00 then hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_ENT_DECL)) + else a + in recoverDecl false (c,a1,q) + end + + (*--------------------------------------------------------------------*) + (* parse a notation declaration, the initial '' *) + (* *) + (* (see also the comments for ParseDtd.parseMarkupDecl). *) + (* *) + (* print an error and raise SyntaxState if no notation name, no *) + (* external/public identifier or no final '>' is found. *) + (* print an error if the '>' is not in the same entity as the ' let val err = ERR_EXPECTED(expANotName,[c]) + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + val idx = AttNot2Index dtd name + val caq3 = skipPS dtd caq2 + + val (extId,_,(c4,a4,q4)) = parseExtIdNot dtd caq3 + + val a5 = if useParamEnts() orelse not ext then addNotation dtd (a4,q1) (idx,extId) else a4 + val a6 = hookDecl(a5,((startPos,getPos q4),DEC_NOTATION(idx,extId,ext))) + in + if c4<>0wx3E (* #">" *) + then let val a7 = hookError(a6,(getPos q4,ERR_EXPECTED(expGt,[c4]))) + in raise SyntaxError (c4,a7,q4) + end + else let val a7 = if not (!O_VALIDATE) orelse getEntId q4=startEnt then a6 + else hookError(a6,(getPos q4,ERR_DECL_ENT_NESTING LOC_NOT_DECL)) + in getChar(a7,q4) + end + end + handle exn as SyntaxError(c,a,q) => + let val a1 = if c=0wx00 then hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_NOT_DECL)) + else a + in recoverDecl false (c,a1,q) + end + + (*--------------------------------------------------------------------*) + (* parse a mixed-content specification, the initial '(', S? and '#' *) + (* already read. The unique id of the openening paren's entity is *) + (* given as first arg. Cf. 3.2.1/2: *) + (* *) + (* Validity Constraint: Proper Group/PE Nesting *) + (* Parameter-entity replacement text must be properly nested with *) + (* parenthetized groups. That is to say, if either of the opening *) + (* or closing parentheses in a choice, seq, or Mixed construct is *) + (* contained in the replacement text for a parameter entity, both *) + (* must be contained in the same replacement text. *) + (* ... *) + (* [51] Mixed ::= '(' S? '#PCDATA' [ VC: Proper Group/PE *) + (* (S? '|' S? Name)* S? ')*' Nesting ] *) + (* | '(' S? '#PCDATA' S? ')' [ VC: No Duplicate *) + (* Types ] *) + (* *) + (* print an error and raise SyntaxState if no name is found first. *) + (* print an error if a name other than 'PCDATA' is found. *) + (* is found in the first place. *) + (* print an error if element names are specified but no '*' follows. *) + (* print an error if an element name is specified more than once. *) + (* print an error and raise SyntaxState if neither '|' nor ')' is *) + (* found after the 'PCDATA' or after an element name. *) + (* print an error if the closing parenthesis is not in the same *) + (* as the opening one. *) + (* *) + (* return the mixed-content specification, togther with the next *) + (* character and state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseMixed dtd lparEnt (caq as (_,_,q)) = + let + fun doit is (c,a,q) = + case c + of 0wx29 (* #")" *) => + let val a1 = if not (!O_VALIDATE) orelse getEntId q=lparEnt then a + else hookError(a,(getPos q,ERR_GROUP_ENT_NESTING LOC_MIXED)) + in (rev is,getChar(a1,q)) + end + | 0wx7C (* #"|" *) => + let + val caq1 as (_,_,q1) = skipPSopt dtd (getChar(a,q)) + + val (name,(c2,a2,q2)) = parseName caq1 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expAName,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError (c,a1,q) + end + val i = Element2Index dtd name + val (newis,a3) = + if not (member i is) then (i::is,a2) + else let val a3 = if !O_VALIDATE + then hookError(a2,(getPos q1,ERR_MULT_MIXED name)) + else a2 + in (is,a3) + end + val caq3 = skipPSopt dtd (c2,a3,q2) + in doit newis caq3 + end + | _ => let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expBarRpar,[c]))) + in raise SyntaxError (c,a1,q) + end + + val (name,(c1,a1,q1)) = parseName caq + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expPcdata,[c]) + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + val a2 = case name + of [0wx50,0wx43,0wx44,0wx41,0wx54,0wx41] (* "PCDATA" *) => a1 + | _ => hookError(a1,(getPos q,ERR_EXPECTED(expPcdata,name))) + + val caq2 = skipPSopt dtd (c1,a2,q1) + val (is,(c3,a3,q3)) = doit nil caq2 + + val caq4 = if c3=0wx2A (* #"*" *) then getChar(a3,q3) + else let val a4 = if null is then a3 + else hookError(a3,(getPos q3,ERR_EXPECTED(expRep,[c3]))) + in (c3,a4,q3) + end + in + (CT_MIXED is,caq4) + end + + (*--------------------------------------------------------------------*) + (* parse an optional occurrence indicator afer a content particle or *) + (* a content model, given as first argument. Cf. 3.2.1: *) + (* *) + (* [47] children ::= (choice | seq) ('?' | '*' | '+')? *) + (* [48] cp ::= (Name | choice | seq) ('?' | '*' | '+')? *) + (* *) + (* return the (possibly modified) content particle, together with the *) + (* next char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseOcc cm (c,a,q) = + case c + of 0wx3F (* #"?" *) => (CM_OPT cm,getChar(a,q)) + | 0wx2A (* #"*" *) => (CM_REP cm,getChar(a,q)) + | 0wx2B (* #"+" *) => (CM_PLUS cm,getChar(a,q)) + | _ => (cm,(c,a,q)) + + (*--------------------------------------------------------------------*) + (* parse a content particle. Cf. 3.2.1: *) + (* *) + (* Validity Constraint: Proper Group/PE Nesting *) + (* Parameter-entity replacement text must be properly nested with *) + (* parenthetized groups. ... *) + (* *) + (* (see also parseMixed) *) + (* *) + (* [48] cp ::= (Name | choice | seq) ('?' | '*' | '+')? *) + (* [49] choice ::= '(' S? cp [ VC: Proper Group/ *) + (* ( S? '|' S? cp )* S? ')' PE Nesting ] *) + (* [50] seq ::= '(' S? cp [ VC: Proper Group/ *) + (* ( S? ',' S? cp )* S? ')' PE Nesting ] *) + (* *) + (* print an error and raise SyntaxState if no element name or "(" is *) + (* found in the first place. *) + (* *) + (* return the content particle together with the next char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseCP dtd (c,a,q) = + case c + of 0wx28 (* #"(" *) => + let + val lparEnt = getEntId q + val caq1 = skipPSopt dtd (getChar (a,q)) + in parseGroup dtd lparEnt caq1 + end + | _ => (* must be an element name *) + let + val (name,caq1) = parseName (c,a,q) + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expElemLpar,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError (c,a1,q) + end + val idx = Element2Index dtd name + in + parseOcc (CM_ELEM idx) caq1 + end + + (*--------------------------------------------------------------------*) + (* parse a seq/choice, the first content particle and the connector *) + (* already parsed; the connector, the type of group and the entity id *) + (* of the opening parenthesis are given in first arg. Cf. 3.2.1: *) + (* *) + (* Validity Constraint: Proper Group/PE Nesting *) + (* Parameter-entity replacement text must be properly nested with *) + (* parenthetized groups. ... *) + (* *) + (* (see also parseMixed) *) + (* *) + (* [49] choice ::= '(' S? cp [ VC: Proper Group/ *) + (* ( S? '|' S? cp )* S? ')' PE Nesting ] *) + (* [50] seq ::= '(' S? cp [ VC: Proper Group/ *) + (* ( S? ',' S? cp )* S? ')' PE Nesting ] *) + (* *) + (* print an error and raise SyntaxState if something other than the *) + (* connector or ')' is found after a content particle. *) + (* print an error if the closing parenthesis of a group is not in the *) + (* same entity as the opening one. *) + (* *) + (* return the list of content particles parsed, together with the *) + (* remaining character and state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + and parseGroup' dtd (con,loc,lparEnt) caq = + let fun doit caq = + let + val caq1 = skipPSopt dtd caq + val (cp,caq2) = parseCP dtd caq1 + val (c3,a3,q3) = skipPSopt dtd caq2 + in + if c3=0wx29 (* #")" ( *) + then let val a4 = if not (!O_VALIDATE) orelse getEntId q3=lparEnt then a3 + else hookError(a3,(getPos q3,ERR_GROUP_ENT_NESTING loc)) + in ([cp],getChar(a4,q3)) + end + else (if c3=con then let val (cps,caq4) = doit (getChar(a3,q3)) + in (cp::cps,caq4) + end + else let val err = ERR_EXPECTED(expConCRpar con,[c3]) + in raise SyntaxError (c3,hookError(a3,(getPos q3,err)),q3) + end) + end + in + doit caq + end + + (*--------------------------------------------------------------------*) + (* parse a seq/choice, the first content particle parsed; the entity *) + (* id of the opening parenthesis are given in first arg. Cf. 3.2.1: *) + (* *) + (* (see also parseMixed) *) + (* *) + (* [49] choice ::= '(' S? cp [ VC: Proper Group/ *) + (* ( S? '|' S? cp )* S? ')' PE Nesting ] *) + (* [50] seq ::= '(' S? cp [ VC: Proper Group/ *) + (* ( S? ',' S? cp )* S? ')' PE Nesting ] *) + (* *) + (* print an error and raise SyntaxState if neither '|' nor ',' nor *) + (* ')' follows the first content particle in a seq/choice. *) + (* *) + (* return the list of as a ContentModel, together with the remaining *) + (* character and state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + and parseGroup dtd lparEnt caq = + let + val (cp,caq1) = parseCP dtd caq + val (c2,a2,q2) = skipPSopt dtd caq1 + val (group,caq3) = + case c2 + of 0wx29 (* #")" *) => + let val a3 = if not (!O_VALIDATE) orelse getEntId q2=lparEnt then a2 + else hookError(a2,(getPos q2,ERR_GROUP_ENT_NESTING LOC_SEQ)) + in (CM_SEQ[cp],getChar(a3,q2)) + end + | 0wx2C (* #"," *) => + let val (cps,caq3) = parseGroup' dtd (c2,LOC_SEQ,lparEnt) (getChar(a2,q2)) + in (CM_SEQ(cp::cps),caq3) + end + | 0wx7C (* #"|" *) => + let val (cps,caq3) = parseGroup' dtd (c2,LOC_CHOICE,lparEnt) (getChar(a2,q2)) + in (CM_ALT(cp::cps),caq3) + end + | _ => let val a3 = hookError(a2,(getPos q2,ERR_EXPECTED(expConRpar,[c2]))) + in raise SyntaxError (c2,a3,q2) + end + in parseOcc group caq3 + end + + (*--------------------------------------------------------------------*) + (* parse a content specification. Cf. 3.2/3.2.1: *) + (* *) + (* Validity Constraint: Proper Group/PE Nesting *) + (* Parameter-entity replacement text must be properly nested with *) + (* parenthetized groups. That is to say, if either of the opening *) + (* or closing parentheses in a choice, seq, or Mixed construct is *) + (* contained in the replacement text for a parameter entity, both *) + (* must be contained in the same replacement text. *) + (* ... *) + (* [46] contentspec ::= 'EMPTY' | 'ANY' | Mixed | children *) + (* *) + (* [47] children ::= (choice | seq) ('?' | '*' | '+')? *) + (* *) + (* [49] choice ::= '(' S? cp ( S? '|' S? cp )* S? ')' [ VC:Proper *) + (* [50] seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' Group/PE *) + (* Nesting ]*) + (* *) + (* [51] Mixed ::= '(' S? '#PCDATA' [ VC: Proper Group/PE *) + (* (S? '|' S? Name)* S? ')*' Nesting ] *) + (* | '(' S? '#PCDATA' S? ')' [ VC: No Duplicate *) + (* Types ] *) + (* *) + (* print an error and raise SyntaxState if no children, Mixed, or *) + (* name is found. *) + (* print an error and assume ANY if an ambiguous content model is *) + (* specified. *) + (* print an error and assume ANY if a name other than EMPTY or ANY *) + (* is found. *) + (* print an error if the closing parenthesis of a Mixed is not in the *) + (* same entity as the opening one. *) + (* *) + (* return the parsed content specification, togther with the next *) + (* character and state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseContentSpec dtd curr (c,a,q) = + case c + of 0wx28 (* #"(" *) => + let + val (c1,a1,q1) = skipPSopt dtd (getChar(a,q)) + val lparEnt = getEntId q + in + if c1=0wx23 (* #"#" *) + then parseMixed dtd lparEnt (getChar(a1,q1)) + else let val (cm,(c2,a2,q2)) = parseGroup dtd lparEnt (c1,a1,q1) + val (dfa,a3) = (makeDfa cm,a2) handle Ambiguous(a,n1,n2) + => if !O_COMPATIBILITY + then let val err = ERR_AMBIGUOUS(Index2Element dtd a,n1,n2) + val a3 = hookError(a2,(getPos q,err)) + val dfa = makeChoiceDfa cm + in (dfa,a3) + end + else (makeAmbiguous cm,a2) handle DfaTooLarge max + => let val a3 = if !O_DFA_WARN_TOO_LARGE + then hookWarning + (a2,(getPos q,WARN_DFA_TOO_LARGE(curr,max))) + else a2 + val dfa = makeChoiceDfa cm + in (dfa,a3) + end + in (CT_ELEMENT(cm,dfa),(c2,a3,q2)) + end + end + | _ => (* must be ANY or EMPTY *) + let + val (name,caq1 as (c1,a1,q1)) = parseName (c,a,q) + handle NotFound (c,a,q) => + let val err = ERR_EXPECTED(expContSpec,[c]) + in raise SyntaxError(c,hookError(a,(getPos q,err)),q) + end + in case name + of [0wx41,0wx4e,0wx59] (* "ANY" *) => (CT_ANY,caq1) + | [0wx45,0wx4d,0wx50,0wx54,0wx59] (* "EMPTY" *) => (CT_EMPTY,caq1) + | _ => let val a2 = hookError(a1,(getPos q,ERR_EXPECTED(expContSpec,name))) + in (CT_ANY,(c1,a2,q1)) + end + end + + (*--------------------------------------------------------------------*) + (* parse an element declaration, the initial '' Element Type *) + (* Declaration ] *) + (* *) + (* (see also the comments for ParseDtd.parseMarkupDecl). *) + (* *) + (* print an error and raise SyntaxState if no element name, no *) + (* content specification, or no final '>' is found. *) + (* print an error if the '>' is not in the same entity as the ' let val err = ERR_EXPECTED(expAnElemName,[c]) + in raise SyntaxError(c,hookError(a,(getPos q,err)),q) + end + val a3 = checkElemName (a2,q1) name + val idx = Element2Index dtd name + val caq3 = skipPS dtd (c2,a3,q2) + + val (contSpec,(c4,a4,q4)) = parseContentSpec dtd name caq3 + + val a5 = if useParamEnts() orelse not ext then addElement dtd (a4,q1) (idx,contSpec,ext) + else a4 + val a5' = hookDecl(a5,((startPos,getPos q4),DEC_ELEMENT(idx,contSpec,ext))) + + val (c6,a6,q6) = skipPSopt dtd (c4,a5',q4) + in + if c6<>0wx3E (* #">" *) + then let val a7 = hookError(a6,(getPos q6,ERR_EXPECTED(expGt,[c6]))) + in raise SyntaxError(c6,a7,q6) + end + else let val a7 = if not (!O_VALIDATE) orelse getEntId q6=startEnt then a6 + else hookError(a6,(getPos q6,ERR_DECL_ENT_NESTING LOC_ELEM_DECL)) + in getChar(a7,q6) + end + end + handle exn as SyntaxError (c,a,q) => + let val a1 = if c=0wx00 then hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_ELEM_DECL)) + else a + in recoverDecl false (c,a1,q) + end + + (*--------------------------------------------------------------------*) + (* parse an enumerated attribute type, the '(' already consumed. the *) + (* 1st arg is a string describing the attribute (nmtoken or notation),*) + (* the 2nd arg is a function that parses a single token, the 3rd arg *) + (* a function for converting the token to its index. 3.3.1: *) + (* *) + (* [58] NotationType ::= 'NOTATION' S *) + (* '(' S? Name (S? '|' S? Name)* S? ')' *) + (* [59] Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' *) + (* *) + (* print an error and raise SyntaxState if no token is found after a *) + (* '(' or '|', or if neither '|' nor ')' follows a token. *) + (* *) + (* return the (sorted) list of indices of the parsed tokens. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseEnumerated dtd (expWhat,parseToken,Token2Index) caq = + let fun doit idxs caq = + let + val caq1 as (_,_,q1) = skipPSopt dtd caq + val (nt,(c2,a2,q2)) = parseToken caq1 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expWhat,[c]) + in raise SyntaxError(c,hookError(a,(getPos q,err)),q) + end + val (idx,a3) = Token2Index dtd (a2,q1) nt + val (c4,a4,q4) = skipPSopt dtd (c2,a3,q2) + val newIdxs = insertInt(idx,idxs) + in case c4 + of 0wx7C (* #"|" *) => doit newIdxs (getChar(a4,q4)) + | 0wx29 (* #")" *) => (newIdxs,getChar(a4,q4)) + | _ => let val a5 = hookError(a4,(getPos q4,ERR_EXPECTED(expBarRpar,[c4]))) + in raise SyntaxError (c4,a5,q4) + end + end + in doit nil caq + end + + (*--------------------------------------------------------------------*) + (* Convert a (name) token to its index as an enumerated attribute. *) + (* 3.3.1: *) + (* *) + (* Validity Constraint: Notation Attributes *) + (* ... all notation names in the declaration must be declared. *) + (* *) + (* print an error if a notation is not declared. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun Token2NmtokenIndex dtd (a,_) token = (AttNot2Index dtd token,a) + fun Token2NotationIndex dtd (a,q) token = + let + val idx = AttNot2Index dtd token + val a1 = if not (!O_VALIDATE) orelse hasNotation dtd idx then a + else hookError(a,(getPos q,ERR_UNDECLARED(IT_NOTATION,token,LOC_NONE))) + in (idx,a1) + end + + (*--------------------------------------------------------------------*) + (* parse an attribute type, the 1st arg being the element this decl. *) + (* refers to. 3.3.1: *) + (* *) + (* [54] AttType ::= StringType | TokenizedType | EnumeratedType *) + (* *) + (* [55] StringType ::= 'CDATA' *) + (* [56] TokenizedType ::= 'ID' [VC: One ID per Element Type ] *) + (* | 'IDREF' *) + (* | 'IDREFS' *) + (* | 'ENTITY' *) + (* | 'ENTITIES' *) + (* | 'NMTOKEN' *) + (* | 'NMTOKENS' *) + (* *) + (* Validity Constraint: One ID per Element Type *) + (* No element type may have more than one ID attribute specified. *) + (* *) + (* Enumerated Attribute Types *) + (* *) + (* [57] EnumeratedType ::= NotationType | Enumeration *) + (* [58] NotationType ::= 'NOTATION' S '(' ... *) + (* [59] Enumeration ::= '(' ... *) + (* *) + (* print an error and raise SyntaxState if no '(', or name is found *) + (* in the first place, or the name does not start an attribute type, *) + (* or if no '(' follows a 'NOTATION'. *) + (* print an error and assume NMTOKEN instead of ID if the element *) + (* already has an ID attribute. *) + (* *) + (* return the attribute type together with the next char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseAttType dtd elem (c,a,q) = + if c=0wx28 (* #"(" *) then + let val (idxs,caq1) = parseEnumerated dtd + (expANameToken,parseNmtoken,Token2NmtokenIndex) (getChar(a,q)) + in (AT_GROUP idxs,caq1) + end + else let val (name,caq1 as (c1,a1,q1)) = parseName (c,a,q) + handle NotFound cq => let val err = ERR_EXPECTED(expAttType,[c]) + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + in case name + of [0wx43,0wx44,0wx41,0wx54,0wx41] (* "CDATA" *) => + (AT_CDATA,caq1) + | [0wx49,0wx44] (* "ID" *) => + (AT_ID,caq1) + | [0wx49,0wx44,0wx52,0wx45,0wx46] (* "IDREF" *) => + (AT_IDREF,caq1) + | [0wx49,0wx44,0wx52,0wx45,0wx46,0wx53] (* "IDREFS" *) => + (AT_IDREFS,caq1) + | [0wx45,0wx4e,0wx54,0wx49,0wx54,0wx59] (* "ENTITY" *) => + (AT_ENTITY,caq1) + | [0wx45,0wx4e,0wx54,0wx49,0wx54,0wx49,0wx45,0wx53] (* "ENTITIES" *) => + (AT_ENTITIES,caq1) + | [0wx4e,0wx4d,0wx54,0wx4f,0wx4b,0wx45,0wx4e] (* "NMTOKEN" *) => + (AT_NMTOKEN,caq1) + | [0wx4e,0wx4d,0wx54,0wx4f,0wx4b,0wx45,0wx4e,0wx53] (* "NMTOKEN" *) => + (AT_NMTOKENS,caq1) + | [0wx4e,0wx4f,0wx54,0wx41,0wx54,0wx49,0wx4f,0wx4e] (* "NOTATION" *) => + let val (c2,a2,q2) = skipPSopt dtd caq1 + in case c2 + of 0wx28 (* #"(" *) => + let val (idxs,caq3) = parseEnumerated dtd + (expANotName,parseName,Token2NotationIndex) (getChar(a2,q2)) + in (AT_NOTATION idxs,caq3) + end + | _ => let val err = ERR_EXPECTED(expLpar,[c2]) + in raise SyntaxError(c2,hookError(a2,(getPos q2,err)),q2) + end + end + | _ => let val a2 = hookError(a1,(getPos q,ERR_EXPECTED(expAttType,name))) + in raise SyntaxError (c1,a2,q1) + end + end + + (*--------------------------------------------------------------------*) + (* parse an attribute default, for an attribute whose type is given *) + (* the 1st argument. Cf. 3.3.2: *) + (* *) + (* [60] DefaultDecl ::= '#REQUIRED' | '#IMPLIED' *) + (* | (('#FIXED' S)? AttValue) *) + (* *) + (* Validity Constraint: Attribute Default Legal *) + (* The declared default value must meet the lexical constraints of *) + (* the declared attribute type. *) + (* *) + (* and 3.3.1: *) + (* *) + (* Validity Constraint: ID Attribute Default *) + (* An ID attribute must have a declared default of #IMPLIED or *) + (* #REQUIRED. *) + (* *) + (* print an error and raise SyntaxState if no '#' or literal is found *) + (* in the first place, or no name or a wrong name is found after the *) + (* '#', or if no literal follows the 'FIXED'. *) + (* print an error if white space is missing. *) + (* print an error and assume IMPLIED if the default for an ID attrib. *) + (* is not IMPLIED or REQUIRED. *) + (* *) + (* return the default together with the remaining char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseDefaultDecl dtd (aidx,attType) (c,a,q) = + if c=0wx23 (* #"#" *) then + let + val caq0 as (_,_,q0) = (getChar(a,q)) + val (name,caq1) = parseName caq0 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expAttDefKey,[c]) + in raise SyntaxError(c,hookError(a,(getPos q,err)),q) + end + in case name + of [0wx46,0wx49,0wx58,0wx45,0wx44] (* "FIXED" *) => + let + val caq2 as (_,_,q2) = skipPS dtd caq1 + val (lit,text,(c3,a3,q3)) = parseAttValue dtd caq2 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expLitQuote,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError (c,a1,q) + end + in + if !O_VALIDATE andalso isIdType attType + then let val a4 = hookError(a3,(getPos q,ERR_ID_DEFAULT)) + in (AD_IMPLIED,(c3,a4,q3)) + end + else + let val (cv,(av,a4)) = makeAttValue dtd (a3,q2) + (aidx,attType,false,true,text) + in (AD_FIXED((lit,cv,av),(getPos q2,ref false)),(c3,a4,q3)) + end + handle AttValue a => (AD_IMPLIED,(c3,a,q3)) + end + + | [0wx49,0wx4d,0wx50,0wx4c,0wx49,0wx45,0wx44] (* "IMPLIED" *) => + (AD_IMPLIED,caq1) + | [0wx52,0wx45,0wx51,0wx55,0wx49,0wx52,0wx45,0wx44] (* "REQUIRED" *) => + (AD_REQUIRED,caq1) + | _ => let val (c1,a1,q1) = caq1 + val a2 = hookError(a1,(getPos q0,ERR_EXPECTED(expAttDefKey,name))) + in raise SyntaxError (c1,a2,q1) + end + end + else let + val (lit,text,(c1,a1,q1)) = parseAttValue dtd (c,a,q) + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expQuoteRni,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError(c,a1,q) + end + in + if !O_VALIDATE andalso isIdType attType + then let val a2 = hookError(a1,(getPos q,ERR_ID_DEFAULT)) + in (AD_IMPLIED,(c1,a2,q1)) + end + else let val (cv,(av,a2)) = makeAttValue dtd (a1,q) (aidx,attType,false,true,text) + in (AD_DEFAULT((lit,cv,av),(getPos q,ref false)),(c1,a2,q1)) + end + handle AttValue a => (AD_IMPLIED,(c1,a,q1)) + end + + (*--------------------------------------------------------------------*) + (* parse an attribute definition, the referred element given as 1st *) + (* argument. 3.3: *) + (* *) + (* [53] AttDef ::= S Name S AttType S DefaultDecl *) + (* *) + (* raise NotFound if no name is found (and thus no attribute def.) *) + (* print an error if white space is missing. *) + (* *) + (* enter the attribute definition into the element table. *) + (* return the next character and the remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: NotFound SyntaxState *) + (*--------------------------------------------------------------------*) + fun parseAttDef dtd (elem,ext) caq = + let + val (hadS,caq1 as (_,_,q1)) = skipPSmay dtd caq + + val (name,(c2,a2,q2)) = parseName caq1 (* NotFound falls through to the next level *) + val a3 = if hadS then a2 else hookError(a2,(getPos q1,ERR_MISSING_WHITE)) + val a4 = checkAttName (a3,q1) name + val idx = AttNot2Index dtd name + + val caq5 = skipPS dtd (c2,a4,q2) + val (attType,caq6) = parseAttType dtd elem caq5 + val caq7 = skipPS dtd caq6 + + val (attDef,(c8,a8,q8)) = parseDefaultDecl dtd (idx,attType) caq7 + + val a9 = if useParamEnts() orelse not ext + then addAttribute dtd (a8,q1) (elem,(idx,attType,attDef,ext)) else a8 + in + ((idx,attType,attDef),(c8,a9,q8)) + end + + (*--------------------------------------------------------------------*) + (* parse an attribute-list declaration, the initial '' *) + (* *) + (* (see also the comments for ParseDtd.parseMarkupDecl). *) + (* *) + (* check whether the element already had an attlist declaration. (cf. *) + (* DtdElements.enterAttDecl) *) + (* *) + (* print an error and raise SyntaxState if no element name, or no *) + (* final '>' is found. *) + (* print an error if the '>' is not in the same entity as the ' let val err = ERR_EXPECTED(expAnElemName,[c]) + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + val a3 = checkElemName (a2,q1) name + val idx = Element2Index dtd name + + val a4 = if !O_VALIDATE orelse not ext then enterAttList dtd (a3,q1) idx else a3 + + fun doit attDefs caq = + let val (attDef,caq1) = parseAttDef dtd (idx,ext) caq + handle NotFound (c,a,q) => raise NotFound + (c,hookDecl(a,((startPos,getPos q),DEC_ATTLIST(idx,rev attDefs,ext))),q) + | SyntaxError (c,a,q) => raise SyntaxError + (c,hookDecl(a,((startPos,getPos q),DEC_ATTLIST(idx,rev attDefs,ext))),q) + in doit (attDef::attDefs) caq1 + end + + val (c5,a5,q5) = doit nil (c2,a4,q2) handle NotFound caq => caq + in + if c5 <> 0wx3E (* #">" *) + then let val a6 = hookError(a5,(getPos q5,ERR_EXPECTED(expAttNameGt,[c5]))) + in raise SyntaxError (c5,a6,q5) + end + else let val a6 = if not (!O_VALIDATE) orelse getEntId q5=startEnt then a5 + else hookError(a5,(getPos q5,ERR_DECL_ENT_NESTING LOC_ATT_DECL)) + in getChar(a6,q5) + end + end + handle exn as SyntaxError (c,a,q) => + let val a1 = if c=0wx00 then hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_ATT_DECL)) + else a + in recoverDecl false (c,a,q) + end +end +(* stop of ../../Parser/Parse/parseDecl.sml *) +(* start of ../../Parser/Parse/parseDtd.sml *) +signature ParseDtd = + sig + (*---------------------------------------------------------------------- + include ParseBase + + val parseName : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val openExtern : int * Uri.Uri -> AppData * State + -> Encoding.Encoding * HookData.TextDecl option * (UniChar.Char * AppData * State) + val openDocument : Uri.Uri option -> AppData + -> Encoding.Encoding * HookData.XmlDecl option * (UniChar.Char * AppData * State) + + val skipCharRef : AppData * State -> (UniChar.Char * AppData * State) + val skipReference : UniChar.Char * AppData * State -> (UniChar.Char * AppData * State) + val parseGenRef : Dtd -> UniChar.Char * AppData * State + -> (int * Base.GenEntity) * (AppData * State) + val parseCharRefLit : UniChar.Data -> AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val parseComment : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val parseProcInstr : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + + val skipTag : Errors.Location -> AppData * State -> (UniChar.Char * AppData * State) + val parseETag : Dtd -> AppData * State + -> int * UniChar.Data * Errors.Position * (UniChar.Char * AppData * State) + val parseSTag : Dtd -> Errors.Position -> UniChar.Char * AppData * State + -> (HookData.StartTagInfo * Base.ElemInfo) * (UniChar.Char * AppData * State) + + val skipDecl : bool -> UniChar.Char * AppData * State -> UniChar.Char * AppData * State + ----------------------------------------------------------------------*) + include ParseDecl + + val parseDocTypeDecl : Dtd -> (UniChar.Char * AppData * State) + -> int option * (UniChar.Char * AppData * State) + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseDtd *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* parseDocTypeDecl : none *) +(*--------------------------------------------------------------------------*) +functor ParseDtd (structure ParseBase : ParseBase) + : ParseDtd = +struct + structure ParseDecl = ParseDecl (structure ParseBase = ParseBase) + + open + Base UniChar Errors + ParseDecl + + (*--------------------------------------------------------------------*) + (* parse a markup declaration other than a processing instruction, *) + (* " (* #"-" *) + let val (c1,a1,q1) = getChar (a,q) + in if c1<>0wx2D (* #"-" *) + then let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expDash,[c1]))) + in recoverDecl false (c1,a2,q1) + end + else parseComment startPos (a1,q1) + end + | _ => let + val (name,caq1) = parseName (c,a,q) + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expStartMarkup,[c]) + val a1 = hookError(a,(getPos q,err)) + in raise SyntaxError (c,a1,q) + end + val ext = hasExternal dtd + in case name + of [0wx45,0wx4c,0wx45,0wx4d,0wx45,0wx4e,0wx54] (* "ELEMENT" *) => + parseElementDecl dtd (startEnt,startPos,ext) caq1 + | [0wx41,0wx54,0wx54,0wx4c,0wx49,0wx53,0wx54] (* "ATTLIST" *) => + parseAttListDecl dtd (startEnt,startPos,ext) caq1 + | [0wx4e,0wx4f,0wx54,0wx41,0wx54,0wx49,0wx4f,0wx4e] (* "NOTATION" *) => + parseNotationDecl dtd (startEnt,startPos,ext) caq1 + | [0wx45,0wx4e,0wx54,0wx49,0wx54,0wx59] (* "ENTITY" *) => + parseEntityDecl dtd (startEnt,startPos,ext) caq1 + | _ => let val (c1,a1,q1) = caq1 + val err = ERR_EXPECTED(expStartMarkup,name) + val a2 = hookError(a1,(getPos q,err)) + in recoverDecl false (c1,a2,q1) + end + end + + (*--------------------------------------------------------------------*) + (* skip an ignored section, starting after the '". 3.4: *) + (* *) + (* [63] ignoreSect ::= '' *) + (* [64] ignoreSectContents ::= Ignore ('' Ignore)* *) + (* [65] Ignore ::= Char* - (Char* ('') Char* ) *) + (* *) + (* ... If the keyword of the conditional section is IGNORE, then *) + (* the contents of the conditional section are not logically part *) + (* of the DTD. Note that for reliable parsing, the contents of even *) + (* ignored conditional sections must be read in order to detect *) + (* nested conditional sections and ensure that the end of the *) + (* outermost (ignored) conditional section is properly detected. *) + (* If a conditional section with a keyword of INCLUDE occurs within *) + (* a larger conditional section with a keyword of IGNORE, both the *) + (* outer and the inner conditional sections are ignored. *) + (* *) + (* print an error an finish if an entity end is encountered. *) + (* *) + (* return the next char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun skipIgnored caq = + let + (*--------------------------------------------------------------*) + (* level counts the nesting of conditional sections. *) + (* if the second char after a "<" ("]") is not a "[" ("]"), it *) + (* can nevertheless start another delimiter and is therefore *) + (* fed into a recursive call of doit. *) + (*--------------------------------------------------------------*) + fun doit level (c,a,q) = + case c + of 0wx00 => (c,hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_IGNORED)),q) + | 0wx3C (* #"<" *) => + let val (c1,a1,q1) = getChar (a,q) + in if c1=0wx21 (* #"!" *) + then let val (c2,a2,q2) = (getChar(a1,q1)) + in if c2=0wx5B (* #"[" *) then doit (level+1) (getChar(a2,q2)) + else doit level (c2,a2,q2) + end + else doit level (c1,a1,q1) + end + | 0wx5D (* #"]" *) => + let val (c1,a1,q1) = getChar (a,q) + in if c1=0wx5D (* #"]" *) then doit' level (getChar (a1,q1)) + else doit level (c1,a1,q1) + end + | _ => doit level (getChar (a,q)) + (*--------------------------------------------------------------*) + (* if the second "]" is followed by a "]", then this might be *) + (* the real second "]". Therefore doit' loops as long as it *) + (* finds "]"'s. *) + (*--------------------------------------------------------------*) + and doit' level (c,a,q) = + case c + of 0wx3E (* #">" *) => if level>0 then doit (level-1) (getChar (a,q)) + else getChar (a,q) + | 0wx5D (* #"]" *) => doit' level (getChar (a,q)) + | _ => doit level (c,a,q) + in + doit 0 caq + end + + (*--------------------------------------------------------------------*) + (* parse the internal or external subset of the dtd. handle included *) + (* sections by counting their nesting level. Cf 2.8: *) + (* *) + (* Validity Constraint: Proper Declaration/PE Nesting *) + (* Parameter-entity replacement text must be properly nested with *) + (* markup declarations. That is to say, if either the first *) + (* character or the last character of a markup declaration *) + (* (markupdecl above) is contained in the replacement text for a *) + (* parameter-entity reference, both must be contained in the same *) + (* replacement text. *) + (* ... *) + (* [28] doctypedecl ::= '' *) + (* [29] markupdecl ::= elementdecl | AttlistDecl | EntityDecl *) + (* | NotationDecl | PI | Comment *) + (* [30] extSubset ::= TextDecl? extSubsetDecl *) + (* [31] extSubsetDecl ::= ( markupdecl | conditionalSect *) + (* | PEReference | S )* *) + (* and 3.4: *) + (* *) + (* [61] conditionalSect ::= includeSect | ignoreSect *) + (* [62] includeSect ::= '' *) + (* [63] ignoreSect ::= '' *) + (* *) + (* print an error and finish if the end of document is encountered in *) + (* the internal subset. *) + (* print an error and raise SyntaxState if a "<" is not followed by a *) + (* "!" or a "?". *) + (* print an error and raise SyntaxState if a "]" is not followed by *) + (* "]>". *) + (* print an error if a "" is found outside an included section. *) + (* print an error an raise SyntaxState if something other than a *) + (* markup declaration, parameter entity reference, white space or *) + (* a conditional section is encountered. *) + (* print an error and raise SyntaxState if a " (ws,(c,a,q)) + | 0wx09 => doit false (c::ws) (getChar(a,q)) + | 0wx0A => doit false (c::ws) (getChar(a,q)) + | 0wx20 => doit false (c::ws) (getChar(a,q)) + | 0wx25 => (ws,(c,a,q)) + | 0wx3C => (ws,(c,a,q)) + | 0wx5D => (ws,(c,a,q)) + | _ => if hadError then doit true ws (getChar(a,q)) + else let val err = ERR_FORBIDDEN_HERE(IT_DATA nil,LOC_SUBSET) + val a1 = hookError (a,(getPos q,err)) + in doit true ws (getChar(a1,q)) + end + + val (ws,(c1,a1,q1)) = doit false nil caq + val a2 = if null ws then a1 + else hookWhite(a1,Data2Vector (rev ws)) + in (c1,a2,q1) + end + + fun doit cond (c,a,q) = + case c + of 0wx00 => + if isSpecial q + (*---------------------------------------------------*) + (* the external subset ends at and of special entity.*) + (* so does the internal subset, but with error. *) + (*---------------------------------------------------*) + then + let val a1 = + if inDocEntity q + then hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_INT_SUBSET)) + else if cond=0 then a + else hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_INCLUDED)) + in (c,a1,q) + end + else let val a1 = hookEntEnd (a,getPos q) + in doit cond (getChar(a1,q)) + end + + (* ignore errors in parameter references -----------------*) + | 0wx25 (* #"%" *) => + let + val caq2 = + let val ((id,ent),(a1,q1)) = parseParRef dtd (getChar(a,q)) + in if !O_VALIDATE orelse !O_INCLUDE_PARAM_ENTS then + case ent + of PE_NULL => getChar(a1,q1) + | PE_INTERN(_,rep) => + let + val q2 = pushIntern(q1,id,true,rep) + val a2 = hookParRef(a1,((getPos q,getPos q1),id,ent,true)) + in getChar(a2,q2) + end + | PE_EXTERN extId => + let + val a2 = hookParRef(a1,((getPos q,getPos q1),id,ent,true)) + val caq3 = + #3(openExtern (id,true,resolveExtId extId) (a2,q1)) + handle CantOpenFile(fmsg,a) + => let val err = ERR_NO_SUCH_FILE fmsg + val a1 = hookError(a,(getPos q1,err)) + val a2 = hookEntEnd (a1,getPos q1) + in (getChar(a2,q1)) + end + in caq3 + end + (* changed 080600: setExternal is already called by parseParRef *) + else let val a2 = hookParRef(a1,((getPos q,getPos q1),id,ent,false)) + in getChar(a2,q1) + end + end + handle SyntaxError caq => caq + | NoSuchEntity aq => getChar aq + in doit cond caq2 + end + + | 0wx3C (* #"<" *) => + let val (c1,a1,q1) = getChar(a,q) + in case c1 + of 0wx3F => (* #"?" *) + let val caq2 = parseProcInstr (getPos q) (a1,q1) + in doit cond caq2 + end + | 0wx21 => (* #"!" *) + let val (c2,a2,q2) = (getChar(a1,q1)) + in if c2=0wx5B (* #"[" *) + then do_cond cond q (a2,q2) + else + let val caq3 = parseMarkupDecl dtd + (getEntId q,getPos q) (c2,a2,q2) + in doit cond caq3 + end + end + | _ => let val err = ERR_EXPECTED(expExclQuest,[c1]) + val a2 = hookError(a1,(getPos q1,err)) + val caq3 = recoverDecl false (c1,a2,q1) + in doit cond caq3 + end + end + + | 0wx5D (* #"]" *) => do_brack cond q (getChar(a,q)) + | _ => let val caq1 = do_data (c,a,q) + in doit cond caq1 + end + + and do_brack cond q0 (c,a,q) = + if inDocEntity q then (c,a,q) + else if c=0wx5D (* #"]" *) + then let val (c1,a1,q1) = getChar(a,q) + in if c1=0wx3E (* #">" *) + (* ignore wrong "]]>"'s ------------------*) + then if cond=0 + then let val err = ERR_FORBIDDEN_HERE(IT_DATA [c,c,c1], + LOC_OUT_COND) + val a2 = hookError(a1,(getPos q0,err)) + in doit cond (getChar(a2,q1)) + end + else doit (cond-1) (getChar(a1,q1)) + (* the second "]" may start another "]]>" ---*) + else let val a2 = hookError(a1,(getPos q1,ERR_EXPECTED(expGt,[c1]))) + in do_brack cond q (c1,a2,q1) + end + end + else let val a1 = hookError(a,(getPos q,ERR_EXPECTED(expRbrack,[c]))) + in doit cond (c,a1,q) + end + + and do_cond cond q0 (a,q) = + let + (* marked sections are forbidden in the internal subset. -*) + val inInt = inDocEntity q + val a1 = if inInt then hookError (a,(getPos q0,ERR_FORBIDDEN_HERE + (IT_COND,LOC_INT_SUBSET))) + else a + + val caq2 as (_,_,q2) = skipPSopt dtd (getChar(a1,q)) + + val (status,caq3) = + let + val (name,(c3,a3,q3)) = parseName caq2 + (* ignore sections with bad status keyword ---------*) + val (status,a4) = + case name + of [0wx49,0wx47,0wx4e,0wx4f,0wx52,0wx45] => (IGNORE,a3) + | [0wx49,0wx4e,0wx43,0wx4c,0wx55,0wx44,0wx45] => (INCLUDE,a3) + | _ => let val err = ERR_EXPECTED(expCondStatus,name) + val a4 = hookError(a3,(getPos q2,err)) + in (IGNORE,a4) + end + val (c5,a5,q5) = skipPSopt dtd (c3,a4,q3) + in (* ignore sections without "[" after keyword -------*) + if c5=0wx5B then (status,getChar(a5,q5)) + else let val a6 = hookError(a5,(getPos q5,ERR_EXPECTED(expLbrack,[c5]))) + in (IGNORE,(c5,a6,q5)) + end + end + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expCondStatus,[c]) + val a1 = hookError(a,(getPos q,err)) + in (IGNORE,(c,a1,q)) + end + in + (* ignore sections in the internal subset ----------------*) + case (status,inInt) + of (INCLUDE,_) => doit (cond+1) caq3 + | (_,_) => doit cond (skipIgnored caq3) + end + in + doit 0 caq + end + + (*--------------------------------------------------------------------*) + (* parse the internal subset of the dtd. Cf 2.8: *) + (* *) + (* return the remaining character and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseInternalSubset dtd (a,q) = + let val a1 = hookSubset (a,getPos q) + in parseSubset dtd (getChar(a1,q)) + end + + (*--------------------------------------------------------------------*) + (* parse the external subset of the dtd, the filename given as first *) + (* argument. handle included sections by counting their nesting level.*) + (* the file is opened on its own stack, and closed at the end. *) + (* Cf 2.8: *) + (* *) + (* print an error and do nothing if the file cannot be opened. *) + (* *) + (* return nothing. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseExternalSubset dtd (a,q) extId = + let + val uri = resolveExtId extId + val (enc,textDecl,(c1,a1,q1)) = openSubset uri a + val a2 = hookExtSubset (a1,(uri,enc,textDecl)) + val (_,a3,q3) = parseSubset dtd (c1,a2,q1) + val _ = closeAll q3 + in a3 + end + handle CantOpenFile(fmsg,a) => hookError(a,(getPos q,ERR_NO_SUCH_FILE fmsg)) + + (*--------------------------------------------------------------------*) + (* Parse the document type declaration, the ' *) + (* *) + (* print an error and raise SyntaxState if no name is found. *) + (* print an error and raise SyntaxState if no final ">" is found. *) + (* external identifier is found. *) + (* print an error if white space is missing. *) + (* *) + (* return nothing. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseDocTypeDecl dtd caq = + let + val _ = setHasDtd dtd + val caq1 = skipS caq + + val (doc,caq2) = parseName caq1 + handle NotFound (c,a,q) => let val err = ERR_EXPECTED(expAName,[c]) + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + val idx = Element2Index dtd doc + + val (hadS,caq3 as (_,_,q3)) = skipSmay caq2 + val (ext,(c4,a4,q4)) = let val (extId,_,(c4,a4,q4)) = parseExtIdSub dtd caq3 + val a5 = if hadS then a4 + else hookError(a4,(getPos q3,ERR_MISSING_WHITE)) + in (SOME extId,(c4,a5,q4)) + end + handle NotFound caq => (NONE,caq) + + val a4' = hookDocType(a4,(idx,ext)) + val (c5,a5,q5) = case c4 + of 0wx5B (* #"[" *) => + let val caq5 = parseInternalSubset dtd (a4',q4) + in skipSopt caq5 + end + | _ => (c4,a4',q4) + + val a6 = case ext + of NONE => a5 + | SOME extId => let val _ = setExternal dtd + in if !O_VALIDATE orelse !O_INCLUDE_PARAM_ENTS + then parseExternalSubset dtd (a5,q5) extId + else a5 + end + + val a7 = checkMultEnum dtd (a6,q5) + val a7'= checkPreDefined dtd (a7,q5) + val a8 = checkUnparsed dtd a7' + + val (c9,a9,q9) = if c5=0wx3E (* #">" *) then getChar(a8,q5) + else let val err = expectedOrEnded(expGt,LOC_DOC_DECL) c5 + val a9 = hookError(a8,(getPos q5,err)) + in recoverDecl false (c5,a9,q5) + end + in + (SOME idx,(c9,hookEndDtd(a9,getPos q9),q9)) + end + handle exn as SyntaxError(c,a,q) => + let val a1 = if c=0wx00 then hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_DOC_DECL)) + else a + val (c2,a2,q2) = recoverDecl true (c,a1,q) + in (NONE,(c2,hookEndDtd(a2,getPos q2),q2)) + end +end +(* stop of ../../Parser/Parse/parseDtd.sml *) +(* start of ../../Parser/Parse/parseContent.sml *) +signature ParseContent = + sig + (*---------------------------------------------------------------------- + include ParseBase + + val parseName : UniChar.Char * AppData * State + -> UniChar.Data * (UniChar.Char * AppData * State) + + val openDocument : Uri.Uri option -> AppData + -> Encoding.Encoding * HookData.XmlDecl option * (UniChar.Char * AppData * State) + + val skipCharRef : AppData * State -> (UniChar.Char * AppData * State) + val skipReference : UniChar.Char * AppData * State -> (UniChar.Char * AppData * State) + + val parseComment : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + val parseProcInstr : Errors.Position -> AppData * State -> (UniChar.Char * AppData * State) + + val skipTag : Errors.Location -> AppData * State -> (UniChar.Char * AppData * State) + val parseSTag : Dtd -> Errors.Position -> UniChar.Char * AppData * State + -> (HookData.StartTagInfo * Base.ElemInfo) * (UniChar.Char * AppData * State) + + val skipDecl : bool -> UniChar.Char * AppData * State -> UniChar.Char * AppData * State + + val parseDocTypeDecl : Dtd -> (UniChar.Char * AppData * State) + -> int option * (UniChar.Char * AppData * State) + ----------------------------------------------------------------------*) + include ParseDtd + + val skipBadSection : UniChar.Char * AppData * State -> (UniChar.Char * AppData * State) + + val parseElement : Dtd * int list * State * (HookData.StartTagInfo * Base.ElemInfo) + * (UniChar.Char * AppData * State) + -> (int * UniChar.Data * Errors.Position * Errors.Position) option + * (UniChar.Char * AppData * State) + end + +(*--------------------------------------------------------------------------*) +(* Structure: ParseContent *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* skipBadSection : none *) +(* parseElement : none *) +(*--------------------------------------------------------------------------*) +functor ParseContent (structure ParseBase : ParseBase) + : ParseContent = +struct + structure ParseDtd = ParseDtd (structure ParseBase = ParseBase) + + open + Base Errors UniChar UniClasses UtilList + ParseDtd + + val THIS_MODULE = "ParseContent" + val DATA_BUFSIZE = 1024 + val dataBuffer = Array.array(DATA_BUFSIZE,0w0:UniChar.Char) + + (*--------------------------------------------------------------------*) + (* skip a cdata section, the initial "' Char* )) [[ *) + (* [21] CDEnd ::= ']]>' *) + (* *) + (* don't care abeout whether "CDATA[" is present. just skip until the *) + (* next "]]>" or entity end. *) + (* *) + (* return the remaining char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun skipBadSection caq = + let(*--------------------------------------------------------------*) + (* for a sequence of "]"s, check whether the last two are *) + (* followed by a ">" *) + (*--------------------------------------------------------------*) + fun checkEnd aq = + let val (c1,a1,q1) = getChar aq + in case c1 + of 0wx3E (* #">" *) => getChar(a1,q1) + | 0wx5D (* #"]" *) => checkEnd(a1,q1) + | _ => doit(c1,a1,q1) + end + and doit (c,a,q) = + case c + of 0wx00 => let val a1 = hookError(a,(getPos q,ERR_ENDED_BY_EE LOC_CDATA)) + in (c,a1,q) + end + | 0wx5D (* #"]" *) => let val (c1,a1,q1) = getChar(a,q) + in if c1=0wx5D (* #"]" *) then checkEnd(a1,q1) + else doit (c1,a1,q1) + end + | _ => doit (getChar(a,q)) + in doit caq + end + + (*--------------------------------------------------------------------*) + (* parse a cdata section, the initial "' Char* )) [[ *) + (* [21] CDEnd ::= ']]>' *) + (* *) + (* print an error and finish if an entity end is found. *) + (* *) + (* return the data as a Vector option and the next char & state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseCDataSection' (aq as (_,q)) = + let + (*--------------------------------------------------------------*) + (* for a sequence of "]"s, check whether the last two are *) + (* followed by a ">" *) + (*--------------------------------------------------------------*) + fun doEnd (text,q0,q1) (a2,q2) = + let val (c3,a3,q3) = getChar (a2,q2) + in case c3 + of 0wx00 => + let val a4 = hookError(a3,(getPos q3,ERR_ENDED_BY_EE LOC_CDATA)) + in (0wx5D::text,getPos q2,(c3,a4,q3)) + end + | 0wx3E => (* #">" *) (text,getPos q0,getChar(a3,q3)) + | 0wx5D => doEnd (0wx5D::text,q1,q2) (a3,q3) + | _ => doit (c3::0wx5D::0wx5D::text) (a3,q3) + end + and doBrack (text,q0) (a1,q1) = + let val (c2,a2,q2) = getChar(a1,q1) + in case c2 + of 0wx00 => + let val a3 = hookError(a2,(getPos q2,ERR_ENDED_BY_EE LOC_CDATA)) + in (0wx5D::text,getPos q1,(c2,a3,q2)) + end + | 0wx5D (* #"]" *) => doEnd (text,q0,q1) (a2,q2) + | _ => doit (c2::0wx5D::text) (a2,q2) + end + and doit text (a,q) = + let val (c1,a1,q1) = getChar(a,q) + in case c1 + of 0wx00 => + let val a2 = hookError(a1,(getPos q1,ERR_ENDED_BY_EE LOC_CDATA)) + in (text,getPos q,(c1,a2,q1)) + end + | 0wx5D (* #"]" *) => doBrack (text,q) (a1,q1) + | _ => doit (c1::text) (a1,q1) + end + val (c1,a1,q1) = getChar aq + val startPos = getPos q1 + val (cs,endPos,(c2,a2,q2)) = + case c1 + of 0wx00 => + let val a2 = hookError(a1,(getPos q1,ERR_ENDED_BY_EE LOC_CDATA)) + in (nil,getPos q,(c1,a2,q1)) + end + | 0wx5D (* #"]" *) => doBrack (nil,q) (a1,q1) + | _ => doit [c1] (a1,q1) + val text = Data2Vector(rev cs) + val a3 = hookCData(a1,((startPos,endPos),text)) + in (c2,a3,q2) + end + (*--------------------------------------------------------------------*) + (* parse a cdata section, the initial "' Char* )) [[ *) + (* [21] CDEnd ::= ']]>' *) + (* *) + (* print an error and skip the section if no name or a name other *) + (* than CDATA comes first, or no '[' follows the name. *) + (* *) + (* return the text of the section together with the remaining state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseCDataSection startPos aq = + let + val caq0 as (_,_,q0) = (getChar aq) + val (name,(c1,a1,q1)) = parseName caq0 + handle NotFound (c,a,q) => let val err = expectedOrEnded(expCdata,LOC_CDATA) c + in raise SyntaxError(c,hookError(a,(getPos q,err)),q) + end + + val _ = if name = [0wx43,0wx44,0wx41,0wx54,0wx41] (* "CDATA" *) then () + else let val err = ERR_EXPECTED(expCdata,name) + in raise SyntaxError(c1,hookError(a1,(getPos q0,err)),q1) + end + + val _ = if c1=0wx5B (* #"[" *) then () + else let val err = expectedOrEnded(expLbrack,LOC_CDATA) c1 + in raise SyntaxError(c1,hookError(a1,(getPos q1,err)),q1) + end + in + parseCDataSection'(a1,q1) + end + handle SyntaxError caq => skipBadSection caq + + (*--------------------------------------------------------------------*) + (* parse element or empty content. The second arg holds the unique *) + (* number of the element's first characters's entity, the index of *) + (* the current element, and the dfa for its content. Cf. 3: *) + (* *) + (* [39] element ::= EmptyElemTag *) + (* | STag content ETag *) + (* ... *) + (* Well-Formedness Constraint: Element Type Match *) + (* The Name in an element's end-tag must match the element type in *) + (* the start-tag. *) + (* *) + (* Validity Constraint: Element Valid *) + (* An element is valid if there is a declaration matching *) + (* elementdecl where the Name matches the element type, and one of *) + (* the following holds: *) + (* *) + (* 1. The declaration matches EMPTY and the element has no content. *) + (* 2. The declaration matches children and the sequence of child *) + (* elements belongs to the language generated by the regular *) + (* expression in the content model, with optional white space *) + (* (characters matching the nonterminal S) between each pair of *) + (* child elements. *) + (* *) + (* and 3.1: *) + (* *) + (* [43] content ::= (element | CharData | Reference | CDSect | PI *) + (* | Comment)* *) + (* 2.4: *) + (* The ampersand character (&) and the left angle bracket (<) may *) + (* appear in their literal form only when used as markup delimiters,*) + (* or within a comment, a processing instruction, or a CDATA *) + (* section... If they are needed elsewhere, they must be escaped *) + (* using either numeric character references or the strings "&" *) + (* and "<" respectively... *) + (* *) + (* consume the content of the element, accumulating it via the user *) + (* data functions (parameter a in subfunctions). trace the content *) + (* model of the element with a dfa transitions on a dfa state (para- *) + (* meter p in subfunctions). finish at the first end-tag, whether *) + (* matching or not, or at the document end. *) + (* *) + (* handle all syntax and other recoverable errors from subfunctions *) + (* and try to continue. *) + (* *) + (* return the accumulated user data and the next char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + fun parseElementContent dtd (openElems,startEnt,curr,dfa,ext,mt) caq = + let + (*--------------------------------------------------------------*) + (* check whether the dfa allows a transition/an end tag here. *) + (* print an error if not. After a transition return the new *) + (* dfa state. *) + (*--------------------------------------------------------------*) + fun fin_elem (a,pos,dfa,p) = + if dfaFinal(dfa,p) then a + else hookError(a,(pos,ERR_ENDED_EARLY(Index2Element dtd curr))) + fun trans_elem (a,q,dfa,p,el) = + let val p1 = dfaTrans(dfa,p,el) + in if p1<>dfaError then (p1,a) + else let val err = ERR_BAD_ELEM(Index2Element dtd curr,Index2Element dtd el) + in (p1,hookError(a,(getPos q,err))) + end + end + + (*--------------------------------------------------------------*) + (* consume all white space and skip all data until the next "<" *) + (* or "&". print an error for each sequence of data encountered.*) + (* *) + (* add the white space as data to the user data. *) + (* return the next char and state. *) + (*--------------------------------------------------------------*) + fun do_char_elem (c0,a0,q0) = + let + (*--------------------------------------------------------------*) + (* read data characters until the next "<", "&" or entity end. *) + (* add the data to the user data when an error occurs or no *) + (* more data follows. *) + (* *) + (* return the modified user data with the next char and state. *) + (*--------------------------------------------------------------*) + fun data_hook(a,q,cs) = + if null cs then a + else hookData(a,((getPos q0,getPos q),Data2Vector(rev cs),true)) + fun after_error (caq as (c,a,q)) = + case c + of 0wx00 => caq + | 0wx26 (* #"&" *) => caq + | 0wx3C (* #"<" *) => caq + | _ => after_error(getChar(a,q)) + fun do_data (yet,aq as (_,q)) = + let val (c1,a1,q1) = getChar aq + in case c1 + of 0wx00 => (c1,data_hook(a1,q,yet),q1) + | 0wx26 (* #"&" *) => (c1,data_hook(a1,q,yet),q1) + | 0wx3C (* #"<" *) => (c1,data_hook(a1,q,yet),q1) + | _ => + if isS c1 then do_data (c1::yet,(a1,q1)) + else let val a2 = data_hook(a1,q,yet) + val err = ERR_ELEM_CONTENT(IT_DATA nil) + val a3 = hookError(a2,(getPos q1,err)) + in after_error (getChar(a3,q1)) + end + end + in + if isS c0 then + let val a1 = if not (ext andalso standsAlone dtd) then a0 + else let val err = ERR_STANDALONE_ELEM(Index2Element dtd curr) + val _ = setStandAlone dtd (not (!O_ERROR_MINIMIZE)) + in hookError(a0,(getPos q0,err)) + end + in do_data ([c0],(a1,q0)) + end + else let val a1 = hookError(a0,(getPos q0,ERR_ELEM_CONTENT(IT_DATA nil))) + in after_error(getChar(a1,q0)) + end + end + (*--------------------------------------------------------------*) + (* consume a reference, handling errors by ignoring them. *) + (*--------------------------------------------------------------*) + fun do_ref (q,(c1,a1,q1)) = + if c1=0wx23 (* #"#" *) + (*------------------------------------------------------*) + (* it's a character reference. *) + (*------------------------------------------------------*) + then let val err = ERR_ELEM_CONTENT IT_CHAR_REF + val a2 = hookError(a1,(getPos q,err)) + in skipCharRef(a2,q1) + end + (*---------------------------------------------------------*) + (* it's a general entity reference. *) + (*---------------------------------------------------------*) + else let val ((id,ent),(a2,q2)) = parseGenRef dtd (c1,a1,q1) + in case ent + of GE_NULL => + let val a3 = hookGenRef(a2,((getPos q,getPos q2),id,ent,false)) + in (getChar(a3,q2)) + end + | GE_INTERN(_,rep) => + let + val q3 = pushIntern(q2,id,false,rep) + val a3 = hookGenRef(a2,((getPos q,getPos q2),id,ent,true)) + in (getChar(a3,q3)) + end + | GE_EXTERN ext => + if !O_VALIDATE orelse !O_INCLUDE_EXT_PARSED + then + let + val a3 = hookGenRef(a2,((getPos q,getPos q2),id,ent,true)) + val caq4 = #3(openExtern (id,false,resolveExtId ext) (a3,q2)) + handle CantOpenFile(fmsg,a) + => let val err = ERR_NO_SUCH_FILE fmsg + val a2 = hookError(a,(getPos q2,err)) + val a3 = hookEntEnd(a2,getPos q2) + in (getChar(a3,q2)) + end + in caq4 + end + else let val a3 = hookGenRef(a2,((getPos q,getPos q2),id,ent,false)) + in getChar(a3,q2) + end + | GE_UNPARSED _ => + raise InternalError + (THIS_MODULE,"parseElementContent", + "parseGenRef returned GE_UNPARSED") + end + (*-------------------------------------------------------*) + (* handle any errors in references by ignoring them. *) + (*-------------------------------------------------------*) + handle SyntaxError caq => caq + | NoSuchEntity aq => getChar aq + + (*--------------------------------------------------------------*) + (* handle an end-tag. finish the element in the user data and *) + (* return. *) + (* *) + (* print an error if the element's content is not yet finished. *) + (* print an error if the end-tag is for another element. *) + (* print an error if the element's first character was not in *) + (* the same entity. *) + (*--------------------------------------------------------------*) + and do_etag (p,etag as (elem,space,startPos,endPos),(c,a,q)) = + let + fun checkNesting a = + if getEntId q=startEnt then a + else hookError(a,(startPos,ERR_ELEM_ENT_NESTING(Index2Element dtd curr))) + in + if elem=curr then let val a1 = fin_elem (a,startPos,dfa,p) + val a2 = checkNesting a1 + val a3 = hookEndTag + (a2,((startPos,endPos),curr,SOME(elem,space))) + in (NONE,(c,a3,q)) + end + else if member elem openElems + then let val err = ERR_OMITTED_END_TAG(Index2Element dtd curr) + val a1 = hookError(a,(startPos,err)) + val a2 = fin_elem (a1,startPos,dfa,p) + val a3 = hookEndTag(a2,((startPos,endPos),curr,NONE)) + in (SOME etag,(c,a3,q)) + end + else if dfaFinal(dfa,p) + then let val err = ERR_ELEM_TYPE_MATCH(Index2Element dtd curr, + Index2Element dtd elem) + val a1 = hookError(a,(startPos,err)) + val a2 = checkNesting a1 + val a3 = hookEndTag(a2,((startPos,endPos),curr,SOME(elem,space))) + in (NONE,(c,a3,q)) + end + else let val err = ERR_IGNORED_END_TAG(Index2Element dtd curr, + Index2Element dtd elem) + val a1 = hookError(a,(startPos,err)) + in do_elem(p,(c,a1,q)) + end + end + + (*--------------------------------------------------------------*) + (* handle a declaration, proc. instr or tag. *) + (*--------------------------------------------------------------*) + and do_lt (p,q,(c1,a1,q1)) = + case c1 + of 0wx21 (* #"!" *) => + (*------------------------------------------------------*) + (* its a declaration, cdata section or comment. *) + (* Only comments are valid. *) + (*------------------------------------------------------*) + let val (c2,a2,q2) = getChar(a1,q1) + val caq3 = + case c2 + of 0wx2D (* #"-" *) => + let val (c3,a3,q3) = getChar(a2,q2) + in if c3=0wx2D then parseComment (getPos q) (a3,q3) + else let val err = ERR_EXPECTED(expDash,[c3]) + val a4 = hookError(a3,(getPos q3,err)) + in recoverDecl false (c3,a4,q3) + end + end + | 0wx5B (* #"[" *) => + let val a3 = hookError(a2,(getPos q2,ERR_ELEM_CONTENT IT_CDATA)) + in skipBadSection (getChar(a3,q2)) + end + | _ => (c2,hookError(a2,(getPos q2,ERR_EXPECTED(expDash,[c2]))),q2) + in do_elem(p,caq3) + end + | 0wx2F (* #"/" *) => + (let val (elem,space,endPos,caq2) = parseETag dtd (a1,q1) + in do_etag (p,(elem,space,getPos q,endPos),caq2) + end + handle SyntaxError caq => do_elem(p,caq)) + | 0wx3F (* #"?" *) => do_elem (p,parseProcInstr (getPos q) (a1,q1)) + | _ => + (*------------------------------------------------------*) + (* it's a start tag. the recursive call to parseElement *) + (* might return an end-tag that has to be consumed. *) + (*------------------------------------------------------*) + if isNms c1 then + let val (p1,(opt,caq2)) = + (let val (stag as ((_,elem,_,_,_),_),(c2,a2,q2)) = + parseSTag dtd (getPos q) (c1,a1,q1) + val (p1,a3) = trans_elem (a2,q1,dfa,p,elem) + in (p1,parseElement (dtd,curr::openElems,q,stag,(c2,a3,q2))) + end) + handle SyntaxError caq => (p,(NONE,caq)) + in case opt + of NONE => do_elem (p1,caq2) + | SOME etag => do_etag (p1,etag,caq2) + end + else let val err = ERR_FORBIDDEN_HERE(IT_CHAR 0wx3C,LOC_CONTENT) + val a2 = hookError(a1,(getPos q,err)) + in do_elem (p,(c1,a2,q1)) + end + + (*--------------------------------------------------------------*) + (* do element content. handle the document end by printing an *) + (* error and finishing like with an end-tag. *) + (*--------------------------------------------------------------*) + and do_elem (p,(c,a,q)) = + case c + of 0wx00 => if isSpecial q + then let val err = ERR_OMITTED_END_TAG(Index2Element dtd curr) + val a1 = hookError(a,(getPos q,err)) + val pos = getPos q + val a2 = fin_elem (a1,pos,dfa,p) + val a3 = hookEndTag(a2,((pos,pos),curr,NONE)) + in (NONE,(c,a3,q)) + end + else let val a1 = hookEntEnd(a,getPos q) + in do_elem (p,getChar(a1,q)) + end + | 0wx26 (* #"&" *) => do_elem (p,do_ref (q,getChar(a,q))) + | 0wx3C (* #"<" *) => do_lt (p,q,getChar(a,q)) + | _ => do_elem (p,do_char_elem (c,a,q)) + + (*--------------------------------------------------------------*) + (* do empty content. if the first thing to come is the current *) + (* element's end-tag, finish it. Otherwise print an error and *) + (* continue as for element content. *) + (*--------------------------------------------------------------*) + and do_empty (c,a,q) = + if c<>0wx3C (* #"<" *) + then let val a1 = hookError(a,(getPos q,ERR_NONEMPTY(Index2Element dtd curr))) + in do_elem (dfaInitial,(c,a1,q)) + end + else + let val (c1,a1,q1) = getChar(a,q) + in if c1<>0wx2F (* #"/" *) + then let val err = ERR_NONEMPTY(Index2Element dtd curr) + val a2 = hookError(a1,(getPos q,err)) + in do_lt (dfaInitial,q,(c1,a2,q1)) + end + else let val (elem,space,endPos,caq2) = parseETag dtd (a1,q1) + in do_etag (dfaInitial,(elem,space,getPos q,endPos),caq2) + end + handle SyntaxError caq => do_elem (dfaInitial,caq) + end + + in if mt then do_empty caq + else do_elem (dfaInitial,caq) + end + + (*--------------------------------------------------------------------*) + (* parse mixed or any content. The second arg holds the unique number *) + (* of the element's first characters's entity, the idx of the current *) + (* element, and a function for validating child elements. Cf. 3: *) + (* *) + (* [39] element ::= EmptyElemTag *) + (* | STag content ETag *) + (* ... *) + (* Well-Formedness Constraint: Element Type Match *) + (* The Name in an element's end-tag must match the element type in *) + (* the start-tag. *) + (* *) + (* Validity Constraint: Element Valid *) + (* An element is valid if there is a declaration matching *) + (* elementdecl where the Name matches the element type, and one of *) + (* the following holds: *) + (* ... *) + (* 3. The declaration matches Mixed and the content consists of *) + (* character data and child elements whose types match names in *) + (* the content model. *) + (* 4. The declaration matches ANY, and the types of any child *) + (* elements have been declared. *) + (* *) + (* 3.1: *) + (* *) + (* [43] content ::= (element | CharData | Reference | CDSect | PI *) + (* | Comment)* *) + (* 2.4: *) + (* The ampersand character (&) and the left angle bracket (<) may *) + (* appear in their literal form only when used as markup delimiters,*) + (* or within a comment, a processing instruction, or a CDATA *) + (* section... If they are needed elsewhere, they must be escaped *) + (* using either numeric character references or the strings "&" *) + (* and "<" respectively. The right angle bracket (>) may be *) + (* represented using the string ">", and must, for compatibility,*) + (* be escaped using ">" or a character reference when it appears *) + (* in the string "]]>" in content, when that string is not marking *) + (* the end of a CDATA section. *) + (* *) + (* consume the content of the element, accumulating it via the user *) + (* data functions (parameter a in subfunctions). for each child, *) + (* check whether it was specified in the element's Mixed content *) + (* specification (validate). finish at the first end-tag, whether *) + (* matching or not, or at the document end. *) + (* *) + (* handle all syntax and other recoverable errors from subfunctions *) + (* and try to continue. *) + (* *) + (* return the accumulated user data and the next char and state. *) + (*--------------------------------------------------------------------*) + (* might raise: none *) + (*--------------------------------------------------------------------*) + and parseMixedContent dtd (openElems,startEnt,curr,validate) caq = + let + (*--------------------------------------------------------------*) + (* read data characters until the next "<", "&" or entity end. *) + (* add the data to the user data when an error occurs or no *) + (* more data follows. *) + (* *) + (* return the modified user data with the next char and state. *) + (*--------------------------------------------------------------*) + fun do_data (br,(c0,a0,q0)) = + let + val pos0 = ref (getPos q0) + val _ = Array.update(dataBuffer,0,c0) + + fun data_hook (i,(a,q)) = + hookData(a,((!pos0,getPos q),Array.extract(dataBuffer,0,SOME i),false)) + fun takeOne (c,qE,i,aq as (a,q)) = + if i (c1,data_hook(i,(a1,q)),q1) + | 0wx26 (* #"&" *) => (c1,data_hook(i,(a1,q)),q1) + | 0wx3C (* #"<" *) => (c1,data_hook(i,(a1,q)),q1) + | 0wx5D (* #"]" *) => do_br (n+1,takeOne(c1,q,i,(a1,q1))) + | 0wx3E (* #">" *) => + let val a2 = if n=1 then a1 + else hookError(a1,(getPos q1,ERR_MUST_ESCAPE c1)) + in doit (takeOne(c1,q,i,(a2,q1))) + end + | _ => doit (takeOne(c1,q,i,(a1,q1))) + end + and doit (i,aq as (_,q)) = + let val (c1,a1,q1) = getChar aq + in case c1 + of 0wx00 => (c1,data_hook(i,(a1,q)),q1) + | 0wx26 (* #"&" *) => (c1,data_hook(i,(a1,q)),q1) + | 0wx3C (* #"<" *) => (c1,data_hook(i,(a1,q)),q1) + | 0wx5D (* #"]" *) => if !O_COMPATIBILITY + then do_br (1,takeOne(c1,q,i,(a1,q1))) + else doit (takeOne(c1,q,i,(a1,q1))) + | _ => doit (takeOne(c1,q,i,(a1,q1))) + end + in + if br then do_br (1,(1,(a0,q0))) + else doit (1,(a0,q0)) + end + (* + fun do_data (br,(c0,a0,q0)) = + let + fun data_hook (yet,(a,q)) = + hookData(a,((getPos q0,getPos q),Data2Vector(rev yet),false)) + fun do_br (n,yet,aq as (_,q)) = + let val (c1,a1,q1) = getChar aq + in case c1 + of 0wx00 => (c1,data_hook(yet,(a1,q)),q1) + | 0wx26 (* #"&" *) => (c1,data_hook(yet,(a1,q)),q1) + | 0wx3C (* #"<" *) => (c1,data_hook(yet,(a1,q)),q1) + | 0wx5D (* #"]" *) => do_br (n+1,c1::yet,(a1,q1)) + | 0wx3E (* #">" *) => + let val a2 = if n=1 then a1 + else hookError(a1,(getPos q1,ERR_MUST_ESCAPE c1)) + in doit (c1::yet,(a2,q1)) + end + | _ => doit (c1::yet,(a1,q1)) + end + and doit (yet,aq as (_,q)) = + let val (c1,a1,q1) = getChar aq + in case c1 + of 0wx00 => (c1,data_hook(yet,(a1,q)),q1) + | 0wx26 (* #"&" *) => (c1,data_hook(yet,(a1,q)),q1) + | 0wx3C (* #"<" *) => (c1,data_hook(yet,(a1,q)),q1) + | 0wx5D (* #"]" *) => if !O_COMPATIBILITY + then do_br (1,c1::yet,(a1,q1)) + else doit (c1::yet,(a1,q1)) + | _ => doit (c1::yet,(a1,q1)) + end + in + if br then do_br (1,[0wx5D],(a0,q0)) + else doit ([c0],(a0,q0)) + end + *) + + (*--------------------------------------------------------------*) + (* consume a reference, handling errors by ignoring them. *) + (*--------------------------------------------------------------*) + fun do_ref (q0,(c,a,q)) = + if c=0wx23 (* #"#" *) + (*------------------------------------------------------*) + (* it's a character reference. *) + (*------------------------------------------------------*) + then let val (cs,(ch,a1,q1)) = parseCharRefLit [0wx23,0wx26] (a,q) + val cv = Data2Vector(rev cs) + val a2 = hookCharRef(a1,((getPos q0,getPos q1),ch,cv)) + in getChar(a2,q1) + end + handle SyntaxError caq => caq + | NoSuchChar aq => getChar aq + (*---------------------------------------------------------*) + (* it's a general entity reference. *) + (*---------------------------------------------------------*) + else let val ((id,ent),(a1,q1)) = parseGenRef dtd (c,a,q) + in case ent + of GE_NULL => + let val a2 = hookGenRef(a1,((getPos q0,getPos q1),id,ent,false)) + in getChar(a2,q1) + end + | GE_INTERN(_,rep) => + let + val q2 = pushIntern(q1,id,false,rep) + val a2 = hookGenRef(a1,((getPos q0,getPos q1),id,ent,true)) + in getChar(a2,q2) + end + | GE_EXTERN ext => + if !O_VALIDATE orelse !O_INCLUDE_EXT_PARSED + then + let + val a2 = hookGenRef(a1,((getPos q0,getPos q1),id,ent,true)) + val caq3 = #3(openExtern (id,false,resolveExtId ext) (a2,q1)) + handle CantOpenFile(fmsg,a) + => let val err = ERR_NO_SUCH_FILE fmsg + val a1 = hookError(a,(getPos q1,err)) + val a2 = hookEntEnd(a1,getPos q1) + in (getChar(a2,q1)) + end + in caq3 + end + else let val a2 = hookGenRef(a1,((getPos q0,getPos q1),id,ent,false)) + in getChar(a2,q1) + end + | GE_UNPARSED _ => + raise InternalError + ("THIS_MODULE","parseMixedContent", + "parseGenRef returned GE_UNPARSED") + end + (*-------------------------------------------------------*) + (* handle any errors in references by ignoring them. *) + (*-------------------------------------------------------*) + handle SyntaxError caq => caq + | NoSuchEntity aq => getChar aq + + (*--------------------------------------------------------------*) + (* handle an end-tag. finish the element in the user data and *) + (* return. *) + (* *) + (* print an error if the element's content is not yet finished. *) + (* print an error if the end-tag is for another element. *) + (* print an error if the element's first character was not in *) + (* the same entity. *) + (*--------------------------------------------------------------*) + and do_etag (etag as (elem,space,startPos,endPos),(c,a,q)) = + let + fun checkNesting a = + if getEntId q=startEnt then a + else hookError(a,(startPos,ERR_ELEM_ENT_NESTING(Index2Element dtd curr))) + in + if elem=curr then let val a1 = checkNesting a + val a2 = hookEndTag + (a1,((startPos,endPos),curr,SOME(elem,space))) + in (NONE,(c,a2,q)) + end + else if member elem openElems + then let val err = ERR_OMITTED_END_TAG(Index2Element dtd curr) + val a1 = hookError(a,(startPos,err)) + val a2 = hookEndTag(a1,((startPos,endPos),curr,NONE)) + in (SOME etag,(c,a2,q)) + end + else let val err = ERR_ELEM_TYPE_MATCH(Index2Element dtd curr, + Index2Element dtd elem) + val a1 = hookError(a,(startPos,err)) + val a2 = checkNesting a1 + val a3 = hookEndTag(a2,((startPos,endPos),curr,SOME(elem,space))) + in (NONE,(c,a3,q)) + end + end + + (*--------------------------------------------------------------*) + (* handle a declaration, proc. instr or tag. If it is an end- *) + (* tag, finish the element in the user data and return. *) + (* *) + (* print an error if the element's content is not yet finished. *) + (* print an error if the end-tag is for another element. *) + (* print an error if the element's first character was not in *) + (* the same entity. *) + (*--------------------------------------------------------------*) + and do_lt (q,(c1,a1,q1)) = + case c1 + of 0wx21 (* #"!" *) => + (*------------------------------------------------------*) + (* its a declaration, cdata section or comment. *) + (* Only comments and cdata sections are valid. *) + (*------------------------------------------------------*) + let val (c2,a2,q2) = getChar(a1,q1) + val caq3 = + case c2 + of 0wx2D (* #"-" *) => + let val (c3,a3,q3) = getChar(a2,q2) + in if c3=0wx2D then parseComment (getPos q) (a3,q3) + else let val err = ERR_EXPECTED(expDash,[c3]) + val a4 = hookError(a3,(getPos q3,err)) + in recoverDecl false (c3,a4,q3) + end + end + | 0wx5B (* #"[" *) => parseCDataSection (getPos q) (a2,q2) + | _ => + (c2,hookError(a2,(getPos q2,ERR_EXPECTED(expDashLbrack,[c2]))),q2) + in do_mixed caq3 + end + | 0wx2F (* #"/" *) => + (let val (elem,space,endPos,caq2) = parseETag dtd (a1,q1) + in do_etag ((elem,space,getPos q,endPos),caq2) + end + handle SyntaxError caq => do_mixed caq) + | 0wx3F (* #"?" *) => do_mixed (parseProcInstr (getPos q) (a1,q1)) + | _ => + (*------------------------------------------------------*) + (* it's a start tag. the recursive call to parseElement *) + (* might return an end-tag that has to be consumed. *) + (*------------------------------------------------------*) + if isNms c1 then + let val (opt,caq2) = + (let val (stag as ((_,elem,_,_,_),_),(c2,a2,q2)) = + parseSTag dtd (getPos q) (c1,a1,q1) + val a3 = validate (a2,q1) elem + in parseElement (dtd,curr::openElems,q,stag,(c2,a3,q2)) + end + handle SyntaxError caq => (NONE,caq)) + in case opt + of NONE => do_mixed caq2 + | SOME etag => do_etag (etag,caq2) + end + else let val err = ERR_FORBIDDEN_HERE(IT_CHAR 0wx3C,LOC_CONTENT) + val a2 = hookError(a1,(getPos q,err)) + in do_mixed (c1,a2,q1) + end + + (*--------------------------------------------------------------*) + (* do mixed content. handle the document end by printing an *) + (* error and finishing like with an end-tag. *) + (*--------------------------------------------------------------*) + and do_mixed (c,a,q) = + case c + of 0wx00 => if isSpecial q + then let val err = ERR_OMITTED_END_TAG(Index2Element dtd curr) + val a1 = hookError(a,(getPos q,err)) + val pos = getPos q + val a2 = hookEndTag(a1,((pos,pos),curr,NONE)) + in (NONE,(c,a2,q)) + end + else let val a1 = hookEntEnd(a,getPos q) + in do_mixed (getChar(a1,q)) + end + | 0wx26 (* #"&" *) => do_mixed (do_ref (q,getChar(a,q))) + | 0wx3C (* #"<" *) => do_lt (q,getChar(a,q)) + | 0wx5D => do_mixed (do_data (!O_COMPATIBILITY,(c,a,q))) + | _ => do_mixed (do_data (false,(c,a,q))) + in + do_mixed caq + end + + (*--------------------------------------------------------------------*) + (* parse an element, the start tag already read. the second arg holds *) + (* the number of the entity of the start-tag's first char, and the *) + (* start-tag information. The 1st arg is the start value for the user *) + (* data. 3: *) + (* *) + (* [39] element ::= EmptyElemTag *) + (* | STag content ETag *) + (* and 3.1: *) + (* *) + (* Empty-element tags may be used for any element which has no *) + (* content, whether or not it is declared using the keyword EMPTY. *) + (* For interoperability, the empty-element tag must be used, and *) + (* can only be used, for elements which are declared EMPTY. *) + (*--------------------------------------------------------------------*) + and parseElement (dtd,openElems,q0,(stag as (_,curr,_,_,mt),elemInfo),(c,a,q)) = + let + (*--------------------------------------------------------------*) + (* validate whether an element is allowed in mixed/any content. *) + (*--------------------------------------------------------------*) + fun trans_any (a,_) _ = a + fun trans_mixed is (a,q) i = + if member i is then a + else let val err = ERR_BAD_ELEM(Index2Element dtd curr,Index2Element dtd i) + in hookError(a,(getPos q,err)) + end + in + (*-----------------------------------------------------------*) + (* For empty-element tags, verify that the element's declar. *) + (* allows empty content. *) + (*-----------------------------------------------------------*) + if mt then + let val a1 = + if not (!O_VALIDATE andalso hasDtd dtd) then a + else + case #decl elemInfo + of (SOME(CT_EMPTY,_)) => a + | (SOME(CT_ELEMENT(_,dfa),_)) => + if not (dfaFinal(dfa,dfaInitial)) + then hookError(a,(getPos q0,ERR_EMPTY_TAG(Index2Element dtd curr))) + else if not (!O_INTEROPERABILITY) then a + else hookError + (a,(getPos q0,ERR_EMPTY_TAG_INTER (Index2Element dtd curr))) + | _ => if not (!O_INTEROPERABILITY) then a + else hookError(a,(getPos q0,ERR_EMPTY_TAG_INTER + (Index2Element dtd curr))) + in (NONE,(c,hookStartTag(a1,stag),q)) + end + (*-----------------------------------------------------------*) + (* for normal start-tags, check whether the element's decl. *) + (* requires an empty-element tag, or empty content, then *) + (* call the appropriate function that parses the content. *) + (*-----------------------------------------------------------*) + else + let val startEnt = getEntId q0 + in if !O_VALIDATE then + case getOpt(#decl elemInfo,(CT_ANY,false)) + of (CT_ANY,_) => parseMixedContent dtd + (openElems,startEnt,curr,trans_any) (c,hookStartTag(a,stag),q) + | (CT_MIXED is,_) => parseMixedContent dtd + (openElems,startEnt,curr,trans_mixed is) (c,hookStartTag(a,stag),q) + | (CT_ELEMENT(_,dfa),ext) => parseElementContent dtd + (openElems,startEnt,curr,dfa,ext,false) + (c,hookStartTag(a,stag),q) + | (CT_EMPTY,_) => + let val a1 = if not (!O_INTEROPERABILITY) then a + else let val err = ERR_MUST_BE_EMPTY(Index2Element dtd curr) + in hookError(a,(getPos q0,err)) + end + val a2 = hookStartTag(a1,stag) + in parseElementContent dtd + (openElems,startEnt,curr,emptyDfa,false,true) (c,a2,q) + end + else parseMixedContent dtd + (openElems,startEnt,curr,trans_any) (c,hookStartTag(a,stag),q) + end + end +end +(* stop of ../../Parser/Parse/parseContent.sml *) +(* start of ../../Parser/Parse/parseDocument.sml *) +(*--------------------------------------------------------------------------*) +(* Structure: ParseDocument *) +(* *) +(* Exceptions raised by functions in this structure: *) +(* parseDocTypeDecl : none *) +(*--------------------------------------------------------------------------*) +functor Parse + (structure Dtd : Dtd + structure Hooks : Hooks + structure Resolve : Resolve + structure ParserOptions : ParserOptions) : + sig + val parseDocument : Uri.Uri option -> Dtd.Dtd option -> Hooks.AppData -> Hooks.AppFinal + end + = +struct + structure ParseBase = ParseBase (structure Dtd = Dtd + structure Hooks = Hooks + structure Resolve = Resolve + structure ParserOptions = ParserOptions) + + structure ParseContent = ParseContent (structure ParseBase = ParseBase) + + open + Base UniChar Errors UniClasses Uri + ParseContent + + val THIS_MODULE = "ParseContent" + + datatype Where = + PROLOG + | EPILOG + | INSTANCE of int option + + fun locOf wher = + case wher + of PROLOG => LOC_PROLOG + | INSTANCE _ => LOC_PROLOG + | EPILOG => LOC_EPILOG + + fun checkRoot dtd (a,q) (doc,stag as ((_,elem,_,_,_),_)) = + if !O_VALIDATE + then case doc + of NONE => a + | SOME doc => + if doc=elem then a + else let val err = ERR_ROOT_ELEM(Index2Element dtd doc, + Index2Element dtd elem) + in hookError(a,(getPos q,err)) + end + else a + + fun parseDoc dtd caq = + let + fun do_data wher caq = + let fun doit hadError ws (c,a,q) = + case c + of 0wx00 => (ws,(c,a,q)) + | 0wx26 (* #"&" *) => (ws,(c,a,q)) + | 0wx3C (* #"<" *) => (ws,(c,a,q)) + | 0wx09 (* #"\t"*) => doit hadError (c::ws) (getChar(a,q)) + | 0wx0A (* #"\n"*) => doit hadError (c::ws) (getChar(a,q)) + | 0wx20 (* #" " *) => doit hadError (c::ws) (getChar(a,q)) + | _ => let val a1 = if hadError then a + else hookError(a,(getPos q,ERR_FORBIDDEN_HERE + (IT_DATA nil,locOf wher))) + in doit true ws (getChar(a1,q)) + end + + val (ws,(c1,a1,q1)) = doit false nil caq + val a2 = if null ws then a1 + else hookWhite(a1,Data2Vector (rev ws)) + in (c1,a2,q1) + end + + fun do_decl wher q0 (c,a,q) = + case c + of 0wx2D (* #"-" *) => + let val (c1,a1,q1) = getChar(a,q) + in if c1=0wx2D then (wher,parseComment (getPos q0) (a1,q1)) + else let val err = ERR_EXPECTED(expDash,[c1]) + val a2 = hookError(a1,(getPos q1,err)) + val caq2 = recoverDecl false (c1,a2,q1) + in (wher,caq2) + end + end + | 0wx5B (* #"[" *) => + let + val err = ERR_FORBIDDEN_HERE (IT_CDATA,locOf wher) + val a1 = hookError(a,(getPos q0,err)) + val caq2 = skipBadSection (getChar(a1,q)) + in (wher,caq2) + end + | _ => + case wher + of PROLOG => + (let val (name,(c1,a1,q1)) = parseName (c,a,q) + handle NotFound (c,a,q) => + let val err = expectedOrEnded(expDashDocLbrk,LOC_DECL) c + in raise SyntaxError (c,hookError(a,(getPos q,err)),q) + end + + val _ = if name=[0wx44,0wx4f,0wx43,0wx54,0wx59,0wx50,0wx45] + (* "DOCTYPE" *) then () + else let val err = ERR_EXPECTED(expDashDocLbrk,name) + val a2 = hookError(a1,(getPos q,err)) + in raise SyntaxError (c1,a2,q1) + end + + val (doc,caq2) = parseDocTypeDecl dtd (c1,a1,q1) + in (INSTANCE doc,caq2) + end + handle SyntaxError caq => (PROLOG,recoverDecl true caq)) + + | _ => let val loc = if wher=EPILOG then LOC_EPILOG else LOC_AFTER_DTD + val err = ERR_FORBIDDEN_HERE (IT_DECL,loc) + val a1 = hookError(a,(getPos q0,err)) + val caq2 = skipDecl true (c,a1,q) + in (wher,caq2) + end + + and doit wher (c,a,q) = + case c + of 0wx00 => if isSpecial q then (wher,(a,q)) + else doit wher (getChar(a,q)) + (*--------------------------------------------------------------*) + (* References are forbidden outside the document element *) + (*--------------------------------------------------------------*) + | 0wx26 (* #"&" *) => + let + val (c1,a1,q1) = getChar(a,q) + val caq2 = + if c1=0wx23 (* #"#" *) + then let val err = ERR_FORBIDDEN_HERE(IT_CHAR_REF,locOf wher) + val a2 = hookError(a1,(getPos q,err)) + in skipCharRef (a2,q1) + end + else let val err = ERR_FORBIDDEN_HERE(IT_REF,locOf wher) + val a2 = hookError(a1,(getPos q,err)) + in skipReference (c1,a2,q1) + end + in doit wher caq2 + end + | 0wx3C (* #"<" *) => + let val (c1,a1,q1) = getChar (a,q) + in case c1 + of 0wx21 (* #"!" *) => + let val (wher1,caq2) = do_decl wher q (getChar(a1,q1)) + in doit wher1 caq2 + end + | 0wx2F (* #"/" *) => + let + val err = ERR_FORBIDDEN_HERE(IT_ETAG,locOf wher) + val a2 = hookError(a1,(getPos q,err)) + val caq3 = skipTag LOC_ETAG (a2,q1) + in doit wher caq3 + end + | 0wx3F (* #"?" *) => doit wher (parseProcInstr (getPos q) (a1,q1)) + | _ => + if isName c1 then + let val wher1 = + case wher + of PROLOG => INSTANCE NONE + | _ => wher + in case wher1 + of PROLOG => + raise InternalError(THIS_MODULE,"parseDoc.doit","") + | EPILOG => + let + val err = ERR_FORBIDDEN_HERE(IT_STAG,LOC_EPILOG) + val a2 = hookError(a1,(getPos q,err)) + val caq3 = skipTag LOC_STAG (a2,q1) + in doit EPILOG caq3 + end + | INSTANCE doc => + (let + val a2 = + if not (!O_VALIDATE) orelse isSome doc then a1 + else hookError(a1,(getPos q,ERR_NO_DTD)) + val (stag,(c3,a3,q3)) = parseSTag + dtd (getPos q) (c1,a2,q1) + val a4 = checkRoot dtd (a3,q1) (doc,stag) + val (opt,(c5,a5,q5)) = parseElement + (dtd,nil,q,stag,(c3,a4,q3)) + val a6 = checkDefinedIds dtd (a5,q5) + in case opt + of NONE => doit EPILOG (c5,a6,q5) + | SOME (_,_,startPos,_) => + let + val err = ERR_FORBIDDEN_HERE(IT_ETAG,LOC_EPILOG) + val a7 = hookError(a6,(startPos,err)) + in doit EPILOG (c5,a7,q5) + end + end + handle SyntaxError caq => doit wher1 caq) + end + else let val err = ERR_FORBIDDEN_HERE(IT_CHAR 0wx3C,locOf wher) + val a2 = hookError(a1,(getPos q,err)) + in doit wher (c1,a2,q1) + end + end + | _ => let val caq1 = do_data wher (c,a,q) + in doit wher caq1 + end + in + doit PROLOG caq + end + + (* to false. (cf. 2.9) *) + (* *) + (* ... If ... there is no standalone document declaration, the *) + (* value "no" is assumed. *) + fun parseDocument uriOpt dtdOpt a = + let + val dtd = case dtdOpt + of NONE => initDtdTables () + | SOME dtd => dtd + val (enc,xmlDecl,(c1,a1,q1)) = openDocument uriOpt a + val uri = getUri q1 + val alone = case xmlDecl + of (SOME(_,_,SOME sa)) => sa + | _ => false + val _ = if alone then setStandAlone dtd true else () + val a2 = hookXml(a1,(uri,enc,xmlDecl)) + val (wher,(a3,q3)) = parseDoc dtd (c1,a2,q1) + val _ = closeAll q3 + val a4 = case wher + of EPILOG => a3 + | _ => hookError(a3,(getPos q3,ERR_ENDED_IN_PROLOG)) + in hookFinish a4 + end + handle CantOpenFile(fmsg,a) => + let val a1 = hookError(a,(nullPosition,ERR_NO_SUCH_FILE fmsg)) + in hookFinish a1 + end +end +(* stop of ../../Parser/Parse/parseDocument.sml *) +(* start of ../../Catalog/catError.sml *) + + + + + + + + + + +signature CatError = + sig + type Position + val nullPosition : Position + val Position2String : Position -> string + + datatype Location = + LOC_CATALOG + | LOC_COMMENT + | LOC_NOCOMMENT + | LOC_PUBID + | LOC_SYSID + + datatype Expected = + EXP_NAME + | EXP_LITERAL + + datatype CatError = + ERR_DECODE_ERROR of Decode.Error.DecodeError + | ERR_NO_SUCH_FILE of string * string + | ERR_ILLEGAL_HERE of UniChar.Char * Location + | ERR_MISSING_WHITE + | ERR_EOF of Location + | ERR_EXPECTED of Expected * UniChar.Char + | ERR_XML of Errors.Error + | ERR_MISSING_ATT of UniChar.Data * UniChar.Data + | ERR_NON_PUBID of UniChar.Data * UniChar.Data + + val catMessage : CatError -> string list + end + +structure CatError : CatError = + struct + open Errors UtilError UtilString + + type Position = string * int * int + val nullPosition = ("",0,0) + + fun Position2String (fname,l,c) = + if fname="" then "" + else String.concat ["[",fname,":",Int2String l,".",Int2String c,"]"] + + datatype Location = + LOC_CATALOG + | LOC_COMMENT + | LOC_NOCOMMENT + | LOC_PUBID + | LOC_SYSID + + fun Location2String loc = + case loc + of LOC_CATALOG => "catalog file" + | LOC_COMMENT => "comment" + | LOC_NOCOMMENT => "something other than a comment" + | LOC_PUBID => "public identifier" + | LOC_SYSID => "system identifier" + + fun InLocation2String loc = + case loc + of LOC_CATALOG => "in a catalog file" + | LOC_COMMENT => "in a comment" + | LOC_NOCOMMENT => "outside of comments" + | LOC_PUBID => "in a public identifier" + | LOC_SYSID => "in a system identifier" + + datatype Expected = + EXP_NAME + | EXP_LITERAL + + fun Expected2String exp = + case exp + of EXP_NAME => "a name" + | EXP_LITERAL => "a literal" + + datatype CatError = + ERR_DECODE_ERROR of Decode.Error.DecodeError + | ERR_NO_SUCH_FILE of string * string + | ERR_ILLEGAL_HERE of UniChar.Char * Location + | ERR_MISSING_WHITE + | ERR_EOF of Location + | ERR_EXPECTED of Expected * UniChar.Char + | ERR_XML of Error + | ERR_MISSING_ATT of UniChar.Data * UniChar.Data + | ERR_NON_PUBID of UniChar.Data * UniChar.Data + + fun catMessage err = + case err + of ERR_DECODE_ERROR err => Decode.Error.decodeMessage err + | ERR_NO_SUCH_FILE(f,msg) => ["Could not open file",quoteErrorString f,"("^msg^")"] + + | ERR_ILLEGAL_HERE (c,loc) => + ["Character",quoteErrorChar c,"is not allowed",InLocation2String loc] + + | ERR_MISSING_WHITE => ["Missing white space"] + | ERR_EOF loc => [toUpperFirst (Location2String loc),"ended by end of file"] + | ERR_EXPECTED (exp,c) => + ["Expected",Expected2String exp,"but found",quoteErrorChar c] + + | ERR_XML err => errorMessage err + | ERR_MISSING_ATT(elem,att) => + ["Element",quoteErrorData elem,"has no",quoteErrorData att,"attribute"] + | ERR_NON_PUBID(att,cs) => + ["Value specified for attribute",quoteErrorData att,"contains non-PublicId", + case cs + of [c] => "character"^quoteErrorChar c + | cs => List2xString ("characters ",", ","") quoteErrorChar cs] + end +(* stop of ../../Catalog/catError.sml *) +(* start of ../../Catalog/catParams.sml *) + + + + + +signature CatParams = + sig + val O_CATALOG_FILES : Uri.Uri list ref + val O_PREFER_SOCAT : bool ref + val O_PREFER_SYSID : bool ref + val O_PREFER_CATALOG : bool ref + val O_SUPPORT_REMAP : bool ref + val O_CATALOG_ENC : Encoding.Encoding ref + + val catError : CatError.Position * CatError.CatError -> unit + end + +(* stop of ../../Catalog/catParams.sml *) +(* start of ../../Unicode/Uri/uriDict.sml *) + + + + + + + +structure KeyUri : Key = + struct + type Key = Uri.Uri + + val null = Uri.emptyUri + val compare = Uri.compareUri + val toString = Uri.Uri2String + val hash = Uri.hashUri + end + +structure UriDict = Dict (structure Key = KeyUri) +(* stop of ../../Unicode/Uri/uriDict.sml *) +(* start of ../../Catalog/catData.sml *) + + +structure CatData = + struct + datatype CatEntry = + E_BASE of Uri.Uri + | E_DELEGATE of string * Uri.Uri + | E_EXTEND of Uri.Uri + | E_MAP of string * Uri.Uri + | E_REMAP of Uri.Uri * Uri.Uri + + type Catalog = Uri.Uri * CatEntry list + end +(* stop of ../../Catalog/catData.sml *) +(* start of ../../Catalog/catFile.sml *) + + + + + + + + + +signature CatFile = + sig + type CatFile + type Position + + val catOpenFile : Uri.Uri -> CatFile + val catCloseFile : CatFile -> unit + val catGetChar : CatFile -> UniChar.Char * CatFile + val catPos : CatFile -> CatError.Position + end + +functor CatFile ( structure Params : CatParams ) : CatFile = + struct + open UniChar CatError Decode Params Uri UtilError + + (* column, line, break *) + type PosInfo = int * int * bool + val startPos = (0,1,false) + + datatype CatFile = + NOFILE of string * PosInfo + | DIRECT of DecFile * PosInfo + + fun catPos cf = + case cf + of NOFILE (uri,(col,line,_)) => (uri,line,col) + | DIRECT (dec,(col,line,_)) => (decName dec,line,col) + + fun catOpenFile uri = + let val dec = decOpenUni(SOME uri,!O_CATALOG_ENC) + in DIRECT(dec,startPos) + end + handle NoSuchFile fmsg => let val _ = catError(nullPosition,ERR_NO_SUCH_FILE fmsg) + in NOFILE(Uri2String uri,startPos) + end + + fun catCloseFile cf = + case cf + of NOFILE _ => () + | DIRECT(dec,_) => ignore (decClose dec) + + fun catGetChar cf = + case cf + of NOFILE _ => (0wx00,cf) + | DIRECT(dec,(col,line,brk)) => + (let val (c,dec1) = decGetChar dec + in case c + of 0wx09 => (c,DIRECT(dec1,(col+1,line,false))) + | 0wx0A => if brk then catGetChar(DIRECT(dec1,(col,line,false))) + else (c,DIRECT(dec1,(0,line+1,false))) + | 0wx0D => (0wx0A,DIRECT(dec1,(0,line+1,true))) + | _ => if c>=0wx20 then (c,DIRECT(dec1,(col+1,line,false))) + else let val err = ERR_ILLEGAL_HERE(c,LOC_CATALOG) + val _ = catError(catPos cf,err) + in catGetChar(DIRECT(dec1,(col+1,line,false))) + end + end + handle DecEof dec => (0wx00,NOFILE(decName dec,(col,line,brk))) + | DecError(dec,_,err) => + let val _ = catError(catPos cf,ERR_DECODE_ERROR err) + in catGetChar(DIRECT(dec,(col,line,false))) + end + ) + end + +(* stop of ../../Catalog/catFile.sml *) +(* start of ../../Catalog/socatParse.sml *) + + + + + + + + + +signature SocatParse = + sig + val parseSoCat : Uri.Uri -> CatData.Catalog + end + +functor SocatParse ( structure Params : CatParams ) : SocatParse = + struct + structure CatFile = CatFile ( structure Params = Params ) + + open CatData CatError CatFile Params UniChar UniClasses Uri + + exception SyntaxError of UniChar.Char * CatFile.CatFile + exception NotFound of UniChar.Char * CatFile.CatFile + + val getChar = catGetChar + + fun parseName' (c,f) = + if isName c then let val (cs,cf1) = parseName' (getChar f) + in (c::cs,cf1) + end + else (nil,(c,f)) + fun parseName (c,f) = + if isNms c then let val (cs,cf1) = parseName' (getChar f) + in (c::cs,cf1) + end + else raise NotFound (c,f) + + datatype Keyword = + KW_BASE + | KW_CATALOG + | KW_DELEGATE + | KW_PUBLIC + | KW_SYSTEM + | KW_OTHER of UniChar.Data + + fun parseKeyword cf = + let + val (name,cf1) = parseName cf + val kw = case name + of [0wx42,0wx41,0wx53,0wx45] => KW_BASE + | [0wx43,0wx41,0wx54,0wx41,0wx4c,0wx4f,0wx47] => KW_CATALOG + | [0wx44,0wx45,0wx4c,0wx45,0wx47,0wx41,0wx54,0wx45] => KW_DELEGATE + | [0wx50,0wx55,0wx42,0wx4c,0wx49,0wx43] => KW_PUBLIC + | [0wx53,0wx59,0wx53,0wx54,0wx45,0wx4d] => KW_SYSTEM + | _ => KW_OTHER name + in (kw,cf1) + end + + fun parseSysLit' quote f = + let + fun doit text (c,f) = + if c=quote then (text,getChar f) + else if c<>0wx0 then doit (c::text) (getChar f) + else let val _ = catError(catPos f,ERR_EOF LOC_SYSID) + in (text,(c,f)) + end + val (text,cf1) = doit nil (getChar f) + in (Data2Uri(rev text),cf1) + end + fun parseSysLit req (c,f) = + if c=0wx22 orelse c=0wx27 then parseSysLit' c f + else if req then let val _ = catError(catPos f,ERR_EXPECTED(EXP_LITERAL,c)) + in raise SyntaxError (c,f) + end + else raise NotFound (c,f) + + fun parsePubLit' quote f = + let + fun doit (hadSpace,atStart,text) (c,f) = + case c + of 0wx0 => let val _ = catError(catPos f,ERR_EOF LOC_PUBID) + in (text,(c,f)) + end + | 0wx0A => doit (true,atStart,text) (getChar f) + | 0wx20 => doit (true,atStart,text) (getChar f) + | _ => + if c=quote then (text,getChar f) + else if isPubid c + then if hadSpace andalso not atStart + then doit (false,false,c::0wx20::text) (getChar f) + else doit (false,false,c::text) (getChar f) + else let val _ = catError(catPos f,ERR_ILLEGAL_HERE(c,LOC_PUBID)) + in doit (hadSpace,atStart,text) (getChar f) + end + val (text,cf1) = doit (false,true,nil) (getChar f) + in (Latin2String(rev text),cf1) + end + fun parsePubLit (c,f) = + if c=0wx22 orelse c=0wx27 then parsePubLit' c f + else let val _ = catError(catPos f,ERR_EXPECTED(EXP_LITERAL,c)) + in raise SyntaxError (c,f) + end + + fun skipComment (c,f) = + case c + of 0wx00 => let val _ = catError(catPos f,ERR_EOF LOC_COMMENT) + in (c,f) + end + | 0wx2D => let val (c1,f1) = getChar f + in if c1 = 0wx2D then (getChar f1) else skipComment (c1,f1) + end + | _ => skipComment (getChar f) + fun skipCopt (c,f) = + case c + of 0wx00 => (c,f) + | 0wx2D => let val (c1,f1) = getChar f + in if c1=0wx2D then skipComment (getChar f1) + else let val _ = catError(catPos f,ERR_ILLEGAL_HERE(c,LOC_NOCOMMENT)) + in (c1,f1) + end + end + | _ => (c,f) + + fun skipScomm req0 cf = + let + fun endit req (c,f) = + if req andalso c<>0wx00 + then let val _ = catError(catPos f,ERR_MISSING_WHITE) + in (c,f) + end + else (c,f) + fun doit req (c,f) = + case c + of 0wx00 => endit req (c,f) + | 0wx09 => doit false (getChar f) + | 0wx0A => doit false (getChar f) + | 0wx20 => doit false (getChar f) + | 0wx22 => endit req (c,f) + | 0wx27 => endit req (c,f) + | 0wx2D => + let val (c1,f1) = getChar f + in if c1=0wx2D + then let val _ = if not req then () + else catError(catPos f1,ERR_MISSING_WHITE) + val cf1 = skipComment (getChar f1) + in doit true cf1 + end + else let val _ = catError(catPos f,ERR_ILLEGAL_HERE(c,LOC_NOCOMMENT)) + in doit req (c1,f1) + end + end + | _ => if isNms c then endit req (c,f) + else let val _ = catError(catPos f,ERR_ILLEGAL_HERE(c,LOC_NOCOMMENT)) + in doit req (getChar f) + end + in doit req0 cf + end + + val skipWS = skipScomm true + val skipCommWS = (skipScomm false) o skipCopt + val skipWSComm = skipScomm false + + fun skipOther cf = + let + val cf1 = skipWS cf + val cf2 = let val (_,cf') = parseName cf1 + in skipWS cf' + end + handle NotFound cf => cf + + fun doit cf = + let val (_,cf1) = parseSysLit false cf + in doit (skipWS cf1) + end + handle NotFound(c,f) => (c,f) + in + (NONE,doit cf2) + end + + fun parseBase cf = + let + val cf1 = skipWS cf + val (lit,cf2) = parseSysLit true cf1 + val cf3 = skipWS cf2 + in + (SOME(E_BASE lit),cf3) + end + + fun parseExtend cf = + let + val cf1 = skipWS cf + val (lit,cf2) = parseSysLit true cf1 + val cf3 = skipWS cf2 + in + (SOME(E_EXTEND lit),cf3) + end + + fun parseDelegate cf = + let + val cf1 = skipWS cf + val (pub,cf2) = parsePubLit cf1 + val cf3 = skipWS cf2 + val (sys,cf4) = parseSysLit true cf3 + val cf5 = skipWS cf4 + in + (SOME(E_DELEGATE(pub,sys)),cf5) + end + + fun parseRemap cf = + let + val cf1 = skipWS cf + val (sys0,cf2) = parseSysLit true cf1 + val cf3 = skipWS cf2 + val (sys,cf4) = parseSysLit true cf3 + val cf5 = skipWS cf4 + in + (SOME(E_REMAP(sys0,sys)),cf5) + end + + fun parseMap cf = + let + val cf1 = skipWS cf + val (pub,cf2) = parsePubLit cf1 + val cf3 = skipWS cf2 + val (sys,cf4) = parseSysLit true cf3 + val cf5 = skipWS cf4 + in + (SOME(E_MAP(pub,sys)),cf5) + end + + fun recover cf = + let + fun do_lit q (c,f) = + if c=0wx00 then (c,f) + else if c=q then getChar f + else do_lit q (getChar f) + fun do_com (c,f) = + case c + of 0wx00 => (c,f) + | 0wx2D => let val (c1,f1) = getChar f + in if c1=0wx2D then getChar f1 + else do_com (c1,f1) + end + | _ => do_com (getChar f) + fun doit (c,f) = + case c + of 0wx00 => (c,f) + | 0wx22 => doit (do_lit c (getChar f)) + | 0wx27 => doit (do_lit c (getChar f)) + | 0wx2D => let val (c1,f1) = getChar f + in if c1=0wx2D then doit (do_com (getChar f1)) + else doit (c1,f1) + end + | _ => if isNms c then (c,f) + else doit (getChar f) + in doit cf + end + + fun parseEntry (cf as (c,f)) = + let val (kw,cf1) = parseKeyword cf handle NotFound cf => raise SyntaxError cf + in case kw + of KW_BASE => parseBase cf1 + | KW_CATALOG => parseExtend cf1 + | KW_DELEGATE => parseDelegate cf1 + | KW_SYSTEM => parseRemap cf1 + | KW_PUBLIC => parseMap cf1 + | KW_OTHER _ => skipOther cf1 + end + handle SyntaxError cf => (NONE,recover cf) + + fun parseDocument cf = + let + fun doit (c,f) = + if c=0wx0 then nil before catCloseFile f + else let val (opt,cf1) = parseEntry (c,f) + val entries = doit cf1 + in case opt + of NONE => entries + | SOME entry => entry::entries + end + + val cf1 = skipCommWS cf + in + doit cf1 + end + + fun parseSoCat uri = + let + val f = catOpenFile uri + val cf1 = getChar f + in + (uri,parseDocument cf1) + end + end +(* stop of ../../Catalog/socatParse.sml *) +(* start of ../../Catalog/catDtd.sml *) +signature CatDtd = + sig + type Dtd + + val baseIdx : int + val delegateIdx : int + val extendIdx : int + val mapIdx : int + val remapIdx : int + + val hrefIdx : int + val pubidIdx : int + val sysidIdx : int + + val Index2AttNot : Dtd -> int -> UniChar.Data + val Index2Element : Dtd -> int -> UniChar.Data + end + +structure CatDtd = + struct + open Dtd + + val baseGi = UniChar.String2Data "Base" + val delegateGi = UniChar.String2Data "Delegate" + val extendGi = UniChar.String2Data "Extend" + val mapGi = UniChar.String2Data "Map" + val remapGi = UniChar.String2Data "Remap" + + val hrefAtt = UniChar.String2Data "HRef" + val pubidAtt = UniChar.String2Data "PublicId" + val sysidAtt = UniChar.String2Data "SystemId" + + fun initDtdTables () = + let + val dtd = Dtd.initDtdTables() + val _ = app (ignore o (Element2Index dtd)) [baseGi,delegateGi,extendGi,mapGi,remapGi] + val _ = app (ignore o (AttNot2Index dtd)) [hrefAtt,pubidAtt,sysidAtt] + in dtd + end + + local + val dtd = initDtdTables() + in + val baseIdx = Element2Index dtd baseGi + val delegateIdx = Element2Index dtd delegateGi + val extendIdx = Element2Index dtd extendGi + val mapIdx = Element2Index dtd mapGi + val remapIdx = Element2Index dtd remapGi + + val hrefIdx = AttNot2Index dtd hrefAtt + val pubidIdx = AttNot2Index dtd pubidAtt + val sysidIdx = AttNot2Index dtd sysidAtt + end + end +(* stop of ../../Catalog/catDtd.sml *) +(* start of ../../Parser/Params/ignore.sml *) +structure IgnoreHooks = + struct + type AppData = unit + type AppFinal = unit + + fun hookXml(a,_) = a + fun hookFinish a = a + + fun hookError(a,_) = a + fun hookWarning(a,_) = a + + fun hookProcInst(a,_) = a + fun hookComment(a,_) = a + fun hookWhite(a,_) = a + fun hookDecl (a,_) = a + + fun hookStartTag(a,_) = a + fun hookEndTag(a,_) = a + fun hookCData(a,_) = a + fun hookData(a,_) = a + + fun hookCharRef(a,_) = a + fun hookGenRef(a,_) = a + fun hookParRef(a,_) = a + fun hookEntEnd(a,_) = a + + fun hookDocType(a,_) = a + fun hookSubset(a,_) = a + fun hookExtSubset(a,_) = a + fun hookEndDtd(a,_) = a + end +(* stop of ../../Parser/Params/ignore.sml *) +(* start of ../../Catalog/catHooks.sml *) +signature CatHooks = + sig + type AppData = CatData.CatEntry list + + val initCatHooks : unit -> AppData + end + +functor CatHooks (structure Params : CatParams + structure Dtd : CatDtd ) = + struct + open + Dtd HookData IgnoreHooks Params UniChar UniClasses Uri UtilList + CatData CatError + + type AppData = Dtd * CatEntry list + type AppFinal = CatEntry list + + fun initCatHooks dtd = (dtd,nil) + + fun hookError (a,(pos,err)) = a before catError (pos,ERR_XML err) + + fun getAtt dtd (pos,elem,att,trans) atts = + let + val cvOpt = findAndMap + (fn (i,ap,_) => if i<>att then NONE + else case ap + of AP_DEFAULT(_,cv,_) => SOME cv + | AP_PRESENT(_,cv,_) => SOME cv + | _ => NONE) + atts + in case cvOpt + of SOME cv => trans (pos,att) cv + | NONE => NONE before catError + (pos,ERR_MISSING_ATT(Index2Element dtd elem,Index2AttNot dtd att)) + end + + fun makePubid dtd (pos,att) cv = + let val (cs,bad) = + Vector.foldr + (fn (c,(cs,bad)) => if isPubid c then (Char2char c::cs,bad) + else (cs,c::bad)) + (nil,nil) cv + in if null bad then SOME(String.implode cs) + else NONE before catError(pos,ERR_NON_PUBID(Index2AttNot dtd att,bad)) + end + + fun makeUri (pos,att) cv = SOME cv + + fun hookStartTag (a as (dtd,items),((_,pos),elem,atts,_,_)) = + if elem=baseIdx + then let val hrefOpt = getAtt dtd (pos,elem,hrefIdx,makeUri) atts + in case hrefOpt + of NONE => a + | SOME href => (dtd,E_BASE (Vector2Uri href)::items) + end + else if elem=delegateIdx + then let val hrefOpt = getAtt dtd (pos,elem,hrefIdx,makeUri) atts + val pubidOpt = getAtt dtd (pos,elem,pubidIdx,makePubid dtd) atts + in case (hrefOpt,pubidOpt) + of (SOME href,SOME pubid) => + (dtd,E_DELEGATE(pubid,Vector2Uri href)::items) + | _ => a + end + else if elem=extendIdx + then let val hrefOpt = getAtt dtd (pos,elem,hrefIdx,makeUri) atts + in case hrefOpt + of NONE => a + | SOME href => (dtd,E_EXTEND (Vector2Uri href)::items) + end + else if elem=mapIdx + then let val hrefOpt = getAtt dtd (pos,elem,hrefIdx,makeUri) atts + val pubidOpt = getAtt dtd (pos,elem,pubidIdx,makePubid dtd) atts + in case (hrefOpt,pubidOpt) + of (SOME href,SOME pubid) => + (dtd,E_MAP(pubid,Vector2Uri href)::items) + | _ => a + end + else if elem=remapIdx + then let val hrefOpt = getAtt dtd (pos,elem,hrefIdx,makeUri) atts + val sysidOpt = getAtt dtd (pos,elem,sysidIdx,makeUri) atts + in case (hrefOpt,sysidOpt) + of (SOME href,SOME sysid) => + (dtd,E_REMAP(Vector2Uri sysid,Vector2Uri href)::items) + | _ => a + end + else a + + fun hookFinish (_,items) = rev items + end +(* stop of ../../Catalog/catHooks.sml *) +(* start of ../../Catalog/catParse.sml *) +signature CatParse = + sig + val parseCatalog : Uri.Uri -> CatData.Catalog + end + +functor CatParse (structure Params : CatParams) : CatParse = + struct + structure SocatParse = SocatParse (structure Params = Params) + + structure ParserOptions = + struct + structure Options = ParserOptions() + open Options + + local + fun setDefaults() = + let + val _ = setParserDefaults() + + val _ = O_WARN_MULT_ENUM := false + val _ = O_WARN_XML_DECL := false + val _ = O_WARN_ATT_NO_ELEM := false + val _ = O_WARN_MULT_ENT_DECL := false + val _ = O_WARN_MULT_NOT_DECL := false + val _ = O_WARN_MULT_ATT_DEF := false + val _ = O_WARN_MULT_ATT_DECL := false + val _ = O_WARN_SHOULD_DECLARE := false + + val _ = O_VALIDATE := false + val _ = O_COMPATIBILITY := false + val _ = O_INTEROPERABILITY := false + + val _ = O_INCLUDE_EXT_PARSED := true + in () + end + in + val setParserDefaults = setDefaults + end + + end + structure CatHooks = CatHooks (structure Params = Params + structure Dtd = CatDtd) + structure Parse = Parse (structure Dtd = CatDtd + structure Hooks = CatHooks + structure Resolve = ResolveNull + structure ParserOptions = ParserOptions) + + open CatHooks CatDtd Parse ParserOptions SocatParse Uri + + fun parseXmlCat uri = + let + val _ = setParserDefaults() + val dtd = initDtdTables() + val items = parseDocument (SOME uri) (SOME dtd) (initCatHooks dtd) + in + (uri,items) + end + + fun isSocatSuffix x = x="soc" orelse x="SOC" + fun isXmlSuffix x = x="xml" orelse x="XML" + + fun parseCatalog uri = + let val suffix = uriSuffix uri + in if isSocatSuffix suffix then parseSoCat uri + else (if isXmlSuffix suffix then parseXmlCat uri + else (if !O_PREFER_SOCAT then parseSoCat uri + else parseXmlCat uri)) + end + end +(* stop of ../../Catalog/catParse.sml *) +(* start of ../../Catalog/catalog.sml *) + + + + + + + + + +signature Catalog = + sig + val resolveExtId : string option * (Uri.Uri * Uri.Uri) option -> Uri.Uri option + end + +functor Catalog ( structure Params : CatParams ) : Catalog = + struct + structure CatParse = CatParse ( structure Params = Params ) + + open CatData CatParse Params Uri UriDict + + val catDict = makeDict("catalog",6,NONE:Catalog option) + + fun getCatalog uri = + let val idx = getIndex(catDict,uri) + in case getByIndex(catDict,idx) + of SOME cat => cat + | NONE => let val cat = parseCatalog uri + val _ = setByIndex(catDict,idx,SOME cat) + in cat + end + end + + datatype SearchType = + SYS of Uri + | PUB of string + datatype SearchResult = + FOUND of Uri * Uri + | NOTFOUND of Uri list + + fun searchId id = + let + fun searchOne (base,other) nil = NOTFOUND other + | searchOne (base,other) (entry::entries) = + case entry + of E_BASE path => + let val newBase = uriJoin(base,path) + in searchOne (newBase,other) entries + end + | E_EXTEND path => + let val fullPath = uriJoin(base,path) + in searchOne (base,fullPath::other) entries + end + | E_DELEGATE(prefix,path) => + (case id + of PUB pid => if String.isPrefix prefix pid + then let val fullPath = uriJoin(base,path) + in searchOne (base,fullPath::other) entries + end + else searchOne (base,other) entries + | SYS _ => searchOne (base,other) entries) + | E_MAP(pubid,path) => + (case id + of PUB pid => if pubid=pid then FOUND (base,path) + else searchOne (base,other) entries + | _ => searchOne (base,other) entries) + | E_REMAP(sysid,path) => + (case id + of SYS sid => if sysid=sid then FOUND(base,path) + else searchOne (base,other) entries + | _ => searchOne (base,other) entries) + + fun searchLevel other nil = NOTFOUND(rev other) + | searchLevel other (fname::fnames) = + let + val (base,entries) = getCatalog fname + in + case searchOne (base,other) entries + of FOUND bp => FOUND bp + | NOTFOUND other' => searchLevel other' fnames + end + + fun searchAll fnames = + if null fnames then NONE + else case searchLevel nil fnames + of FOUND bp => SOME bp + | NOTFOUND other => searchAll other + + val fnames = !O_CATALOG_FILES + in + case id + of PUB _ => searchAll fnames + | SYS _ => if !O_SUPPORT_REMAP then searchAll fnames else NONE + end + + fun resolveExtId (pub,sys) = + let + fun resolvePubCat () = + case pub + of NONE => NONE + | SOME id => case searchId (PUB id) + of NONE => NONE + | SOME(base,sysid) => case searchId (SYS sysid) + of NONE => SOME(base,sysid) + | new => new + + fun resolveSysCat () = + case sys + of NONE => NONE + | SOME(base,id) => searchId (SYS id) + + fun resolveCat () = + if !O_PREFER_SYSID + then case resolveSysCat () + of NONE => resolvePubCat () + | found => found + else case resolvePubCat () + of NONE => resolveSysCat () + | found => found + + fun resolve () = + if !O_PREFER_CATALOG + then case resolveCat () + of NONE => (case sys + of NONE => NONE + | SOME(base,id) => SOME(base,id)) + | found => found + else case sys + of NONE => resolvePubCat () + | SOME(base,id) => SOME(base,id) + in + if null (!O_CATALOG_FILES) + then case sys + of NONE => NONE + | SOME(base,id) => SOME (uriJoin (base,id)) + else case resolve () + of NONE => NONE + | SOME bp => SOME (uriJoin bp) + end + end +(* stop of ../../Catalog/catalog.sml *) +(* start of ../../Catalog/catResolve.sml *) + + + + + + + +functor ResolveCatalog ( structure Params : CatParams ) : Resolve = + struct + structure Catalog = Catalog ( structure Params = Params ) + + open Base Errors + + fun resolveExtId (id as EXTID(pub,sys)) = + let val pub1 = case pub + of NONE => NONE + | SOME (str,_) => SOME str + val sys1 = case sys + of NONE => NONE + | SOME (base,file,_) => SOME(base,file) + in case Catalog.resolveExtId (pub1,sys1) + of NONE => raise NoSuchFile ("","Could not generate system identifier") + | SOME uri => uri + end + end +(* stop of ../../Catalog/catResolve.sml *) +(* start of ../../Catalog/catOptions.sml *) +signature CatOptions = + sig + val O_CATALOG_FILES : Uri.Uri list ref + val O_PREFER_SOCAT : bool ref + val O_PREFER_SYSID : bool ref + val O_PREFER_CATALOG : bool ref + val O_SUPPORT_REMAP : bool ref + val O_CATALOG_ENC : Encoding.Encoding ref + + val setCatalogDefaults : unit -> unit + val setCatalogOptions : Options.Option list * (string -> unit) -> Options.Option list + + val catalogUsage : Options.Usage + end + +functor CatOptions () : CatOptions = + struct + open Encoding Options Uri + + val O_CATALOG_FILES = ref nil: Uri list ref + val O_PREFER_SOCAT = ref false + val O_PREFER_SYSID = ref false + val O_PREFER_CATALOG = ref true + val O_SUPPORT_REMAP = ref true + val O_CATALOG_ENC = ref LATIN1 + + fun setCatalogDefaults() = + let + val _ = O_CATALOG_FILES := nil + val _ = O_PREFER_SOCAT := false + val _ = O_PREFER_SYSID := false + val _ = O_PREFER_CATALOG := true + val _ = O_SUPPORT_REMAP := true + val _ = O_CATALOG_ENC := LATIN1 + in () + end + + val catalogUsage = + [U_ITEM(["-C ","--catalog="],"Use catalog "), + U_ITEM(["--catalog-syntax=(soc|xml)"],"Default syntax for catalogs (xml)"), + U_ITEM(["--catalog-encoding="],"Default encoding for Socat catalogs (LATIN1)"), + U_ITEM(["--catalog-remap=[(yes|no)]"],"Support remapping of system identifiers (yes)"), + U_ITEM(["--catalog-priority=(map|remap|sys)"],"Resolving strategy in catalogs (map)") + ] + + fun setCatalogOptions (opts,doError) = + let + val catalogs = ref nil:string list ref + + fun hasNoArg key = "option "^key^" has no argument" + fun mustHave key = String.concat ["option ",key," must have an argument"] + fun mustBe(key,what) = String.concat ["the argument to --",key," must be ",what] + + val yesNo = "'yes' or 'no'" + val mapRemapSys = "'map', 'remap' or 'sys'" + val encName = "'ascii', 'latin1', 'utf8' or 'utf16'" + val syntaxName = "'soc' or 'xml'" + + fun do_catalog valOpt = + case valOpt + of NONE => doError(mustHave "--catalog") + | SOME s => catalogs := s::(!catalogs) + + fun do_prio valOpt = + let fun set(cat,sys) = (O_PREFER_CATALOG := cat; O_PREFER_SYSID := sys) + in case valOpt + of NONE => doError(mustHave "--catalog-priority") + | SOME "map" => set(true,false) + | SOME "remap" => set(true,true) + | SOME "sys" => set(false,true) + | SOME s => doError(mustBe("catalog-priority",mapRemapSys)) + end + + fun do_enc valOpt = + case valOpt + of NONE => doError(mustHave "--catalog-encoding") + | SOME s => case isEncoding s + of NOENC => doError("unsupported encoding "^s) + | enc => O_CATALOG_ENC := enc + + fun do_remap valOpt = + case valOpt + of NONE => doError(mustHave "--catalog-remap") + | SOME "no" => O_SUPPORT_REMAP := false + | SOME "yes" => O_SUPPORT_REMAP := true + | SOME s => doError(mustBe("catalog-remap",yesNo)) + + fun do_syntax valOpt = + case valOpt + of NONE => doError(mustHave "--catalog-syntax") + | SOME "soc" => O_PREFER_SOCAT := true + | SOME "xml" => O_PREFER_SOCAT := false + | SOME s => doError(mustBe("catalog-remap",syntaxName)) + + fun do_long(key,valOpt) = + case key + of "catalog" => true before do_catalog valOpt + | "catalog-remap" => true before do_remap valOpt + | "catalog-syntax" => true before do_syntax valOpt + | "catalog-encoding" => true before do_enc valOpt + | "catalog-priority" => true before do_prio valOpt + | _ => false + + fun do_short cs opts = + case cs + of nil => doit opts + | [#"C"] => + (case opts + of OPT_STRING s::opts1 => (catalogs := s::(!catalogs); + doit opts1) + | _ => let val _ = doError (mustHave "-C") + in doit opts + end) + | cs => + let val cs1 = List.filter + (fn c => if #"C"<>c then true + else false before doError (mustHave "-C")) cs + in if null cs1 then doit opts else (OPT_SHORT cs1)::doit opts + end + + and doit nil = nil + | doit (opt::opts) = + case opt + of OPT_NOOPT => opts + | OPT_LONG(key,value) => if do_long(key,value) then doit opts + else opt::doit opts + | OPT_SHORT cs => do_short cs opts + | OPT_NEG cs => opt::doit opts + | OPT_STRING s => opt::doit opts + + val opts1 = doit opts + val uris = map String2Uri (!catalogs) + val _ = O_CATALOG_FILES := uris + in opts1 + end + end +(* stop of ../../Catalog/catOptions.sml *) +(* start of nullOptions.sml *) +signature NullOptions = + sig + val O_SILENT : bool ref + val O_ERROR_DEVICE : TextIO.outstream ref + val O_ERROR_LINEWIDTH : int ref + + val setNullDefaults : unit -> unit + val setNullOptions : Options.Option list * (string -> unit) + -> bool * bool * string option * string option + + val nullUsage : Options.Usage + end + +structure NullOptions : NullOptions = + struct + open Options + + val O_SILENT = ref false + val O_ERROR_DEVICE = ref TextIO.stdErr + val O_ERROR_LINEWIDTH = ref 80 + + val nullUsage = + [U_ITEM(["-s","--silent"],"Suppress reporting of errors and warnings"), + U_ITEM(["-e ","--error-output="],"Redirect errors to file (stderr)"), + U_SEP, + U_ITEM(["--version"],"Print the version number and exit"), + U_ITEM(["-?","--help"],"Print this text and exit"), + U_ITEM(["--"],"Do not recognize remaining arguments as options") + ] + + fun setNullDefaults () = + let + val _ = O_SILENT := false + val _ = O_ERROR_DEVICE := TextIO.stdErr + in () + end + + fun setNullOptions (opts,optError) = + let + fun onlyOne what = "at most one "^what^" may be specified" + fun unknown pre opt = String.concat ["unknown option ",pre,opt] + fun hasNoArg pre key = String.concat ["option ",pre,key," expects no argument"] + fun mustHave pre key = String.concat ["option ",pre,key," must have an argument"] + + fun check_noarg(key,valOpt) = + if isSome valOpt then optError (hasNoArg "--" key) else () + + fun do_long (pars as (v,h,e,f)) (key,valOpt) = + case key + of "help" => (v,true,e,f) before check_noarg(key,valOpt) + | "version" => (true,h,e,f) before check_noarg(key,valOpt) + | "silent" => pars before O_SILENT := true before check_noarg(key,valOpt) + | "error-output" => + (case valOpt + of NONE => pars before optError (mustHave "--" key) + | SOME s => (v,h,SOME s,f)) + | _ => pars before optError(unknown "--" key) + + fun do_short (pars as (v,h,e,f)) (cs,opts) = + case cs + of nil => doit pars opts + | [#"e"] => (case opts + of OPT_STRING s::opts1 => doit (v,h,SOME s,f) opts1 + | _ => (optError (hasNoArg "-" "e"); doit pars opts)) + | cs => doit (foldr + (fn (c,pars) + => case c + of #"e" => pars before optError (hasNoArg "-" "e") + | #"s" => pars before O_SILENT := true + | #"?" => (v,true,e,f) + | c => pars before + optError (unknown "-" (String.implode [c]))) + pars cs) opts + + and doit pars nil = pars + | doit (pars as (v,h,e,f)) (opt::opts) = + case opt + of OPT_LONG(key,valOpt) => doit (do_long pars (key,valOpt)) opts + | OPT_SHORT cs => do_short pars (cs,opts) + | OPT_STRING s => if isSome f + then let val _ = optError(onlyOne "input file") + in doit pars opts + end + else doit (v,h,e,SOME s) opts + | OPT_NOOPT => doit pars opts + | OPT_NEG cs => let val _ = if null cs then () + else app (fn c => optError + (unknown "-n" (String.implode[c]))) cs + in doit pars opts + end + in doit (false,false,NONE,NONE) opts + end + end +(* stop of nullOptions.sml *) +(* start of nullHooks.sml *) +structure NullHooks = + struct + open Errors IgnoreHooks NullOptions + + type AppData = OS.Process.status + type AppFinal = AppData + val nullStart = OS.Process.success + + fun printError(pos,err) = if !O_SILENT then () else TextIO.output + (!O_ERROR_DEVICE,formatMessage (4,!O_ERROR_LINEWIDTH) + (Position2String pos + ::(if isFatalError err then "Fatal error:" else "Error:") + ::errorMessage err)) + fun printWarning(pos,warn) = if !O_SILENT then () else TextIO.output + (!O_ERROR_DEVICE,formatMessage (4,!O_ERROR_LINEWIDTH) + (Position2String pos^" Warning:"::warningMessage warn)) + + fun hookError (_,pe) = OS.Process.failure before printError pe + fun hookWarning (status,pw) = status before printWarning pw + end +(* stop of nullHooks.sml *) +(* start of null.sml *) +structure Null = + struct + structure ParserOptions = ParserOptions () + structure CatOptions = CatOptions () + structure CatParams = + struct + open CatError CatOptions NullOptions Uri UtilError + + fun catError(pos,err) = if !O_SILENT then () else TextIO.output + (!O_ERROR_DEVICE,formatMessage (4,!O_ERROR_LINEWIDTH) + (Position2String pos^" Error in catalog:"::catMessage err)) + end + structure Resolve = ResolveCatalog (structure Params = CatParams) + structure ParseNull = Parse (structure Dtd = Dtd + structure Hooks = NullHooks + structure Resolve = Resolve + structure ParserOptions = ParserOptions) + + fun parseNull uri = ParseNull.parseDocument uri NONE NullHooks.nullStart + + open + CatOptions NullOptions Options ParserOptions Uri + + val usage = List.concat [parserUsage,[U_SEP],catalogUsage,[U_SEP],nullUsage] + + exception Exit of OS.Process.status + + fun null(prog,args) = + let + val prog = "fxp" + val hadError = ref false + + fun optError msg = + let val _ = TextIO.output(TextIO.stdErr,msg^".\n") + in hadError := true + end + fun exitError msg = + let val _ = TextIO.output(TextIO.stdErr,msg^".\n") + in raise Exit OS.Process.failure + end + fun exitHelp prog = + let val _ = printUsage TextIO.stdOut prog usage + in raise Exit OS.Process.success + end + fun exitVersion prog = + let val _ = app print [prog," version ",Version.FXP_VERSION,"\n"] + in raise Exit OS.Process.success + end + + fun summOpt prog = "For a summary of options type "^prog^" --help" + fun noFile(f,cause) = "can't open file '"^f^"': "^exnMessage cause + + val opts = parseOptions args + val _ = setParserDefaults() + val opts1 = setParserOptions (opts,optError) + val _ = setCatalogDefaults() + val opts2 = setCatalogOptions (opts1,optError) + val _ = setNullDefaults() + val (vers,help,err,file) = setNullOptions (opts2,optError) + val _ = if !hadError then exitError (summOpt prog) else () + val _ = if vers then exitVersion prog else () + val _ = if help then exitHelp prog else () + val _ = case err + of SOME "-" => O_ERROR_DEVICE := TextIO.stdErr + | SOME f => (O_ERROR_DEVICE := TextIO.openOut f + handle IO.Io {cause,...} => exitError(noFile(f,cause))) + | NONE => () + val f = valOf file handle Option => "-" + val uri = if f="-" then NONE else SOME(String2Uri f) + val status = parseNull uri + val _ = if isSome err then TextIO.closeOut (!O_ERROR_DEVICE) else () + in status + end + handle Exit status => status + | exn => + let val _ = TextIO.output + (TextIO.stdErr,prog^": Unexpected exception: "^exnMessage exn^".\n") + in OS.Process.failure + end + end + +(* stop of null.sml *) +(* start of call-null.sml *) +val _ = Null.null (CommandLine.name (), CommandLine.arguments ()) +(* stop of call-null.sml *) diff --git a/benchmark/tests/hamlet.sml b/benchmark/tests/hamlet.sml new file mode 100644 index 0000000..34aaf26 --- /dev/null +++ b/benchmark/tests/hamlet.sml @@ -0,0 +1,22901 @@ +(* + * 2001-2-14. + * Stephen Weeks (sweeks@sweeks.com) generated this file from the hamlet SML + * interpreter written by Andreas Rossberg. + * The sources are from http://www.ps.uni-sb.de/~rossberg/hamlet/hamlet.tar + * + * The file consists of the concatenation of all of the source code (plus SML/NJ + * library code) in the correct order, with a simple test case to test the + * interpreter at the end. + * + * I also removed uses of the nonstandard Unsafe structure. + * + * I also made a minor change so that it could read in from a file instead of + * from stdIn. + *) + +val ins = ref TextIO.stdIn + +(* start of STAMP.sml *) +(* + * Stamp generator. + *) + + +signature STAMP = + sig + + eqtype stamp + + val stamp: unit -> stamp + val toString: stamp -> string + + val reset: unit -> unit + + val compare: stamp * stamp -> order + + end +(* stop of STAMP.sml *) +(* start of Stamp.sml *) +(* + * Stamp generator. + *) + + +structure Stamp :> STAMP = + struct + + type stamp = int + + val r = ref 0 + + fun reset() = r := 0 + fun stamp() = (r := !r + 1; !r) + + val toString = Int.toString + val compare = Int.compare + + end +(* stop of Stamp.sml *) +(* start of smlnj-lib/Util/ord-key-sig.sml *) +(* ord-key-sig.sml + * + * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * + * Abstract linearly ordered keys. + * + *) + +signature ORD_KEY = + sig + type ord_key + + val compare : ord_key * ord_key -> order + + end (* ORD_KEY *) +(* stop of smlnj-lib/Util/ord-key-sig.sml *) +(* start of smlnj-lib/Util/lib-base-sig.sml *) +(* lib-base-sig.sml + * + * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + *) + +signature LIB_BASE = + sig + + exception Unimplemented of string + (* raised to report unimplemented features *) + exception Impossible of string + (* raised to report internal errors *) + + exception NotFound + (* raised by searching operations *) + + val failure : {module : string, func : string, msg : string} -> 'a + (* raise the exception Fail with a standard format message. *) + + val version : {date : string, system : string, version_id : int list} + val banner : string + + end (* LIB_BASE *) + +(* stop of smlnj-lib/Util/lib-base-sig.sml *) +(* start of smlnj-lib/Util/lib-base.sml *) +(* lib-base.sml + * + * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + *) + +structure LibBase : LIB_BASE = + struct + + (* raised to report unimplemented features *) + exception Unimplemented of string + + (* raised to report internal errors *) + exception Impossible of string + + (* raised by searching operations *) + exception NotFound + + (* raise the exception Fail with a standard format message. *) + fun failure {module, func, msg} = + raise (Fail(concat[module, ".", func, ": ", msg])) + + val version = { + date = "June 1, 1996", + system = "SML/NJ Library", + version_id = [1, 0] + } + + fun f ([], l) = l + | f ([x : int], l) = (Int.toString x)::l + | f (x::r, l) = (Int.toString x) :: "." :: f(r, l) + + val banner = concat ( + #system version :: ", Version " :: + f (#version_id version, [", ", #date version])) + + end (* LibBase *) + +(* stop of smlnj-lib/Util/lib-base.sml *) +(* start of smlnj-lib/Util/ord-map-sig.sml *) +(* ord-map-sig.sml + * + * COPYRIGHT (c) 1996 by AT&T Research. See COPYRIGHT file for details. + * + * Abstract signature of an applicative-style finite maps (dictionaries) + * structure over ordered monomorphic keys. + *) + +signature ORD_MAP = + sig + + structure Key : ORD_KEY + + type 'a map + + val empty : 'a map + (* The empty map *) + + val isEmpty : 'a map -> bool + (* Return true if and only if the map is empty *) + + val singleton : (Key.ord_key * 'a) -> 'a map + (* return the specified singleton map *) + + val insert : 'a map * Key.ord_key * 'a -> 'a map + val insert' : ((Key.ord_key * 'a) * 'a map) -> 'a map + (* Insert an item. *) + + val find : 'a map * Key.ord_key -> 'a option + (* Look for an item, return NONE if the item doesn't exist *) + + val inDomain : ('a map * Key.ord_key) -> bool + (* return true, if the key is in the domain of the map *) + + val remove : 'a map * Key.ord_key -> 'a map * 'a + (* Remove an item, returning new map and value removed. + * Raises LibBase.NotFound if not found. + *) + + val first : 'a map -> 'a option + val firsti : 'a map -> (Key.ord_key * 'a) option + (* return the first item in the map (or NONE if it is empty) *) + + val numItems : 'a map -> int + (* Return the number of items in the map *) + + val listItems : 'a map -> 'a list + val listItemsi : 'a map -> (Key.ord_key * 'a) list + (* Return an ordered list of the items (and their keys) in the map. *) + + val listKeys : 'a map -> Key.ord_key list + (* return an ordered list of the keys in the map. *) + + val collate : ('a * 'a -> order) -> ('a map * 'a map) -> order + (* given an ordering on the map's range, return an ordering + * on the map. + *) + + val unionWith : ('a * 'a -> 'a) -> ('a map * 'a map) -> 'a map + val unionWithi : (Key.ord_key * 'a * 'a -> 'a) -> ('a map * 'a map) -> 'a map + (* return a map whose domain is the union of the domains of the two input + * maps, using the supplied function to define the map on elements that + * are in both domains. + *) + + val intersectWith : ('a * 'b -> 'c) -> ('a map * 'b map) -> 'c map + val intersectWithi : (Key.ord_key * 'a * 'b -> 'c) -> ('a map * 'b map) -> 'c map + (* return a map whose domain is the intersection of the domains of the + * two input maps, using the supplied function to define the range. + *) + + val app : ('a -> unit) -> 'a map -> unit + val appi : ((Key.ord_key * 'a) -> unit) -> 'a map -> unit + (* Apply a function to the entries of the map in map order. *) + + val map : ('a -> 'b) -> 'a map -> 'b map + val mapi : (Key.ord_key * 'a -> 'b) -> 'a map -> 'b map + (* Create a new map by applying a map function to the + * name/value pairs in the map. + *) + + val foldl : ('a * 'b -> 'b) -> 'b -> 'a map -> 'b + val foldli : (Key.ord_key * 'a * 'b -> 'b) -> 'b -> 'a map -> 'b + (* Apply a folding function to the entries of the map + * in increasing map order. + *) + + val foldr : ('a * 'b -> 'b) -> 'b -> 'a map -> 'b + val foldri : (Key.ord_key * 'a * 'b -> 'b) -> 'b -> 'a map -> 'b + (* Apply a folding function to the entries of the map + * in decreasing map order. + *) + + val filter : ('a -> bool) -> 'a map -> 'a map + val filteri : (Key.ord_key * 'a -> bool) -> 'a map -> 'a map + (* Filter out those elements of the map that do not satisfy the + * predicate. The filtering is done in increasing map order. + *) + + val mapPartial : ('a -> 'b option) -> 'a map -> 'b map + val mapPartiali : (Key.ord_key * 'a -> 'b option) -> 'a map -> 'b map + (* map a partial function over the elements of a map in increasing + * map order. + *) + + end (* ORD_MAP *) +(* stop of smlnj-lib/Util/ord-map-sig.sml *) +(* start of smlnj-lib/Util/binary-map-fn.sml *) +(* binary-map-fn.sml + * + * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * + * This code was adapted from Stephen Adams' binary tree implementation + * of applicative integer sets. + * + * Copyright 1992 Stephen Adams. + * + * This software may be used freely provided that: + * 1. This copyright notice is attached to any copy, derived work, + * or work including all or part of this software. + * 2. Any derived work must contain a prominent notice stating that + * it has been altered from the original. + * + * + * Name(s): Stephen Adams. + * Department, Institution: Electronics & Computer Science, + * University of Southampton + * Address: Electronics & Computer Science + * University of Southampton + * Southampton SO9 5NH + * Great Britian + * E-mail: sra@ecs.soton.ac.uk + * + * Comments: + * + * 1. The implementation is based on Binary search trees of Bounded + * Balance, similar to Nievergelt & Reingold, SIAM J. Computing + * 2(1), March 1973. The main advantage of these trees is that + * they keep the size of the tree in the node, giving a constant + * time size operation. + * + * 2. The bounded balance criterion is simpler than N&R's alpha. + * Simply, one subtree must not have more than `weight' times as + * many elements as the opposite subtree. Rebalancing is + * guaranteed to reinstate the criterion for weight>2.23, but + * the occasional incorrect behaviour for weight=2 is not + * detrimental to performance. + * + *) + +functor BinaryMapFn (K : ORD_KEY) : ORD_MAP = + struct + + structure Key = K + + (* + ** val weight = 3 + ** fun wt i = weight * i + *) + fun wt (i : int) = i + i + i + + datatype 'a map + = E + | T of { + key : K.ord_key, + value : 'a, + cnt : int, + left : 'a map, + right : 'a map + } + + val empty = E + + fun isEmpty E = true + | isEmpty _ = false + + fun numItems E = 0 + | numItems (T{cnt,...}) = cnt + + (* return the first item in the map (or NONE if it is empty) *) + fun first E = NONE + | first (T{value, left=E, ...}) = SOME value + | first (T{left, ...}) = first left + + (* return the first item in the map and its key (or NONE if it is empty) *) + fun firsti E = NONE + | firsti (T{key, value, left=E, ...}) = SOME(key, value) + | firsti (T{left, ...}) = firsti left + +local + fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} + | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r} + | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E} + | N(k,v,l as T n,r as T n') = + T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r} + + fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = + N(b,bv,N(a,av,x,y),z) + | single_L _ = raise Match + fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = + N(a,av,x,N(b,bv,y,z)) + | single_R _ = raise Match + fun double_L (a,av,w,T{key=c,value=cv,left=T{key=b,value=bv,left=x,right=y,...},right=z,...}) = + N(b,bv,N(a,av,w,x),N(c,cv,y,z)) + | double_L _ = raise Match + fun double_R (c,cv,T{key=a,value=av,left=w,right=T{key=b,value=bv,left=x,right=y,...},...},z) = + N(b,bv,N(a,av,w,x),N(c,cv,y,z)) + | double_R _ = raise Match + + fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} + | T' (k,v,E,r as T{right=E,left=E,...}) = + T{key=k,value=v,cnt=2,left=E,right=r} + | T' (k,v,l as T{right=E,left=E,...},E) = + T{key=k,value=v,cnt=2,left=l,right=E} + + | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p + | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p + + (* these cases almost never happen with small weight*) + | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) = + if ln < rn then single_L p else double_L p + | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) = + if ln > rn then single_R p else double_R p + + | T' (p as (_,_,E,T{left=E,...})) = single_L p + | T' (p as (_,_,T{right=E,...},E)) = single_R p + + | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...}, + r as T{cnt=rn,left=rl,right=rr,...})) = + if rn >= wt ln then (*right is too big*) + let val rln = numItems rl + val rrn = numItems rr + in + if rln < rrn then single_L p else double_L p + end + + else if ln >= wt rn then (*left is too big*) + let val lln = numItems ll + val lrn = numItems lr + in + if lrn < lln then single_R p else double_R p + end + + else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r} + + local + fun min (T{left=E,key,value,...}) = (key,value) + | min (T{left,...}) = min left + | min _ = raise Match + + fun delmin (T{left=E,right,...}) = right + | delmin (T{key,value,left,right,...}) = T'(key,value,delmin left,right) + | delmin _ = raise Match + in + fun delete' (E,r) = r + | delete' (l,E) = l + | delete' (l,r) = let val (mink,minv) = min r in + T'(mink,minv,l,delmin r) + end + end +in + fun mkDict () = E + + fun singleton (x,v) = T{key=x,value=v,cnt=1,left=E,right=E} + + fun insert (E,x,v) = T{key=x,value=v,cnt=1,left=E,right=E} + | insert (T(set as {key,left,right,value,...}),x,v) = + case K.compare (key,x) of + GREATER => T'(key,value,insert(left,x,v),right) + | LESS => T'(key,value,left,insert(right,x,v)) + | _ => T{key=x,value=v,left=left,right=right,cnt= #cnt set} + fun insert' ((k, x), m) = insert(m, k, x) + + fun inDomain (set, x) = let + fun mem E = false + | mem (T(n as {key,left,right,...})) = (case K.compare (x,key) + of GREATER => mem right + | EQUAL => true + | LESS => mem left + (* end case *)) + in + mem set + end + + fun find (set, x) = let + fun mem E = NONE + | mem (T(n as {key,left,right,...})) = (case K.compare (x,key) + of GREATER => mem right + | EQUAL => SOME(#value n) + | LESS => mem left + (* end case *)) + in + mem set + end + + fun remove (E,x) = raise LibBase.NotFound + | remove (set as T{key,left,right,value,...},x) = ( + case K.compare (key,x) + of GREATER => let + val (left', v) = remove(left, x) + in + (T'(key, value, left', right), v) + end + | LESS => let + val (right', v) = remove (right, x) + in + (T'(key, value, left, right'), v) + end + | _ => (delete'(left,right),value) + (* end case *)) + + fun listItems d = let + fun d2l (E, l) = l + | d2l (T{key,value,left,right,...}, l) = + d2l(left, value::(d2l(right,l))) + in + d2l (d,[]) + end + + fun listItemsi d = let + fun d2l (E, l) = l + | d2l (T{key,value,left,right,...}, l) = + d2l(left, (key,value)::(d2l(right,l))) + in + d2l (d,[]) + end + + fun listKeys d = let + fun d2l (E, l) = l + | d2l (T{key,left,right,...}, l) = d2l(left, key::(d2l(right,l))) + in + d2l (d,[]) + end + + local + fun next ((t as T{right, ...})::rest) = (t, left(right, rest)) + | next _ = (E, []) + and left (E, rest) = rest + | left (t as T{left=l, ...}, rest) = left(l, t::rest) + in + fun collate cmpRng (s1, s2) = let + fun cmp (t1, t2) = (case (next t1, next t2) + of ((E, _), (E, _)) => EQUAL + | ((E, _), _) => LESS + | (_, (E, _)) => GREATER + | ((T{key=x1, value=y1, ...}, r1), (T{key=x2, value=y2, ...}, r2)) => ( + case Key.compare(x1, x2) + of EQUAL => (case cmpRng(y1, y2) + of EQUAL => cmp (r1, r2) + | order => order + (* end case *)) + | order => order + (* end case *)) + (* end case *)) + in + cmp (left(s1, []), left(s2, [])) + end + end (* local *) + + fun appi f d = let + fun app' E = () + | app' (T{key,value,left,right,...}) = ( + app' left; f(key, value); app' right) + in + app' d + end + fun app f d = let + fun app' E = () + | app' (T{value,left,right,...}) = ( + app' left; f value; app' right) + in + app' d + end + + fun mapi f d = let + fun map' E = E + | map' (T{key,value,left,right,cnt}) = let + val left' = map' left + val value' = f(key, value) + val right' = map' right + in + T{cnt=cnt, key=key, value=value', left = left', right = right'} + end + in + map' d + end + fun map f d = mapi (fn (_, x) => f x) d + + fun foldli f init d = let + fun fold (E, v) = v + | fold (T{key,value,left,right,...}, v) = + fold (right, f(key, value, fold(left, v))) + in + fold (d, init) + end + fun foldl f init d = foldli (fn (_, v, accum) => f (v, accum)) init d + + fun foldri f init d = let + fun fold (E,v) = v + | fold (T{key,value,left,right,...},v) = + fold (left, f(key, value, fold(right, v))) + in + fold (d, init) + end + fun foldr f init d = foldri (fn (_, v, accum) => f (v, accum)) init d + +(** To be implemented ** + val filter : ('a -> bool) -> 'a map -> 'a map + val filteri : (Key.ord_key * 'a -> bool) -> 'a map -> 'a map +**) + + end (* local *) + +(* the following are generic implementations of the unionWith and intersectWith + * operetions. These should be specialized for the internal representations + * at some point. + *) + fun unionWith f (m1, m2) = let + fun ins f (key, x, m) = (case find(m, key) + of NONE => insert(m, key, x) + | (SOME x') => insert(m, key, f(x, x')) + (* end case *)) + in + if (numItems m1 > numItems m2) + then foldli (ins (fn (a, b) => f (b, a))) m1 m2 + else foldli (ins f) m2 m1 + end + fun unionWithi f (m1, m2) = let + fun ins f (key, x, m) = (case find(m, key) + of NONE => insert(m, key, x) + | (SOME x') => insert(m, key, f(key, x, x')) + (* end case *)) + in + if (numItems m1 > numItems m2) + then foldli (ins (fn (k, a, b) => f (k, b, a))) m1 m2 + else foldli (ins f) m2 m1 + end + + fun intersectWith f (m1, m2) = let + (* iterate over the elements of m1, checking for membership in m2 *) + fun intersect f (m1, m2) = let + fun ins (key, x, m) = (case find(m2, key) + of NONE => m + | (SOME x') => insert(m, key, f(x, x')) + (* end case *)) + in + foldli ins empty m1 + end + in + if (numItems m1 > numItems m2) + then intersect f (m1, m2) + else intersect (fn (a, b) => f(b, a)) (m2, m1) + end + fun intersectWithi f (m1, m2) = let + (* iterate over the elements of m1, checking for membership in m2 *) + fun intersect f (m1, m2) = let + fun ins (key, x, m) = (case find(m2, key) + of NONE => m + | (SOME x') => insert(m, key, f(key, x, x')) + (* end case *)) + in + foldli ins empty m1 + end + in + if (numItems m1 > numItems m2) + then intersect f (m1, m2) + else intersect (fn (k, a, b) => f(k, b, a)) (m2, m1) + end + + (* this is a generic implementation of filter. It should + * be specialized to the data-structure at some point. + *) + fun filter predFn m = let + fun f (key, item, m) = if predFn item + then insert(m, key, item) + else m + in + foldli f empty m + end + fun filteri predFn m = let + fun f (key, item, m) = if predFn(key, item) + then insert(m, key, item) + else m + in + foldli f empty m + end + + (* this is a generic implementation of mapPartial. It should + * be specialized to the data-structure at some point. + *) + fun mapPartial f m = let + fun g (key, item, m) = (case f item + of NONE => m + | (SOME item') => insert(m, key, item') + (* end case *)) + in + foldli g empty m + end + fun mapPartiali f m = let + fun g (key, item, m) = (case f(key, item) + of NONE => m + | (SOME item') => insert(m, key, item') + (* end case *)) + in + foldli g empty m + end + + end (* functor BinaryMapFn *) +(* stop of smlnj-lib/Util/binary-map-fn.sml *) +(* start of FIN_MAP.sml *) +(* + * Standard ML finite maps + * + * Definition, section 4.2 + * + * Note: + * This signature just extends the one available in the SML/NJ lib. + * Actually, the operation added here would be general purpose and useful enough + * (and more efficient) to be in the lib. Also see FIN_SET. + *) + +signature FIN_MAP = + sig + + include ORD_MAP + + val fromList: (Key.ord_key * 'a) list -> 'a map + + val all: ('a -> bool) -> 'a map -> bool + val exists: ('a -> bool) -> 'a map -> bool + val alli: (Key.ord_key * 'a -> bool) -> 'a map -> bool + val existsi: (Key.ord_key * 'a -> bool) -> 'a map -> bool + + val disjoint: 'a map * 'a map -> bool + + end +(* stop of FIN_MAP.sml *) +(* start of FinMapFn.sml *) +(* + * Standard ML finite maps + * + * Definition, section 4.2 + * + * Note: + * This functor just extends the one available in the SML/NJ lib. + * Actually, the operation added here would be general purpose and useful enough + * (and more efficient) to be in the lib. Also see FinSetFn. + *) + +functor FinMapFn(Key: ORD_KEY) :> FIN_MAP where type Key.ord_key = Key.ord_key = + struct + + structure BinaryMap = BinaryMapFn(Key) + + open BinaryMap + + fun fromList kvs = List.foldl (fn((k, v),m) => insert(m, k, v)) empty kvs + + fun all p = foldl (fn(v, b) => b andalso p v) true + fun exists p = foldl (fn(v, b) => b orelse p v) false + fun alli p = foldli (fn(k, v, b) => b andalso p(k, v)) true + fun existsi p = foldli (fn(k, v, b) => b orelse p(k, v)) false + + fun disjoint(m1,m2) = isEmpty(intersectWith #2 (m1, m2)) + + end +(* stop of FinMapFn.sml *) +(* start of ID.sml *) +(* + * Standard ML identifiers + * + * Definition, section 2.4 + * + * Note: + * This is a generic signature to represent all kinds of identifiers (except + * for labels and tyvars). + *) + + +signature ID = + sig + + (* Type [Section 2.4] *) + + eqtype Id (* [id] *) + + (* Operations *) + + val invent: unit -> Id + + val fromString: string -> Id + val toString: Id -> string + + val compare: Id * Id -> order + + end +(* stop of ID.sml *) +(* start of IdFn.sml *) +(* + * Standard ML identifiers + * + * Definition, section 2.4 + * + * Note: + * This is a generic functor to represent all kinds of identifiers (except + * for labels tyvars). + *) + + +functor IdFn() :> ID = + struct + + (* Type [Section 2.4] *) + + type Id = string (* [id] *) + + + (* Creation *) + + fun invent() = "_id" ^ Stamp.toString(Stamp.stamp()) + + fun fromString s = s + fun toString s = s + + + (* Ordering *) + + val compare = String.compare + + end +(* stop of IdFn.sml *) +(* start of IdsModule.sml *) +(* + * Standard ML identifiers for modules + * + * Definition, section 3.2 + *) + + +structure SigId = IdFn() +structure FunId = IdFn() +(* stop of IdsModule.sml *) +(* start of AssembliesModule.sml *) +(* + * Standard ML sets and maps for the module semantics + * + * Definition, sections 5.1 and 7.2 + *) + +structure SigIdMap = FinMapFn(type ord_key = SigId.Id + val compare = SigId.compare) + +structure FunIdMap = FinMapFn(type ord_key = FunId.Id + val compare = FunId.compare) +(* stop of AssembliesModule.sml *) +(* start of LONGID.sml *) +(* + * Standard ML long identifiers + * + * Definition, section 2.4 + * + * Note: + * This is a generic signature to represent all kinds of long identifiers. + *) + + +signature LONGID = + sig + + (* Import *) + + structure Id: ID + structure StrId: ID + + type Id = Id.Id + type StrId = StrId.Id + + + (* Type [Section 2.4] *) + + eqtype longId (* [longid] *) + + + (* Operations *) + + val invent: unit -> longId + val fromId: Id -> longId + val toId: longId -> Id + val toString: longId -> string + + val strengthen: StrId * longId -> longId + val implode: StrId list * Id -> longId + val explode: longId -> StrId list * Id + + val isUnqualified: longId -> bool + + val compare: longId * longId -> order + + end +(* stop of LONGID.sml *) +(* start of LongIdFn.sml *) +(* + * Standard ML long identifiers + * + * Definition, section 2.4 + * + * Note: + * This is a generic functor that generates a long identifier type from a + * given identifier type and the StrId type. + *) + + +functor LongIdFn(structure Id: ID + structure StrId: ID + ) :> LONGID where type Id.Id = Id.Id + and type StrId.Id = StrId.Id + = + struct + + (* Import *) + + structure Id = Id + structure StrId = StrId + + type Id = Id.Id + type StrId = StrId.Id + + + (* Type [Section 2.4] *) + + type longId = StrId list * Id (* [longid] *) + + + (* Conversions *) + + fun toId(strid, id) = id + fun fromId id = ([],id) + fun invent() = ([],Id.invent()) + + fun toString(strids, id) = + let + fun prefix [] = Id.toString id + | prefix(id::ids) = StrId.toString id ^ "." ^ prefix ids + in + prefix strids + end + + fun strengthen(strid, (strids, id)) = (strid::strids, id) + + fun implode longid = longid + fun explode longid = longid + + fun isUnqualified (strids,id) = List.null strids + + + (* Ordering *) + + fun compare(longid1, longid2) = + String.compare(toString longid1, toString longid2) + + end +(* stop of LongIdFn.sml *) +(* start of IdsCore.sml *) +(* + * Standard ML identifiers for the core + * + * Definition, section 2.4 + *) + + +structure VId = IdFn() +structure TyCon = IdFn() +structure StrId = IdFn() + +structure LongVId = LongIdFn(structure Id = VId + structure StrId = StrId) +structure LongTyCon = LongIdFn(structure Id = TyCon + structure StrId = StrId) +structure LongStrId = LongIdFn(structure Id = StrId + structure StrId = StrId) +(* stop of IdsCore.sml *) +(* start of smlnj-lib/Util/ord-set-sig.sml *) +(* ordset-sig.sml + * + * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * + * Signature for a set of values with an order relation. + *) + +signature ORD_SET = + sig + + structure Key : ORD_KEY + + type item = Key.ord_key + type set + + val empty : set + (* The empty set *) + + val singleton : item -> set + (* Create a singleton set *) + + val add : set * item -> set + val add' : (item * set) -> set + (* Insert an item. *) + + val addList : set * item list -> set + (* Insert items from list. *) + + val delete : set * item -> set + (* Remove an item. Raise NotFound if not found. *) + + val member : set * item -> bool + (* Return true if and only if item is an element in the set *) + + val isEmpty : set -> bool + (* Return true if and only if the set is empty *) + + val equal : (set * set) -> bool + (* Return true if and only if the two sets are equal *) + + val compare : (set * set) -> order + (* does a lexical comparison of two sets *) + + val isSubset : (set * set) -> bool + (* Return true if and only if the first set is a subset of the second *) + + val numItems : set -> int + (* Return the number of items in the table *) + + val listItems : set -> item list + (* Return an ordered list of the items in the set *) + + val union : set * set -> set + (* Union *) + + val intersection : set * set -> set + (* Intersection *) + + val difference : set * set -> set + (* Difference *) + + val map : (item -> item) -> set -> set + (* Create a new set by applying a map function to the elements + * of the set. + *) + + val app : (item -> unit) -> set -> unit + (* Apply a function to the entries of the set + * in decreasing order + *) + + val foldl : (item * 'b -> 'b) -> 'b -> set -> 'b + (* Apply a folding function to the entries of the set + * in increasing order + *) + + val foldr : (item * 'b -> 'b) -> 'b -> set -> 'b + (* Apply a folding function to the entries of the set + * in decreasing order + *) + + val filter : (item -> bool) -> set -> set + + val exists : (item -> bool) -> set -> bool + + val find : (item -> bool) -> set -> item option + + end (* ORD_SET *) +(* stop of smlnj-lib/Util/ord-set-sig.sml *) +(* start of smlnj-lib/Util/binary-set-fn.sml *) +(* binary-set-fn.sml + * + * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * + * This code was adapted from Stephen Adams' binary tree implementation + * of applicative integer sets. + * + * Copyright 1992 Stephen Adams. + * + * This software may be used freely provided that: + * 1. This copyright notice is attached to any copy, derived work, + * or work including all or part of this software. + * 2. Any derived work must contain a prominent notice stating that + * it has been altered from the original. + * + * Name(s): Stephen Adams. + * Department, Institution: Electronics & Computer Science, + * University of Southampton + * Address: Electronics & Computer Science + * University of Southampton + * Southampton SO9 5NH + * Great Britian + * E-mail: sra@ecs.soton.ac.uk + * + * Comments: + * + * 1. The implementation is based on Binary search trees of Bounded + * Balance, similar to Nievergelt & Reingold, SIAM J. Computing + * 2(1), March 1973. The main advantage of these trees is that + * they keep the size of the tree in the node, giving a constant + * time size operation. + * + * 2. The bounded balance criterion is simpler than N&R's alpha. + * Simply, one subtree must not have more than `weight' times as + * many elements as the opposite subtree. Rebalancing is + * guaranteed to reinstate the criterion for weight>2.23, but + * the occasional incorrect behaviour for weight=2 is not + * detrimental to performance. + * + * 3. There are two implementations of union. The default, + * hedge_union, is much more complex and usually 20% faster. I + * am not sure that the performance increase warrants the + * complexity (and time it took to write), but I am leaving it + * in for the competition. It is derived from the original + * union by replacing the split_lt(gt) operations with a lazy + * version. The `obvious' version is called old_union. + * + * 4. Most time is spent in T', the rebalancing constructor. If my + * understanding of the output of * in the sml batch + * compiler is correct then the code produced by NJSML 0.75 + * (sparc) for the final case is very disappointing. Most + * invocations fall through to this case and most of these cases + * fall to the else part, i.e. the plain contructor, + * T(v,ln+rn+1,l,r). The poor code allocates a 16 word vector + * and saves lots of registers into it. In the common case it + * then retrieves a few of the registers and allocates the 5 + * word T node. The values that it retrieves were live in + * registers before the massive save. + * + * Modified to functor to support general ordered values + *) + +functor BinarySetFn (K : ORD_KEY) : ORD_SET = + struct + + structure Key = K + + type item = K.ord_key + + datatype set + = E + | T of { + elt : item, + cnt : int, + left : set, + right : set + } + + fun numItems E = 0 + | numItems (T{cnt,...}) = cnt + + fun isEmpty E = true + | isEmpty _ = false + + fun mkT(v,n,l,r) = T{elt=v,cnt=n,left=l,right=r} + + (* N(v,l,r) = T(v,1+numItems(l)+numItems(r),l,r) *) + fun N(v,E,E) = mkT(v,1,E,E) + | N(v,E,r as T{cnt=n,...}) = mkT(v,n+1,E,r) + | N(v,l as T{cnt=n,...}, E) = mkT(v,n+1,l,E) + | N(v,l as T{cnt=n,...}, r as T{cnt=m,...}) = mkT(v,n+m+1,l,r) + + fun single_L (a,x,T{elt=b,left=y,right=z,...}) = N(b,N(a,x,y),z) + | single_L _ = raise Match + fun single_R (b,T{elt=a,left=x,right=y,...},z) = N(a,x,N(b,y,z)) + | single_R _ = raise Match + fun double_L (a,w,T{elt=c,left=T{elt=b,left=x,right=y,...},right=z,...}) = + N(b,N(a,w,x),N(c,y,z)) + | double_L _ = raise Match + fun double_R (c,T{elt=a,left=w,right=T{elt=b,left=x,right=y,...},...},z) = + N(b,N(a,w,x),N(c,y,z)) + | double_R _ = raise Match + + (* + ** val weight = 3 + ** fun wt i = weight * i + *) + fun wt (i : int) = i + i + i + + fun T' (v,E,E) = mkT(v,1,E,E) + | T' (v,E,r as T{left=E,right=E,...}) = mkT(v,2,E,r) + | T' (v,l as T{left=E,right=E,...},E) = mkT(v,2,l,E) + + | T' (p as (_,E,T{left=T _,right=E,...})) = double_L p + | T' (p as (_,T{left=E,right=T _,...},E)) = double_R p + + (* these cases almost never happen with small weight*) + | T' (p as (_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) = + if lnrn then single_R p else double_R p + + | T' (p as (_,E,T{left=E,...})) = single_L p + | T' (p as (_,T{right=E,...},E)) = single_R p + + | T' (p as (v,l as T{elt=lv,cnt=ln,left=ll,right=lr}, + r as T{elt=rv,cnt=rn,left=rl,right=rr})) = + if rn >= wt ln (*right is too big*) + then + let val rln = numItems rl + val rrn = numItems rr + in + if rln < rrn then single_L p else double_L p + end + else if ln >= wt rn (*left is too big*) + then + let val lln = numItems ll + val lrn = numItems lr + in + if lrn < lln then single_R p else double_R p + end + else mkT(v,ln+rn+1,l,r) + + fun add (E,x) = mkT(x,1,E,E) + | add (set as T{elt=v,left=l,right=r,cnt},x) = + case K.compare(x,v) of + LESS => T'(v,add(l,x),r) + | GREATER => T'(v,l,add(r,x)) + | EQUAL => mkT(x,cnt,l,r) + fun add' (s, x) = add(x, s) + + fun concat3 (E,v,r) = add(r,v) + | concat3 (l,v,E) = add(l,v) + | concat3 (l as T{elt=v1,cnt=n1,left=l1,right=r1}, v, + r as T{elt=v2,cnt=n2,left=l2,right=r2}) = + if wt n1 < n2 then T'(v2,concat3(l,v,l2),r2) + else if wt n2 < n1 then T'(v1,l1,concat3(r1,v,r)) + else N(v,l,r) + + fun split_lt (E,x) = E + | split_lt (T{elt=v,left=l,right=r,...},x) = + case K.compare(v,x) of + GREATER => split_lt(l,x) + | LESS => concat3(l,v,split_lt(r,x)) + | _ => l + + fun split_gt (E,x) = E + | split_gt (T{elt=v,left=l,right=r,...},x) = + case K.compare(v,x) of + LESS => split_gt(r,x) + | GREATER => concat3(split_gt(l,x),v,r) + | _ => r + + fun min (T{elt=v,left=E,...}) = v + | min (T{left=l,...}) = min l + | min _ = raise Match + + fun delmin (T{left=E,right=r,...}) = r + | delmin (T{elt=v,left=l,right=r,...}) = T'(v,delmin l,r) + | delmin _ = raise Match + + fun delete' (E,r) = r + | delete' (l,E) = l + | delete' (l,r) = T'(min r,l,delmin r) + + fun concat (E, s) = s + | concat (s, E) = s + | concat (t1 as T{elt=v1,cnt=n1,left=l1,right=r1}, + t2 as T{elt=v2,cnt=n2,left=l2,right=r2}) = + if wt n1 < n2 then T'(v2,concat(t1,l2),r2) + else if wt n2 < n1 then T'(v1,l1,concat(r1,t2)) + else T'(min t2,t1, delmin t2) + + + local + fun trim (lo,hi,E) = E + | trim (lo,hi,s as T{elt=v,left=l,right=r,...}) = + if K.compare(v,lo) = GREATER + then if K.compare(v,hi) = LESS then s else trim(lo,hi,l) + else trim(lo,hi,r) + + fun uni_bd (s,E,_,_) = s + | uni_bd (E,T{elt=v,left=l,right=r,...},lo,hi) = + concat3(split_gt(l,lo),v,split_lt(r,hi)) + | uni_bd (T{elt=v,left=l1,right=r1,...}, + s2 as T{elt=v2,left=l2,right=r2,...},lo,hi) = + concat3(uni_bd(l1,trim(lo,v,s2),lo,v), + v, + uni_bd(r1,trim(v,hi,s2),v,hi)) + (* inv: lo < v < hi *) + + (* all the other versions of uni and trim are + * specializations of the above two functions with + * lo=-infinity and/or hi=+infinity + *) + + fun trim_lo (_, E) = E + | trim_lo (lo,s as T{elt=v,right=r,...}) = + case K.compare(v,lo) of + GREATER => s + | _ => trim_lo(lo,r) + + fun trim_hi (_, E) = E + | trim_hi (hi,s as T{elt=v,left=l,...}) = + case K.compare(v,hi) of + LESS => s + | _ => trim_hi(hi,l) + + fun uni_hi (s,E,_) = s + | uni_hi (E,T{elt=v,left=l,right=r,...},hi) = + concat3(l,v,split_lt(r,hi)) + | uni_hi (T{elt=v,left=l1,right=r1,...}, + s2 as T{elt=v2,left=l2,right=r2,...},hi) = + concat3(uni_hi(l1,trim_hi(v,s2),v),v,uni_bd(r1,trim(v,hi,s2),v,hi)) + + fun uni_lo (s,E,_) = s + | uni_lo (E,T{elt=v,left=l,right=r,...},lo) = + concat3(split_gt(l,lo),v,r) + | uni_lo (T{elt=v,left=l1,right=r1,...}, + s2 as T{elt=v2,left=l2,right=r2,...},lo) = + concat3(uni_bd(l1,trim(lo,v,s2),lo,v),v,uni_lo(r1,trim_lo(v,s2),v)) + + fun uni (s,E) = s + | uni (E,s) = s + | uni (T{elt=v,left=l1,right=r1,...}, + s2 as T{elt=v2,left=l2,right=r2,...}) = + concat3(uni_hi(l1,trim_hi(v,s2),v), v, uni_lo(r1,trim_lo(v,s2),v)) + + in + val hedge_union = uni + end + + (* The old_union version is about 20% slower than + * hedge_union in most cases + *) + fun old_union (E,s2) = s2 + | old_union (s1,E) = s1 + | old_union (T{elt=v,left=l,right=r,...},s2) = + let val l2 = split_lt(s2,v) + val r2 = split_gt(s2,v) + in + concat3(old_union(l,l2),v,old_union(r,r2)) + end + + val empty = E + fun singleton x = T{elt=x,cnt=1,left=E,right=E} + + fun addList (s,l) = List.foldl (fn (i,s) => add(s,i)) s l + + val add = add + + fun member (set, x) = let + fun pk E = false + | pk (T{elt=v, left=l, right=r, ...}) = ( + case K.compare(x,v) + of LESS => pk l + | EQUAL => true + | GREATER => pk r + (* end case *)) + in + pk set + end + + local + (* true if every item in t is in t' *) + fun treeIn (t,t') = let + fun isIn E = true + | isIn (T{elt,left=E,right=E,...}) = member(t',elt) + | isIn (T{elt,left,right=E,...}) = + member(t',elt) andalso isIn left + | isIn (T{elt,left=E,right,...}) = + member(t',elt) andalso isIn right + | isIn (T{elt,left,right,...}) = + member(t',elt) andalso isIn left andalso isIn right + in + isIn t + end + in + fun isSubset (E,_) = true + | isSubset (_,E) = false + | isSubset (t as T{cnt=n,...},t' as T{cnt=n',...}) = + (n<=n') andalso treeIn (t,t') + + fun equal (E,E) = true + | equal (t as T{cnt=n,...},t' as T{cnt=n',...}) = + (n=n') andalso treeIn (t,t') + | equal _ = false + end + + local + fun next ((t as T{right, ...})::rest) = (t, left(right, rest)) + | next _ = (E, []) + and left (E, rest) = rest + | left (t as T{left=l, ...}, rest) = left(l, t::rest) + in + fun compare (s1, s2) = let + fun cmp (t1, t2) = (case (next t1, next t2) + of ((E, _), (E, _)) => EQUAL + | ((E, _), _) => LESS + | (_, (E, _)) => GREATER + | ((T{elt=e1, ...}, r1), (T{elt=e2, ...}, r2)) => ( + case Key.compare(e1, e2) + of EQUAL => cmp (r1, r2) + | order => order + (* end case *)) + (* end case *)) + in + cmp (left(s1, []), left(s2, [])) + end + end + + fun delete (E,x) = raise LibBase.NotFound + | delete (set as T{elt=v,left=l,right=r,...},x) = + case K.compare(x,v) of + LESS => T'(v,delete(l,x),r) + | GREATER => T'(v,l,delete(r,x)) + | _ => delete'(l,r) + + val union = hedge_union + + fun intersection (E, _) = E + | intersection (_, E) = E + | intersection (s, T{elt=v,left=l,right=r,...}) = let + val l2 = split_lt(s,v) + val r2 = split_gt(s,v) + in + if member(s,v) + then concat3(intersection(l2,l),v,intersection(r2,r)) + else concat(intersection(l2,l),intersection(r2,r)) + end + + fun difference (E,s) = E + | difference (s,E) = s + | difference (s, T{elt=v,left=l,right=r,...}) = + let val l2 = split_lt(s,v) + val r2 = split_gt(s,v) + in + concat(difference(l2,l),difference(r2,r)) + end + + fun map f set = let + fun map'(acc, E) = acc + | map'(acc, T{elt,left,right,...}) = + map' (add (map' (acc, left), f elt), right) + in + map' (E, set) + end + + fun app apf = + let fun apply E = () + | apply (T{elt,left,right,...}) = + (apply left;apf elt; apply right) + in + apply + end + + fun foldl f b set = let + fun foldf (E, b) = b + | foldf (T{elt,left,right,...}, b) = + foldf (right, f(elt, foldf (left, b))) + in + foldf (set, b) + end + + fun foldr f b set = let + fun foldf (E, b) = b + | foldf (T{elt,left,right,...}, b) = + foldf (left, f(elt, foldf (right, b))) + in + foldf (set, b) + end + + fun listItems set = foldr (op::) [] set + + fun filter pred set = + foldl (fn (item, s) => if (pred item) then add(s, item) else s) + empty set + + fun find p E = NONE + | find p (T{elt,left,right,...}) = (case find p left + of NONE => if (p elt) + then SOME elt + else find p right + | a => a + (* end case *)) + + fun exists p E = false + | exists p (T{elt, left, right,...}) = + (exists p left) orelse (p elt) orelse (exists p right) + + end (* BinarySetFn *) +(* stop of smlnj-lib/Util/binary-set-fn.sml *) +(* start of FIN_SET.sml *) +(* + * Standard ML finite sets + * + * Definition, section 4.2 + * + * Note: + * This signature just extends the one available in the SML/NJ lib. + * Actually, the operation added here would be general purpose and useful enough + * to be in the lib. Also see FIN_MAP. + *) + +signature FIN_SET = + sig + + include ORD_SET + + val fromList: item list -> set + + end +(* stop of FIN_SET.sml *) +(* start of FinSetFn.sml *) +(* + * Standard ML finite sets + * + * Definition, section 4.2 + * + * Note: + * This functor just extends the one available in the SML/NJ lib. + * Actually, the operation added here would be general purpose and useful enough + * to be in the lib. Also see FinMapFn. + *) + +functor FinSetFn(Key: ORD_KEY) :> FIN_SET where type Key.ord_key = Key.ord_key = + struct + + structure BinarySet = BinarySetFn(Key) + + open BinarySet + + fun fromList xs = addList(empty, xs) + + end +(* stop of FinSetFn.sml *) +(* start of TYVAR.sml *) +(* + * Standard ML type variables + * + * Definition, sections 2.4 and 4.1 + *) + + +signature TYVAR = + sig + + (* Type [Sections 2.4 and 4.1]*) + + eqtype TyVar (* [alpha] or [tyvar] *) + + + (* Operations *) + + val invent: bool -> TyVar + val fromIndex: bool -> int -> TyVar + val fromString: string -> TyVar + val toString: TyVar -> string + + val admitsEquality: TyVar -> bool + val isExplicit: TyVar -> bool + + val instance: TyVar -> TyVar + val normalise: TyVar * int -> TyVar + + val compare: TyVar * TyVar -> order + + end +(* stop of TYVAR.sml *) +(* start of TyVar.sml *) +(* + * Standard ML type variables + * + * Definition, sections 2.4 and 4.1 + * + * Note: + * - Internally generated tyvars get names '#xxx, where xxx is a stamp number. + * - Tyvars generated from integers are mapped to 'a,'b,..,'z,'aa,'bb,..,'zz, + * 'aaa,... + *) + + +structure TyVar :> TYVAR = + struct + + (* Type [Sections 2.4 and 4.1]*) + + type TyVar = { name: string, equality: bool } (* [alpha] or [tyvar] *) + + + (* Creation *) + + fun invent equality = + { name="'#" ^ Stamp.toString(Stamp.stamp()), + equality=equality } + + fun fromIndex equality n = + let + fun rep(0,c) = c + | rep(n,c) = c ^ rep(n-1,c) + + val c = String.str(Char.chr(Char.ord #"a" + n mod 26)) + val name = (if equality then "''" else "'") ^ rep(n div 26, c) + in + { name=name, equality=equality } + end + + fun fromString s = + { name = s, + equality = String.size(s) > 1 andalso String.sub(s,1) = #"'" } + + fun toString{name,equality} = name + + + (* Attributes [Section 4.1] *) + + fun admitsEquality{name,equality} = equality + + fun isExplicit{name,equality} = + String.size name = 1 orelse String.sub(name,1) <> #"#" + + + (* Small helpers *) + + fun normalise({name,equality}, n) = fromIndex equality n + + fun instance{name,equality} = invent equality + + + (* Ordering *) + + fun compare(alpha1: TyVar, alpha2: TyVar) = + String.compare(#name alpha1, #name alpha2) + + end +(* stop of TyVar.sml *) +(* start of TYNAME.sml *) +(* + * Standard ML type names + * + * Definition, section 4.1 + * + * Notes: + * - Equality is not a boolean attribute. We distinguish a 3rd kind of special + * type names which have equality regardless of the types applied. This + * implements ref, array, and equivalent types. + * - For easy checking of pattern exhaustiveness we add an attribute + * `span' counting the number of constructors of the type. + *) + + +signature TYNAME = + sig + + (* Import *) + + type TyCon = TyCon.Id + + + (* Type [Section 4.1] *) + + eqtype TyName (* [t] *) + + datatype Equality = NOEQ | EQ | SPECIALEQ + + + (* Operations *) + + val tyname: TyCon * int * Equality * int -> TyName + val invent: int * Equality -> TyName + val rename: TyName -> TyName + val removeEquality: TyName -> TyName + val Abs: TyName -> TyName + + val arity: TyName -> int + val equality: TyName -> Equality + val span: TyName -> int + val tycon: TyName -> TyCon + val toString: TyName -> string + + val compare: TyName * TyName -> order + + end +(* stop of TYNAME.sml *) +(* start of TyName.sml *) +(* + * Standard ML type names + * + * Definition, section 4.1 + * + * Notes: + * - Equality is not a boolean attribute. We distinguish a 3rd kind of special + * type names which have equality regardless of the types applied. This + * implements ref, array, and equivalent types. + * - For easy checking of pattern exhaustiveness we add an attribute + * `span' counting the number of constructors of the type. + *) + + +structure TyName :> TYNAME = + struct + + (* Import *) + + type TyCon = TyCon.Id + type stamp = Stamp.stamp + + + (* Type [Section 4.1] *) + + datatype Equality = NOEQ | EQ | SPECIALEQ + + type TyName = (* [t] *) + { tycon: TyCon + , stamp: stamp + , arity: int + , equality: Equality + , span: int + } + + + (* Creation *) + + fun tyname(tycon, arity, equality, span) = + { tycon = tycon + , stamp = Stamp.stamp() + , arity = arity + , equality = equality + , span = span + } + + fun invent(arity, equality) = tyname(TyCon.invent(), arity, equality, 0) + + + (* Creation from existing *) + + fun rename{tycon, stamp, arity, equality, span} = + tyname(tycon, arity, equality, span) + + fun removeEquality{tycon, stamp, arity, equality, span} = + tyname(tycon, arity, NOEQ, span) + + fun Abs{tycon, stamp, arity, equality, span} = + tyname(tycon, arity, NOEQ, 0) + + + (* Attributes [Section 4.1] *) + + fun arity {tycon, stamp, arity, equality, span} = arity + fun equality{tycon, stamp, arity, equality, span} = equality + fun span {tycon, stamp, arity, equality, span} = span + fun tycon {tycon, stamp, arity, equality, span} = tycon + + fun toString{tycon, stamp, arity, equality, span} = TyCon.toString tycon + + + (* Ordering *) + + fun compare(t1: TyName, t2: TyName) = Stamp.compare(#stamp t1, #stamp t2) + + end +(* stop of TyName.sml *) +(* start of SCON.sml *) +(* + * Standard ML special constants + * + * Definition, section 2.2 + *) + + +signature SCON = + sig + + (* Type [Section 2.2] *) + + datatype SCon = (* [scon] *) + INT of int + | WORD of word + | STRING of string + | CHAR of char + | REAL of real + + (* Operations *) + + val fromInt: int -> SCon + val fromWord: word -> SCon + val fromString: string -> SCon + val fromChar: char -> SCon + val fromReal: real -> SCon + + val toString: SCon -> string + + val compare: SCon * SCon -> order + + end +(* stop of SCON.sml *) +(* start of SCon.sml *) +(* + * Standard ML special constants + * + * Definition, section 2.2 + *) + + +structure SCon :> SCON = + struct + + (* Type [Section 2.2] *) + + datatype SCon = (* [scon] *) + INT of int + | WORD of word + | STRING of string + | CHAR of char + | REAL of real + + + (* Conversions *) + + val fromInt = INT + val fromWord = WORD + val fromString = STRING + val fromChar = CHAR + val fromReal = REAL + + fun toString(INT i) = Int.toString i + | toString(WORD w) = "0wx" ^ Word.toString w + | toString(STRING s) = "\"" ^ String.toCString s ^ "\"" + | toString(CHAR c) = "\"#" ^ Char.toCString c ^ "\"" + | toString(REAL r) = Real.toString r + + + (* Ordering *) + + fun compare(INT n1, INT n2) = Int.compare(n1, n2) + | compare(WORD w1, WORD w2) = Word.compare(w1, w2) + | compare(STRING s1, STRING s2) = String.compare(s1, s2) + | compare(CHAR c1, CHAR c2) = Char.compare(c1, c2) + | compare(REAL x1, REAL x2) = Real.compare(x1, x2) + | compare _ = raise Domain + + end +(* stop of SCon.sml *) +(* start of LAB.sml *) +(* + * Standard ML label identifiers + * + * Definition, section 2.4 + *) + + +signature LAB = + sig + + (* Type [Section 2.4] *) + + eqtype Lab (* [lab] *) + + + (* Operations *) + + val fromString: string -> Lab + val fromInt: int -> Lab + val toString: Lab -> string + + val compare: Lab * Lab -> order + + end +(* stop of LAB.sml *) +(* start of Lab.sml *) +(* + * Standard ML label identifiers + * + * Definition, section 2.4 + *) + + +structure Lab :> LAB = + struct + + (* Type [Section 2.4] *) + + type Lab = string (* [lab] *) + + + (* Conversions *) + + fun fromString s = s + val fromInt = Int.toString + fun toString s = s + + + (* Ordering *) + + fun compare(lab1,lab2) = + case (Int.fromString lab1, Int.fromString lab2) + of (SOME i1, SOME i2) => Int.compare(i1,i2) + | _ => String.compare(lab1,lab2) + + end +(* stop of Lab.sml *) +(* start of AssembliesCoreStatic.sml *) +(* + * Standard ML sets and maps for the static semantics of the core + * + * Definition, section 4.2 + *) + +structure TyVarSet = FinSetFn(type ord_key = TyVar.TyVar + val compare = TyVar.compare) + +structure TyNameSet = FinSetFn(type ord_key = TyName.TyName + val compare = TyName.compare) + +structure SConSet = FinSetFn(type ord_key = SCon.SCon + val compare = SCon.compare) + +structure VIdSet = FinSetFn(type ord_key = VId.Id + val compare = VId.compare) + +structure LongVIdSet = FinSetFn(type ord_key = LongVId.longId + val compare = LongVId.compare) + + +structure LabMap = FinMapFn(type ord_key = Lab.Lab + val compare = Lab.compare) + +structure VIdMap = FinMapFn(type ord_key = VId.Id + val compare = VId.compare) + +structure TyConMap = FinMapFn(type ord_key = TyCon.Id + val compare = TyCon.compare) + +structure TyVarMap = FinMapFn(type ord_key = TyVar.TyVar + val compare = TyVar.compare) + +structure TyNameMap = FinMapFn(type ord_key = TyName.TyName + val compare = TyName.compare) + +structure StrIdMap = FinMapFn(type ord_key = StrId.Id + val compare = StrId.compare) +(* stop of AssembliesCoreStatic.sml *) +(* start of OVERLOADINGCLASS.sml *) +(* + * Standard ML overloading classes + * + * Definition, appendix E + * + * Note: + * Overloading -- and defaulting in particular -- is not well formalised in + * the Definition. We describe an overloading class as a pair (T,t) of a set + * of type names (like the definition does), plus the default type name t. + * For overloading to be sound some well-formedness properties have to be + * enforced for all existing overloading classes (T,t): + * (1) t elem T + * (2) Eq T = 0 \/ t admits equality + * (3) forall (T',t') . ( TT' = 0 \/ t = t' ) + * where Eq T = { t elem T | t admits equality } and we write TT' for the + * T intersect T' and 0 for the empty set. + * The reason for (1) is obvious. (2) guarantees that we do not loose the + * default if we enforce equality. (3) ensures the same if we have to unify + * two overloading classes. (2) and (3) also allow the resulting set to become + * empty which will cause a type error. + *) + +signature OVERLOADINGCLASS = + sig + + (* Import types *) + + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + + + (* Type *) + + type OverloadingClass (* [O] *) + + + (* Operations *) + + val make: TyNameSet * TyName -> OverloadingClass + + val isEmpty: OverloadingClass -> bool + val isSingular: OverloadingClass -> bool + val default: OverloadingClass -> TyName + val set: OverloadingClass -> TyNameSet + val member: OverloadingClass * TyName -> bool + val getItem: OverloadingClass -> TyName + + val makeEquality: OverloadingClass -> OverloadingClass option + val intersection: OverloadingClass * OverloadingClass -> + OverloadingClass option + val union: OverloadingClass * OverloadingClass -> + OverloadingClass + + end +(* stop of OVERLOADINGCLASS.sml *) +(* start of OverloadingClass.sml *) +(* + * Standard ML overloading classes + * + * Definition, appendix E + * + * Note: + * Overloading -- and defaulting in particular -- is not well formalised in + * the Definition. We describe an overloading class as a pair (T,t) of a set + * of type names (like the definition does), plus the default type name t. + * For overloading to be sound some well-formedness properties have to be + * enforced for all existing overloading classes (T,t): + * (1) t elem T + * (2) Eq T = 0 \/ t admits equality + * (3) forall (T',t') . ( TT' = 0 \/ t = t' ) + * where Eq T = { t elem T | t admits equality } and we write TT' for the + * T intersect T' and 0 for the empty set. + * The reason for (1) is obvious. (2) guarantees that we do not loose the + * default if we enforce equality. (3) ensures the same if we have to unify + * two overloading classes. (2) and (3) also allow the resulting set to become + * empty which will cause a type error. + *) + +structure OverloadingClass :> OVERLOADINGCLASS = + struct + + (* Import types *) + + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + + + (* Type *) + + type OverloadingClass = TyNameSet * TyName (* [O] *) + + + (* Simple operations *) + + fun make O = O + + fun isEmpty (T,t) = TyNameSet.isEmpty T + fun isSingular (T,t) = TyNameSet.numItems T = 1 + fun default (T,t) = t + fun set (T,t) = T + fun member((T,t), t') = TyNameSet.member(T, t') + fun getItem (T,t) = valOf(TyNameSet.find (fn _ => true) T) + + + (* Filter equality types *) + + fun makeEquality (T,t) = + let + val T' = TyNameSet.filter (fn t => TyName.equality t = TyName.EQ) T + in + if TyNameSet.isEmpty T' then + NONE + else if TyName.equality t <> TyName.NOEQ then + SOME(T',t) + else + raise Fail "OverloadingClass.makeEquality: \ + \inconsistent overloading classes" + end + + + (* Intersection and union *) + + fun intersection((T1,t1), (T2,t2)) = + let + val T' = TyNameSet.intersection(T1,T2) + in + if TyNameSet.isEmpty T' then + NONE + else if t1 = t2 then + SOME(T',t1) + else + raise Fail "OverloadingClass.intersect: \ + \inconsistent overloading classes" + end + + + fun union((T1,t1), (T2,t2)) = ( TyNameSet.union(T1,T2), t2 ) + + end +(* stop of OverloadingClass.sml *) +(* start of TYPE.sml *) +(* + * Standard ML types + * + * Definition, section 4.2 and 4.4 + * + * Notes: + * - Types are references so that unification can work via side effects. + * We need links (forwards) to unify two type variables. + * - Types built bottom-up have to be `normalised' to induce the required + * sharing on type variables. + * - Care has to be taken to clone types at the proper places. + * - Substitution creates a clone, but shares free type variables. + * - To represent overloaded type (variables), we add a special type. + * - Record types may contain a row variable to represent open record types + * (which appear during type inference). Flexible rows have to carry an + * equality flag to properly propagate equality enforced by unification + * when extending a row. + *) + +signature TYPE = + sig + + (* Import types *) + + type Lab = Lab.Lab + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type OverloadingClass = OverloadingClass.OverloadingClass + type 'a LabMap = 'a LabMap.map + type 'a TyVarMap = 'a TyVarMap.map + type 'a TyNameMap = 'a TyNameMap.map + + + (* Types [Section 4.2] *) + + datatype RowVar = CLOSEDRow | FLEXRow of bool (* [r] *) + + datatype Type' = (* [tau] *) + TyVar of TyVar + | RowType of (*RowType*) (Type' ref LabMap * RowVar) + | FunType of (*FunType*) (Type' ref * Type' ref) + | ConsType of (*ConsType*)(Type' ref list * TyName) + | Overloaded of OverloadingClass + | Link of (*Type*) Type' ref + + type Type = Type' ref + + type RowType = Type LabMap * RowVar (* [rho] *) + type FunType = Type * Type + type ConsType = Type list * TyName + + type TypeFcn = TyVar list * Type (* [theta] *) + + type Substitution = Type TyVarMap (* [mu] *) + type Realisation = TypeFcn TyNameMap (* [phi] *) + + + (* Operations *) + + val invent: unit -> Type + val fromTyVar: TyVar -> Type + val fromRowType: RowType -> Type + val fromFunType: FunType -> Type + val fromConsType: ConsType -> Type + val fromOverloadingClass: OverloadingClass -> Type + + val range: Type -> Type + val tyname: Type -> TyName + + val normalise: Type -> Type + val substitute: Substitution -> Type -> Type + val realise: Realisation -> Type -> Type + + val tyvars: Type -> TyVarSet + val tynames: Type -> TyNameSet + val admitsEquality: Type -> bool + val isFlexible: Type -> bool + + exception Unify + val unify: Type * Type -> unit (* Unify *) + val unifyRestricted: TyVarSet -> Type * Type -> unit (* Unify *) + val makeEquality: Type -> unit (* Unify *) + + val defaultOverloaded: Type -> unit + + + (* Operations on rows *) + + val emptyRho: RowType + val singletonRho: Lab * Type -> RowType + val insertRho: RowType * Lab * Type -> RowType + val inventRho: unit -> RowType + val findLab: RowType * Lab -> Type option + + end +(* stop of TYPE.sml *) +(* start of Type.sml *) +(* + * Standard ML types + * + * Definition, section 4.2 and 4.4 + * + * Notes: + * - Types are references so that unification can work via side effects. + * We need links (forwards) to unify two type variables. + * - Types built bottom-up have to be `normalised' to induce the required + * sharing on type variables. + * - Care has to be taken to clone types at the proper places. + * - Substitution creates a clone, but shares free type variables. + * - To represent overloaded type (variables), we add a special type. + * - Record types may contain a row variable to represent open record types + * (which appear during type inference). Flexible rows have to carry an + * equality flag to properly propagate equality enforced by unification + * when extending a row. + *) + +structure Type :> TYPE = + struct + + (* Import types *) + + type Lab = Lab.Lab + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type OverloadingClass = OverloadingClass.OverloadingClass + type 'a LabMap = 'a LabMap.map + type 'a TyVarMap = 'a TyVarMap.map + type 'a TyNameMap = 'a TyNameMap.map + + + (* Types [Section 4.2] *) + + datatype RowVar = CLOSEDRow | FLEXRow of bool (* [r] *) + + datatype Type' = (* [tau] *) + TyVar of TyVar + | RowType of RowType + | FunType of FunType + | ConsType of ConsType + | Overloaded of OverloadingClass + | Link of Type + + withtype Type = Type' ref + + and RowType = Type' ref LabMap * RowVar (* [rho] *) + and FunType = Type' ref * Type' ref + and ConsType = Type' ref list * TyName + + type TypeFcn = TyVar list * Type (* [theta] *) + + type Substitution = Type TyVarMap (* [mu] *) + type Realisation = TypeFcn TyNameMap (* [phi] *) + + + (* Creation *) + + fun invent() = ref(TyVar(TyVar.invent false)) + + fun fromTyVar alpha = ref(TyVar alpha) + fun fromRowType rho = ref(RowType rho) + fun fromFunType x = ref(FunType x) + fun fromConsType x = ref(ConsType x) + fun fromOverloadingClass O = ref(Overloaded O) + + + (* Projections *) + + fun range(ref(FunType(tau1,tau2))) = tau2 + | range tau = tau + + fun tyname(ref(ConsType(taus,t))) = t + | tyname _ = + raise Fail "Type.tyname: non-constructed type" + + + (* Induce sharing on equal type variables in a type *) + + fun normalise tau = + let + (* Note that Overloaded nodes also have to be shared. + * But since such types are always pre-built rather than + * infered, we just take care that we construct them with + * proper sharing and ignore Overloaded nodes here. + *) + + val alphas = ref [] + + fun normalise(tau as ref(TyVar(alpha))) = + (case List.find (fn(alpha1,_) => alpha1 = alpha) (!alphas) + of SOME(_,tau1) => tau1 + | NONE => ( alphas := (alpha,tau) :: !alphas + ; tau + ) + ) + | normalise(ref(Link(tau))) = normalise tau + | normalise(tau as ref tau') = ( tau := normalise' tau' ; tau ) + + and normalise'(RowType(Rho,r)) = + RowType(LabMap.map normalise Rho, r) + + | normalise'(FunType(tau1,tau2)) = + FunType(normalise tau1, normalise tau2) + + | normalise'(ConsType(taus,t)) = + ConsType(List.map normalise taus, t) + + | normalise'(Overloaded(O)) = + Overloaded(O) + + | normalise' _ = + raise Fail "Type.normalise: bypassed type variable or link" + in + normalise tau + end + + + + (* Cloning under a substitution and a type realisation *) + + fun clone (mu,phi) tau = + let + (* Cloning must respect sharing, so an association list is used + * to remember nodes already visited together with their copy. + *) + + val mu' = ref mu + val cloned = ref [] + + fun clone tau = + case List.find (fn(tau1,_) => tau1 = tau) (!cloned) + of SOME(_,tau2) => tau2 + | NONE => let val tau2 = clone' tau in + cloned := (tau,tau2) :: !cloned + ; tau2 + end + + and clone'(tau as ref(TyVar(alpha))) = + (case TyVarMap.find(!mu', alpha) + of NONE => tau + | SOME tau => tau + ) + | clone'(ref(RowType(Rho,r))) = + ref(RowType(LabMap.map clone Rho, r)) + + | clone'(ref(FunType(tau1,tau2))) = + ref(FunType(clone tau1, clone tau2)) + + | clone'(tau as ref(ConsType(taus,t))) = + let + val taus2 = List.map clone taus + in + case TyNameMap.find(phi, t) + of NONE => ref(ConsType(taus2,t)) + | SOME(alphas,tau1) => + let + val cloned' = !cloned + in + mu' := ListPair.foldl + (fn(alpha,tau2,mu) => + TyVarMap.insert(mu,alpha,tau2)) + (!mu') (alphas,taus2) + ; clone' tau1 + before cloned := cloned' + end + end + + | clone'(ref(Overloaded(O))) = + ref(Overloaded(O)) + + | clone'(ref(Link(tau))) = + clone tau + in + clone tau + end + + + (* Substitution, and realisation [Section 5.2] *) + + fun substitute mu = clone(mu,TyNameMap.empty) + fun realise phi = clone(TyVarMap.empty,phi) + + + (* Type variable and type name extraction [Section 4.2] *) + + fun tyvars(ref tau') = tyvars' tau' + + and tyvars'(TyVar(alpha)) = TyVarSet.singleton alpha + + | tyvars'(RowType(Rho,r)) = + LabMap.foldl (fn(tau,U) => TyVarSet.union(U, tyvars tau)) + TyVarSet.empty Rho + + | tyvars'(FunType(tau1,tau2)) = + TyVarSet.union(tyvars tau1, tyvars tau2) + + | tyvars'(ConsType(taus,t)) = + List.foldl (fn(tau,U) => TyVarSet.union(U, tyvars tau)) + TyVarSet.empty taus + + | tyvars'(Overloaded(O)) = + TyVarSet.empty + + | tyvars'(Link(tau)) = + tyvars tau + + + fun tynames(ref tau') = tynames' tau' + + and tynames'(TyVar(alpha)) = TyNameSet.empty + + | tynames'(RowType(Rho,r)) = + LabMap.foldl (fn(tau,T) => + TyNameSet.union(T, tynames tau)) TyNameSet.empty Rho + + | tynames'(FunType(tau1,tau2)) = + TyNameSet.union(tynames tau1, tynames tau2) + + | tynames'(ConsType(taus,t)) = + let + val T = List.foldl (fn(tau,T) => TyNameSet.union(T, tynames tau)) + TyNameSet.empty taus + in + TyNameSet.add(T, t) + end + + | tynames'(Overloaded(O)) = + (* Conservative approximation *) + OverloadingClass.set O + + | tynames'(Link(tau)) = + tynames tau + + + + (* Check for equality type [Section 4.4] *) + + fun admitsEquality(ref tau') = admitsEquality' tau' + + and admitsEquality'(TyVar alpha) = + TyVar.admitsEquality alpha orelse + not(TyVar.isExplicit alpha) + + | admitsEquality'(RowType(Rho,CLOSEDRow)) = + LabMap.all admitsEquality Rho + + | admitsEquality'(RowType(Rho,FLEXRow _)) = + raise Fail "Type.admitsEquality: flexible row" + + | admitsEquality'(FunType _) = false + + | admitsEquality'(ConsType(taus,t)) = + (case TyName.equality t + of TyName.SPECIALEQ => true + | TyName.EQ => List.all admitsEquality taus + | TyName.NOEQ => false + ) + + | admitsEquality'(Overloaded(O)) = + raise Fail "Type.admitsEquality: overloaded type" + + | admitsEquality'(Link(tau)) = + admitsEquality tau + + + + (* Look for flexible records *) + + fun isFlexible(ref tau') = isFlexible' tau' + + and isFlexible'(TyVar(alpha')) = false + + | isFlexible'(RowType(Rho,r)) = + r <> CLOSEDRow orelse LabMap.exists isFlexible Rho + + | isFlexible'(FunType(tau1,tau2)) = + isFlexible tau1 orelse isFlexible tau2 + + | isFlexible'(ConsType(taus,t)) = + List.exists isFlexible taus + + | isFlexible'(Overloaded(O)) = false + + | isFlexible'(Link(tau)) = isFlexible tau + + + + (* Unification *) + + exception Unify + + + fun occurs(alpha, ref tau') = occurs'(alpha, tau') + + and occurs'(alpha, TyVar(alpha')) = + alpha = alpha' + + | occurs'(alpha, RowType(Rho,r)) = + LabMap.exists (fn tau => occurs(alpha, tau)) Rho + + | occurs'(alpha, FunType(tau1,tau2)) = + occurs(alpha, tau1) orelse occurs(alpha, tau2) + + | occurs'(alpha, ConsType(taus,t)) = + List.exists (fn tau => occurs(alpha, tau)) taus + + | occurs'(alpha, Overloaded(O)) = + false + + | occurs'(alpha, Link(tau)) = + occurs(alpha, tau) + + + fun unify(ref(Link(tau1)), tau2) = unify(tau1, tau2) + | unify(tau1, ref(Link(tau2))) = unify(tau1, tau2) + + | unify(tau1 as ref tau1', tau2 as ref tau2') = + if tau1 = tau2 then () else + let + val tau' = Link(ref(unify'(tau1',tau2'))) + in + tau1 := tau' ; tau2 := tau' + end + + and unify'(TyVar(alpha), tau') = unifyTyVar(alpha, tau') + | unify'(tau', TyVar(alpha)) = unifyTyVar(alpha, tau') + | unify'(Overloaded(O), tau') = unifyOverloaded(O, tau') + | unify'(tau', Overloaded(O)) = unifyOverloaded(O, tau') + + | unify'(tau' as FunType(tau11,tau12), FunType(tau21,tau22)) = + ( unify(tau11,tau21) + ; unify(tau12,tau22) + ; tau' + ) + + | unify'(RowType(Rho1,r1), RowType(Rho2,r2)) = + let + fun unifyField r (lab, tau1, Rho) = + case LabMap.find(Rho, lab) + of SOME tau2 => ( unify(tau1,tau2) + ; #1(LabMap.remove(Rho,lab)) + ) + | NONE => + case r + of CLOSEDRow => raise Unify + | FLEXRow eq => ( if eq then makeEquality tau1 else () + ; Rho + ) + + val Rho1' = LabMap.foldli (unifyField r1) Rho1 Rho2 + val _ = LabMap.foldli (unifyField r2) Rho2 Rho1' + val r = case (r1,r2) + of (CLOSEDRow, _) => CLOSEDRow + | (_, CLOSEDRow) => CLOSEDRow + | (FLEXRow eq1, FLEXRow eq2) => + FLEXRow(eq1 orelse eq2) + in + RowType(LabMap.unionWith #2 (Rho2,Rho1'), r) + end + + + | unify'(tau' as ConsType(taus1,t1), ConsType(taus2,t2)) = + if t1 = t2 then + ( ListPair.app unify (taus1,taus2) + ; tau' + ) + else + raise Unify + + | unify' _ = raise Unify + + + and unifyTyVar(alpha1, TyVar(alpha2)) = + if alpha1 = alpha2 then + TyVar(alpha2) + else if not(TyVar.isExplicit alpha1) then + bindTyVar(alpha1, TyVar(alpha2)) + else if not(TyVar.isExplicit alpha2) then + bindTyVar(alpha2, TyVar(alpha1)) + else + raise Unify + + | unifyTyVar(alpha, tau') = + if TyVar.isExplicit alpha orelse occurs'(alpha, tau') then + raise Unify + else + bindTyVar(alpha, tau') + + and bindTyVar(alpha, tau') = + if TyVar.admitsEquality alpha then + makeEquality' tau' + else + tau' + + + and unifyOverloaded(O, TyVar(alpha2)) = + unifyTyVar(alpha2, Overloaded(O)) + + | unifyOverloaded(O, tau' as ConsType([],t)) = + if OverloadingClass.member(O, t) then + tau' + else + raise Unify + + | unifyOverloaded(O1, Overloaded(O2)) = + (case OverloadingClass.intersection(O1,O2) + of NONE => raise Unify + | SOME O => Overloaded(O) + ) + + | unifyOverloaded(O, _) = + raise Unify + + + and makeEquality(tau as ref tau') = tau := makeEquality' tau' + + and makeEquality'(TyVar(alpha)) = + if TyVar.admitsEquality alpha then + TyVar(alpha) + else if TyVar.isExplicit alpha then + raise Unify + else + TyVar(TyVar.invent true) + + | makeEquality'(RowType(Rho,r)) = + ( LabMap.app makeEquality Rho + ; RowType(Rho, case r of CLOSEDRow => CLOSEDRow + | FLEXRow _ => FLEXRow true) + ) + + | makeEquality'(FunType _) = + raise Unify + + | makeEquality'(tau' as ConsType(taus,t)) = + (case TyName.equality t + of TyName.SPECIALEQ => tau' + | TyName.EQ => ( List.app makeEquality taus ; tau' ) + | TyName.NOEQ => raise Unify + ) + + | makeEquality'(Overloaded(O)) = + (case OverloadingClass.makeEquality O + of NONE => raise Unify + | SOME O' => Overloaded(O') + ) + | makeEquality'(Link(tau)) = + ( makeEquality tau ; Link(tau) ) + + + + fun unifyRestricted U (tau1,tau2) = + let + fun skolemise(alpha, mu) = + let + val equality = if TyVar.admitsEquality alpha then TyName.EQ + else TyName.NOEQ + val tau' = ConsType([], TyName.invent(0,equality)) + in + TyVarMap.insert(mu, alpha, ref tau') + end + + val mu = TyVarSet.foldl skolemise TyVarMap.empty U + in + unify(substitute mu tau1, substitute mu tau2) + end + + + + (* Assign default type to overloaded type components [Appendix E] *) + + fun defaultOverloaded(tau as ref(Overloaded(O))) = + tau := ConsType([], OverloadingClass.default O) + + | defaultOverloaded(ref tau') = defaultOverloaded' tau' + + and defaultOverloaded'(TyVar(alpha')) = () + + | defaultOverloaded'(RowType(Rho,r)) = + LabMap.app defaultOverloaded Rho + + | defaultOverloaded'(FunType(tau1,tau2)) = + ( defaultOverloaded tau1 ; defaultOverloaded tau2 ) + + | defaultOverloaded'(ConsType(taus,t)) = + List.app defaultOverloaded taus + + | defaultOverloaded'(Overloaded(O)) = + raise Fail "Type.defaultOverloaded: bypassed overloaded type" + + | defaultOverloaded'(Link(tau)) = + defaultOverloaded tau + + + + (* Operations on rows *) + + val emptyRho = ( LabMap.empty, CLOSEDRow ) + fun singletonRho(lab,tau) = ( LabMap.singleton(lab,tau), CLOSEDRow ) + fun inventRho() = ( LabMap.empty, FLEXRow false ) + fun insertRho((Rho,r), lab, tau) = ( LabMap.insert(Rho, lab, tau), r ) + fun findLab((Rho,r), lab) = LabMap.find(Rho, lab) + + end +(* stop of Type.sml *) +(* start of TYPESCHEME.sml *) +(* + * Standard ML type schemes + * + * Definition, section 4.2, 4.5, and 4.8 + * + * Note: + * Instantiation copies a type (except free type variables). + * Closure does not! + *) + +signature TYPESCHEME = + sig + + (* Import types *) + + type Type = Type.Type + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type Substitution = Type.Substitution + type Realisation = Type.Realisation + type 'a TyNameMap = 'a TyNameMap.map + + + (* Type [Section 4.2] *) + + type TypeScheme = TyVar list * Type (* [sigma] *) + + + (* Operations *) + + val instance: TypeScheme -> Type + val instance': TypeScheme -> TyVar list * Type + val Clos: Type -> TypeScheme + val ClosRestricted: TyVarSet -> Type -> TypeScheme + val isClosed: TypeScheme -> bool + + val tyvars: TypeScheme -> TyVarSet + val tynames: TypeScheme -> TyNameSet + val normalise: TypeScheme -> TypeScheme + + val generalises: TypeScheme * TypeScheme -> bool + val equals: TypeScheme * TypeScheme -> bool + + val substitute: Substitution -> TypeScheme -> TypeScheme + val realise: Realisation -> TypeScheme -> TypeScheme + + end +(* stop of TYPESCHEME.sml *) +(* start of TypeScheme.sml *) +(* + * Standard ML type schemes + * + * Definition, section 4.2, 4.5, and 4.8 + * + * Note: + * Instantiation copies a type (except free type variables). + * Closure does not! + *) + +structure TypeScheme :> TYPESCHEME = + struct + + (* Import types *) + + type Type = Type.Type + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type Substitution = Type.Substitution + type Realisation = Type.Realisation + type 'a TyNameMap = 'a TyNameMap.map + + + (* Type [Section 4.2] *) + + type TypeScheme = TyVar list * Type (* [sigma] *) + + + (* Some helper (this should be in the library...) *) + + fun List_foldri f y0 xs = + let + fun fold(n, []) = y0 + | fold(n, x::xs) = f(n, x, fold(n+1,xs)) + in + fold(0,xs) + end + + + + (* Type variable and type name extraction [Section 4.2] *) + + fun tyvars (alphas,tau) = + let + val U = Type.tyvars tau + in + List.foldl + (fn(alpha,U) => TyVarSet.delete(U,alpha) + handle LibBase.NotFound => U) + U alphas + end + + fun tynames (alphas,tau) = Type.tynames tau + + + + (* Instantiation *) + + fun instance' (alphas,tau) = + let + val alphas' = List.map TyVar.instance alphas + val mu = ListPair.foldl + (fn(alpha, alpha', mu) => + TyVarMap.insert(mu, alpha, Type.fromTyVar alpha')) + TyVarMap.empty (alphas, alphas') + in + ( alphas', Type.substitute mu tau ) + end + + fun instance sigma = #2(instance' sigma) + + + + (* Generalisation [Section 4.5] *) + + fun generalisesType(sigma, tau) = + let + val U = Type.tyvars tau + in + ( Type.unifyRestricted U (instance sigma, tau) ; true ) + handle Type.Unify => false + end + + fun generalises(sigma1, sigma2) = + generalisesType(sigma1, instance sigma2) + + + + (* Closure [Section 4.8] *) + + fun Clos tau = + (* Does not copy! *) + ( TyVarSet.listItems(Type.tyvars tau), tau ) + + fun ClosRestricted U tau = + ( TyVarSet.listItems(TyVarSet.difference(Type.tyvars tau, U)), tau ) + + fun isClosed (alphas,tau) = + TyVarSet.isSubset(Type.tyvars tau, TyVarSet.fromList alphas) + + + (* Comparison [Section 4.5] *) + + fun equals((alphas1,tau1), (alphas2,tau2)) = + List.length alphas1 = List.length alphas2 andalso + let + fun insert(alpha1, alpha2, mu) = + TyVarMap.insert(mu, alpha1, Type.fromTyVar alpha2) + + val (alphas2',tau2') = instance' (alphas2,tau2) + val mu = ListPair.foldl insert TyVarMap.empty (alphas1,alphas2') + val tau1' = Type.substitute mu tau1 + val U = TyVarSet.fromList alphas2' + in + ( Type.unifyRestricted U (tau1',tau2') ; true ) + handle Type.Unify => false + end + + + (* Normalisation (for output) *) + + fun normalise (alphas,tau) = + let + fun insert(n, alpha, (alphas',mu)) = + let + val alpha' = TyVar.normalise(alpha, n) + val tau = Type.fromTyVar alpha' + in + ( alpha'::alphas', TyVarMap.insert(mu, alpha,tau) ) + end + + val (alphas',mu) = List_foldri insert (nil,TyVarMap.empty) alphas + in + ( alphas', Type.substitute mu tau ) + end + + + (* Substitution *) + + fun substitute mu (alphas,tau) = + let + val mu' = List.foldl (fn(alpha,mu) => + #1(TyVarMap.remove(mu,alpha)) + handle LibBase.NotFound => mu) mu alphas + in + ( alphas, Type.substitute mu' tau ) + end + + + (* Realisation [Section 5.2] *) + + fun realise phi (alphas,tau) = (alphas, Type.realise phi tau) + + end +(* stop of TypeScheme.sml *) +(* start of TYPEFCN.sml *) +(* + * Standard ML type functions + * + * Definition, section 4.2, 4.4, and 4.8 + * + * Note: + * Application copies the type (except free type variables). + *) + +signature TYPEFCN = + sig + + (* Import types *) + + type Type = Type.Type + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type Realisation = Type.TypeFcn TyNameMap.map + + + (* Type [Section 4.2] *) + + type TypeFcn = Type.TypeFcn (* [theta] *) + + + (* Operations *) + + val fromTyName: TyName -> TypeFcn + val toTyName: TypeFcn -> TyName option + val isClosed: TypeFcn -> bool + + val arity: TypeFcn -> int + val admitsEquality: TypeFcn -> bool + + val tyvars: TypeFcn -> TyVarSet + val tynames: TypeFcn -> TyNameSet + val normalise: TypeFcn -> TypeFcn + val rename: TypeFcn -> TypeFcn + + val equals: TypeFcn * TypeFcn -> bool + + exception Apply + val apply: Type list * TypeFcn -> Type (* may raise Apply *) + + val realise: Realisation -> TypeFcn -> TypeFcn + + val makeEquality: TypeFcn -> unit + + end +(* stop of TYPEFCN.sml *) +(* start of TypeFcn.sml *) +(* + * Standard ML type functions + * + * Definition, section 4.2, 4.4, and 4.8 + * + * Note: + * Application copies the type (except free type variables). + *) + +structure TypeFcn :> TYPEFCN = + struct + + (* Import types *) + + type Type = Type.Type + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type Realisation = Type.TypeFcn TyNameMap.map + + + (* Type [Section 4.2] *) + + type TypeFcn = Type.TypeFcn (* [theta] *) + + + (* Operations *) + + val tyvars = TypeScheme.tyvars (* same type ;-) *) + val tynames = TypeScheme.tynames + val equals = TypeScheme.equals + val isClosed = TypeScheme.isClosed + val realise = TypeScheme.realise + val rename = TypeScheme.instance' + val normalise = TypeScheme.normalise + + + (* Arity [Section 4.4] *) + + fun arity (alphas,tau) = List.length alphas + + + (* Equality [Section 4.4] *) + + fun admitsEquality (alphas,tau) = + let + fun insert(alpha, mu) = + TyVarMap.insert(mu, alpha, Type.fromTyVar(TyVar.invent true)) + + val mu = List.foldl insert TyVarMap.empty alphas + in + Type.admitsEquality(Type.substitute mu tau) + end + + + (* Eta-conversion [Section 4.4] *) + + fun fromTyName t = + let + val alphas = List.tabulate(TyName.arity t, TyVar.fromIndex false) + in + ( alphas, Type.fromConsType(List.map Type.fromTyVar alphas, t) ) + end + + fun toTyName(alphas, ref(Type.ConsType(taus,t))) = t + | toTyName _ = raise Fail "TypeFcn.toTyName: invalid type function" + + fun toTyName(alphas, ref(Type.ConsType(taus,t))) = + let + fun isSame(alpha, ref(Type.TyVar alpha')) = alpha = alpha' + | isSame(alpha, _ ) = false + in + if List.length alphas = List.length taus + andalso ListPair.all isSame (alphas, taus) then + SOME t + else + NONE + end + + | toTyName _ = NONE + + + (* Application [Section 4.4] *) + + exception Apply + + fun apply(taus, (alphas,tau)) = + if List.length taus <> List.length alphas then raise Apply else + let + fun insert(alpha, tau, mu) = TyVarMap.insert(mu, alpha, tau) + val mu = ListPair.foldl insert TyVarMap.empty (alphas, taus) + in + Type.substitute mu tau + end + + + (* Make it an equality type *) + + fun makeEquality (alphas,tau) = Type.makeEquality tau + + end +(* stop of TypeFcn.sml *) +(* start of IDSTATUS.sml *) +(* + * Standard ML identifier status + * + * Definition, sections 4.1 and 5.5 + *) + + +signature IDSTATUS = + sig + + (* Type [Section 4.1] *) + + datatype IdStatus = c | e | v (* [is] *) + + + (* Operations *) + + val generalises: IdStatus * IdStatus -> bool + + end +(* stop of IDSTATUS.sml *) +(* start of IdStatus.sml *) +(* + * Standard ML identifier status + * + * Definition, sections 4.1 and 5.5 + *) + + +structure IdStatus :> IDSTATUS = + struct + + (* Type [Section 4.1] *) + + datatype IdStatus = c | e | v (* [is] *) + + + (* Generalisation [Section 5.5] *) + + fun generalises(is1,is2) = is1 = is2 orelse is2 = v + + end +(* stop of IdStatus.sml *) +(* start of GENERIC_ENV.sml *) +(* + * Standard ML generic core environment + * + * Definition, sections 4.2, 4.3, 6.3 and 7.2 + * + * Notes: + * - A datatype Str is necessary to break the recursion + * between Env and StrEnv. + * - Also, all types are parameterised over the range of value and type + * environments. This is because of the recursion between values and + * the dynamic environment (via function closures) -- we cannot make them + * into functor parameters as this would require recursive structures. + *) + +signature GENERIC_ENV = + sig + + (* Import types *) + + type VId = VId.Id + type TyCon = TyCon.Id + type StrId = StrId.Id + type longVId = LongVId.longId + type longTyCon = LongTyCon.longId + type longStrId = LongStrId.longId + type IdStatus = IdStatus.IdStatus + + type 'a VIdMap = 'a VIdMap.map + type 'a TyConMap = 'a TyConMap.map + type 'a StrIdMap = 'a StrIdMap.map + + + (* Export types [Section 4.2 and 6.3] *) + + datatype ('a,'b) Str' = Str of (*Env*) + ('a,'b) Str' StrIdMap * 'b TyConMap * 'a VIdMap + + type 'a ValEnv' = 'a VIdMap + type 'b TyEnv' = 'b TyConMap + type ('a,'b) StrEnv' = ('a,'b) Str' StrIdMap + + type ('a,'b) Env' = ('a,'b) StrEnv' * 'b TyEnv' * 'a ValEnv' + + + (* Operations *) + + val empty: ('a,'b) Env' + + val fromSE: ('a,'b) StrEnv' -> ('a,'b) Env' + val fromTE: 'b TyEnv' -> ('a,'b) Env' + val fromVE: 'a ValEnv' -> ('a,'b) Env' + val fromVEandTE: 'a ValEnv' * 'b TyEnv' -> ('a,'b) Env' + + val plus: ('a,'b) Env' * ('a,'b) Env' -> ('a,'b) Env' + val plusVE: ('a,'b) Env' * 'a ValEnv' -> ('a,'b) Env' + val plusTE: ('a,'b) Env' * 'b TyEnv' -> ('a,'b) Env' + val plusSE: ('a,'b) Env' * ('a,'b) StrEnv' -> ('a,'b) Env' + val plusVEandTE: ('a,'b) Env' * ('a ValEnv' * 'b TyEnv') -> ('a,'b) Env' + + val findVId: ('a,'b) Env' * VId -> 'a option + val findTyCon: ('a,'b) Env' * TyCon -> 'b option + val findStrId: ('a,'b) Env' * StrId -> ('a,'b) Str' option + val findLongVId: ('a,'b) Env' * longVId -> 'a option + val findLongTyCon: ('a,'b) Env' * longTyCon -> 'b option + val findLongStrId: ('a,'b) Env' * longStrId -> ('a,'b) Str' option + + val disjoint: ('a,'b) Env' * ('a,'b) Env' -> bool + + end +(* stop of GENERIC_ENV.sml *) +(* start of GenericEnvFn.sml *) +(* + * Standard ML generic core environment + * + * Definition, sections 4.2, 4.3, 6.3 and 7.2 + * + * Notes: + * - A datatype Str is necessary to break the recursion + * between Env and StrEnv. + * - Also, all types are parameterised over the range of value and type + * environments. This is because of the recursion between values and + * the dynamic environment (via function closures) -- we cannot make them + * into functor parameters as this would require recursive structures. + *) + +functor GenericEnvFn() :> GENERIC_ENV = + struct + + (* Import types *) + + type VId = VId.Id + type TyCon = TyCon.Id + type StrId = StrId.Id + type longVId = LongVId.longId + type longTyCon = LongTyCon.longId + type longStrId = LongStrId.longId + type IdStatus = IdStatus.IdStatus + + type 'a VIdMap = 'a VIdMap.map + type 'a TyConMap = 'a TyConMap.map + type 'a StrIdMap = 'a StrIdMap.map + + + (* Export types [Section 4.2 and 6.3] *) + + datatype ('a,'b) Str' = Str of (*Env*) + ('a,'b) Str' StrIdMap * 'b TyConMap * 'a VIdMap + + type 'a ValEnv' = 'a VIdMap (* [VE] *) + type 'b TyEnv' = 'b TyConMap (* [TE] *) + type ('a,'b) StrEnv' = ('a,'b) Str' StrIdMap (* [SE] *) + + type ('a,'b) Env' = ('a,'b) StrEnv' * 'b TyEnv' * 'a ValEnv' (* [E] *) + + + (* Injections [Section 4.3] *) + + val empty = ( StrIdMap.empty, TyConMap.empty, VIdMap.empty ) + + fun fromSE SE = ( SE, TyConMap.empty, VIdMap.empty ) + fun fromTE TE = ( StrIdMap.empty, TE, VIdMap.empty ) + fun fromVE VE = ( StrIdMap.empty, TyConMap.empty, VE ) + fun fromVEandTE(VE,TE) = ( StrIdMap.empty, TE, VE ) + + + (* Modifications [Section 4.3] *) + + infix plus plusVE plusTE plusSE plusVEandTE + + fun (SE,TE,VE) plus (SE',TE',VE') = + ( StrIdMap.unionWith #2 (SE,SE') + , TyConMap.unionWith #2 (TE,TE') + , VIdMap.unionWith #2 (VE,VE') + ) + + fun (SE,TE,VE) plusVE VE' = ( SE, TE, VIdMap.unionWith #2 (VE,VE') ) + fun (SE,TE,VE) plusTE TE' = ( SE, TyConMap.unionWith #2 (TE,TE'), VE ) + fun (SE,TE,VE) plusSE SE' = ( StrIdMap.unionWith #2 (SE,SE'), TE, VE ) + fun (SE,TE,VE) plusVEandTE (VE',TE') = + ( SE + , TyConMap.unionWith #2 (TE,TE') + , VIdMap.unionWith #2 (VE,VE') + ) + + + (* Application (lookup) [Section 4.3] *) + + fun findVId ((SE,TE,VE), vid) = VIdMap.find(VE, vid) + fun findTyCon((SE,TE,VE), tycon) = TyConMap.find(TE, tycon) + fun findStrId((SE,TE,VE), strid) = StrIdMap.find(SE, strid) + + fun findLongX'(E, findX, [], x) = findX(E, x) + | findLongX'(E, findX, strid::strids, x) = + Option.mapPartial (fn E => findLongX'(E, findX, strids, x)) + (Option.map (fn Str E => E) (findStrId(E, strid))) + + fun findLongX (explodeLongX, findX) (E, longX) = + let + val (strids,x) = explodeLongX longX + in + findLongX'(E, findX, strids, x) + end + + fun findLongVId x = findLongX (LongVId.explode, findVId) x + fun findLongTyCon x = findLongX (LongTyCon.explode, findTyCon) x + fun findLongStrId x = findLongX (LongStrId.explode, findStrId) x + + + (* Disjointness *) + + fun disjoint((SE1,TE1,VE1), (SE2,TE2,VE2)) = + StrIdMap.disjoint(SE1,SE2) andalso + TyConMap.disjoint(TE1,TE2) andalso + VIdMap.disjoint(VE1,VE2) + + end +(* stop of GenericEnvFn.sml *) +(* start of STATIC_ENV.sml *) +(* + * Standard ML environments of the static semantics of the core + * + * Definition, sections 4.2, 4.3, 4.8, 4.9, and 5.5 + * + * Note: + * We call the domain type of value environments ValStr. + *) + +signature STATIC_ENV = + sig + + (* Inheritance *) + + include GENERIC_ENV + + + (* Import types *) + + type TypeScheme = TypeScheme.TypeScheme + type TypeFcn = TypeFcn.TypeFcn + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type Realisation = Type.Realisation + + + (* Export types [Section 4.2] *) + + type ValStr = TypeScheme * IdStatus + type ValEnv = ValStr VIdMap (* [VE] *) + + type TyStr = TypeFcn * ValEnv + type TyEnv = TyStr TyConMap (* [TE] *) + + type Str = (ValStr, TyStr) Str' + type StrEnv = Str StrIdMap (* [SE] *) + + type Env = StrEnv * TyEnv * ValEnv (* [E] *) + + + (* Operations *) + + val tyvarsVE: ValEnv -> TyVarSet + val tyvars: Env -> TyVarSet + val tynamesTE: TyEnv -> TyNameSet + val tynamesSE: StrEnv -> TyNameSet + val tynames: Env -> TyNameSet + + val isWellFormed: Env -> bool + + val Clos: ValEnv -> ValEnv + val containsFlexibleType: ValEnv -> bool + val defaultOverloaded: ValEnv -> unit + val makeEquality: TyEnv -> unit + val maximiseEquality: TyEnv * ValEnv -> TyEnv * ValEnv + val Abs: TyEnv * Env -> Env + val realise: Realisation -> Env -> Env + + val enriches: Env * Env -> bool + + end +(* stop of STATIC_ENV.sml *) +(* start of StaticEnv.sml *) +(* + * Standard ML environments of the static semantics of the core + * + * Definition, sections 4.2, 4.3, 4.8, 4.9, and 5.5 + * + * Note: + * We call the domain type of value environments ValStr. + *) + +structure StaticEnv :> STATIC_ENV = + struct + + (* Inheritance *) + + structure GenericEnv = GenericEnvFn() + + open GenericEnv + + + (* Import types *) + + type TypeScheme = TypeScheme.TypeScheme + type TypeFcn = TypeFcn.TypeFcn + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type Realisation = Type.Realisation + + + (* Export types [Section 4.2] *) + + type ValStr = TypeScheme * IdStatus + type ValEnv = ValStr VIdMap (* [VE] *) + + type TyStr = TypeFcn * ValEnv + type TyEnv = TyStr TyConMap (* [TE] *) + + type Str = (ValStr, TyStr) Str' + type StrEnv = Str StrIdMap (* [SE] *) + + type Env = StrEnv * TyEnv * ValEnv (* [E] *) + + + (* Further modifications [Section 4.3] *) + + infix TEplus + + fun TE' TEplus (SE,TE,VE) = ( SE, TyConMap.unionWith #2 (TE',TE), VE ) + + + (* Type variable and type name set [Section 4.2] *) + + fun tyvarsVE VE = + VIdMap.foldl + (fn((sigma,is), U) => TyVarSet.union(U, TypeScheme.tyvars sigma)) + TyVarSet.empty VE + + fun tyvarsTE TE = + TyConMap.foldl + (fn((theta,VE), U) => TyVarSet.union(TyVarSet.union + (U, TypeFcn.tyvars theta), tyvarsVE VE)) + TyVarSet.empty TE + + fun tyvarsSE SE = + StrIdMap.foldl + (fn(Str E, U) => TyVarSet.union(U, tyvars E)) + TyVarSet.empty SE + + and tyvars (SE,TE,VE) = + TyVarSet.union(TyVarSet.union(tyvarsSE SE, tyvarsTE TE), tyvarsVE VE) + + + fun tynamesVE VE = + VIdMap.foldl + (fn((sigma,is), T) => TyNameSet.union(T, TypeScheme.tynames sigma)) + TyNameSet.empty VE + + fun tynamesTE TE = + TyConMap.foldl + (fn((theta,VE), T) => TyNameSet.union(TyNameSet.union + (T, TypeFcn.tynames theta), tynamesVE VE)) + TyNameSet.empty TE + + fun tynamesSE SE = + StrIdMap.foldl + (fn(Str E, T) => TyNameSet.union(T, tynames E)) + TyNameSet.empty SE + + and tynames (SE,TE,VE) = + TyNameSet.union(TyNameSet.union(tynamesSE SE, tynamesTE TE), + tynamesVE VE) + + + (* Well-formedness [Section 4.9] *) + + fun isWellFormedTyStr (theta,VE) = + VIdMap.isEmpty VE orelse isSome(TypeFcn.toTyName theta) + + fun isWellFormedTE TE = + TyConMap.all isWellFormedTyStr TE + + fun isWellFormedSE SE = + StrIdMap.all (fn Str E => isWellFormed E) SE + + and isWellFormed (SE,TE,VE) = + isWellFormedTE TE andalso isWellFormedSE SE + + + + (* Closure [Section 4.8] *) + + fun Clos VE = + VIdMap.map (fn((_,tau), is) => (TypeScheme.Clos tau, is)) VE + + + (* Check for unresolved flexible record types [Section 4.11, item 1] *) + + fun containsFlexibleType VE = + VIdMap.exists (fn((_,tau), is) => Type.isFlexible tau) VE + + + (* Assign default types to overloaded types [Appendix E] *) + + fun defaultOverloaded VE = + VIdMap.app (fn((_,tau), is) => Type.defaultOverloaded tau) VE + + + (* Realisation [Section 5.2] *) + + fun realiseVE phi VE = + VIdMap.map (fn(sigma,is) => ( TypeScheme.realise phi sigma, is )) VE + + and realiseTE phi TE = + TyConMap.map (fn(theta,VE) => ( TypeFcn.realise phi theta + , realiseVE phi VE + )) TE + and realiseSE phi SE = + StrIdMap.map (fn(Str E) => Str(realise phi E)) SE + + and realise phi (SE,TE,VE) = + ( realiseSE phi SE + , realiseTE phi TE + , realiseVE phi VE + ) + + + (* Make all type names bound in a type environment equality types *) + + (* Assumes abstract types, i.e. no constructors. *) + + fun makeEquality TE = + TyConMap.app (fn(theta,VE) => TypeFcn.makeEquality theta) TE + + + + (* Maximise equality of a type environment [Section 4.9], + * together with its appendant value envrionment + *) + + fun admitsEqualityValStr ((_,tau),_) = Type.admitsEquality tau + + fun maximiseEquality(TE,VE) = + let + fun checkTyStr((theta,VE), (phi,changed)) = + let + val t = valOf(TypeFcn.toTyName theta) + in + if TyName.equality t = TyName.EQ + andalso not(VIdMap.all admitsEqualityValStr VE) then + ( TyNameMap.insert(phi, + t, + TypeFcn.fromTyName + (TyName.removeEquality t) + ) + , true + ) + else + ( phi, changed ) + end + + fun checkTE(TE, phi) = + let + val (phi',change) = TyConMap.foldl checkTyStr (phi,false) TE + val TE' = realiseTE phi' TE + in + if change then checkTE(TE', phi') + else (TE', phi') + end + + val (TE',phi) = checkTE(TE, TyNameMap.empty) + in + ( TE', realiseVE phi VE ) + end + + + + (* Abstraction of a type environment [Section 4.9] *) + + fun AbsTE(TE) = TyConMap.map (fn(theta,_) => (theta,VIdMap.empty)) TE + + fun Abs(TE,E) = + let + val ts = tynamesTE TE + val phi = TyNameSet.foldl + (fn(t,phi) => TyNameMap.insert(phi, t, + TypeFcn.fromTyName(TyName.Abs t))) + TyNameMap.empty ts + in + realise phi (AbsTE(TE) TEplus E) + end + + + (* Disjointness *) + + fun disjoint((SE1,TE1,VE1), (SE2,TE2,VE2)) = + StrIdMap.disjoint(SE1,SE2) andalso + TyConMap.disjoint(TE1,TE2) andalso + VIdMap.disjoint(VE1,VE2) + + + (* Enrichment [Section 5.5] *) + + fun equalsVE(VE1,VE2) = + VIdMap.numItems VE1 = VIdMap.numItems VE2 andalso + VIdMap.alli + (fn(vid, (sigma1,is1)) => + case VIdMap.find(VE2, vid) + of NONE => false + | SOME(sigma2,is2) => + TypeScheme.equals(sigma1,sigma2) andalso is1 = is2 + ) + VE1 + + + fun enriches((SE1,TE1,VE1), (SE2,TE2,VE2)) = + enrichesSE(SE1,SE2) andalso + enrichesTE(TE1,TE2) andalso + enrichesVE(VE1,VE2) + + and enrichesSE(SE1,SE2) = + StrIdMap.alli + (fn(strid, Str E2) => + case StrIdMap.find(SE1, strid) + of NONE => false + | SOME(Str E1) => enriches(E1,E2) + ) + SE2 + + and enrichesTE(TE1,TE2) = + TyConMap.alli + (fn(tycon, tystr2) => + case TyConMap.find(TE1, tycon) + of NONE => false + | SOME tystr1 => enrichesTyStr(tystr1,tystr2) + ) + TE2 + + and enrichesVE(VE1,VE2) = + VIdMap.alli + (fn(vid, valstr2) => + case VIdMap.find(VE1, vid) + of NONE => false + | SOME valstr1 => enrichesValStr(valstr1,valstr2) + ) + VE2 + + and enrichesTyStr((theta1,VE1), (theta2,VE2)) = + TypeFcn.equals(theta1,theta2) andalso + ( VIdMap.isEmpty VE2 orelse equalsVE(VE1,VE2) ) + + and enrichesValStr((sigma1,is1), (sigma2,is2)) = + TypeScheme.generalises(sigma1,sigma2) andalso + IdStatus.generalises(is1,is2) + + end +(* stop of StaticEnv.sml *) +(* start of SIG.sml *) +(* + * Standard ML signatures + * + * Definition, sections 5.1, 5.3, and 5.6 + *) + + +signature SIG = + sig + + (* Import types *) + + type Env = StaticEnv.Env + type TyVarSet = TyVarSet.set + type TyNameSet = TyNameSet.set + type Realisation = Type.Realisation + + + (* Type [Section 5.1] *) + + type Sig = TyNameSet * Env (* [Sigma] *) + + + (* Operations *) + + val tyvars: Sig -> TyVarSet + val tynames: Sig -> TyNameSet + + val rename: Sig -> Sig + + exception Match + val match: Env * Sig -> Env * Realisation (* Matching *) + + end +(* stop of SIG.sml *) +(* start of Sig.sml *) +(* + * Standard ML signatures + * + * Definition, sections 5.1, 5.3, and 5.6 + *) + + +structure Sig :> SIG = + struct + + (* Import types *) + + type Env = StaticEnv.Env + type TyVarSet = TyVarSet.set + type TyNameSet = TyNameSet.set + type Realisation = Type.Realisation + + + (* Type [Section 5.1] *) + + type Sig = TyNameSet * Env (* [Sigma] *) + + + (* Type variable and type name extraction [Section 4.2] *) + + fun tyvars (T,E) = StaticEnv.tyvars E + fun tynames (T,E) = TyNameSet.difference(StaticEnv.tynames E, T) + + + (* Alpha Renaming *) + + fun rename (T,E) = + let + val phi' = TyNameSet.foldl + (fn(t,phi')=> TyNameMap.insert(phi',t,TyName.rename t)) + TyNameMap.empty T + val phi = TyNameMap.map TypeFcn.fromTyName phi' + val T' = TyNameSet.map (fn t => valOf(TyNameMap.find(phi',t))) T + val E' = StaticEnv.realise phi E + in + (T',E') + end + + + (* Matching [Section 5.6] *) + + exception Match + + fun matchTypeFcn(theta', theta, phi, T) = + if TypeFcn.arity theta <> TypeFcn.arity theta' then + raise Match + else + case TypeFcn.toTyName theta + of NONE => phi + | SOME t => + if isSome(TyNameMap.find(phi, t)) + orelse not(TyNameSet.member(T, t)) then + phi + else + let + val phi' = TyNameMap.insert(phi, t, TypeFcn.rename theta') + in + TyNameMap.map (TypeFcn.realise phi') phi' + end + + fun matchTE(TE', TE, phi, T) = + let + fun matchTyStr(tycon, (theta,VE), phi) = + case TyConMap.find(TE', tycon) + of NONE => raise Match + | SOME(theta',VE') => matchTypeFcn(theta', theta, phi, T) + in + TyConMap.foldli matchTyStr phi TE + end + + fun matchSE(SE', SE, phi, T) = + let + fun matchStr(strid, StaticEnv.Str E, phi) = + case StrIdMap.find(SE', strid) + of NONE => raise Match + | SOME(StaticEnv.Str E') => matchE(E', E, phi, T) + in + StrIdMap.foldli matchStr phi SE + end + + and matchE((SE',TE',VE'), (SE,TE,VE), phi, T) = + let + val phi1 = matchTE(TE', TE, phi, T) + val phi2 = matchSE(SE', SE, phi1, T) + in + phi2 + end + + fun match(E', (T,E)) = + let + val phi = matchE(E', E, TyNameMap.empty, T) + val E'' = StaticEnv.realise phi E + in + if StaticEnv.enriches(E',E'') then + (E'', phi) + else + raise Match + end + + end +(* stop of Sig.sml *) +(* start of FUNSIG.sml *) +(* + * Standard ML functor signatures + * + * Definition, sections 5.1 and 5.4 + *) + + +signature FUNSIG = + sig + + (* Import types *) + + type Env = StaticEnv.Env + type Sig = Sig.Sig + type TyVarSet = TyVarSet.set + type TyNameSet = TyNameSet.set + + + (* Type [Section 5.1] *) + + type FunSig = TyNameSet * (Env * Sig) (* [Phi] *) + + + (* Operations *) + + val tyvars: FunSig -> TyVarSet + val tynames: FunSig -> TyNameSet + + end +(* stop of FUNSIG.sml *) +(* start of FunSig.sml *) +(* + * Standard ML functor signatures + * + * Definition, sections 5.1 and 5.4 + *) + + +structure FunSig :> FUNSIG = + struct + + (* Import types *) + + type Env = StaticEnv.Env + type Sig = Sig.Sig + type TyVarSet = TyVarSet.set + type TyNameSet = TyNameSet.set + + + (* Type [Section 5.1] *) + + type FunSig = TyNameSet * (Env * Sig) (* [Phi] *) + + + (* Type variable and type name extraction [Section 4.2] *) + + fun tyvars (T,(E,Sigma)) = + TyVarSet.union(StaticEnv.tyvars E, Sig.tyvars Sigma) + + fun tynames (T,(E,Sigma)) = + TyNameSet.difference(TyNameSet.union(StaticEnv.tynames E, + Sig.tynames Sigma), T) + + end +(* stop of FunSig.sml *) +(* start of CONTEXT.sml *) +(* + * Standard ML contexts + * + * Definition, sections 4.2, 4.3, 4.7, and 4.9 + *) + +signature CONTEXT = + sig + + (* Import types *) + + type VId = VId.Id + type TyCon = TyCon.Id + type StrId = StrId.Id + type longVId = LongVId.longId + type longTyCon = LongTyCon.longId + type longStrId = LongStrId.longId + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type IdStatus = IdStatus.IdStatus + type TypeScheme = TypeScheme.TypeScheme + type StrEnv = StaticEnv.StrEnv + type Str = StaticEnv.Str + type TyStr = StaticEnv.TyStr + type TyEnv = StaticEnv.TyEnv + type ValStr = StaticEnv.ValStr + type ValEnv = StaticEnv.ValEnv + type Env = StaticEnv.Env + + + (* Type [Section 4.2] *) + + type Context = TyNameSet * TyVarSet * Env (* [C] *) + + + (* Operations *) + + val Tof: Context -> TyNameSet + val Uof: Context -> TyVarSet + val Eof: Context -> Env + + val plusVE: Context * ValEnv -> Context + val plusU: Context * TyVarSet -> Context + val oplusE: Context * Env -> Context + val oplusTE: Context * TyEnv -> Context + val oplusVEandTE: Context * (ValEnv * TyEnv) -> Context + + val findVId: Context * VId -> ValStr option + val findTyCon: Context * TyCon -> TyStr option + val findStrId: Context * StrId -> Str option + val findLongVId: Context * longVId -> ValStr option + val findLongTyCon: Context * longTyCon -> TyStr option + val findLongStrId: Context * longStrId -> Str option + + val tyvars: Context -> TyVarSet + + end +(* stop of CONTEXT.sml *) +(* start of Context.sml *) +(* + * Standard ML contexts + * + * Definition, sections 4.2, 4.3, 4.7, and 4.9 + *) + +structure Context :> CONTEXT = + struct + + (* Import types *) + + type VId = VId.Id + type TyCon = TyCon.Id + type StrId = StrId.Id + type longVId = LongVId.longId + type longTyCon = LongTyCon.longId + type longStrId = LongStrId.longId + type TyName = TyName.TyName + type TyNameSet = TyNameSet.set + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type IdStatus = IdStatus.IdStatus + type TypeScheme = TypeScheme.TypeScheme + type StrEnv = StaticEnv.StrEnv + type Str = StaticEnv.Str + type TyStr = StaticEnv.TyStr + type TyEnv = StaticEnv.TyEnv + type ValStr = StaticEnv.ValStr + type ValEnv = StaticEnv.ValEnv + type Env = StaticEnv.Env + + + (* Type [Section 4.2] *) + + type Context = TyNameSet * TyVarSet * Env (* [C] *) + + + (* Projections [Section 4.3] *) + + fun Tof (T,U,E) = T + fun Uof (T,U,E) = U + fun Eof (T,U,E) = E + + + (* Modification [Section 4.3] *) + + infix plusVE plusU oplusE oplusTE oplusVEandTE + + fun (T,U,E) plusVE VE = ( T, U, StaticEnv.plusVE(E,VE) ) + fun (T,U,E) plusU U' = ( T, TyVarSet.union(U,U'), E ) + + fun (T,U,E) oplusE E' = + ( TyNameSet.union(T, StaticEnv.tynames E) + , U + , StaticEnv.plus(E,E') + ) + + fun (T,U,E) oplusTE TE = + ( TyNameSet.union(T, StaticEnv.tynamesTE TE) + , U + , StaticEnv.plusTE(E,TE) + ) + + fun (T,U,E) oplusVEandTE (VE,TE) = + ( TyNameSet.union(T, StaticEnv.tynamesTE TE) + , U + , StaticEnv.plusVEandTE(E, (VE,TE)) + ) + + + (* Application (lookup) [Section 4.3] *) + + fun findVId ((T,U,E), vid) = StaticEnv.findVId(E, vid) + fun findTyCon((T,U,E), tycon) = StaticEnv.findTyCon(E, tycon) + fun findStrId((T,U,E), strid) = StaticEnv.findStrId(E, strid) + + fun findLongVId ((T,U,E), longvid) = StaticEnv.findLongVId(E,longvid) + fun findLongTyCon((T,U,E), longtycon) = StaticEnv.findLongTyCon(E,longtycon) + fun findLongStrId((T,U,E), longstrid) = StaticEnv.findLongStrId(E,longstrid) + + + (* Calculation of tyvars [Section 4.2] *) + + fun tyvars (T,U,E) = TyVarSet.union(U, StaticEnv.tyvars E) + + end +(* stop of Context.sml *) +(* start of STATIC_BASIS.sml *) +(* + * Standard ML static basis and environments of modules + * + * Definition, section 5.1 + *) + +signature STATIC_BASIS = + sig + + (* Import types *) + + type StrId = StrId.Id + type SigId = SigId.Id + type FunId = FunId.Id + type longStrId = LongStrId.longId + type longTyCon = LongTyCon.longId + type Env = StaticEnv.Env + type StrEnv = StaticEnv.StrEnv + type Str = StaticEnv.Str + type TyStr = StaticEnv.TyStr + type Context = Context.Context + type Sig = Sig.Sig + type FunSig = FunSig.FunSig + type TyVarSet = TyVarSet.set + type TyNameSet = TyNameSet.set + type 'a SigIdMap = 'a SigIdMap.map + type 'a FunIdMap = 'a FunIdMap.map + + + (* Types [Section 5.1] *) + + type SigEnv = Sig SigIdMap (* [G] *) + type FunEnv = FunSig FunIdMap (* [F] *) + + type Basis = TyNameSet * FunEnv * SigEnv * Env (* [B] *) + + + (* Operations *) + + val empty: Basis + val fromTandE: TyNameSet * Env -> Basis + val fromTandF: TyNameSet * FunEnv -> Basis + val fromTandG: TyNameSet * SigEnv -> Basis + + val Tof: Basis -> TyNameSet + val Cof: Basis -> Context + + val plus: Basis * Basis -> Basis + val plusT: Basis * TyNameSet -> Basis + val oplusSE: Basis * StrEnv -> Basis + val oplusG: Basis * SigEnv -> Basis + val oplusF: Basis * FunEnv -> Basis + val oplusE: Basis * Env -> Basis + + val findStrId: Basis * StrId -> Str option + val findSigId: Basis * SigId -> Sig option + val findFunId: Basis * FunId -> FunSig option + val findLongStrId: Basis * longStrId -> Str option + val findLongTyCon: Basis * longTyCon -> TyStr option + + val tyvars: Basis -> TyVarSet + val tynamesF: FunEnv -> TyNameSet + val tynamesG: SigEnv -> TyNameSet + + end +(* stop of STATIC_BASIS.sml *) +(* start of StaticBasis.sml *) +(* + * Standard ML static basis and environments of modules + * + * Definition, section 5.1 + *) + +structure StaticBasis :> STATIC_BASIS = + struct + + (* Import types *) + + type StrId = StrId.Id + type SigId = SigId.Id + type FunId = FunId.Id + type longStrId = LongStrId.longId + type longTyCon = LongTyCon.longId + type Env = StaticEnv.Env + type StrEnv = StaticEnv.StrEnv + type Str = StaticEnv.Str + type TyStr = StaticEnv.TyStr + type Context = Context.Context + type Sig = Sig.Sig + type FunSig = FunSig.FunSig + type TyVarSet = TyVarSet.set + type TyNameSet = TyNameSet.set + type 'a SigIdMap = 'a SigIdMap.map + type 'a FunIdMap = 'a FunIdMap.map + + + (* Types [Section 5.1] *) + + type SigEnv = Sig SigIdMap (* [G] *) + type FunEnv = FunSig FunIdMap (* [F] *) + + type Basis = TyNameSet * FunEnv * SigEnv * Env (* [B] *) + + + + (* Calculation of type variable and type name sets [Section 4.2] *) + + fun tyvarsG G = + SigIdMap.foldl + (fn(Sigma, U) => TyVarSet.union(U, Sig.tyvars Sigma)) + TyVarSet.empty G + + fun tyvarsF F = + FunIdMap.foldl + (fn(Phi, U) => TyVarSet.union(U, FunSig.tyvars Phi)) + TyVarSet.empty F + + fun tyvars (T,F,G,E) = TyVarSet.union(TyVarSet.union( + tyvarsF F, tyvarsG G), StaticEnv.tyvars E) + + + + fun tynamesG G = + SigIdMap.foldl + (fn(Sigma, T) => TyNameSet.union(T, Sig.tynames Sigma)) + TyNameSet.empty G + + fun tynamesF F = + FunIdMap.foldl + (fn(Phi, T) => TyNameSet.union(T, FunSig.tynames Phi)) + TyNameSet.empty F + + + + (* Injection [Sections 4.3 and 5.1] *) + + val empty = + ( TyNameSet.empty, FunIdMap.empty, SigIdMap.empty, StaticEnv.empty ) + + fun fromTandE(T,E) = ( T, FunIdMap.empty, SigIdMap.empty, E ) + fun fromTandF(T,F) = ( T, F, SigIdMap.empty, StaticEnv.empty ) + fun fromTandG(T,G) = ( T, FunIdMap.empty, G, StaticEnv.empty ) + + + (* Projections [Sections 4.3 and 5.1] *) + + fun Tof (T,F,G,E) = T + fun Cof (T,F,G,E) = (T, TyVarSet.empty, E) + + + (* Modifications [Sections 4.3 and 5.1] *) + + infix plus plusT oplusG oplusF oplusE oplusSE + + fun (T,F,G,E) plus (T',F',G',E') = + ( TyNameSet.union(T,T') + , FunIdMap.unionWith #2 (F,F') + , SigIdMap.unionWith #2 (G,G') + , StaticEnv.plus(E,E') + ) + + fun (T,F,G,E) plusT T' = ( TyNameSet.union(T,T'), F, G, E ) + + fun (T,F,G,E) oplusG G' = + ( TyNameSet.union(T, tynamesG G') + , F + , SigIdMap.unionWith #2 (G,G') + , E + ) + + fun (T,F,G,E) oplusF F' = + ( TyNameSet.union(T, tynamesF F') + , FunIdMap.unionWith #2 (F,F') + , G + , E + ) + + fun (T,F,G,E) oplusE E' = + ( TyNameSet.union(T, StaticEnv.tynames E') + , F + , G + , StaticEnv.plus(E,E') + ) + + fun (T,F,G,E) oplusSE SE = + ( TyNameSet.union(T, StaticEnv.tynamesSE SE) + , F + , G + , StaticEnv.plusSE(E,SE) + ) + + (* Application (lookup) [Sections 5.1 and 4.3] *) + + fun findStrId((T,F,G,E), strid) = StaticEnv.findStrId(E, strid) + fun findSigId((T,F,G,E), sigid) = SigIdMap.find(G, sigid) + fun findFunId((T,F,G,E), funid) = FunIdMap.find(F, funid) + fun findLongStrId((T,F,G,E), longstrid) = + StaticEnv.findLongStrId(E, longstrid) + fun findLongTyCon((T,F,G,E), longtycon) = + StaticEnv.findLongTyCon(E, longtycon) + + end +(* stop of StaticBasis.sml *) +(* start of INITIAL_STATIC_ENV.sml *) +(* + * Standard ML core view of the initial static basis + * + * Definition, appendices C and E + *) + +signature INITIAL_STATIC_ENV = + sig + + (* Import types *) + + type Type = Type.Type + type TyNameSet = TyNameSet.set + type OverloadingClass = OverloadingClass.OverloadingClass + type Env = StaticEnv.Env + + + (* Predefined monomorphic types [Figure 24] *) + + val tauBool: Type + val tauInt: Type + val tauWord: Type + val tauReal: Type + val tauString: Type + val tauChar: Type + val tauExn: Type + + (* Overloading classes [Appendix E.1] *) + + val Int: OverloadingClass + val Real: OverloadingClass + val Word: OverloadingClass + val String: OverloadingClass + val Char: OverloadingClass + val WordInt: OverloadingClass + val RealInt: OverloadingClass + val Num: OverloadingClass + val NumTxt: OverloadingClass + + (* Initial environment [Appendix C] *) + + val T0: TyNameSet + val E0: Env + + end +(* stop of INITIAL_STATIC_ENV.sml *) +(* start of InitialStaticEnv.sml *) +(* + * Standard ML core view of the initial static basis + * + * Definition, appendices C and E + *) + +structure InitialStaticEnv :> INITIAL_STATIC_ENV = + struct + + (* Import *) + + type Type = Type.Type + type TyNameSet = TyNameSet.set + type Overloadingclass = OverloadingClass.OverloadingClass + type VIdSet = VIdSet.set + type Env = StaticEnv.Env + type ValEnv = StaticEnv.ValEnv + + + open Type + open IdStatus + + + (* Helpers *) + + fun pairType(tau1,tau2) = + let + val Rho = LabMap.insert(LabMap.insert(LabMap.empty, + Lab.fromInt 1, tau1), + Lab.fromInt 2, tau2) + in + fromRowType (Rho,CLOSEDRow) + end + + + (* VIds [Figure 25] *) + + val vidEq = VId.fromString "=" + val vidAssign = VId.fromString ":=" + + val vidFalse = VId.fromString "false" + val vidTrue = VId.fromString "true" + val vidNil = VId.fromString "nil" + val vidCons = VId.fromString "::" + val vidRef = VId.fromString "ref" + + val vidMatch = VId.fromString "Match" + val vidBind = VId.fromString "Bind" + + + (* TyCons [Figure 24] *) + + val tyconUnit = TyCon.fromString "unit" + val tyconBool = TyCon.fromString "bool" + val tyconInt = TyCon.fromString "int" + val tyconWord = TyCon.fromString "word" + val tyconReal = TyCon.fromString "real" + val tyconString = TyCon.fromString "string" + val tyconChar = TyCon.fromString "char" + val tyconList = TyCon.fromString "list" + val tyconRef = TyCon.fromString "ref" + val tyconExn = TyCon.fromString "exn" + + + (* TyNames [Appendix C] *) + + val tBool = TyName.tyname(tyconBool, 0, TyName.EQ, 2) + val tInt = TyName.tyname(tyconInt, 0, TyName.EQ, 0) + val tWord = TyName.tyname(tyconWord, 0, TyName.EQ, 0) + val tReal = TyName.tyname(tyconReal, 0, TyName.NOEQ, 0) + val tString = TyName.tyname(tyconString, 0, TyName.EQ, 0) + val tChar = TyName.tyname(tyconChar, 0, TyName.EQ, 0) + val tList = TyName.tyname(tyconList, 1, TyName.EQ, 2) + val tRef = TyName.tyname(tyconRef, 1, TyName.SPECIALEQ, 1) + val tExn = TyName.tyname(tyconExn, 0, TyName.NOEQ, 0) + + val T0 = TyNameSet.fromList[tBool, tInt, tWord, tReal, tString, tChar, + tList, tRef, tExn] + + + (* Types *) + + val alpha = TyVar.fromString "'a" + val alphaEq = TyVar.fromString "''a" + val tauAlpha = fromTyVar alpha + val tauAlphaEq = fromTyVar alphaEq + + val tauUnit = fromRowType emptyRho + val tauBool = fromConsType([], tBool) + val tauInt = fromConsType([], tInt) + val tauWord = fromConsType([], tWord) + val tauReal = fromConsType([], tReal) + val tauString = fromConsType([], tString) + val tauChar = fromConsType([], tChar) + val tauExn = fromConsType([], tExn) + val tauAlphaList = fromConsType([tauAlpha], tList) + val tauAlphaRef = fromConsType([tauAlpha], tRef) + + + (* TypeSchemes [Figure 25] *) + + val sigmaEq = ([alphaEq], fromFunType(pairType(tauAlphaEq,tauAlphaEq), + tauBool)) + val sigmaAssign = ([alpha], fromFunType(pairType(tauAlphaRef,tauAlpha), + tauUnit)) + val sigmaFalse = ([], tauBool) + val sigmaTrue = ([], tauBool) + val sigmaNil = ([alpha], tauAlphaList) + val sigmaCons = ([alpha], fromFunType(pairType(tauAlpha, tauAlphaList), + tauAlphaList)) + val sigmaRef = ([alpha], fromFunType(tauAlpha, tauAlphaRef)) + + val sigmaMatch = ([], tauExn) + val sigmaBind = ([], tauExn) + + + (* Value entries [Figure 25] *) + + val valstrEq = (sigmaEq, v) + val valstrAssign = (sigmaAssign, v) + + val valstrFalse = (sigmaFalse, c) + val valstrTrue = (sigmaTrue, c) + val valstrNil = (sigmaNil, c) + val valstrCons = (sigmaCons, c) + val valstrRef = (sigmaRef, c) + + val valstrMatch = (sigmaMatch, e) + val valstrBind = (sigmaBind, e) + + + (* TypeFcns [Figure 24] *) + + val thetaUnit = ([], tauUnit) + val thetaBool = ([], tauBool) + val thetaInt = ([], tauInt) + val thetaWord = ([], tauWord) + val thetaReal = ([], tauReal) + val thetaString = ([], tauString) + val thetaChar = ([], tauChar) + val thetaExn = ([], tauExn) + val thetaList = ([alpha], tauAlphaList) + val thetaRef = ([alpha], tauAlphaRef) + + + (* TyStrs [Figure 25] *) + + val VEEmpty = VIdMap.empty + val VEBool = VIdMap.fromList[(vidFalse, valstrFalse), + (vidTrue, valstrTrue)] : ValEnv + val VEList = VIdMap.fromList[(vidNil, valstrNil), + (vidCons, valstrCons)] + val VERef = VIdMap.fromList[(vidRef, valstrRef)] + + val tystrUnit = (thetaUnit, VEEmpty) + val tystrBool = (thetaBool, VEBool ) + val tystrInt = (thetaInt, VEEmpty) + val tystrWord = (thetaWord, VEEmpty) + val tystrReal = (thetaReal, VEEmpty) + val tystrString = (thetaString, VEEmpty) + val tystrChar = (thetaChar, VEEmpty) + val tystrList = (thetaList, VEList ) + val tystrRef = (thetaRef, VERef ) + val tystrExn = (thetaExn, VEEmpty) + + + (* Environments [Appendix C] *) + + val SE0 = StrIdMap.empty + + val TE0 = TyConMap.fromList[(tyconUnit, tystrUnit), + (tyconBool, tystrBool), + (tyconInt, tystrInt), + (tyconWord, tystrWord), + (tyconReal, tystrReal), + (tyconString, tystrString), + (tyconChar, tystrChar), + (tyconList, tystrList), + (tyconRef, tystrRef), + (tyconExn, tystrExn)] + + val VE0 = VIdMap.fromList [(vidEq, valstrEq), + (vidAssign, valstrAssign), + (vidRef, valstrRef), + (vidNil, valstrNil), + (vidCons, valstrCons), + (vidFalse, valstrFalse), + (vidTrue, valstrTrue), + (vidMatch, valstrMatch), + (vidBind, valstrBind)] + + val E0 = (SE0,TE0,VE0) + + + (* Overloading classes [Section E.1] *) + + val Int = OverloadingClass.make(TyNameSet.singleton tInt, tInt) + val Real = OverloadingClass.make(TyNameSet.singleton tReal, tReal) + val Word = OverloadingClass.make(TyNameSet.singleton tWord, tWord) + val String = OverloadingClass.make(TyNameSet.singleton tString, tString) + val Char = OverloadingClass.make(TyNameSet.singleton tChar, tChar) + val WordInt = OverloadingClass.union(Word, Int) (* default is 2nd *) + val RealInt = OverloadingClass.union(Real, Int) + val Num = OverloadingClass.union(Word, RealInt) + val Txt = OverloadingClass.union(String, Char) + val NumTxt = OverloadingClass.union(Txt, Num) + + end +(* stop of InitialStaticEnv.sml *) +(* start of INITIAL_STATIC_BASIS.sml *) +(* + * Standard ML initial static basis + * + * Definition, appendices C and E + *) + +signature INITIAL_STATIC_BASIS = + sig + + (* Import *) + + type Basis = StaticBasis.Basis + + + (* Export *) + + val B0: Basis + + end +(* stop of INITIAL_STATIC_BASIS.sml *) +(* start of InitialStaticBasis.sml *) +(* + * Standard ML initial static basis + * + * Definition, appendices C and E + *) + +structure InitialStaticBasis :> INITIAL_STATIC_BASIS = + struct + + (* Import *) + + type Basis = StaticBasis.Basis + + + (* Enviornments *) + + val T0 = InitialStaticEnv.T0 + val F0 = FunIdMap.empty + val G0 = SigIdMap.empty + val E0 = InitialStaticEnv.E0 + + val B0 = (T0,F0,G0,E0) + + end +(* stop of InitialStaticBasis.sml *) +(* start of EXNAME.sml *) +(* + * Standard ML exception names + * + * Definition, section 6.2 + *) + +signature EXNAME = + sig + + (* Import *) + + type VId = VId.Id + + + (* Type [Section 6.2] *) + + eqtype ExName (* [en] *) + + + (* Operations *) + + val exname: VId -> ExName + val toString: ExName -> string + + val compare: ExName * ExName -> order + + end +(* stop of EXNAME.sml *) +(* start of ExName.sml *) +(* + * Standard ML exception names + * + * Definition, section 6.2 + *) + + +structure ExName :> EXNAME = + struct + + (* Import *) + + type VId = VId.Id + type stamp = Stamp.stamp + + + (* Type [Section 6.2] *) + + type ExName = (* [en] *) + { vid: VId + , stamp: stamp + } + + + (* Creation *) + + fun exname vid = { vid = vid, stamp = Stamp.stamp() } + + + (* Conversion *) + + fun toString{vid, stamp} = VId.toString vid + + + (* Ordering *) + + fun compare(en1: ExName, en2: ExName) = + Stamp.compare(#stamp en1, #stamp en2) + + end +(* stop of ExName.sml *) +(* start of ADDR.sml *) +(* + * Standard ML addresses + * + * Definition, section 6.2 + *) + +signature ADDR = + sig + + (* Type [Section 6.2] *) + + eqtype Addr (* [a] *) + + + (* Operations *) + + val addr: unit -> Addr + val compare: Addr * Addr -> order + + end +(* stop of ADDR.sml *) +(* start of Addr.sml *) +(* + * Standard ML addresses + * + * Definition, section 6.2 + *) + + +structure Addr :> ADDR = + struct + + (* Type [Section 6.2] *) + + type Addr = Stamp.stamp (* [a] *) + + + (* Operations *) + + val addr = Stamp.stamp + val compare = Stamp.compare + + end +(* stop of Addr.sml *) +(* start of AssembliesCoreDynamic.sml *) +(* + * Standard ML additional sets and maps for the dynamic semantics of the core + * + * Definition, section 6.3 + *) + +structure ExNameSet = FinSetFn(type ord_key = ExName.ExName + val compare = ExName.compare) + +structure AddrMap = FinMapFn(type ord_key = Addr.Addr + val compare = Addr.compare) +(* stop of AssembliesCoreDynamic.sml *) +(* start of SVAL.sml *) +(* + * Standard ML special values + * + * Definition, section 6.2 + *) + + +signature SVAL = + sig + + (* Type [Section 6.2] *) + + datatype SVal = (* [sv] *) + INT of int + | WORD of word + | STRING of string + | CHAR of char + | REAL of real + + (* Operations *) + + val toString: SVal -> string + val equal: SVal * SVal -> bool + + end +(* stop of SVAL.sml *) +(* start of SVal.sml *) +(* + * Standard ML special values + * + * Definition, section 6.2 + *) + + +structure SVal :> SVAL = + struct + + (* Type [Section 6.2] *) + + datatype SVal = (* [sv] *) + INT of int + | WORD of word + | STRING of string + | CHAR of char + | REAL of real + + + (* Conversions *) + + fun toString(INT i) = Int.toString i + | toString(WORD w) = "0wx" ^ Word.toString w + | toString(STRING s) = "\"" ^ String.toString s ^ "\"" + | toString(CHAR c) = "\"#" ^ Char.toString c ^ "\"" + | toString(REAL r) = Real.toString r + + (* Equality *) + + fun equal(INT n1, INT n2 ) = n1 = n2 + | equal(WORD w1, WORD w2 ) = w1 = w2 + | equal(STRING s1, STRING s2) = s1 = s2 + | equal(CHAR c1, CHAR c2 ) = c1 = c2 + | equal _ = raise Fail "type error: equality type expected" + + end +(* stop of SVal.sml *) +(* start of VAL.sml *) +(* + * Standard ML values + * + * Definition, sections 6.2, 6.3, and 6.4 + * + * Note: + * - All value types are parameterised over the representation of function + * closures to break up the recursion between values and environments. + * - The basic values are just strings. + *) + + +signature VAL = + sig + + (* Import *) + + type Addr = Addr.Addr + type ExName = ExName.ExName + type SVal = SVal.SVal + type VId = VId.Id + type 'a LabMap = 'a LabMap.map + + + (* Types [Sections 6.2 and 6.3] *) + + type BasVal = string (* [b] *) + + datatype 'a Val = (* [v] *) + := + | SVal of SVal + | BasVal of BasVal + | VId of VId + | VIdVal of VId * 'a Val + | ExVal of 'a ExVal + | Record of (*Record*) 'a Val LabMap + | Addr of Addr + | FcnClosure of 'a + + and 'a ExVal = (* [e] *) + ExName of ExName + | ExNameVal of ExName * 'a Val + + type 'a Record = 'a Val LabMap (* [r] *) + + + (* Operations *) + + val equal: 'a Val * 'a Val -> bool + + val toBoolVal: bool -> 'a Val + val unpair: 'a Val -> ('a Val * 'a Val) option + + end +(* stop of VAL.sml *) +(* start of Val.sml *) +(* + * Standard ML values + * + * Definition, sections 6.2, 6.3, and 6.4 + * + * Note: + * - All value types are parameterised over the representation of function + * closures to break up the recursion between values and environments. + * - The basic values are just strings. + *) + + +structure Val :> VAL = + struct + + (* Import *) + + type Addr = Addr.Addr + type ExName = ExName.ExName + type SVal = SVal.SVal + type VId = VId.Id + type 'a LabMap = 'a LabMap.map + + + (* Types [Sections 6.2 and 6.3] *) + + type BasVal = string (* [b] *) + + + datatype 'a Val = (* [v] *) + op:= + | SVal of SVal + | BasVal of BasVal + | VId of VId + | VIdVal of VId * 'a Val + | ExVal of 'a ExVal + | Record of 'a Record + | Addr of Addr + | FcnClosure of 'a + + and 'a ExVal = (* [e] *) + ExName of ExName + | ExNameVal of ExName * 'a Val + + withtype 'a Record = 'a Val LabMap (* [r] *) + + + (* Operations *) + + fun toBoolVal b = VId(VId.fromString(if b then "true" else "false")) + + + fun unpair(Record r) = + (case (LabMap.find(r, Lab.fromInt 1), LabMap.find(r, Lab.fromInt 2)) + of (SOME v1, SOME v2) => SOME(v1, v2) + | _ => NONE + ) + | unpair _ = NONE + + + + (* Implementation of polymorphic equality *) + + fun equal(SVal sv1, SVal sv2 ) = SVal.equal(sv1, sv2) + | equal(VId vid1, VId vid2 ) = vid1 = vid2 + | equal(ExVal(ExName en1), ExVal(ExName en2)) = en1 = en2 + | equal(Addr a1, Addr a2 ) = a1 = a2 + + | equal(VIdVal(vid1, v1), VIdVal(vid2, v2)) = + vid1 = vid2 andalso equal(v1, v2) + + | equal(ExVal(ExNameVal(en1,v1)), ExVal(ExNameVal(en2,v2))) = + en1 = en2 andalso equal(v1, v2) + + | equal(Record r1, Record r2) = + LabMap.numItems r1 = LabMap.numItems r2 andalso + LabMap.alli (fn(lab, v1) => + case LabMap.find(r2, lab) + of SOME v2 => equal(v1, v2) + | NONE => false + ) r1 + + | equal _ = false + + end +(* stop of Val.sml *) +(* start of STATE.sml *) +(* + * Standard ML state + * + * Definition, section 6.3 + * + * Notes: + * - Memory gets represented by references. This avoids expanding out all + * occurances of the state convention in the inference rules. + * - Since exception names are generated by stamps we do not really need the + * exception name set. We maintain it anyway. + *) + +signature STATE = + sig + + (* Import *) + + type Addr = Addr.Addr + type ExName = ExName.ExName + type ExNameSet = ExNameSet.set + type 'a Val = 'a Val.Val + type 'a AddrMap = 'a AddrMap.map + + + (* Types [Section 6.3] *) + + type 'a Mem = 'a Val AddrMap (* [mem] *) + + type 'a State = 'a Mem * ExNameSet (* [s] *) + + + (* Operations *) + + val insertAddr: 'a State * Addr * 'a Val -> 'a State + val insertExName: 'a State * ExName -> 'a State + + val findAddr: 'a State * Addr -> 'a Val option + + end +(* stop of STATE.sml *) +(* start of State.sml *) +(* + * Standard ML state + * + * Definition, section 6.3 + * + * Notes: + * - Memory gets represented by references. This avoids expanding out all + * occurances of the state convention in the inference rules. + * - Since exception names are generated by stamps we do not really need the + * exception name set. We maintain it anyway. + *) + +structure State :> STATE = + struct + + (* Import *) + + type Addr = Addr.Addr + type ExName = ExName.ExName + type ExNameSet = ExNameSet.set + type 'a Val = 'a Val.Val + type 'a AddrMap = 'a AddrMap.map + + + (* Types [Section 6.3] *) + + type 'a Mem = 'a Val AddrMap (* [mem] *) + + type 'a State = 'a Mem * ExNameSet (* [s] *) + + + (* Operations *) + + fun insertAddr ((mem,ens), a, v) = ( AddrMap.insert(mem, a, v), ens ) + fun insertExName((mem,ens), en) = ( mem, ExNameSet.add(ens, en) ) + + fun findAddr((mem,ens), a) = AddrMap.find(mem, a) + + end +(* stop of State.sml *) +(* start of GRAMMAR_CORE.sml *) +(* + * Standard ML abstract core grammar + * + * Definition, section 2.8 + * + * Note: + * This is the syntax used in the inference rules for the core [Definition, + * sections 4.10 and 6.7]. It omits almost anything having to do with infixed + * identifiers: + * - fixity directives + * - infixed application + * - infixed value construction + * However, op prefixes are kept, since they are required for rebuilding the + * syntax tree during fixity resolution. + * Optional semicolons are also omitted. + *) + +signature GRAMMAR_CORE = + sig + + (* Import *) + + type Info + + type SCon = SCon.SCon + type Lab = Lab.Lab + type VId = VId.Id + type TyCon = TyCon.Id + type TyVar = TyVar.TyVar + type StrId = StrId.Id + type longVId = LongVId.longId + type longTyCon = LongTyCon.longId + type longStrId = LongStrId.longId + + + (* Optional keyword `op' *) + + datatype Op = SANSOp | WITHOp + + + (* Expressions [Figures 2 and 4] *) + + datatype AtExp = + SCONAtExp of Info * SCon + | LONGVIDAtExp of Info * Op * longVId + | RECORDAtExp of Info * ExpRow option + | LETAtExp of Info * Dec * Exp + | PARAtExp of Info * Exp + + and ExpRow = + ExpRow of Info * Lab * Exp * ExpRow option + + and Exp = + ATEXPExp of Info * AtExp + | APPExp of Info * Exp * AtExp + | TYPEDExp of Info * Exp * Ty + | HANDLEExp of Info * Exp * Match + | RAISEExp of Info * Exp + | FNExp of Info * Match + + (* Matches [Figures 2 and 4] *) + + and Match = + Match of Info * Mrule * Match option + + and Mrule = + Mrule of Info * Pat * Exp + + (* Declarations [Figures 2 and 4] *) + + and Dec = + VALDec of Info * TyVarseq * ValBind + | TYPEDec of Info * TypBind + | DATATYPEDec of Info * DatBind + | REPLICATIONDec of Info * TyCon * longTyCon + | ABSTYPEDec of Info * DatBind * Dec + | EXCEPTIONDec of Info * ExBind + | LOCALDec of Info * Dec * Dec + | OPENDec of Info * longStrId list + | EMPTYDec of Info + | SEQDec of Info * Dec * Dec + + (* Bindings [Figures 2 and 4] *) + + and ValBind = + PLAINValBind of Info * Pat * Exp * ValBind option + | RECValBind of Info * ValBind + + and TypBind = + TypBind of Info * TyVarseq * TyCon * Ty * TypBind option + + and DatBind = + DatBind of Info * TyVarseq * TyCon * ConBind * DatBind option + + and ConBind = + ConBind of Info * Op * VId * Ty option * ConBind option + + and ExBind = + NEWExBind of Info * Op * VId * Ty option * ExBind option + | EQUALExBind of Info * Op * VId * Op * longVId * ExBind option + + (* Patterns [Figures 2 and 3] *) + + and AtPat = + WILDCARDAtPat of Info + | SCONAtPat of Info * SCon + | LONGVIDAtPat of Info * Op * longVId + | RECORDAtPat of Info * PatRow option + | PARAtPat of Info * Pat + + and PatRow = + WILDCARDPatRow of Info + | ROWPatRow of Info * Lab * Pat * PatRow option + + and Pat = + ATPATPat of Info * AtPat + | CONPat of Info * Op * longVId * AtPat + | TYPEDPat of Info * Pat * Ty + | ASPat of Info * Op * VId * Ty option * Pat + + (* Type expressions [Figures 2 and 3] *) + + and Ty = + TYVARTy of Info * TyVar + | RECORDTy of Info * TyRow option + | TYCONTy of Info * Tyseq * longTyCon + | ARROWTy of Info * Ty * Ty + | PARTy of Info * Ty + + and TyRow = + TyRow of Info * Lab * Ty * TyRow option + + (* Sequences [Section 2.8] *) + + and Tyseq = + Tyseq of Info * Ty list + + and TyVarseq = + TyVarseq of Info * TyVar list + + + (* Operations *) + + val infoAtExp: AtExp -> Info + val infoExpRow: ExpRow -> Info + val infoExp: Exp -> Info + val infoMatch: Match -> Info + val infoMrule: Mrule -> Info + val infoDec: Dec -> Info + val infoValBind: ValBind -> Info + val infoTypBind: TypBind -> Info + val infoDatBind: DatBind -> Info + val infoConBind: ConBind -> Info + val infoExBind: ExBind -> Info + val infoAtPat: AtPat -> Info + val infoPatRow: PatRow -> Info + val infoPat: Pat -> Info + val infoTy: Ty -> Info + val infoTyRow: TyRow -> Info + val infoTyseq: Tyseq -> Info + val infoTyVarseq: TyVarseq -> Info + + end +(* stop of GRAMMAR_CORE.sml *) +(* start of GrammarCoreFn.sml *) +(* + * Standard ML abstract core grammar + * + * Definition, section 2.8 + * + * Note: + * This is the syntax used in the inference rules for the core [Definition, + * sections 4.10 and 6.7]. It omits almost anything having to do with infixed + * identifiers: + * - fixity directives + * - infixed application + * - infixed value construction + * However, op prefixes are kept, since they are required for rebuilding the + * syntax tree during fixity resolution. + * Optional semicolons are also omitted. + *) + +functor GrammarCoreFn(type Info) : GRAMMAR_CORE = + struct + + (* Import *) + + type Info = Info + + type SCon = SCon.SCon + type Lab = Lab.Lab + type VId = VId.Id + type TyCon = TyCon.Id + type TyVar = TyVar.TyVar + type StrId = StrId.Id + type longVId = LongVId.longId + type longTyCon = LongTyCon.longId + type longStrId = LongStrId.longId + + + (* Optional keyword `op' *) + + datatype Op = SANSOp | WITHOp + + + (* Expressions [Figures 2 and 4] *) + + datatype AtExp = + SCONAtExp of Info * SCon + | LONGVIDAtExp of Info * Op * longVId + | RECORDAtExp of Info * ExpRow option + | LETAtExp of Info * Dec * Exp + | PARAtExp of Info * Exp + + and ExpRow = + ExpRow of Info * Lab * Exp * ExpRow option + + and Exp = + ATEXPExp of Info * AtExp + | APPExp of Info * Exp * AtExp + | TYPEDExp of Info * Exp * Ty + | HANDLEExp of Info * Exp * Match + | RAISEExp of Info * Exp + | FNExp of Info * Match + + (* Matches [Figures 2 and 4] *) + + and Match = + Match of Info * Mrule * Match option + + and Mrule = + Mrule of Info * Pat * Exp + + (* Declarations [Figures 2 and 4] *) + + and Dec = + VALDec of Info * TyVarseq * ValBind + | TYPEDec of Info * TypBind + | DATATYPEDec of Info * DatBind + | REPLICATIONDec of Info * TyCon * longTyCon + | ABSTYPEDec of Info * DatBind * Dec + | EXCEPTIONDec of Info * ExBind + | LOCALDec of Info * Dec * Dec + | OPENDec of Info * longStrId list + | EMPTYDec of Info + | SEQDec of Info * Dec * Dec + + (* Bindings [Figures 2 and 4] *) + + and ValBind = + PLAINValBind of Info * Pat * Exp * ValBind option + | RECValBind of Info * ValBind + + and TypBind = + TypBind of Info * TyVarseq * TyCon * Ty * TypBind option + + and DatBind = + DatBind of Info * TyVarseq * TyCon * ConBind * DatBind option + + and ConBind = + ConBind of Info * Op * VId * Ty option * ConBind option + + and ExBind = + NEWExBind of Info * Op * VId * Ty option * ExBind option + | EQUALExBind of Info * Op * VId * Op * longVId * ExBind option + + (* Patterns [Figures 2 and 3] *) + + and AtPat = + WILDCARDAtPat of Info + | SCONAtPat of Info * SCon + | LONGVIDAtPat of Info * Op * longVId + | RECORDAtPat of Info * PatRow option + | PARAtPat of Info * Pat + + and PatRow = + WILDCARDPatRow of Info + | ROWPatRow of Info * Lab * Pat * PatRow option + + and Pat = + ATPATPat of Info * AtPat + | CONPat of Info * Op * longVId * AtPat + | TYPEDPat of Info * Pat * Ty + | ASPat of Info * Op * VId * Ty option * Pat + + (* Type expressions [Figures 2 and 3] *) + + and Ty = + TYVARTy of Info * TyVar + | RECORDTy of Info * TyRow option + | TYCONTy of Info * Tyseq * longTyCon + | ARROWTy of Info * Ty * Ty + | PARTy of Info * Ty + + and TyRow = + TyRow of Info * Lab * Ty * TyRow option + + (* Sequences [Section 2.8] *) + + and Tyseq = + Tyseq of Info * Ty list + + and TyVarseq = + TyVarseq of Info * TyVar list + + + + (* Extracting info fields *) + + fun infoAtExp(SCONAtExp(I,_)) = I + | infoAtExp(LONGVIDAtExp(I,_,_)) = I + | infoAtExp(RECORDAtExp(I,_)) = I + | infoAtExp(LETAtExp(I,_,_)) = I + | infoAtExp(PARAtExp(I,_)) = I + + fun infoExpRow(ExpRow(I,_,_,_)) = I + + fun infoExp(ATEXPExp(I,_)) = I + | infoExp(APPExp(I,_,_)) = I + | infoExp(TYPEDExp(I,_,_)) = I + | infoExp(HANDLEExp(I,_,_)) = I + | infoExp(RAISEExp(I,_)) = I + | infoExp(FNExp(I,_)) = I + + fun infoMatch(Match(I,_,_)) = I + + fun infoMrule(Mrule(I,_,_)) = I + + fun infoDec(VALDec(I,_,_)) = I + | infoDec(TYPEDec(I,_)) = I + | infoDec(DATATYPEDec(I,_)) = I + | infoDec(REPLICATIONDec(I,_,_)) = I + | infoDec(ABSTYPEDec(I,_,_)) = I + | infoDec(EXCEPTIONDec(I,_)) = I + | infoDec(LOCALDec(I,_,_)) = I + | infoDec(OPENDec(I,_)) = I + | infoDec(EMPTYDec(I)) = I + | infoDec(SEQDec(I,_,_)) = I + + fun infoValBind(PLAINValBind(I,_,_,_)) = I + | infoValBind(RECValBind(I,_)) = I + + fun infoTypBind(TypBind(I,_,_,_,_)) = I + + fun infoDatBind(DatBind(I,_,_,_,_)) = I + + fun infoConBind(ConBind(I,_,_,_,_)) = I + + fun infoExBind(NEWExBind(I,_,_,_,_)) = I + | infoExBind(EQUALExBind(I,_,_,_,_,_)) = I + + fun infoAtPat(WILDCARDAtPat(I)) = I + | infoAtPat(SCONAtPat(I,_)) = I + | infoAtPat(LONGVIDAtPat(I,_,_)) = I + | infoAtPat(RECORDAtPat(I,_)) = I + | infoAtPat(PARAtPat(I,_)) = I + + fun infoPatRow(WILDCARDPatRow(I)) = I + | infoPatRow(ROWPatRow(I,_,_,_)) = I + + fun infoPat(ATPATPat(I,_)) = I + | infoPat(CONPat(I,_,_,_)) = I + | infoPat(TYPEDPat(I,_,_)) = I + | infoPat(ASPat(I,_,_,_,_)) = I + + fun infoTy(TYVARTy(I,_)) = I + | infoTy(RECORDTy(I,_)) = I + | infoTy(TYCONTy(I,_,_)) = I + | infoTy(ARROWTy(I,_,_)) = I + | infoTy(PARTy(I,_)) = I + + fun infoTyRow(TyRow(I,_,_,_)) = I + + fun infoTyseq(Tyseq(I,_)) = I + fun infoTyVarseq(TyVarseq(I,_)) = I + + end +(* stop of GrammarCoreFn.sml *) +(* start of SOURCE.sml *) +(* + * Helpers for handling source strings + *) + +signature SOURCE = + sig + + type source = string + type region = int * int + + val over: region * region -> region + val between: region * region -> region + + val compare: region * region -> order + + end +(* stop of SOURCE.sml *) +(* start of Source.sml *) +(* + * Helpers for handling source strings + *) + +structure Source :> SOURCE = + struct + + type source = string + type region = int * int + + fun over(r1: region, r2: region) = (#1 r1, #2 r2) + fun between(r1: region, r2: region) = (#2 r1, #1 r2) + + fun compare((m1,n1), (m2,n2)) = + case Int.compare(m1, m2) + of EQUAL => Int.compare(n1, n2) + | order => order + + end +(* stop of Source.sml *) +(* start of GRAMMAR_MODULE.sml *) +(* + * Standard ML abstract module grammar + * + * Definition, section 3.4 + * + * Notes: + * This is the syntax used in the inference rules for modules [Definition, + * sections 5.7 and 7.3]. Optional semicolons are omitted. + * The structure sharing derived form [Definition, Appendix A] has been added, + * because it cannot be derived purely syntactically. + *) + + +signature GRAMMAR_MODULE = + sig + + (* Import *) + + structure Core: GRAMMAR_CORE + + type Info + + type VId = Core.VId + type TyCon = Core.TyCon + type TyVar = Core.TyVar + type StrId = Core.StrId + type longVId = Core.longVId + type longTyCon = Core.longTyCon + type longStrId = Core.longStrId + type Dec = Core.Dec + type Ty = Core.Ty + type TyVarseq = Core.TyVarseq + + type SigId = SigId.Id + type FunId = FunId.Id + + + (* Structures [Figures 5 and 6] *) + + datatype StrExp = + STRUCTStrExp of Info * StrDec + | LONGSTRIDStrExp of Info * longStrId + | TRANSStrExp of Info * StrExp * SigExp + | OPAQStrExp of Info * StrExp * SigExp + | APPStrExp of Info * FunId * StrExp + | LETStrExp of Info * StrDec * StrExp + + and StrDec = + DECStrDec of Info * Dec + | STRUCTUREStrDec of Info * StrBind + | LOCALStrDec of Info * StrDec * StrDec + | EMPTYStrDec of Info + | SEQStrDec of Info * StrDec * StrDec + + and StrBind = + StrBind of Info * StrId * StrExp * StrBind option + + (* Signatures [Figures 5 and 6] *) + + and SigExp = + SIGSigExp of Info * Spec + | SIGIDSigExp of Info * SigId + | WHERETYPESigExp of Info * SigExp * TyVarseq * longTyCon * Ty + + and SigDec = + SigDec of Info * SigBind + + and SigBind = + SigBind of Info * SigId * SigExp * SigBind option + + (* Specifications [Figures 5 and 7] *) + + and Spec = + VALSpec of Info * ValDesc + | TYPESpec of Info * TypDesc + | EQTYPESpec of Info * TypDesc + | DATATYPESpec of Info * DatDesc + | REPLICATIONSpec of Info * TyCon * longTyCon + | EXCEPTIONSpec of Info * ExDesc + | STRUCTURESpec of Info * StrDesc + | INCLUDESpec of Info * SigExp + | EMPTYSpec of Info + | SEQSpec of Info * Spec * Spec + | SHARINGTYPESpec of Info * Spec * longTyCon list + | SHARINGSpec of Info * Spec * longStrId list + + and ValDesc = + ValDesc of Info * VId * Ty * ValDesc option + + and TypDesc = + TypDesc of Info * TyVarseq * TyCon * TypDesc option + + and DatDesc = + DatDesc of Info * TyVarseq * TyCon * ConDesc * DatDesc option + + and ConDesc = + ConDesc of Info * VId * Ty option * ConDesc option + + and ExDesc = + ExDesc of Info * VId * Ty option * ExDesc option + + and StrDesc = + StrDesc of Info * StrId * SigExp * StrDesc option + + (* Functors [Figures 5 and 8] *) + + and FunDec = + FunDec of Info * FunBind + + and FunBind = + FunBind of Info * FunId * StrId * SigExp * StrExp + * FunBind option + + (* Top-level declarations [Figures 5 and 8] *) + + and TopDec = + STRDECTopDec of Info * StrDec * TopDec option + | SIGDECTopDec of Info * SigDec * TopDec option + | FUNDECTopDec of Info * FunDec * TopDec option + + + (* Operations *) + + val infoStrExp: StrExp -> Info + val infoStrDec: StrDec -> Info + val infoStrBind: StrBind -> Info + val infoSigExp: SigExp -> Info + val infoSigBind: SigBind -> Info + val infoSpec: Spec -> Info + val infoValDesc: ValDesc -> Info + val infoTypDesc: TypDesc -> Info + val infoDatDesc: DatDesc -> Info + val infoConDesc: ConDesc -> Info + val infoExDesc: ExDesc -> Info + val infoStrDesc: StrDesc -> Info + val infoFunDec: FunDec -> Info + val infoFunBind: FunBind -> Info + val infoTopDec: TopDec -> Info + + end +(* stop of GRAMMAR_MODULE.sml *) +(* start of GrammarModuleFn.sml *) +(* + * Standard ML abstract module grammar + * + * Definition, section 3.4 + * + * Notes: + * This is the syntax used in the inference rules for modules [Definition, + * sections 5.7 and 7.3]. Optional semicolons are omitted. + * The structure sharing derived form [Definition, Appendix A] has been added, + * because it cannot be derived purely syntactically. + *) + + +functor GrammarModuleFn(type Info + structure Core: GRAMMAR_CORE + ) : GRAMMAR_MODULE = + struct + + (* Import *) + + structure Core = Core + type Info = Info + + open Core + + type SigId = SigId.Id + type FunId = FunId.Id + + + (* Structures [Figures 5 and 6] *) + + datatype StrExp = + STRUCTStrExp of Info * StrDec + | LONGSTRIDStrExp of Info * longStrId + | TRANSStrExp of Info * StrExp * SigExp + | OPAQStrExp of Info * StrExp * SigExp + | APPStrExp of Info * FunId * StrExp + | LETStrExp of Info * StrDec * StrExp + + and StrDec = + DECStrDec of Info * Dec + | STRUCTUREStrDec of Info * StrBind + | LOCALStrDec of Info * StrDec * StrDec + | EMPTYStrDec of Info + | SEQStrDec of Info * StrDec * StrDec + + and StrBind = + StrBind of Info * StrId * StrExp * StrBind option + + (* Signatures [Figures 5 and 6] *) + + and SigExp = + SIGSigExp of Info * Spec + | SIGIDSigExp of Info * SigId + | WHERETYPESigExp of Info * SigExp * TyVarseq * longTyCon * Ty + + and SigDec = + SigDec of Info * SigBind + + and SigBind = + SigBind of Info * SigId * SigExp * SigBind option + + (* Specifications [Figures 5 and 7] *) + + and Spec = + VALSpec of Info * ValDesc + | TYPESpec of Info * TypDesc + | EQTYPESpec of Info * TypDesc + | DATATYPESpec of Info * DatDesc + | REPLICATIONSpec of Info * TyCon * longTyCon + | EXCEPTIONSpec of Info * ExDesc + | STRUCTURESpec of Info * StrDesc + | INCLUDESpec of Info * SigExp + | EMPTYSpec of Info + | SEQSpec of Info * Spec * Spec + | SHARINGTYPESpec of Info * Spec * longTyCon list + | SHARINGSpec of Info * Spec * longStrId list + + and ValDesc = + ValDesc of Info * VId * Ty * ValDesc option + + and TypDesc = + TypDesc of Info * TyVarseq * TyCon * TypDesc option + + and DatDesc = + DatDesc of Info * TyVarseq * TyCon * ConDesc * DatDesc option + + and ConDesc = + ConDesc of Info * VId * Ty option * ConDesc option + + and ExDesc = + ExDesc of Info * VId * Ty option * ExDesc option + + and StrDesc = + StrDesc of Info * StrId * SigExp * StrDesc option + + (* Functors [Figures 5 and 8] *) + + and FunDec = + FunDec of Info * FunBind + + and FunBind = + FunBind of Info * FunId * StrId * SigExp * StrExp + * FunBind option + + (* Top-level declarations [Figures 5 and 8] *) + + and TopDec = + STRDECTopDec of Info * StrDec * TopDec option + | SIGDECTopDec of Info * SigDec * TopDec option + | FUNDECTopDec of Info * FunDec * TopDec option + + + (* Extracting info fields *) + + fun infoStrExp(STRUCTStrExp(I,_)) = I + | infoStrExp(LONGSTRIDStrExp(I,_)) = I + | infoStrExp(TRANSStrExp(I,_,_)) = I + | infoStrExp(OPAQStrExp(I,_,_)) = I + | infoStrExp(APPStrExp(I,_,_)) = I + | infoStrExp(LETStrExp(I,_,_)) = I + + fun infoStrDec(DECStrDec(I,_)) = I + | infoStrDec(STRUCTUREStrDec(I,_)) = I + | infoStrDec(LOCALStrDec(I,_,_)) = I + | infoStrDec(EMPTYStrDec(I)) = I + | infoStrDec(SEQStrDec(I,_,_)) = I + + fun infoStrBind(StrBind(I,_,_,_)) = I + + fun infoSigExp(SIGSigExp(I,_)) = I + | infoSigExp(SIGIDSigExp(I,_)) = I + | infoSigExp(WHERETYPESigExp(I,_,_,_,_)) = I + + fun infoSigDec(SigDec(I,_)) = I + + fun infoSigBind(SigBind(I,_,_,_)) = I + + fun infoSpec(VALSpec(I,_)) = I + | infoSpec(TYPESpec(I,_)) = I + | infoSpec(EQTYPESpec(I,_)) = I + | infoSpec(DATATYPESpec(I,_)) = I + | infoSpec(REPLICATIONSpec(I,_,_)) = I + | infoSpec(EXCEPTIONSpec(I,_)) = I + | infoSpec(STRUCTURESpec(I,_)) = I + | infoSpec(INCLUDESpec(I,_)) = I + | infoSpec(EMPTYSpec(I)) = I + | infoSpec(SEQSpec(I,_,_)) = I + | infoSpec(SHARINGTYPESpec(I,_,_)) = I + | infoSpec(SHARINGSpec(I,_,_)) = I + + fun infoValDesc(ValDesc(I,_,_,_)) = I + fun infoTypDesc(TypDesc(I,_,_,_)) = I + fun infoDatDesc(DatDesc(I,_,_,_,_)) = I + fun infoConDesc(ConDesc(I,_,_,_)) = I + fun infoExDesc(ExDesc(I,_,_,_)) = I + fun infoStrDesc(StrDesc(I,_,_,_)) = I + + fun infoFunDec(FunDec(I,_)) = I + + fun infoFunBind(FunBind(I,_,_,_,_,_)) = I + + fun infoTopDec(STRDECTopDec(I,_,_)) = I + | infoTopDec(SIGDECTopDec(I,_,_)) = I + | infoTopDec(FUNDECTopDec(I,_,_)) = I + + end +(* stop of GrammarModuleFn.sml *) +(* start of GRAMMAR_PROGRAM.sml *) +(* + * Standard ML abstract program grammar + * + * Definition, section 8 + *) + + +signature GRAMMAR_PROGRAM = + sig + + (* Import *) + + structure Module: GRAMMAR_MODULE + + type Info = Module.Info + + type TopDec = Module.TopDec + + + (* Programs *) + + datatype Program = Program of Info * TopDec * Program option + + + (* Extracting the info field *) + + val infoProgram: Program -> Info + + end +(* stop of GRAMMAR_PROGRAM.sml *) +(* start of GrammarProgramFn.sml *) +(* + * Standard ML abstract program grammar + * + * Definition, section 8 + *) + + +functor GrammarProgramFn(type Info + structure Module: GRAMMAR_MODULE + ) : GRAMMAR_PROGRAM = + struct + + (* Import *) + + structure Module = Module + type Info = Info + + open Module + + + (* Programs *) + + datatype Program = Program of Info * TopDec * Program option + + + (* Extracting the info field *) + + fun infoProgram(Program(I,_,_)) = I + + end +(* stop of GrammarProgramFn.sml *) +(* start of Grammars.sml *) +structure GrammarCore = GrammarCoreFn(type Info = Source.region) + +structure GrammarModule = GrammarModuleFn(type Info = Source.region + structure Core = GrammarCore) + +structure GrammarProgram = GrammarProgramFn(type Info = Source.region + structure Module = GrammarModule) +(* stop of Grammars.sml *) +(* start of DYNAMIC_ENV.sml *) +(* + * Standard ML environments of the dynamic semantics of the core + * + * Definition, sections 6.3 and 6.6 + * + * Notes: + * - We call the domain type of value environments ValStr. + * - The type definitions here are heavily recursive and it is really stupid + * that SML allows no withtype in signatures... + *) + +signature DYNAMIC_ENV = + sig + + (* Inheritance *) + + include GENERIC_ENV + + + (* Import types *) + + type 'a Val = 'a Val.Val + type Match = GrammarCore.Match + + + (* Export types [Section 6.6] *) + + datatype FcnClosure = + FcnClosure of Match + * ( (*Env*) + ( FcnClosure Val * IdStatus + , (FcnClosure Val * IdStatus) VIdMap + ) Str' StrIdMap + * (FcnClosure Val * IdStatus) VIdMap TyConMap + * (FcnClosure Val * IdStatus) VIdMap + ) + * (*ValEnv*) (FcnClosure Val * IdStatus) VIdMap + + type ValStr = FcnClosure Val * IdStatus + type ValEnv = ValStr VIdMap (* [VE] *) + + type TyStr = ValEnv + type TyEnv = TyStr TyConMap (* [TE] *) + + type Str = (ValStr, TyStr) Str' + type StrEnv = Str StrIdMap (* [SE] *) + + type Env = StrEnv * TyEnv * ValEnv (* [E] *) + + + (* Operations *) + + val Rec: ValEnv -> ValEnv + + end +(* stop of DYNAMIC_ENV.sml *) +(* start of DynamicEnv.sml *) +(* + * Standard ML environments of the dynamic semantics of the core + * + * Definition, sections 6.3 and 6.6 + * + * Notes: + * - We call the domain type of value environments ValStr. + * - The type definitions here are heavily recursive. It would be easier if + * SML would define withtype sequentially (as SML/NJ implements it). + * However, it is still better than inside the signature... + *) + +structure DynamicEnv :> DYNAMIC_ENV = + struct + + (* Inheritance *) + + structure GenericEnv = GenericEnvFn() + + open GenericEnv + + + (* Import types *) + + type 'a Val = 'a Val.Val + type Match = GrammarCore.Match + + + (* Export types [Section 6.6] *) + + datatype FcnClosure = + FcnClosure of Match * ((*Env*) StrEnv * TyEnv * ValEnv) * ValEnv + + withtype ValEnv = (FcnClosure Val * IdStatus) VIdMap (* [VE] *) + and TyEnv = (FcnClosure Val * IdStatus) VIdMap TyConMap (* [TE] *) + and StrEnv = (FcnClosure Val * IdStatus, + (FcnClosure Val * IdStatus) VIdMap) Str' StrIdMap + (* [SE] *) + type ValStr = FcnClosure Val * IdStatus + type TyStr = ValEnv + type Str = (ValStr, TyStr) Str' + + type Env = StrEnv * TyEnv * ValEnv (* [E] *) + + + (* Unrolling [Section 6.6] *) + + fun Rec VE = + VIdMap.map + (fn (Val.FcnClosure(FcnClosure(match',E',VE')), IdStatus.v) => + (Val.FcnClosure(FcnClosure(match',E',VE)), IdStatus.v) + | valstr => valstr + ) VE + + end +(* stop of DynamicEnv.sml *) +(* start of INITIAL_DYNAMIC_ENV.sml *) +(* + * Standard ML core view of the initial dynamic basis + * + * Definition, appendix D and section 6.5 + * + * Note: + * The Definition does not specify what the initial state has to contain. + * This is a bug as it must at least contain the exception names Match + * and Bind. We put the state associated with the initial environment in + * here, too. + *) + +signature INITIAL_DYNAMIC_ENV = + sig + + (* Import types *) + + type Env = DynamicEnv.Env + type ExName = ExName.ExName + type State = DynamicEnv.FcnClosure State.State + + + (* Basic exception names [Section 6.5] *) + + val enMatch: ExName + val enBind: ExName + + (* Initial environment [Appendix D] *) + + val E0: Env + + (* Associated state *) + + val s: State + + end +(* stop of INITIAL_DYNAMIC_ENV.sml *) +(* start of InitialDynamicEnv.sml *) +(* + * Standard ML core view of the initial dynamic basis + * + * Definition, appendix D and section 6.5 + * + * Note: + * The Definition does not specify what the initial state has to contain. + * This is a bug as it must at least contain the exception names Match + * and Bind. We put the state associated with the initial environment in + * here, too. + *) + +structure InitialDynamicEnv :> INITIAL_DYNAMIC_ENV = + struct + + (* Import *) + + type Env = DynamicEnv.Env + type ValEnv = DynamicEnv.ValEnv + type ExName = ExName.ExName + type State = DynamicEnv.FcnClosure State.State + + + open Val + open IdStatus + + + (* VIds [Appendix D] *) + + val vidEq = VId.fromString "=" + val vidAssign = VId.fromString ":=" + + val vidFalse = VId.fromString "false" + val vidTrue = VId.fromString "true" + val vidNil = VId.fromString "nil" + val vidCons = VId.fromString "::" + val vidRef = VId.fromString "ref" + + val vidMatch = VId.fromString "Match" + val vidBind = VId.fromString "Bind" + + + (* Basic exception names [Section 6.5] *) + + val enMatch = ExName.exname vidMatch + val enBind = ExName.exname vidBind + + + (* Value entries [Appendix D] *) + + val valstrEq = (BasVal "=", v) + val valstrAssign = (op:=, v) + + val valstrFalse = (VId vidFalse, c) + val valstrTrue = (VId vidTrue, c) + val valstrNil = (VId vidNil, c) + val valstrCons = (VId vidCons, c) + val valstrRef = (VId vidRef, c) + + val valstrMatch = (ExVal(ExName enMatch), e) + val valstrBind = (ExVal(ExName enBind), e) + + + (* TyCons [Figure 26] *) + + val tyconUnit = TyCon.fromString "unit" + val tyconBool = TyCon.fromString "bool" + val tyconInt = TyCon.fromString "int" + val tyconWord = TyCon.fromString "word" + val tyconReal = TyCon.fromString "real" + val tyconString = TyCon.fromString "string" + val tyconChar = TyCon.fromString "char" + val tyconList = TyCon.fromString "list" + val tyconRef = TyCon.fromString "ref" + val tyconExn = TyCon.fromString "exn" + + + (* Type ValEnvs [Figure 26] *) + + val VEUnit = VIdMap.empty + val VEBool = VIdMap.fromList[(vidFalse, valstrFalse), + (vidTrue, valstrTrue)] : ValEnv + val VEInt = VIdMap.empty + val VEWord = VIdMap.empty + val VEReal = VIdMap.empty + val VEString = VIdMap.empty + val VEChar = VIdMap.empty + val VEList = VIdMap.fromList[(vidNil, valstrNil), + (vidCons, valstrCons)] : ValEnv + val VERef = VIdMap.fromList[(vidRef, valstrRef)] : ValEnv + val VEExn = VIdMap.empty + + + (* Environments [Appendix D] *) + + val SE0 = StrIdMap.empty + + val TE0 = TyConMap.fromList[(tyconUnit, VEUnit), + (tyconBool, VEBool), + (tyconInt, VEInt), + (tyconWord, VEWord), + (tyconReal, VEReal), + (tyconString, VEString), + (tyconChar, VEChar), + (tyconList, VEList), + (tyconRef, VERef), + (tyconExn, VEExn)] + + val VE0 = VIdMap.fromList [(vidEq, valstrEq), + (vidAssign, valstrAssign), + (vidRef, valstrRef), + (vidNil, valstrNil), + (vidCons, valstrCons), + (vidFalse, valstrFalse), + (vidTrue, valstrTrue), + (vidMatch, valstrMatch), + (vidBind, valstrBind)] : ValEnv + + val E0 = (SE0,TE0,VE0) + + + (* Associated state *) + + val mem = AddrMap.empty + val ens = ExNameSet.fromList[enMatch, enBind] + + val s = (mem, ens) + + end +(* stop of InitialDynamicEnv.sml *) +(* start of INTERFACE.sml *) +(* + * Standard ML interfaces + * + * Definition, section 7.2 + *) + +signature INTERFACE = + sig + + (* Inheritance *) + + include GENERIC_ENV + + + (* Import *) + + type Env = DynamicEnv.Env + + + (* Export types [Section 7.2] *) + + type ValInt = IdStatus VIdMap (* [VI] *) + type TyInt = ValInt TyConMap (* [TI] *) + + type Str = (IdStatus, ValInt) Str' + type StrInt = Str StrIdMap (* [SI] *) + + type Int = StrInt * TyInt * ValInt (* [I] *) + + + (* Operations *) + + val fromSI: StrInt -> Int + val fromTI: TyInt -> Int + val fromVI: ValInt -> Int + val fromVIandTI: ValInt * TyInt -> Int + + val Inter: Env -> Int + val cutdown: Env * Int -> Env + + end +(* stop of INTERFACE.sml *) +(* start of Interface.sml *) +(* + * Standard ML interfaces + * + * Definition, section 7.2 + *) + + +structure Interface :> INTERFACE = + struct + + (* Inheritance *) + + structure GenericEnv = GenericEnvFn() + + open GenericEnv + + + (* Import *) + + type Env = DynamicEnv.Env + + + (* Export types [Section 7.2] *) + + type ValInt = IdStatus VIdMap (* [VI] *) + type TyInt = ValInt TyConMap (* [TI] *) + + type Str = (IdStatus, ValInt) Str' + type StrInt = Str StrIdMap (* [SI] *) + + type Int = StrInt * TyInt * ValInt (* [I] *) + + + (* Injections [Section 4.3] *) + + val fromSI = fromSE + val fromTI = fromTE + val fromVI = fromVE + val fromVIandTI = fromVEandTE + + + (* Extracting interfaces from environments [Section 7.2] *) + + fun InterVE VE = VIdMap.map (fn(v,is) => is) VE + fun InterTE TE = TyConMap.map (fn VE => InterVE VE) TE + fun InterSE SE = StrIdMap.map (fn DynamicEnv.Str E => Str(Inter E)) SE + + and Inter (SE,TE,VE) = (InterSE SE, InterTE TE, InterVE VE) + + + (* Cutting down environments [Section 7.2] *) + + fun cutdownVE(VE, VI) = + VIdMap.foldli + (fn(vid, is, VE') => + case VIdMap.find(VE, vid) + of SOME(v,is') => VIdMap.insert(VE', vid, (v,is)) + | NONE => VE' + ) VIdMap.empty VI + + fun cutdownTE(TE, TI) = + TyConMap.foldli + (fn(tycon, VI', TE') => + case TyConMap.find(TE, tycon) + of SOME VE' => TyConMap.insert(TE', tycon, cutdownVE(VE',VI')) + | NONE => TE' + ) TyConMap.empty TI + + fun cutdownSE(SE, SI) = + StrIdMap.foldli + (fn(strid, Str I, SE') => + case StrIdMap.find(SE, strid) + of SOME(DynamicEnv.Str E) => + StrIdMap.insert(SE', strid, DynamicEnv.Str(cutdown(E,I))) + | NONE => SE' + ) StrIdMap.empty SI + + and cutdown((SE,TE,VE), (SI,TI,VI)) = + ( cutdownSE(SE, SI), cutdownTE(TE, TI), cutdownVE(VE, VI) ) + + end +(* stop of Interface.sml *) +(* start of DYNAMIC_BASIS.sml *) +(* + * Standard ML dynamic basis and environments of modules + * + * Definition, section 7.2 + *) + +signature DYNAMIC_BASIS = + sig + + (* Import types *) + + type StrId = StrId.Id + type SigId = SigId.Id + type FunId = FunId.Id + type longStrId = LongStrId.longId + type longTyCon = LongTyCon.longId + type Env = DynamicEnv.Env + type ValEnv = DynamicEnv.ValEnv + type StrEnv = DynamicEnv.StrEnv + type Str = DynamicEnv.Str + type Int = Interface.Int + type StrExp = GrammarModule.StrExp + + type 'a SigIdMap = 'a SigIdMap.map + type 'a FunIdMap = 'a FunIdMap.map + + + (* Types [Section 7.2] *) + + datatype FunctorClosure = + FunctorClosure of (StrId * Int) * StrExp * + (*Basis*) (FunctorClosure FunIdMap * Int SigIdMap * Env) + + type SigEnv = Int SigIdMap (* [G] *) + type FunEnv = FunctorClosure FunIdMap (* [F] *) + + type Basis = FunEnv * SigEnv * Env (* [B] *) + + + (* Operations *) + + val empty: Basis + val fromE: Env -> Basis + val fromF: FunEnv -> Basis + val fromG: SigEnv -> Basis + + val Eof: Basis -> Env + + val plus: Basis * Basis -> Basis + val plusSE: Basis * StrEnv -> Basis + val plusG: Basis * SigEnv -> Basis + val plusF: Basis * FunEnv -> Basis + val plusE: Basis * Env -> Basis + + val findStrId: Basis * StrId -> Str option + val findSigId: Basis * SigId -> Int option + val findFunId: Basis * FunId -> FunctorClosure option + val findLongStrId: Basis * longStrId -> Str option + val findLongTyCon: Basis * longTyCon -> ValEnv option + + end +(* stop of DYNAMIC_BASIS.sml *) +(* start of DynamicBasis.sml *) +(* + * Standard ML dynamic basis and environments of modules + * + * Definition, section 7.2 + *) + + +structure DynamicBasis :> DYNAMIC_BASIS = + struct + + (* Import types *) + + type StrId = StrId.Id + type SigId = SigId.Id + type FunId = FunId.Id + type longStrId = LongStrId.longId + type longTyCon = LongTyCon.longId + type Env = DynamicEnv.Env + type ValEnv = DynamicEnv.ValEnv + type StrEnv = DynamicEnv.StrEnv + type Str = DynamicEnv.Str + type Int = Interface.Int + type StrExp = GrammarModule.StrExp + + type 'a SigIdMap = 'a SigIdMap.map + type 'a FunIdMap = 'a FunIdMap.map + + + (* Types [Section 7.2] *) + + datatype FunctorClosure = + FunctorClosure of (StrId * Int) * StrExp * + (*Basis*) (FunEnv * SigEnv * Env) + + withtype SigEnv = Int SigIdMap (* [G] *) + and FunEnv = FunctorClosure FunIdMap (* [F] *) + + type Basis = FunEnv * SigEnv * Env (* [B] *) + + + + (* Injections [Sections 4.3 and 7.2] *) + + val empty = ( FunIdMap.empty, SigIdMap.empty, DynamicEnv.empty ) + + fun fromE E = ( FunIdMap.empty, SigIdMap.empty, E ) + fun fromF F = ( F, SigIdMap.empty, DynamicEnv.empty ) + fun fromG G = ( FunIdMap.empty, G, DynamicEnv.empty ) + + + (* Injections [Sections 4.3 and 7.2] *) + + fun Eof (F,G,E) = E + + + (* Modifications [Sections 4.3 and 7.2] *) + + infix plus plusG plusF plusE plusSE IBplusI + + fun (F,G,E) plus (F',G',E') = + ( FunIdMap.unionWith #2 (F,F') + , SigIdMap.unionWith #2 (G,G') + , DynamicEnv.plus(E,E') + ) + + fun (F,G,E) plusG G' = ( F, SigIdMap.unionWith #2 (G,G'), E ) + fun (F,G,E) plusF F' = ( FunIdMap.unionWith #2 (F,F'), G, E ) + fun (F,G,E) plusE E' = ( F, G, DynamicEnv.plus(E,E') ) + fun (F,G,E) plusSE SE = ( F, G, DynamicEnv.plusSE(E,SE) ) + + + (* Application (lookup) [Sections 7.2 and 4.3] *) + + fun findStrId((F,G,E), strid) = DynamicEnv.findStrId(E, strid) + fun findSigId((F,G,E), sigid) = SigIdMap.find(G, sigid) + fun findFunId((F,G,E), funid) = FunIdMap.find(F, funid) + fun findLongStrId((F,G,E), longstrid) = + DynamicEnv.findLongStrId(E, longstrid) + fun findLongTyCon((F,G,E), longtycon) = + DynamicEnv.findLongTyCon(E, longtycon) + + end +(* stop of DynamicBasis.sml *) +(* start of INITIAL_DYNAMIC_BASIS.sml *) +(* + * Standard ML initial dynamic basis + * + * Definition, appendix D + * + * Note: + * The Definition does not specify what the initial state has to contain. + * This is a bug as it must at least contain the exception names Match + * and Bind. We put the state associated with the initial basis in + * here, too. + *) + +signature INITIAL_DYNAMIC_BASIS = + sig + + (* Import *) + + type Basis = DynamicBasis.Basis + type State = InitialDynamicEnv.State + + + (* Export *) + + val B0: Basis + val s: State + + end +(* stop of INITIAL_DYNAMIC_BASIS.sml *) +(* start of InitialDynamicBasis.sml *) +(* + * Standard ML initial dynamic basis + * + * Definition, appendix D + * + * Note: + * The Definition does not specify what the initial state has to contain. + * This is a bug as it must at least contain the exception names Match + * and Bind. We put the state associated with the initial basis in + * here, too. + *) + +structure InitialDynamicBasis :> INITIAL_DYNAMIC_BASIS = + struct + + (* Import *) + + type Basis = DynamicBasis.Basis + type State = InitialDynamicEnv.State + + + (* Enviornments *) + + val F0 = FunIdMap.empty + val G0 = SigIdMap.empty + val E0 = InitialDynamicEnv.E0 + + val B0 = (F0,G0,E0) + + + (* Associated state *) + + val s = InitialDynamicEnv.s + + end +(* stop of InitialDynamicBasis.sml *) +(* start of ERROR.sml *) +(* + * Error handling. + *) + + +signature ERROR = + sig + + (* Import *) + + type position = Source.region + + + (* Export *) + + exception Error of position * string + + val error: position * string -> 'a + val warning: position * string -> unit + + end +(* stop of ERROR.sml *) +(* start of Error.sml *) +(* + * Error handling. + *) + + +structure Error :> ERROR = + struct + + (* Import *) + + type position = Source.region + + + (* Helper *) + + fun print((pos1,pos2), message) = + let + val a = Int.toString pos1 + val b = Int.toString pos2 + in + TextIO.output(TextIO.stdErr, a ^ "-" ^ b ^ ": " ^ message ^ "\n") + ; TextIO.flushOut TextIO.stdErr + end + + + (* Export *) + + exception Error of position * string + + fun error(pos, message) = + ( print(pos, message) + ; raise Error(pos, message) + ) + + fun warning(pos, message) = + print(pos, "warning: " ^ message) + + end +(* stop of Error.sml *) +(* start of INFIX.sml *) +(* + * Standard ML infix resolution + * + * Definition, section 2.6 + *) + + +signature INFIX = + sig + + (* Import *) + + type Info = GrammarCore.Info + + type Op = GrammarCore.Op + type VId = GrammarCore.VId + type longVId = GrammarCore.longVId + type Exp = GrammarCore.Exp + type Pat = GrammarCore.Pat + type AtExp = GrammarCore.AtExp + type AtPat = GrammarCore.AtPat + + + (* Modifying fixity status *) + + datatype Assoc = LEFT | RIGHT + + type InfStatus = Assoc * int + type InfEnv = InfStatus VIdMap.map (* [J] *) + + val empty: InfEnv + val assign: InfEnv * VId list * InfStatus -> InfEnv + val cancel: InfEnv * VId list -> InfEnv + + + (* Resolving phrases containing infixed identifiers *) + + val parseExp: InfEnv * AtExp list -> Exp + val parsePat: InfEnv * AtPat list -> Pat + val parseFmrule: InfEnv * AtPat list -> Op * VId * AtPat list + + end +(* stop of INFIX.sml *) +(* start of Infix.sml *) +(* + * Standard ML infix resolution + * + * Definition, section 2.6 + *) + + +structure Infix :> INFIX = + struct + + (* Import *) + + open GrammarCore + + + (* Type definitions *) + + datatype Assoc = LEFT | RIGHT + + type InfStatus = Assoc * int + + type InfEnv = InfStatus VIdMap.map (* [J] *) + + + + (* Modifying infix environments *) + + val empty = VIdMap.empty + + fun assign(J, vids, infstatus) = + let + fun insert(vid, J) = VIdMap.insert(J, vid, infstatus) + in + List.foldl insert J vids + end + + fun cancel(J, vids) = + let + fun remove(vid, J) = #1(VIdMap.remove(J, vid)) + in + List.foldl remove J vids + end + + + + (* Helpers for error messages *) + + val error = Error.error + fun errorVId(I, s, vid) = error(I, s ^ VId.toString vid) + fun errorLongVId(I, s, longvid) = error(I, s ^ LongVId.toString longvid) + + + + (* Categorisation of atomic expressions and patterns *) + + datatype 'a FixityCategory = NONFIX of 'a + | INFIX of InfStatus * VId * Info + + fun isInfix J (longvid) = + LongVId.isUnqualified longvid andalso + VIdMap.find(J, LongVId.toId longvid) <> NONE + + fun categoriseLongVId J (atomic, I, longvid) = + if LongVId.isUnqualified longvid then + let + val vid = LongVId.toId longvid + in + case VIdMap.find(J, vid) + of NONE => NONFIX(atomic) + | SOME infstatus => INFIX(infstatus, vid, I) + end + else + NONFIX(atomic) + + fun categoriseAtExp J (atexp as LONGVIDAtExp(I, SANSOp, longvid)) = + categoriseLongVId J (atexp, I, longvid) + | categoriseAtExp J (atexp) = NONFIX(atexp) + + fun categoriseAtPat J (atpat as LONGVIDAtPat(I, SANSOp, longvid)) = + categoriseLongVId J (atpat, I, longvid) + | categoriseAtPat J (atpat) = NONFIX(atpat) + + + + (* Resolving infixing [Section 2.6] *) + + fun parse(app, infapp, es) = + let + fun loop(NONFIX(e)::[], []) = e + + | loop(NONFIX(e2)::NONFIX(e1)::s', i) = + (* reduce nonfix application *) + loop(NONFIX(app(e1, e2))::s', i) + + | loop(s, NONFIX(e)::i') = + (* shift *) + loop(NONFIX(e)::s, i') + + | loop(s as NONFIX(e)::[], INFIX(x)::i') = + (* shift *) + loop(INFIX(x)::s, i') + + | loop(NONFIX(e2)::INFIX(_,vid,_)::NONFIX(e1)::s', []) = + (* reduce infix application *) + loop(NONFIX(infapp(e1, vid, e2))::s', []) + + | loop(s as NONFIX(e2)::INFIX((a1,p1),vid1,I1)::NONFIX(e1)::s', + i as INFIX(x2 as ((a2,p2),vid2,I2))::i') = + if p1 > p2 then + (* reduce infix application *) + loop(NONFIX(infapp(e1, vid1, e2))::s', i) + else if p1 < p2 then + (* shift *) + loop(INFIX(x2)::s, i') + else if a1 <> a2 then + error(Source.over(I1,I2), "conflicting infix associativity") + else if a1 = LEFT then + (* reduce infix application *) + loop(NONFIX(infapp(e1, vid1, e2))::s', i) + else (* a1 = RIGHT *) + (* shift *) + loop(INFIX(x2)::s, i') + + | loop(INFIX(_, vid, I)::s, []) = + errorVId(I, "misplaced infix identifier ", vid) + + | loop(INFIX(x)::s, INFIX(_, vid, I)::i) = + errorVId(I, "misplaced infix identifier ", vid) + + | loop([], INFIX(_, vid, I)::i) = + errorVId(I, "misplaced infix identifier ", vid) + + | loop _ = raise Fail "Infix.parse: inconsistency" + in + loop([], es) + end + + + (* Resolving infixed expressions [Section 2.6] *) + + fun atexpExp(PARAtExp(_, exp)) = exp + | atexpExp atexp = ATEXPExp(infoAtExp atexp, atexp) + + fun appExp(atexp1, atexp2) = + let + val I1 = infoAtExp atexp1 + val I2 = infoAtExp atexp2 + val I = Source.over(I1, I2) + in + PARAtExp(I, APPExp(I, atexpExp atexp1, atexp2)) + end + + fun pairExp(atexp1, atexp2) = + let + val I1 = infoAtExp atexp1 + val I2 = infoAtExp atexp2 + val lab1 = Lab.fromInt 1 + val lab2 = Lab.fromInt 2 + val exprow2 = ExpRow(I2, lab2, atexpExp atexp2, NONE) + val exprow1 = ExpRow(I1, lab1, atexpExp atexp1, SOME exprow2) + in + RECORDAtExp(Source.over(I1,I2), SOME exprow1) + end + + fun infappExp(atexp1, vid, atexp2) = + let + val Ivid = Source.between(infoAtExp atexp1, infoAtExp atexp2) + val longvid = LongVId.fromId vid + val atexp1' = LONGVIDAtExp(Ivid, SANSOp, longvid) + val atexp2' = pairExp(atexp1, atexp2) + in + appExp(atexp1', atexp2') + end + + + fun parseExp(J, atexps) = + let + val atexp = parse(appExp, infappExp, + List.map (categoriseAtExp J) atexps) + in + atexpExp atexp + end + + + (* Resolving infixed patterns [Section 2.6] *) + + fun atpatPat(PARAtPat(_, pat)) = pat + | atpatPat atpat = ATPATPat(infoAtPat atpat, atpat) + + fun conPat(LONGVIDAtPat(I1, op_opt, longvid), atpat) = + let + val I2 = infoAtPat atpat + val I = Source.over(I1, I2) + in + PARAtPat(I, CONPat(I, op_opt, longvid, atpat)) + end + + | conPat(_, atpat) = + error(infoAtPat atpat, "misplaced atomic pattern") + + fun pairPat(atpat1, atpat2) = + let + val I1 = infoAtPat atpat1 + val I2 = infoAtPat atpat2 + val lab1 = Lab.fromInt 1 + val lab2 = Lab.fromInt 2 + val patrow2 = ROWPatRow(I2, lab2, atpatPat atpat2, NONE) + val patrow1 = ROWPatRow(I1, lab1, atpatPat atpat1, SOME patrow2) + in + RECORDAtPat(Source.over(I1,I2), SOME patrow1) + end + + fun infconPat(atpat1, vid, atpat2) = + let + val Ivid = Source.between(infoAtPat atpat1, infoAtPat atpat2) + val longvid = LongVId.fromId vid + val atpat1' = LONGVIDAtPat(Ivid, SANSOp, longvid) + val atpat2' = pairPat(atpat1, atpat2) + in + conPat(atpat1', atpat2') + end + + + fun parsePat(J, atpats) = + let + val atpat = parse(conPat, infconPat, + List.map (categoriseAtPat J) atpats) + in + atpatPat atpat + end + + + (* Resolving fun match rules [Figure 21, note] *) + + fun parseFmrule(J, atpats) = + (* + * Allowed is the following: + * (1) vid atpat+ + * (2) (atpat infix_vid atpat) atpat* + * (3) atpat infix_vid atpat + *) + let + fun checkNonfixity [] = true + | checkNonfixity(NONFIX _::t) = checkNonfixity t + | checkNonfixity(INFIX(_, vid, I)::t) = + errorVId(I, "misplaced infix identifier ", vid) + + fun maybeNonfixClause(ps) = + case List.hd atpats + of LONGVIDAtPat(I, op_opt, longvid) => + if not(LongVId.isUnqualified longvid) then + errorLongVId(I, "misplaced long identifier ", + longvid) + else if List.length atpats < 2 then + error(I, "missing function arguments") + else + ( checkNonfixity ps (* including 1st *) + ; ( op_opt, LongVId.toId longvid, List.tl atpats ) + ) + | WILDCARDAtPat(I) => + error(I, "misplaced wildcard pattern") + | SCONAtPat(I, _) => + error(I, "misplaced constant pattern") + | RECORDAtPat(I, _) => + error(I, "misplaced record or tuple pattern") + | PARAtPat(I, _) => + error(I, "misplaced parenthesised pattern") + + fun maybeParenthesisedInfixClause(ps) = + case List.hd ps + of NONFIX(PARAtPat(_, CONPat(I, SANSOp, longvid, atpat))) => + if not(LongVId.isUnqualified longvid) then + errorLongVId(I, "misplaced long identifier ", + longvid) + else if not(isInfix J longvid) then + error(I, "misplaced non-infix pattern") + else + (* Now, longvid has infix status but is sans `op', + so it can only result from resolving an + appropriate infix construction. *) + ( checkNonfixity(List.tl ps) + ; ( SANSOp, LongVId.toId longvid, + atpat::List.tl atpats ) + ) + + | NONFIX(PARAtPat(_, pat)) => + error(infoPat pat, "misplaced non-infix pattern") + + | _ => maybeNonfixClause(ps) + + fun maybePlainInfixClause(ps) = + case ps + of [NONFIX atpat1, INFIX(_, vid, I), NONFIX atpat2] => + ( SANSOp, vid, pairPat(atpat1, atpat2)::[] ) + + | _ => maybeParenthesisedInfixClause(ps) + in + maybePlainInfixClause(List.map (categoriseAtPat J) atpats) + end + + end +(* stop of Infix.sml *) +(* start of INITIAL_INFIX_ENV.sml *) +(* + * Standard ML initial infix environment + * + * Definition, Appendix C + *) + +signature INITIAL_INFIX_ENV = + sig + + (* Import type *) + + type InfEnv = Infix.InfEnv + + (* Export *) + + val J0: InfEnv + + end +(* stop of INITIAL_INFIX_ENV.sml *) +(* start of InitialInfixEnv.sml *) +(* + * Standard ML initial infix environment + * + * Definition, Appendix C + *) + +structure InitialInfixEnv :> INITIAL_INFIX_ENV = + struct + + (* Import type *) + + type InfEnv = Infix.InfEnv + + (* Value identifiers *) + + val vidCons = VId.fromString "::" + val vidEqual = VId.fromString "=" + val vidAssign = VId.fromString ":=" + + (* Export *) + + val J0 = VIdMap.fromList[(vidCons, (Infix.RIGHT, 5)), + (vidEqual, (Infix.LEFT, 4)), + (vidAssign, (Infix.LEFT, 3))] + end +(* stop of InitialInfixEnv.sml *) +(* start of BASIS.sml *) +(* + * Standard ML combined basis + * + * Definition, section 8 + *) + +signature BASIS = + sig + + (* Import types *) + + type StaticBasis = StaticBasis.Basis (* [B_STAT] *) + type DynamicBasis = DynamicBasis.Basis (* [B_DYN] *) + + (* Type [Section 8] *) + + type Basis = StaticBasis * DynamicBasis (* [B] *) + + + (* Operations *) + + val B_STATof: Basis -> StaticBasis + val B_DYNof: Basis -> DynamicBasis + + val oplus: Basis * Basis -> Basis + + end +(* stop of BASIS.sml *) +(* start of Basis.sml *) +(* + * Standard ML combined basis + * + * Definition, section 8 + *) + +structure Basis :> BASIS = + struct + + (* Import types *) + + type StaticBasis = StaticBasis.Basis (* [B_STAT] *) + type DynamicBasis = DynamicBasis.Basis (* [B_DYN] *) + + (* Type [Section 8] *) + + type Basis = StaticBasis * DynamicBasis (* [B] *) + + + (* Projections *) + + fun B_STATof (B_STAT,B_DYN) = B_STAT + fun B_DYNof (B_STAT,B_DYN) = B_DYN + + + (* Modification [Section 4.3] *) + + infix oplus + + fun (B_STAT,B_DYN) oplus (B_STAT',B_DYN') = + ( StaticBasis.plus(B_STAT, B_STAT') + , DynamicBasis.plus(B_DYN, B_DYN') + ) + + end +(* stop of Basis.sml *) +(* start of PACK.sml *) +(* + * Standard ML exception packets + * + * Definition, section 6.2 + *) + + +signature PACK = + sig + + (* Import *) + + type 'a ExVal = 'a Val.ExVal + type FcnClosure = DynamicEnv.FcnClosure + + + (* Definitions [Section 6.2] *) + + type Pack = FcnClosure ExVal (* [p] *) + + exception Pack of Pack + + end +(* stop of PACK.sml *) +(* start of Pack.sml *) +(* + * Standard ML exception packets + * + * Definition, section 6.2 + *) + + +structure Pack :> PACK = + struct + + (* Import *) + + type 'a ExVal = 'a Val.ExVal + type FcnClosure = DynamicEnv.FcnClosure + + + (* Definitions [Section 6.2] *) + + type Pack = FcnClosure ExVal (* [p] *) + + exception Pack of Pack + + end +(* stop of Pack.sml *) +(* start of BASVAL.sml *) +(* + * Standard ML basic values + * + * Definition, section 6.4 + *) + + +signature BASVAL = + sig + + (* Import *) + + type BasVal = Val.BasVal + type 'a Val = 'a Val.Val + + exception Pack of Pack.Pack (* = Pack.Pack *) + + + (* Operations *) + + exception TypeError + + val APPLY: BasVal * 'a Val -> 'a Val (* / Pack *) + + val toString: BasVal -> string + + end +(* stop of BASVAL.sml *) +(* start of BasVal.sml *) +(* + * Standard ML basic values + * + * Definition, section 6.4 + *) + + +structure BasVal :> BASVAL = + struct + + (* Import *) + + type BasVal = Val.BasVal + type 'a Val = 'a Val.Val + + exception Pack = Pack.Pack + + + (* Conversions *) + + fun toString b = b + + + (* Application of basic values *) + + exception TypeError + + fun APPLY("=", v) = + (case Val.unpair v + of SOME vv => Val.toBoolVal(Val.equal vv) + | NONE => raise TypeError + ) + | APPLY _ = raise Fail "BasVal.APPLY: unknown basic value" + + end +(* stop of BasVal.sml *) +(* start of EVAL_CORE.sml *) +(* + * Standard ML core evaluation + * + * Definition, section 6.7 + * + * Notes: + * - State is passed as reference and modified via side effects. This way + * expanding out of the state and exception convention in the inference + * rules can be avoided (would really be a pain). Note that the state + * therefore never is returned. + * - Doing so, we can model the exception convention using exceptions. + *) + + +signature EVAL_CORE = + sig + + (* Import types *) + + type Dec = GrammarCore.Dec + type Env = DynamicEnv.Env + type State = DynamicEnv.FcnClosure State.State + + (* Export *) + + val evalDec: State ref * Env * Dec -> Env + + end +(* stop of EVAL_CORE.sml *) +(* start of EvalCore.sml *) +(* + * Standard ML core evaluation + * + * Definition, sections 6.7 and 6.2 + * + * Notes: + * - State is passed as reference and modified via side effects. This way + * expanding out the state and exception convention in the inference rules + * can be avoided (would really be a pain). Note that the state therefore + * never is returned. + * - Doing so, we can model the exception convention using exceptions. + * Rules of the form A |- phrase => A'/p therefore turn into + * A |- phrase => A'. + * - We only pass the state where necessary. + * - Special constants have already been evaluated inside the Lexer. + *) + +structure EvalCore :> EVAL_CORE = + struct + + (* Import *) + + type Dec = GrammarCore.Dec + type Env = DynamicEnv.Env + type State = DynamicEnv.FcnClosure State.State + + exception Pack = Pack.Pack + + open GrammarCore + + + (* Some helpers for error messages *) + + val error = Error.error + + fun errorLab(I, s, lab) = error(I, s ^ Lab.toString lab) + fun errorLongVId(I, s, longvid) = error(I, s ^ LongVId.toString longvid) + fun errorLongTyCon(I, s, longtycon) = + error(I, s ^ LongTyCon.toString longtycon) + fun errorLongStrId(I, s, longstrid) = + error(I, s ^ LongStrId.toString longstrid) + + + (* Helpers for environment modification *) + + val plus = DynamicEnv.plus + val plusVE = DynamicEnv.plusVE + val plusTE = DynamicEnv.plusTE + val plusVEandTE = DynamicEnv.plusVEandTE + + infix plus plusVE plusTE plusVEandTE + + + + (* Evaluating special constants [Section 6.2] *) + + fun valSCon(SCon.INT n) = Val.SVal(SVal.INT n) + | valSCon(SCon.WORD w) = Val.SVal(SVal.WORD w) + | valSCon(SCon.CHAR c) = Val.SVal(SVal.CHAR c) + | valSCon(SCon.REAL x) = Val.SVal(SVal.REAL x) + | valSCon(SCon.STRING s) = Val.SVal(SVal.STRING s) + + + (* Inference rules [Section 6.7] *) + + exception FAIL + + + (* Atomic Expressions *) + + fun evalAtExp(s,E, SCONAtExp(I, scon)) = + (* [Rule 90] *) + valSCon scon + + | evalAtExp(s,E, LONGVIDAtExp(I, _, longvid)) = + (* [Rule 91] *) + let + val (v,is) = case DynamicEnv.findLongVId(E, longvid) + of SOME valstr => valstr + | NONE => + errorLongVId(I, "runtime error: \ + \unknown identifier ", longvid) + in + v + end + + | evalAtExp(s,E, RECORDAtExp(I, exprow_opt)) = + (* [Rule 92] *) + let + val r = case exprow_opt + of NONE => LabMap.empty + | SOME exprow => evalExpRow(s,E, exprow) + in + Val.Record r + end + + | evalAtExp(s,E, LETAtExp(I, dec, exp)) = + (* [Rule 93] *) + let + val E' = evalDec(s,E, dec) + val v = evalExp(s,E plus E', exp) + in + v + end + + | evalAtExp(s,E, PARAtExp(I, exp)) = + (* [Rule 94] *) + let + val v = evalExp(s,E, exp) + in + v + end + + + (* Expression Rows *) + + and evalExpRow(s,E, ExpRow(I, lab, exp, exprow_opt)) = + (* [Rule 95] *) + let + val v = evalExp(s,E, exp) + val r = case exprow_opt + of NONE => LabMap.empty + | SOME exprow => evalExpRow(s,E, exprow) + in + LabMap.insert(r, lab, v) + end + + + (* Expressions *) + + and evalExp(s,E, ATEXPExp(I, atexp)) = + (* [Rule 96] *) + let + val v = evalAtExp(s,E, atexp) + in + v + end + + | evalExp(s,E, APPExp(I, exp, atexp)) = + (* [Rules 97 to 103] *) + let + val v1 = evalExp(s,E, exp) + val v = evalAtExp(s,E, atexp) + in + case v1 + of Val.VId vid => + if vid = VId.fromString "ref" then + (* [Rule 99] *) + let + val a = Addr.addr() + in + s := State.insertAddr(!s, a, v) + ; Val.Addr a + end + else + (* [Rule 97] *) + Val.VIdVal (vid,v) + + | Val.ExVal(Val.ExName en) => + (* [Rule 98] *) + Val.ExVal(Val.ExNameVal(en,v)) + + | Val.:= => + (* [Rule 100] *) + (case Val.unpair v + of SOME(Val.Addr a, v) => + ( s := State.insertAddr(!s, a, v) + ; Val.Record LabMap.empty + ) + | _ => error(I, "runtime type error: address expected") + ) + + | Val.BasVal b => + (* [Rule 101] *) + BasVal.APPLY(b, v) + + | Val.FcnClosure(DynamicEnv.FcnClosure(match,E',VE)) => + (* [Rule 102] *) + (let + val v' = evalMatch(s,E' plusVE DynamicEnv.Rec VE, v, match) + in + v' + end + handle FAIL => + (* [Rule 103] *) + raise Pack(Val.ExName InitialDynamicEnv.enMatch) + ) + | _ => + error(I, "runtime type error: applicative value expected") + end + + | evalExp(s,E, TYPEDExp(I, exp, _)) = + (* Omitted [Section 6.1] *) + evalExp(s,E, exp) + + | evalExp(s,E, HANDLEExp(I, exp, match)) = + (* [Rule 104 to 106] *) + (let + val v = evalExp(s,E, exp) + in + (* [Rule 104] *) + v + end + handle Pack.Pack e => + let + val v = evalMatch(s,E,Val.ExVal e, match) + in + (* [Rule 105] *) + v + end + handle FAIL => + (* [Rule 106] *) + raise Pack.Pack e + ) + + | evalExp(s,E, RAISEExp(I, exp)) = + (* [Rule 107] *) + let + val e = case evalExp(s,E, exp) + of Val.ExVal e => e + | _ => error(I, "runtime type error: \ + \exception value expected") + in + raise Pack.Pack e + end + + | evalExp(s,E, FNExp(I, match)) = + (* [Rule 108] *) + Val.FcnClosure(DynamicEnv.FcnClosure(match,E,VIdMap.empty)) + + + (* Matches *) + + and evalMatch(s,E,v, Match(I, mrule, match_opt)) = + (* [Rules 109 to 111] *) + let + val v' = evalMrule(s,E,v, mrule) + in + (* [Rule 109] *) + v' + end + handle FAIL => + case match_opt + of NONE => + (* [Rule 110] *) + raise FAIL + + | SOME match => + (* [Rule 111] *) + let + val v' = evalMatch(s,E,v, match) + in + v' + end + + + (* Match rules *) + + and evalMrule(s,E,v, Mrule(I, pat, exp)) = + (* [Rules 112 and 113] *) + let + val VE = evalPat(s,E,v, pat) + (* [Rule 112] *) + val v' = evalExp(s,E plusVE VE, exp) + in + v' + end + (* FAIL on evalPat propagates through [Rule 113] *) + + + (* Declarations *) + + and evalDec(s,E, VALDec(I, tyvarseq, valbind)) = + (* [Rule 114] *) + let + val VE = evalValBind(s,E, valbind) + in + DynamicEnv.fromVE VE + end + + | evalDec(s,E, TYPEDec(I, typbind)) = + (* [Rule 115] *) + let + val TE = evalTypBind(typbind) + in + DynamicEnv.fromTE TE + end + + | evalDec(s,E, DATATYPEDec(I, datbind)) = + (* [Rule 116] *) + let + val (VE,TE) = evalDatBind(datbind) + in + DynamicEnv.fromVEandTE(VE,TE) + end + + | evalDec(s,E, REPLICATIONDec(I, tycon, longtycon)) = + (* [Rule 117] *) + let + val VE = case DynamicEnv.findLongTyCon(E, longtycon) + of SOME VE => VE + | NONE => + errorLongTyCon(I, "runtime error: unknown type ", + longtycon) + in + DynamicEnv.fromVEandTE(VE, TyConMap.singleton(tycon, VE)) + end + + | evalDec(s,E, ABSTYPEDec(I, datbind, dec)) = + (* [Rule 118] *) + let + val (VE,TE) = evalDatBind(datbind) + val E' = evalDec(s,E plusVEandTE (VE,TE), dec) + in + E' + end + + | evalDec(s,E, EXCEPTIONDec(I, exbind)) = + (* [Rule 119] *) + let + val VE = evalExBind(s,E, exbind) + in + DynamicEnv.fromVE VE + end + + | evalDec(s,E, LOCALDec(I, dec1, dec2)) = + (* [Rule 120] *) + let + val E1 = evalDec(s,E, dec1) + val E2 = evalDec(s,E plus E1, dec2) + in + E2 + end + + | evalDec(s,E, OPENDec(I, longstrids)) = + (* [Rule 121] *) + let + val Es = + List.map + (fn longstrid => + case DynamicEnv.findLongStrId(E, longstrid) + of SOME(DynamicEnv.Str E) => E + | NONE => + errorLongStrId(I, "runtime error: unknown \ + \structure ", longstrid) ) + longstrids + in + List.foldl DynamicEnv.plus DynamicEnv.empty Es + end + + | evalDec(s,E, EMPTYDec(I)) = + (* [Rule 122] *) + DynamicEnv.empty + + | evalDec(s,E, SEQDec(I, dec1, dec2)) = + (* [Rule 123] *) + let + val E1 = evalDec(s,E, dec1) + val E2 = evalDec(s,E plus E1, dec2) + in + E1 plus E2 + end + + + (* Value Bindings *) + + and evalValBind(s,E, PLAINValBind(I, pat, exp, valbind_opt)) = + (* [Rule 124 and 125] *) + (let + val v = evalExp(s,E, exp) + val VE = evalPat(s,E,v, pat) + (* [Rule 124] *) + val VE' = case valbind_opt + of NONE => VIdMap.empty + | SOME valbind => evalValBind(s,E, valbind) + in + VIdMap.unionWith #2 (VE, VE') + end + handle FAIL => + (* [Rule 125] *) + raise Pack.Pack(Val.ExName InitialDynamicEnv.enBind) + ) + + | evalValBind(s,E, RECValBind(I, valbind)) = + (* [Rule 126] *) + let + val VE = evalValBind(s,E, valbind) + in + DynamicEnv.Rec VE + end + + + (* Type Bindings *) + + and evalTypBind(TypBind(I, tyvarseq, tycon, ty, typbind_opt)) = + (* [Rule 127] *) + let + val TE = case typbind_opt + of NONE => TyConMap.empty + | SOME typbind => evalTypBind(typbind) + in + TyConMap.insert(TE, tycon, VIdMap.empty) + end + + + (* Datatype Bindings *) + + and evalDatBind(DatBind(I, tyvarseq, tycon, conbind, datbind_opt)) = + (* [Rule 128] *) + let + val VE = evalConBind(conbind) + val (VE',TE') = case datbind_opt + of NONE => ( VIdMap.empty, TyConMap.empty ) + | SOME datbind' => evalDatBind(datbind') + in + ( VIdMap.unionWith #2 (VE, VE') + , TyConMap.insert(TE', tycon, VE) + ) + end + + + (* Constructor Bindings *) + + and evalConBind(ConBind(I, _, vid, _, conbind_opt)) = + (* [Rule 129] *) + let + val VE = case conbind_opt + of NONE => VIdMap.empty + | SOME conbind => evalConBind(conbind) + in + VIdMap.insert(VE, vid, (Val.VId vid,IdStatus.c)) + end + + + (* Exception Bindings *) + + and evalExBind(s,E, NEWExBind(I, _, vid, _, exbind_opt)) = + (* [Rule 130] *) + let + val en = ExName.exname vid + val VE = case exbind_opt + of NONE => VIdMap.empty + | SOME exbind => evalExBind(s,E, exbind) + in + s := State.insertExName(!s, en) + ; VIdMap.insert(VE, vid, (Val.ExVal(Val.ExName en),IdStatus.e)) + end + + | evalExBind(s,E, EQUALExBind(I, _, vid, _, longvid, exbind_opt)) = + (* [Rule 131] *) + let + val en = case DynamicEnv.findLongVId(E, longvid) + of SOME(en,IdStatus.e) => en + | SOME _ => + errorLongVId(I, "runtime error: non-exception \ + \identifier ", longvid) + | NONE => + errorLongVId(I, "runtime error: unknown identifier ", + longvid) + val VE = case exbind_opt + of NONE => VIdMap.empty + | SOME exbind => evalExBind(s,E, exbind) + in + VIdMap.insert(VE, vid, (en,IdStatus.e)) + end + + + (* Atomic Patterns *) + + and evalAtPat(s,E,v, WILDCARDAtPat(I)) = + (* [Rule 132] *) + VIdMap.empty + + | evalAtPat(s,E,v, SCONAtPat(I, scon)) = + (* [Rule 133 and 134] *) + (case v + of Val.SVal sv => + if Val.equal(v, valSCon(scon)) then + (* [Rule 133] *) + VIdMap.empty + else + (* [Rule 134] *) + raise FAIL + + | _ => error(I, "runtime type error: special constant expected") + ) + + | evalAtPat(s,E,v, LONGVIDAtPat(I, _, longvid)) = + (* [Rule 135 to 137] *) + let + val (strids,vid) = LongVId.explode longvid + in + if List.null strids andalso + ( case DynamicEnv.findVId(E, vid) + of NONE => true + | SOME(_,is) => is = IdStatus.v ) then + (* [Rule 135] *) + VIdMap.singleton(vid, (v,IdStatus.v)) + else + let + val (v',is) = case DynamicEnv.findLongVId(E, longvid) + of SOME valstr => valstr + | NONE => + errorLongVId(I,"runtime error: \ + \unknown constructor ", + longvid) + in + if Val.equal(v, v') then + (* [Rule 136] *) + VIdMap.empty + else + (* [Rule 137] *) + raise FAIL + end + end + + | evalAtPat(s,E,v, RECORDAtPat(I, patrow_opt)) = + (* [Rule 138] *) + let + val r = case v + of Val.Record r => r + | _ => + error(I, "runtime type error: record expected") + + val VE = case patrow_opt + of NONE => + if LabMap.isEmpty r then + VIdMap.empty + else + error(I, "runtime type error: \ + \empty record expected") + + | SOME patrow => + evalPatRow(s,E,r, patrow) + in + VE + end + + | evalAtPat(s,E,v, PARAtPat(I, pat)) = + (* [Rule 139] *) + let + val VE = evalPat(s,E,v, pat) + in + VE + end + + + (* Pattern Rows *) + + and evalPatRow(s,E,r, WILDCARDPatRow(I)) = + (* [Rule 140] *) + VIdMap.empty + + | evalPatRow(s,E,r, ROWPatRow(I, lab, pat, patrow_opt)) = + (* [Rule 141 and 142] *) + let + val v = case LabMap.find(r, lab) + of SOME v => v + | _ => errorLab(I, "runtime type error: \ + \unmatched label ", lab) + val VE = evalPat(s,E,v, pat) + (* [Rule 142] *) + val VE' = case patrow_opt + of NONE => VIdMap.empty + | SOME patrow => evalPatRow(s,E,r, patrow) + in + VIdMap.unionWithi #2 (VE, VE') + end + (* FAIL on evalPat propagates through [Rule 142] *) + + + (* Patterns *) + + and evalPat(s,E,v, ATPATPat(I, atpat)) = + (* [Rule 143] *) + let + val VE = evalAtPat(s,E,v, atpat) + in + VE + end + + | evalPat(s,E,v, CONPat(I, _, longvid, atpat)) = + (* [Rules 144 to 148] *) + (case (DynamicEnv.findLongVId(E, longvid), v) + of ( SOME(Val.VId vid, IdStatus.c), + Val.VIdVal(vid',v') ) => + if vid = VId.fromString "ref" then + error(I, "runtime type error: address expected") + else if vid = vid' then + (* [Rule 144] *) + let + val VE = evalAtPat(s,E,v', atpat) + in + VE + end + else + (* [Rule 145] *) + raise FAIL + + | ( SOME(Val.ExVal(Val.ExName en),IdStatus.e), + Val.ExVal(Val.ExNameVal(en',v')) ) => + if en = en' then + (* [Rule 146] *) + let + val VE = evalAtPat(s,E,v', atpat) + in + VE + end + else + (* [Rule 147] *) + raise FAIL + + | ( SOME(Val.VId vid, IdStatus.c), + Val.Addr a ) => + if vid = VId.fromString "ref" then + (* [Rule 148] *) + let + val v = case State.findAddr(!s, a) + of SOME v => v + | NONE => + raise Fail "EvalCore.evalPat: \ + \invalid address" + val VE = evalAtPat(s,E,v, atpat) + in + VE + end + else + error(I, "runtime type error: reference expected") + + | _ => + error(I, "runtime type error: constructor expected") + ) + + | evalPat(s,E,v, TYPEDPat(I, pat, _)) = + (* Omitted [Section 6.1] *) + evalPat(s,E,v, pat) + + | evalPat(s,E,v, ASPat(I, _, vid, _, pat)) = + (* [Rule 149] *) + let + val VE = evalPat(s,E,v, pat) + in + VIdMap.insert(VE, vid, (v,IdStatus.v)) + end + + end +(* stop of EvalCore.sml *) +(* start of INTBASIS.sml *) +(* + * Standard ML interface basis + * + * Definition, section 7.2 + *) + +signature INTBASIS = + sig + + (* Import types *) + + type SigId = SigId.Id + type longTyCon = LongTyCon.longId + type Basis = DynamicBasis.Basis + type SigEnv = DynamicBasis.SigEnv + type Env = DynamicEnv.Env + type Int = Interface.Int + type ValInt = Interface.ValInt + + type 'a SigIdMap = 'a SigIdMap.map + + + (* Types [Section 7.2] *) + + type IntBasis = SigEnv * Int (* [IB] *) + + + (* Operations *) + + val Inter: Basis -> IntBasis + + val plusI: IntBasis * Int -> IntBasis + + val findSigId: IntBasis * SigId -> Int option + val findLongTyCon: IntBasis * longTyCon -> ValInt option + + end +(* stop of INTBASIS.sml *) +(* start of IntBasis.sml *) +(* + * Standard ML interface basis + * + * Definition, section 7.2 + *) + + +structure IntBasis :> INTBASIS = + struct + + (* Import types *) + + type SigId = SigId.Id + type longTyCon = LongTyCon.longId + type Basis = DynamicBasis.Basis + type SigEnv = DynamicBasis.SigEnv + type Env = DynamicEnv.Env + type Int = Interface.Int + type ValInt = Interface.ValInt + + type 'a SigIdMap = 'a SigIdMap.map + + + (* Types [Section 7.2] *) + + type IntBasis = SigEnv * Int (* [IB] *) + + + (* Injections [Section 7.2] *) + + fun Inter (F,G,E) = (G, Interface.Inter E) + + + (* Modifications [Sections 4.3 and 7.2] *) + + infix plusI + + fun (G,I) plusI I' = ( G, Interface.plus(I,I') ) + + + (* Application (lookup) [Sections 7.2 and 4.3] *) + + fun findSigId((G,I), sigid) = SigIdMap.find(G, sigid) + + fun findLongTyCon((G,I), longtycon) = Interface.findLongTyCon(I, longtycon) + + end +(* stop of IntBasis.sml *) +(* start of EVAL_MODULE.sml *) +(* + * Standard ML modules evaluation + * + * Definition, section 7.3 + * + * Notes: + * - State is passed as reference and modified via side effects. This way + * expanding out the state and exception convention in the inference rules + * can be avoided (would really be a pain). Note that the state therefore + * never is returned. + * - Doing so, we can model the exception convention using exceptions. + *) + +signature EVAL_MODULE = + sig + + (* Import types *) + + type TopDec = GrammarModule.TopDec + type Basis = DynamicBasis.Basis + type State = EvalCore.State + + + (* Export *) + + val evalTopDec: State ref * Basis * TopDec -> Basis + + end +(* stop of EVAL_MODULE.sml *) +(* start of EvalModule.sml *) +(* + * Standard ML modules evaluation + * + * Definition, section 7.3 + * + * Notes: + * - State is passed as reference and modified via side effects. This way + * expanding out the state and exception convention in the inference rules + * can be avoided (would really be a pain). Note that the state therefore + * never is returned. + * - Doing so, we can model the exception convention using exceptions. + * Rules of the form A |- phrase => A'/p therefore turn into + * A |- phrase => A'. + * - We only pass the state where necessary, ie. strexp, strdec, strbind, and + * topdec (compare note in [Section 7.3]). + * - There is a typo in the Definition in rule 182: both occurances of IB + * should be replaced by B. + * - The rules for toplevel declarations are all wrong: in the conclusions, + * the result right of the arrow must be B' <+ B''> instead of B'<'> in + * all three rules. + *) + +structure EvalModule :> EVAL_MODULE = + struct + + (* Import *) + + type TopDec = GrammarModule.TopDec + type Basis = DynamicBasis.Basis + type State = EvalCore.State + + + open GrammarModule + + + (* Helpers for error messages *) + + val error = Error.error + + fun errorSigId(I, s, sigid) = error(I, s ^ SigId.toString sigid) + fun errorFunId(I, s, funid) = error(I, s ^ FunId.toString funid) + + fun errorLongTyCon(I, s, longtycon) = + error(I, s ^ LongTyCon.toString longtycon) + fun errorLongStrId(I, s, longstrid) = + error(I, s ^ LongStrId.toString longstrid) + + + (* Helpers for basis modification *) + + val plus = DynamicBasis.plus + val plusSE = DynamicBasis.plusSE + val plusG = DynamicBasis.plusG + val plusF = DynamicBasis.plusF + val plusE = DynamicBasis.plusE + + infix plus plusG plusF plusE plusSE + + + + (* Inference rules [Section 7.3] *) + + + (* Structure Expressions *) + + fun evalStrExp(s,B, STRUCTStrExp(I, strdec)) = + (* [Rule 150] *) + let + val E = evalStrDec(s,B, strdec) + in + E + end + + | evalStrExp(s,B, LONGSTRIDStrExp(I, longstrid)) = + (* [Rule 151] *) + let + val E = case DynamicBasis.findLongStrId(B, longstrid) + of SOME(DynamicEnv.Str E) => E + | NONE => + errorLongStrId(I, "runtime error: unknown structure ", + longstrid) + in + E + end + + | evalStrExp(s,B, TRANSStrExp(I, strexp, sigexp)) = + (* [Rule 152] *) + let + val E = evalStrExp(s,B, strexp) + val I = evalSigExp(IntBasis.Inter B, sigexp) + in + Interface.cutdown(E, I) + end + + | evalStrExp(s,B, OPAQStrExp(I, strexp, sigexp)) = + (* [Rule 153] *) + let + val E = evalStrExp(s,B, strexp) + val I = evalSigExp(IntBasis.Inter B, sigexp) + in + Interface.cutdown(E, I) + end + + | evalStrExp(s,B, APPStrExp(I, funid, strexp)) = + (* [Rule 154] *) + let + val DynamicBasis.FunctorClosure((strid, I), strexp', B') = + case DynamicBasis.findFunId(B, funid) + of SOME funcclos => funcclos + | NONE => errorFunId(I, "runtime error: \ + \unknown functor ", funid) + val E = evalStrExp(s,B, strexp) + val E' = evalStrExp( + s, + B' plusSE + StrIdMap.singleton(strid, + DynamicEnv.Str(Interface.cutdown(E, I))), + strexp') + in + E' + end + + | evalStrExp(s,B, LETStrExp(I, strdec, strexp)) = + (* [Rule 155] *) + let + val E = evalStrDec(s,B, strdec) + val E' = evalStrExp(s,B plusE E, strexp) + in + E' + end + + + (* Structure-level Declarations *) + + and evalStrDec(s,B, DECStrDec(I, dec)) = + (* [Rule 156] *) + let + val E' = EvalCore.evalDec(s,DynamicBasis.Eof B, dec) + in + E' + end + + | evalStrDec(s,B, STRUCTUREStrDec(I, strbind)) = + (* [Rule 157] *) + let + val SE = evalStrBind(s,B, strbind) + in + DynamicEnv.fromSE SE + end + + | evalStrDec(s,B, LOCALStrDec(I, strdec1, strdec2)) = + (* [Rule 158] *) + let + val E1 = evalStrDec(s,B, strdec1) + val E2 = evalStrDec(s,B plusE E1, strdec2) + in + E2 + end + + | evalStrDec(s,B, EMPTYStrDec(I)) = + (* [Rule 159] *) + DynamicEnv.empty + + | evalStrDec(s,B, SEQStrDec(I, strdec1, strdec2)) = + (* [Rule 160] *) + let + val E1 = evalStrDec(s,B, strdec1) + val E2 = evalStrDec(s,B plusE E1, strdec2) + in + DynamicEnv.plus(E1, E2) + end + + + (* Structure Bindings *) + + and evalStrBind(s,B, StrBind(I, strid, strexp, strbind_opt)) = + (* [Rule 161] *) + let + val E = evalStrExp(s,B, strexp) + val SE = case strbind_opt + of NONE => StrIdMap.empty + | SOME strbind => evalStrBind(s,B, strbind) + in + StrIdMap.insert(SE, strid, DynamicEnv.Str E) + end + + + (* Signature Expressions *) + + and evalSigExp(IB, SIGSigExp(I, spec)) = + (* [Rule 162] *) + let + val I = evalSpec(IB, spec) + in + I + end + + | evalSigExp(IB, SIGIDSigExp(I, sigid)) = + (* [Rule 163] *) + let + val I = case IntBasis.findSigId(IB, sigid) + of SOME I => I + | NONE => errorSigId(I, "runtime error: unknown \ + \signature ",sigid) + in + I + end + + | evalSigExp(IB, WHERETYPESigExp(I, sigexp, _, _, _)) = + (* Omitted [Section 7.1] *) + evalSigExp(IB, sigexp) + + + (* Signature Declarations *) + + and evalSigDec(IB, SigDec(I, sigbind)) = + (* [Rule 164] *) + let + val G = evalSigBind(IB, sigbind) + in + G + end + + + (* Signature Bindings *) + + and evalSigBind(IB, SigBind(I, sigid, sigexp, sigbind_opt)) = + (* [Rule 165] *) + let + val I = evalSigExp(IB, sigexp) + val G = case sigbind_opt + of NONE => SigIdMap.empty + | SOME sigbind => evalSigBind(IB, sigbind) + in + SigIdMap.insert(G, sigid, I) + end + + + (* Specifications *) + + and evalSpec(IB, VALSpec(I, valdesc)) = + (* [Rule 166] *) + let + val VI = evalValDesc(valdesc) + in + Interface.fromVI VI + end + + | evalSpec(IB, TYPESpec(I, typdesc)) = + (* [Rule 167] *) + let + val TI = evalTypDesc(typdesc) + in + Interface.fromTI TI + end + + | evalSpec(IB, EQTYPESpec(I, typdesc)) = + (* [Rule 168] *) + let + val TI = evalTypDesc(typdesc) + in + Interface.fromTI TI + end + + | evalSpec(IB, DATATYPESpec(I, datdesc)) = + (* [Rule 169] *) + let + val (VI,TI) = evalDatDesc(datdesc) + in + Interface.fromVIandTI(VI,TI) + end + + | evalSpec(IB, REPLICATIONSpec(I, tycon, longtycon)) = + (* [Rule 170] *) + let + val VI = case IntBasis.findLongTyCon(IB, longtycon) + of SOME VI => VI + | NONE => errorLongTyCon(I, "runtime error: \ + \unknown type ", longtycon) + val TI = TyConMap.singleton(tycon, VI) + in + Interface.fromVIandTI(VI,TI) + end + + | evalSpec(IB, EXCEPTIONSpec(I, exdesc)) = + (* [Rule 171] *) + let + val VI = evalExDesc(exdesc) + in + Interface.fromVI VI + end + + | evalSpec(IB, STRUCTURESpec(I, strdesc)) = + (* [Rule 172] *) + let + val SI = evalStrDesc(IB, strdesc) + in + Interface.fromSI SI + end + + | evalSpec(IB, INCLUDESpec(I, sigexp)) = + (* [Rule 173] *) + let + val I = evalSigExp(IB, sigexp) + in + I + end + + | evalSpec(IB, EMPTYSpec(I)) = + (* [Rule 174] *) + Interface.empty + + | evalSpec(IB, SEQSpec(I, spec1, spec2)) = + (* [Rule 77] *) + let + val I1 = evalSpec(IB, spec1) + val I2 = evalSpec(IntBasis.plusI(IB, I1), spec2) + in + Interface.plus(I1,I2) + end + + | evalSpec(IB, SHARINGTYPESpec(I, spec, longtycons)) = + (* Omitted [Section 7.1] *) + evalSpec(IB, spec) + + | evalSpec(IB, SHARINGSpec(I, spec, longstrids)) = + (* Omitted [Section 7.1] *) + evalSpec(IB, spec) + + + (* Value Descriptions *) + + and evalValDesc(ValDesc(I, vid, _, valdesc_opt)) = + (* [Rule 176] *) + let + val VI = case valdesc_opt + of NONE => VIdMap.empty + | SOME valdesc => evalValDesc(valdesc) + in + VIdMap.insert(VI, vid, IdStatus.v) + end + + + (* Type Descriptions *) + + and evalTypDesc(TypDesc(I, tyvarseq, tycon, typdesc_opt)) = + (* [Rule 177] *) + let + val TI = case typdesc_opt + of NONE => TyConMap.empty + | SOME typdesc => evalTypDesc(typdesc) + in + TyConMap.insert(TI, tycon, VIdMap.empty) + end + + + (* Datatype Descriptions *) + + and evalDatDesc(DatDesc(I, tyvarseq, tycon, condesc, datdesc_opt)) = + (* [Rule 178] *) + let + val VI = evalConDesc(condesc) + val (VI',TI') = case datdesc_opt + of NONE => ( VIdMap.empty, TyConMap.empty ) + | SOME datdesc' => evalDatDesc(datdesc') + in + ( VIdMap.unionWith #2 (VI, VI') + , TyConMap.insert(TI', tycon, VI) + ) + end + + + (* Constructor Descriptions *) + + and evalConDesc(ConDesc(I, vid, _, condesc_opt)) = + (* [Rule 179] *) + let + val VI = case condesc_opt + of NONE => VIdMap.empty + | SOME condesc => evalConDesc(condesc) + in + VIdMap.insert(VI, vid, IdStatus.c) + end + + + (* Exception Description *) + + and evalExDesc(ExDesc(I, vid, _, exdesc_opt)) = + (* [Rule 180] *) + let + val VI = case exdesc_opt + of NONE => VIdMap.empty + | SOME exdesc => evalExDesc(exdesc) + in + VIdMap.insert(VI, vid, IdStatus.e) + end + + + (* Structure Descriptions *) + + and evalStrDesc(IB, StrDesc(I, strid, sigexp, strdesc_opt)) = + (* [Rule 181] *) + let + val I = evalSigExp(IB, sigexp) + val SI = case strdesc_opt + of NONE => StrIdMap.empty + | SOME strdesc => evalStrDesc(IB, strdesc) + in + StrIdMap.insert(SI, strid, Interface.Str I) + end + + + (* Functor Bindings *) + + and evalFunBind(B, FunBind(I, funid, strid, sigexp, strexp, funbind_opt)) = + (* [Rule 182] *) + (* Note that there is a typo in this rule. *) + let + val I = evalSigExp(IntBasis.Inter B, sigexp) + val F = case funbind_opt + of NONE => FunIdMap.empty + | SOME funbind => evalFunBind(B, funbind) + in + FunIdMap.insert(F, funid, + DynamicBasis.FunctorClosure((strid,I),strexp,B)) + end + + + (* Functor Declarations *) + + and evalFunDec(B, FunDec(I, funbind)) = + (* [Rule 183] *) + let + val F = evalFunBind(B, funbind) + in + F + end + + + (* Top-level Declarations *) + + and evalTopDec(s,B, STRDECTopDec(I, strdec, topdec_opt)) = + (* [Rule 184] *) + (* Note the mistake in the conclusion of this rule. *) + let + val E = evalStrDec(s,B, strdec) + val B' = DynamicBasis.fromE E + val B'' = case topdec_opt + of NONE => DynamicBasis.empty + | SOME topdec => evalTopDec(s,B plus B', topdec) + in + B' plus B'' + end + + | evalTopDec(s,B, SIGDECTopDec(I, sigdec, topdec_opt)) = + (* [Rule 185] *) + (* Note the mistake in the conclusion of this rule. *) + let + val G = evalSigDec(IntBasis.Inter B, sigdec) + val B' = DynamicBasis.fromG G + val B'' = case topdec_opt + of NONE => DynamicBasis.empty + | SOME topdec => evalTopDec(s,B plus B', topdec) + in + B' plus B'' + end + + | evalTopDec(s,B, FUNDECTopDec(I, fundec, topdec_opt)) = + (* [Rule 186] *) + (* Note the mistake in the conclusion of this rule. *) + let + val F = evalFunDec(B, fundec) + val B' = DynamicBasis.fromF F + val B'' = case topdec_opt + of NONE => DynamicBasis.empty + | SOME topdec => evalTopDec(s,B plus B', topdec) + in + B' plus B'' + end + + end +(* stop of EvalModule.sml *) +(* start of PRETTY_PRINT.sml *) +(* + * A generic pretty printer. + * + * Based on: + * Philip Wadler. "A prettier printer" + * http://cm.bell-labs.com/cm/cs/who/wadler/ + * and Christian Lindig's port to OCaml. + * + * The semantics has been extended to allow 4 different kinds of + * groups (`boxes'), 2 modes of nesting, and varying break representations. + * This is no more easily described by an algebra though, and the `below' + * combinator looses optimality. + *) + +signature PRETTY_PRINT = + sig + + type doc + + val empty : doc (* empty document *) + val break : doc (* space or line break *) + val ebreak : doc (* empty or line break *) + val text : string -> doc (* raw text *) + + val ^^ : doc * doc -> doc (* concatenation *) + val ^/^ : doc * doc -> doc (* concatenation with break *) + + val hbox : doc -> doc (* horizontal box *) + val vbox : doc -> doc (* vertical box *) + val fbox : doc -> doc (* fill box (h and v) *) + val abox : doc -> doc (* auto box (h or v) *) + + val nest : int -> doc -> doc (* indentation by k char's *) + val below : doc -> doc (* keep current indentation *) + + val isEmpty : doc -> bool + + val toString : doc * int -> string + val output : TextIO.outstream * doc * int -> unit + + end +(* stop of PRETTY_PRINT.sml *) +(* start of PrettyPrint.sml *) +(* + * A generic pretty printer. + * + * Based on: + * Philip Wadler. "A prettier printer" + * http://cm.bell-labs.com/cm/cs/who/wadler/ + * and Christian Lindig's port to OCaml. + * + * The semantics has been extended to allow 4 different kinds of + * groups (`boxes'), 2 modes of nesting, and varying break representations. + * This is no more easily described by an algebra though, and the `below' + * combinator looses optimality. + *) + +structure PrettyPrint :> PRETTY_PRINT = + struct + + (* Types *) + + datatype mode = H | V | F | A + + datatype doc = + EMPTY + | BREAK of string + | TEXT of string + | CONS of doc * doc + | BOX of mode * doc + | NEST of int * doc + | BELOW of doc + + datatype prim = + PTEXT of string + | PLINE of int + + + (* Interface operators *) + + infixr ^^ ^/^ + + val empty = EMPTY + val break = BREAK " " + val ebreak = BREAK "" + val text = TEXT + + fun x ^^ EMPTY = x + | EMPTY ^^ y = y + | x ^^ y = CONS(x, y) + + fun x ^/^ EMPTY = x + | EMPTY ^/^ y = y + | x ^/^ y = CONS(x, CONS(break, y)) + + fun below EMPTY = EMPTY + | below x = BELOW x + + fun hbox EMPTY = EMPTY + | hbox x = BOX(H, x) + + fun vbox EMPTY = EMPTY + | vbox x = BOX(V, x) + + fun fbox EMPTY = EMPTY + | fbox x = BOX(F, x) + + fun abox EMPTY = EMPTY + | abox x = BOX(A, x) + + fun nest k EMPTY = EMPTY + | nest k x = NEST(k, x) + + + fun isEmpty EMPTY = true + | isEmpty _ = false + + + (* Check whether the first line of a document fits into remaining characters *) + + (* We abuse the mode A (which can never occur in the lists passed to + * fits) to flag breaks which occur inside swallowed vboxes. + *) + + fun fits(w, z) = + w >= 0 andalso + case z + of [] => true + | (i,m,EMPTY)::z => fits(w, z) + | (i,m,CONS(x,y))::z => fits(w, (i,m,x)::(i,m,y)::z) + | (i,m,TEXT s)::z => fits(w - String.size s, z) + | (i,H,BREAK s)::z => fits(w - String.size s, z) + | (i,A,BREAK s)::z => false + | (i,m,BREAK s)::z => true + | (i,m,BOX(V,x))::z => fits(w, (i,A,x)::z) + | (i,m,BOX(n,x))::z => fits(w, (i,H,x)::z) + | (i,m,NEST(j,x))::z => fits(w, (i,m,x)::z) + | (i,m,BELOW x)::z => fits(w, (i,m,x)::z) + + + (* Layout *) + + fun best(w, k, z, a) = + case z + of [] => List.rev a + | (i,m,EMPTY)::z => best(w, k, z, a) + | (i,m,CONS(x,y))::z => best(w, k, (i,m,x)::(i,m,y)::z, a) + | (i,m,TEXT s)::z => best(w, k + String.size s, z, PTEXT(s)::a) + | (i,H,BREAK s)::z => horizontal(w, k, s, z, a) + | (i,V,BREAK s)::z => vertical(w, i, z, a) + | (i,F,BREAK s)::z => if fits(w - k - String.size s, z) + then horizontal(w, k, s, z, a) + else vertical(w, i, z, a) + | (i,A,BREAK s)::z => raise Fail "PrettyPrint.best" + | (i,m,BOX(A,x))::z => if fits(w - k, (i,H,x)::z) + then best(w, k, (i,H,x)::z, a) + else best(w, k, (i,V,x)::z, a) + | (i,m,BOX(n,x))::z => best(w, k, (i,n,x)::z, a) + | (i,m,NEST(j,x))::z => best(w, k, (i+j,m,x)::z, a) + | (i,m,BELOW x)::z => best(w, k, (k,m,x)::z, a) + + and horizontal(w, k, s, z, a) = + best(w, k + String.size s, z, PTEXT(s)::a) + + and vertical(w, i, z, a) = + best(w, i, z, PLINE(i)::a) + + + fun layout(doc, w) = best(w, 0, [(0,V,doc)], []) + + + + (* Convert a document *) + + fun primToString(PTEXT s) = s + | primToString(PLINE i) = + String.implode(#"\n" :: List.tabulate(i, fn _ => #" ")) + + val toString = String.concat o List.map primToString o layout + + + + (* Output a document directly (is MUCH faster!) *) + + fun loop 0 f = () + | loop n f = ( f() ; loop (n-1) f ) + + fun outputPrim os (PTEXT s) = TextIO.output(os, s) + | outputPrim os (PLINE i) = + ( TextIO.output1(os, #"\n") + ; loop i (fn() => TextIO.output1(os, #" ")) + ) + + fun output(os, doc, w) = List.app (outputPrim os) (layout(doc, w)) + + end +(* stop of PrettyPrint.sml *) +(* start of PP_MISC.sml *) +(* + * Standard ML miscellaneous pretty printing helpers + *) + +signature PP_MISC = + sig + + type doc = PrettyPrint.doc + + val nest: doc -> doc + + val paren: doc -> doc + val brace: doc -> doc + val brack: doc -> doc + + val ppCommaList: ('a -> doc) -> 'a list -> doc + val ppStarList: ('a -> doc) -> 'a list -> doc + val ppSeq: ('a -> doc) -> 'a list -> doc + val ppSeqPrec: (int -> 'a -> doc) -> int -> 'a list -> doc + + end +(* stop of PP_MISC.sml *) +(* start of PPMisc.sml *) +(* + * Standard ML miscellaneous pretty printing helpers + *) + +structure PPMisc :> PP_MISC = + struct + + (* Import *) + + open PrettyPrint + + infixr ^^ + + + (* Some PP combinators *) + + val nest = nest 2 + + fun paren doc = text "(" ^^ fbox(below doc) ^^ text ")" + fun brace doc = text "{" ^^ fbox(below doc) ^^ text "}" + fun brack doc = text "[" ^^ fbox(below doc) ^^ text "]" + + fun ppCommaList ppX [] = empty + | ppCommaList ppX [x] = ppX x + | ppCommaList ppX (x::xs) = ppX x ^^ text "," ^^ break ^^ + ppCommaList ppX xs + + fun ppStarList ppX [] = empty + | ppStarList ppX [x] = ppX x + | ppStarList ppX (x::xs) = hbox(ppX x ^^ break ^^ text "*") ^^ break ^^ + ppStarList ppX xs + + fun ppSeqPrec ppXPrec n [] = empty + | ppSeqPrec ppXPrec n [x] = ppXPrec n x + | ppSeqPrec ppXPrec n xs = paren(ppCommaList (ppXPrec 0) xs) + + fun ppSeq ppX = ppSeqPrec (fn _ => ppX) 0 + + end +(* stop of PPMisc.sml *) +(* start of PP_VAL.sml *) +(* + * Standard ML pretty printing of values + *) + +signature PP_VAL = + sig + + type doc = PrettyPrint.doc + type 'a State = 'a State.State + type 'a Val = 'a Val.Val + type 'a ExVal = 'a Val.ExVal + + val ppVal: 'a State * 'a Val -> doc + val ppExVal: 'a State * 'a ExVal -> doc + + end +(* stop of PP_VAL.sml *) +(* start of PPVal.sml *) +(* + * Standard ML pretty printing of values + *) + +structure PPVal :> PP_VAL = + struct + + (* Import *) + + type 'a State = 'a State.State + + open Val + open PrettyPrint + open PPMisc + + infixr ^^ ^/^ + + + (* Simple objects *) + + val ppFn = text "" + + fun ppLab lab = text(Lab.toString lab) + fun ppVId vid = text(VId.toString vid) + fun ppExName en = text(ExName.toString en) + fun ppSVal sv = text(SVal.toString sv) + + + (* Values *) + + (* Precedence: + * 0 : plain expressions + * 1 : constructor arguments + *) + + fun ppVal (s, v) = fbox(below(nest(ppValPrec (0, s) v))) + and ppExVal(s, e) = fbox(below(nest(ppExValPrec (0, s) e))) + + and ppValPrec (p, s) (op:=) = + ppFn + + | ppValPrec (p, s) (SVal sv) = + ppSVal sv + + | ppValPrec (p, s) (BasVal b) = + ppFn + + | ppValPrec (p, s) (VId vid) = + ppVId vid + + | ppValPrec (p, s) (v as VIdVal(vid, v')) = + let + exception NotAList + + fun items(VId vid, vs) = + if vid <> VId.fromString "nil" then + raise NotAList + else + List.rev vs + + | items(VIdVal(vid, v), vs) = + if vid <> VId.fromString "::" then + raise NotAList + else + (case Val.unpair v + of NONE => raise NotAList + | SOME(v1, v2) => items(v2, v1::vs) + ) + + | items(_, vs) = raise NotAList + in + let + val vs = items(v, []) + in + brack(ppCommaList (ppValPrec (0, s)) vs) + end + handle NotAList => + let + val doc = ppVId vid ^/^ ppValPrec (1, s) v' + in + if p = 0 then + doc + else + paren doc + end + end + + | ppValPrec (p, s) (ExVal e) = + ppExValPrec (p, s) e + + | ppValPrec (p, s) (Record r) = + let + fun isTuple( [], n) = n > 2 + | isTuple(lab::labs, n) = + lab = Lab.fromInt n andalso isTuple(labs, n+1) + + val labvs = LabMap.listItemsi r + val (labs,vs) = ListPair.unzip labvs + in + if List.null labs then + text "()" + else if isTuple(labs, 1) then + paren(ppCommaList (ppValPrec (0, s)) vs) + else + brace(ppCommaList (ppLabVal s) labvs) + end + + | ppValPrec (p, s) (Addr a) = + let + val v = case State.findAddr(s, a) + of SOME v => v + | NONE => raise Fail "PPVal.ppVal: invalid address" + + val doc = text "ref" ^/^ ppValPrec (1, s) v + in + if p = 0 then + doc + else + paren doc + end + + | ppValPrec (p, s) (FcnClosure _) = + ppFn + + + and ppLabVal s (lab, v) = + abox( + hbox( + ppLab lab ^/^ + text "=" + ) ^^ + below(nest(break ^^ + ppVal(s, v) + )) + ) + + + and ppExValPrec (p, s) (ExName en) = + ppExName en + + | ppExValPrec (p, s) (ExNameVal(en, v)) = + let + val doc = ppExName en ^/^ ppValPrec (1, s) v + in + if p = 0 then + doc + else + paren doc + end + + end +(* stop of PPVal.sml *) +(* start of PP_DYNAMIC_ENV.sml *) +(* + * Standard ML pretty printing of the dynamic environment + *) + +signature PP_DYNAMIC_ENV = + sig + + type doc = PrettyPrint.doc + type Env = DynamicEnv.Env + type Str = DynamicEnv.Str + type State = DynamicEnv.FcnClosure State.State + + val ppEnv: State * Env -> doc + val ppStr: State * Str -> doc + + end +(* stop of PP_DYNAMIC_ENV.sml *) +(* start of PPDynamicEnv.sml *) +(* + * Standard ML pretty printing of the dynamic environment + *) + +structure PPDynamicEnv :> PP_DYNAMIC_ENV = + struct + + (* Import *) + + type Env = DynamicEnv.Env + type Str = DynamicEnv.Str + type State = DynamicEnv.FcnClosure State.State + + open PrettyPrint + open PPMisc + + infixr ^^ ^/^ + + + (* Simple objects *) + + fun ppVId vid = text(VId.toString vid) + fun ppStrId strid = text(StrId.toString strid) + + + (* Environments *) + + fun ppValEnv(s, VE) = + VIdMap.foldri + (fn(vid, (v,IdStatus.v), doc) => + abox( + hbox( + text "val" ^/^ + ppVId vid ^/^ + text "=" + ) ^^ + nest(break ^^ + abox(PPVal.ppVal(s, v)) + ) + ) ^/^ + doc + + | (vid, (v,_), doc) => doc + ) + empty VE + + fun ppExEnv VE = + VIdMap.foldri + (fn(vid, (v,IdStatus.e), doc) => + hbox( + text "exception" ^/^ + ppVId vid + ) ^/^ + doc + + | (vid, (v,_), doc) => doc + ) + empty VE + + fun ppConEnv VE = + VIdMap.foldli + (fn(vid, (v,IdStatus.c), doc) => + hbox( + text "con" ^/^ + ppVId vid + ) ^/^ + doc + + | (vid, (v,_), doc) => doc + ) + empty VE + + fun ppStrEnv(s, SE) = + StrIdMap.foldri + (fn(strid, S, doc) => + abox( + hbox( + text "structure" ^/^ + ppStrId strid ^/^ + text "=" + ) ^^ + nest(break ^^ + ppStr(s, S) + ) + ) ^/^ + doc + ) + empty SE + + and ppEnv(s, (SE,TE,VE)) = + vbox( + ppStrEnv(s, SE) ^/^ + ppConEnv VE ^/^ + ppExEnv VE ^/^ + ppValEnv(s, VE) + ) + + + (* Structures *) + + and ppStr(s, DynamicEnv.Str E) = + let + val doc = ppEnv(s, E) + in + abox(below( + text "struct" ^^ + (if isEmpty doc then + empty + else + nest(vbox(break ^^ doc)) + ) ^^ break ^^ + text "end" + )) + end + + end +(* stop of PPDynamicEnv.sml *) +(* start of PP_DYNAMIC_BASIS.sml *) +(* + * Standard ML pretty printing of the dynamic basis + *) + +signature PP_DYNAMIC_BASIS = + sig + + type doc = PrettyPrint.doc + type Basis = DynamicBasis.Basis + type State = DynamicEnv.FcnClosure State.State + + val ppBasis: State * Basis -> doc + + end +(* stop of PP_DYNAMIC_BASIS.sml *) +(* start of PPDynamicBasis.sml *) +(* + * Standard ML pretty printing of the dynamic basis + *) + +structure PPDynamicBasis :> PP_DYNAMIC_BASIS = + struct + + (* Import *) + + type Basis = DynamicBasis.Basis + type State = DynamicEnv.FcnClosure State.State + + open PrettyPrint + + infixr ^^ ^/^ + + + (* Simple objects *) + + fun ppFunId funid = text(FunId.toString funid) + + + (* Environments *) + + fun ppFunEnv F = + FunIdMap.foldri + (fn(funid, _, doc) => + hbox( + text "functor" ^/^ + ppFunId funid + ) ^/^ + doc + ) + empty F + + + (* Basis *) + + fun ppBasis(s, (F,G,E)) = + vbox( + ppFunEnv F ^/^ + PPDynamicEnv.ppEnv(s, E) ^/^ + text "" + ) + + end +(* stop of PPDynamicBasis.sml *) +(* start of CHECK_PATTERN.sml *) +(* + * Standard ML consistency of patterns and matches + * + * Definition, section 4.11 + * + * Note: + * The requirement to check for irredundancy of matches is a `bug' in the + * definition since this cannot be checked in general for two reasons: + * + * (1) There may be (hidden) aliasing of exception constructors. + * Consequently, we only detect redundant exception constructors + * if they are denoted by the same longvid. + * + * (2) There is no requirement of consistency for constructors in + * sharing specifications or type realisations (actually, we + * consider this a serious bug). For example, + * datatype t1 = A | B + * datatype t2 = C + * sharing type t1 = t2 + * is a legal specification. This allows a mix of the constructors + * to appear in matches, rendering the terms of irredundancy and + * exhaustiveness meaningless. We make no attempt to detect this, + * so generated warnings may or may not make sense in that situation. + *) + + +signature CHECK_PATTERN = + sig + + (* Import *) + + type Pat = GrammarCore.Pat + type Match = GrammarCore.Match + type Env = StaticEnv.Env + + + (* Operations *) + + val checkPat: Env * Pat -> unit + val checkMatch: Env * Match -> unit + + end +(* stop of CHECK_PATTERN.sml *) +(* start of CheckPattern.sml *) +(* + * Standard ML consistency of patterns and matches + * + * Definition, section 4.11 + * + * Note: + * The requirement to check for irredundancy of matches is a `bug' in the + * definition since this cannot be checked in general for two reasons: + * + * (1) There may be (hidden) aliasing of exception constructors. + * Consequently, we only detect redundant exception constructors + * if they are denoted by the same longvid. + * + * (2) There is no requirement of consistency for constructors in + * sharing specifications or type realisations (actually, we + * consider this a serious bug). For example, + * datatype t1 = A | B + * datatype t2 = C + * sharing type t1 = t2 + * is a legal specification. This allows a mix of the constructors + * to appear in matches, rendering the terms of irredundancy and + * exhaustiveness meaningless. We make no attempt to detect this, + * so generated warnings may or may not make sense in that situation. + * + * Bugs: + * All types of special constants are assumed to be infinite, so that + * a match only gets exhaustive by placing a variable. This is a bit + * inaccurate for char in particular where the programmer actually would + * be able to write down the complete set of values. + * The reason is that for special constants to be treated properly in + * the presence of overloading we would require the (resolved) type + * information. + *) + +structure CheckPattern :> CHECK_PATTERN = + struct + + (* Import *) + + type SCon = SCon.SCon + type Lab = Lab.Lab + type VId = VId.Id + type longVId = LongVId.longId + type Pat = GrammarCore.Pat + type Match = GrammarCore.Match + type Env = StaticEnv.Env + + type SConSet = SConSet.set + type VIdSet = VIdSet.set + type LongVIdSet = LongVIdSet.set + type 'a LabMap = 'a LabMap.map + + + open GrammarCore + + + + (* + * Algorithm has been derived from: + * Peter Sestoft. + * "ML pattern matching compilation and partial evaluation", + * in: Dagstuhl Seminar on Partial Evaluation, + * Lecture Notes in Computer Science, Springer-Verlag 1996 + *) + + + (* Value description *) + + datatype description = + ANY + | SCON of SCon + | NOT_SCON of SConSet + | EXCON of longVId * description option + | NOT_EXCON of LongVIdSet + | CON of VId * description option + | NOT_CON of VIdSet + | RECORD of description LabMap + + datatype context = + EXCON' of longVId + | CON' of VId + | LAB' of Lab + | RECORD' of description LabMap + + type knowledge = description * context list + + type continuations = PatRow option list * Match option + + + + (* Extending the context on partial success *) + + fun augment(EXCON'(longvid)::context, desc) = + augment(context, EXCON(longvid, SOME desc)) + + | augment(CON'(vid)::context, desc) = + augment(context, CON(vid, SOME desc)) + + | augment(LAB'(lab)::RECORD'(descs)::context, desc) = + RECORD'(LabMap.insert(descs, lab, desc)) :: context + + | augment _ = raise Fail "CheckPattern.augment: invalid context" + + + (* Building the description on failure *) + + fun build([], desc) = + desc + + | build(EXCON'(longvid)::context, desc) = + build(context, EXCON(longvid, SOME desc)) + + | build(CON'(vid)::context, desc) = + build(context, CON(vid, SOME desc)) + + | build(LAB'(lab)::RECORD'(descs)::context, desc) = + build(context, RECORD(LabMap.insert(descs, lab, desc))) + + | build _ = raise Fail "CheckPattern.build: invalid context" + + + (* Result type for static matching *) + + structure RegionSet = FinSetFn(type ord_key = Source.region + val compare = Source.compare) + + type result = RegionSet.set * bool + + val success = ( RegionSet.empty, true ) + val failure = ( RegionSet.empty, false ) + + fun branch((P1, exhaustive1), (P2, exhaustive2)) = + ( RegionSet.union(P1, P2), exhaustive1 andalso exhaustive2 ) + + fun reached(I, (P, exhaustive)) = + ( RegionSet.add(P, I), exhaustive ) + + + + (* Static pattern matching *) + + fun matchMatch(E, desc, Match(_, mrule, match_opt)) = + matchMrule(E, desc, mrule, match_opt) + + + and matchMrule(E, desc, Mrule(I, pat, exp), match_opt) = + reached(I, matchPat(E, (desc, []), pat, ([], match_opt))) + + + and matchAtPat(E, know, atpat, cont) = + case atpat + of WILDCARDAtPat(_) => + succeed(E, know, cont) + + | SCONAtPat(_, scon) => + matchSCon(E, know, scon, cont) + + | LONGVIDAtPat(_, _, longvid) => + (case StaticEnv.findLongVId(E, longvid) + of NONE => + succeed(E, know, cont) + + | SOME(sigma, IdStatus.v) => + succeed(E, know, cont) + + | SOME(sigma, IdStatus.e) => + matchExCon(E, know, longvid, NONE, cont) + + | SOME((_,tau), IdStatus.c) => + let + val vid = LongVId.toId longvid + val span = TyName.span(Type.tyname(Type.range tau)) + in + matchCon(E, know, vid, span, NONE, cont) + end + ) + + | RECORDAtPat(_, patrow_opt) => + matchRecord(E, know, patrow_opt, cont) + + | PARAtPat(_, pat) => + matchPat(E, know, pat, cont) + + + and matchPat(E, know, pat, cont) = + case pat + of ATPATPat(_, atpat) => + matchAtPat(E, know, atpat, cont) + + | CONPat(_, _, longvid, atpat) => + (case StaticEnv.findLongVId(E, longvid) + of SOME(sigma, IdStatus.e) => + matchExCon(E, know, longvid, SOME atpat, cont) + + | SOME((_,tau), IdStatus.c) => + let + val vid = LongVId.toId longvid + val span = TyName.span(Type.tyname(Type.range tau)) + in + matchCon(E, know, vid, span, SOME atpat, cont) + end + + | _ => raise Fail "CheckMatching.matchPat: \ + \invalid constructed pattern" + ) + + | TYPEDPat(_, pat, ty) => + matchPat(E, know, pat, cont) + + | ASPat(_, _, vid, ty_opt, pat) => + matchPat(E, know, pat, cont) + + + and matchRecord(E, (desc, context), patrow_opt, cont) = + let + val descs = case desc + of ANY => LabMap.empty + | RECORD descs => descs + | _ => + raise Fail "CheckPattern.matchRecord: type error" + in + matchPatRowOpt(E, RECORD'(descs)::context, patrow_opt, cont) + end + + + and matchPatRowOpt(E, RECORD'(descs)::context, patrow_opt, + cont as (patrow_opts, match_opt)) = + (case patrow_opt + of SOME(ROWPatRow(_, lab, pat, patrow_opt')) => + let + val desc' = case LabMap.find(descs, lab) + of NONE => ANY + | SOME desc' => desc' + in + matchPat(E, (desc', LAB'(lab)::RECORD'(descs)::context), pat, + (patrow_opt'::patrow_opts, match_opt)) + end + + | _ => + succeed(E, (RECORD descs, context), cont) + ) + | matchPatRowOpt _ = + raise Fail "CheckPattern.matchPatRowOpt: inconsistent context" + + + and matchSCon(E, know as (desc, context), scon, cont) = + let + val knowSucc = (SCON scon, context) + fun knowFail scons = (NOT_SCON(SConSet.add(scons, scon)), context) + in + case desc + of ANY => + branch(succeed(E, knowSucc, cont), + fail(E, knowFail SConSet.empty, cont) + ) + + | SCON scon' => + if SCon.compare(scon, scon') = EQUAL then + succeed(E, know, cont) + else + fail(E, know, cont) + + | NOT_SCON scons => + if SConSet.member(scons, scon) then + fail(E, know, cont) + else + branch(succeed(E, knowSucc, cont), + fail(E, knowFail scons, cont) + ) + + | _ => raise Fail "CheckPattern.matchSCon: type error" + end + + + and matchExCon(E, know as (desc, context), longvid, atpat_opt, cont) = + let + val knowSucc = (EXCON(longvid, NONE), EXCON'(longvid)::context) + fun knowFail longvids = + (NOT_EXCON(LongVIdSet.add(longvids, longvid)), context) + in + case desc + of ANY => + branch(matchArgOpt(E, knowSucc, SOME ANY, atpat_opt, cont), + fail(E, knowFail LongVIdSet.empty, cont) + ) + + | EXCON(longvid', desc_opt) => + if longvid = longvid' then + matchArgOpt(E, knowSucc, desc_opt, atpat_opt, cont) + else + fail(E, know, cont) + + | NOT_EXCON longvids => + if LongVIdSet.member(longvids, longvid) then + fail(E, know, cont) + else + branch(matchArgOpt(E, knowSucc, SOME ANY, atpat_opt, cont), + fail(E, knowFail longvids, cont) + ) + + | _ => raise Fail "CheckPattern.matchSCon: type error" + end + + + and matchCon(E, know as (desc, context), vid, span, atpat_opt, cont) = + let + val knowSucc = (CON(vid, NONE), CON'(vid)::context) + fun knowFail vids = (NOT_CON(VIdSet.add(vids, vid)), context) + in + case desc + of ANY => + if span = 1 then + matchArgOpt(E, knowSucc, SOME ANY, atpat_opt, cont) + else + branch(matchArgOpt(E, knowSucc, SOME ANY, atpat_opt, cont), + fail(E, knowFail VIdSet.empty, cont) + ) + + | CON(vid', desc_opt) => + if vid = vid' then + matchArgOpt(E, knowSucc, desc_opt, atpat_opt, cont) + else + fail(E, know, cont) + + | NOT_CON vids => + if VIdSet.member(vids, vid) then + fail(E, know, cont) + else if VIdSet.numItems vids = span - 1 then + matchArgOpt(E, knowSucc, SOME ANY, atpat_opt, cont) + else + branch(matchArgOpt(E, knowSucc, SOME ANY, atpat_opt, cont), + fail(E, knowFail vids, cont) + ) + + | _ => raise Fail "CheckPattern.matchSCon: type error" + end + + + and matchArgOpt(E, (desc, context), desc_opt, atpat_opt, cont) = + case atpat_opt + of NONE => + succeed(E, (desc, List.tl context), cont) + + | SOME atpat => + matchAtPat(E, (valOf desc_opt, context), atpat, cont) + + + + and succeed(E, know, ([], match_opt)) = + success + + | succeed(E, (desc, context), (patrow_opt::patrow_opts, match_opt)) = + let + val context' = augment(context, desc) + in + matchPatRowOpt(E, context', patrow_opt, (patrow_opts, match_opt)) + end + + + and fail(E, know, (_, NONE)) = + failure + + | fail(E, (desc, context), (_, SOME match)) = + matchMatch(E, build(context, desc), match) + + + + (* Checking matches [Section 4.11, item 2] *) + + fun checkReachableMrule(reachables, Mrule(I, _, _)) = + if RegionSet.member(reachables, I) then + () + else + Error.warning(I, "redundant match rule") + + fun checkReachableMatchOpt(reachables, NONE) = () + | checkReachableMatchOpt(reachables, SOME(Match(_, mrule, match_opt))) = + ( checkReachableMrule(reachables, mrule) + ; checkReachableMatchOpt(reachables, match_opt) + ) + + fun checkMatch(E, match) = + let + val (reachables, exhaustive) = matchMatch(E, ANY, match) + in + checkReachableMatchOpt(reachables, SOME match) + ; if exhaustive then + () + else + Error.warning(infoMatch match, "match not exhaustive") + end + + + + (* Checking single patterns [Section 4.11, item 3] *) + + fun checkPat(E, pat) = + let + val (_, exhaustive) = matchPat(E, (ANY, []), pat, ([], NONE)) + in + if exhaustive then + () + else + Error.warning(infoPat pat, "pattern not exhaustive") + end + + end +(* stop of CheckPattern.sml *) +(* start of ELAB_CORE.sml *) +(* + * Standard ML core elaboration + * + * Definition, sections 4.10, 4.11, 4.6, 4.7, 2.9 + * + * Notes: + * - Elaboration also checks the syntactic restrictions [Section 2.9] + * and the further restrictions [Section 4.11]. + * - To implement the 3rd restriction in 4.11 elabDec is passed an + * additional boolean argument to recognise being on the toplevel. + *) + + +signature ELAB_CORE = + sig + + (* Import types *) + + type Dec = GrammarCore.Dec + type Ty = GrammarCore.Ty + type TyVarseq = GrammarCore.TyVarseq + + type VId = VId.Id + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type Type = Type.Type + type Env = StaticEnv.Env + type Context = Context.Context + + + (* Export *) + + val elabDec: bool * Context * Dec -> Env + val elabTy: Context * Ty -> Type + + val tyvars: TyVarseq -> TyVarSet * TyVar list + + val validBindVId: VId -> bool + val validConBindVId: VId -> bool + + end +(* stop of ELAB_CORE.sml *) +(* start of ElabCore.sml *) +(* + * Standard ML core elaboration + * + * Definition, sections 4.10, 4.11, 4.6, 4.7, 2.9 + * + * Notes: + * - Elaboration also checks the syntactic restrictions [Section 2.9] + * and the further restrictions [Section 4.11]. + * - To implement the 3rd restriction in 4.11 some elab functions are + * passed an additional boolean argument to recognise being on the toplevel. + * - There is a bug in the Definition -- an important syntactic restriction + * is missing: + * "Any tyvar occuring on the right side of a typbind or datbind of the + * form tyvarseq tycon = ... must occur in tyvarseq." + * - The definition says that overloaded types get defaulted if the + * "surrounding text" does not resolve it. It leaves some freedom to + * how large this context may be. We choose the innermost value binding. + * - The definition states that "the program context" must determine the + * exact type of flexible records, but it does not say how large this + * context may be either. Again we choose the innermost surrounding value + * binding. + * - Most conditions on type names can be ignored since they are + * always ensured by the Stamp mechanism. + * + * Bugs: + * - Unresolved overloading is left unnoticed if it never propagates to a + * value binding's result environment. To resolve all cases we either had + * to annotate all expressions with their types and walk the whole tree + * for each value binding's RHS, or extend the inference results with + * complicated information on overloaded type variables, or use some dirty + * side effect hack. + * - The same goes for unresolved flexible record types, for essentially the + * same reason. + *) + +structure ElabCore :> ELAB_CORE = + struct + + (* Import *) + + type Dec = GrammarCore.Dec + type Ty = GrammarCore.Ty + type TyVarseq = GrammarCore.TyVarseq + + type VId = VId.Id + type TyVar = TyVar.TyVar + type TyVarSet = TyVarSet.set + type Type = Type.Type + type Env = StaticEnv.Env + type Context = Context.Context + + + open GrammarCore + + + (* Some helpers for error messages *) + + val error = Error.error + + fun errorLab(I, s, lab) = error(I, s ^ Lab.toString lab) + fun errorVId(I, s, vid) = error(I, s ^ VId.toString vid) + fun errorTyCon(I, s, tycon) = error(I, s ^ TyCon.toString tycon) + fun errorTyVar(I, s, tyvar) = error(I, s ^ TyVar.toString tyvar) + + fun errorLongVId(I, s, longvid) = error(I, s ^ LongVId.toString longvid) + fun errorLongTyCon(I, s, longtycon) = + error(I, s ^ LongTyCon.toString longtycon) + fun errorLongStrId(I, s, longstrid) = + error(I, s ^ LongStrId.toString longstrid) + + + + (* Helpers for context modification *) + + val plus = StaticEnv.plus + val plusU = Context.plusU + val plusVE = Context.plusVE + val oplusE = Context.oplusE + val oplusTE = Context.oplusTE + val oplusVEandTE = Context.oplusVEandTE + + infix plusU plusVE oplusE oplusTE oplusVEandTE + + + + (* Checking restriction for vids in binding [Section 2.9, 5th bullet] *) + + fun validBindVId vid = + vid <> VId.fromString "true" andalso + vid <> VId.fromString "false" andalso + vid <> VId.fromString "nil" andalso + vid <> VId.fromString "::" andalso + vid <> VId.fromString "ref" + + fun validConBindVId vid = + validBindVId vid andalso + vid <> VId.fromString "it" + + + (* Treating tyvarseqs *) + + fun tyvars(TyVarseq(I, tyvars)) = + let + fun collect( [], U) = U + | collect(tyvar::tyvars, U) = + if TyVarSet.member(U, tyvar) then + (* Syntactic restriction [Section 2.9, 3rd bullet] *) + errorTyVar(I, "duplicate type variable ", tyvar) + else + collect(tyvars, TyVarSet.add(U, tyvar)) + in + ( collect(tyvars, TyVarSet.empty), tyvars ) + end + + + + (* Typing special constants [Section 4.1, Appendix E.1] *) + + fun typeSCon(SCon.INT _) = Type.fromOverloadingClass InitialStaticEnv.Int + | typeSCon(SCon.WORD _) = Type.fromOverloadingClass InitialStaticEnv.Word + | typeSCon(SCon.CHAR _) = Type.fromOverloadingClass InitialStaticEnv.Char + | typeSCon(SCon.REAL _) = Type.fromOverloadingClass InitialStaticEnv.Real + | typeSCon(SCon.STRING _) = + Type.fromOverloadingClass InitialStaticEnv.String + + + (* Calculate sets of unguarded explicit type variables [Section 4.6] *) + + local + val op+ = TyVarSet.union + + fun ? tyvarsX NONE = TyVarSet.empty + | ? tyvarsX (SOME x) = tyvarsX x + in + + fun unguardedTyVarsAtExp(RECORDAtExp(_, exprow_opt)) = + ?unguardedTyVarsExpRow exprow_opt + | unguardedTyVarsAtExp(LETAtExp(_, dec, exp)) = + unguardedTyVarsDec dec + unguardedTyVarsExp exp + | unguardedTyVarsAtExp(PARAtExp(_, exp)) = + unguardedTyVarsExp exp + | unguardedTyVarsAtExp _ = TyVarSet.empty + + and unguardedTyVarsExpRow(ExpRow(_, lab, exp, exprow_opt)) = + unguardedTyVarsExp exp + ?unguardedTyVarsExpRow exprow_opt + + and unguardedTyVarsExp(ATEXPExp(_, atexp)) = + unguardedTyVarsAtExp atexp + | unguardedTyVarsExp(APPExp(_, exp, atexp)) = + unguardedTyVarsExp exp + unguardedTyVarsAtExp atexp + | unguardedTyVarsExp(TYPEDExp(_, exp, ty)) = + unguardedTyVarsExp exp + unguardedTyVarsTy ty + | unguardedTyVarsExp(HANDLEExp(_, exp, match)) = + unguardedTyVarsExp exp + unguardedTyVarsMatch match + | unguardedTyVarsExp(RAISEExp(_, exp)) = + unguardedTyVarsExp exp + | unguardedTyVarsExp(FNExp(_, match)) = + unguardedTyVarsMatch match + + and unguardedTyVarsMatch(Match(_, mrule, match_opt)) = + unguardedTyVarsMrule mrule + ?unguardedTyVarsMatch match_opt + + and unguardedTyVarsMrule(Mrule(_, pat, exp)) = + unguardedTyVarsPat pat + unguardedTyVarsExp exp + + and unguardedTyVarsDec(ABSTYPEDec(_, datbind, dec)) = + unguardedTyVarsDec dec + | unguardedTyVarsDec(EXCEPTIONDec(_, exbind)) = + unguardedTyVarsExBind exbind + | unguardedTyVarsDec(LOCALDec(_, dec1, dec2)) = + unguardedTyVarsDec dec1 + unguardedTyVarsDec dec2 + | unguardedTyVarsDec(SEQDec(_, dec1, dec2)) = + unguardedTyVarsDec dec1 + unguardedTyVarsDec dec2 + | unguardedTyVarsDec _ = TyVarSet.empty + + and unguardedTyVarsValBind(PLAINValBind(_, pat, exp, valbind_opt)) = + unguardedTyVarsPat pat + unguardedTyVarsExp exp + + ?unguardedTyVarsValBind valbind_opt + | unguardedTyVarsValBind(RECValBind(_, valbind)) = + unguardedTyVarsValBind valbind + + and unguardedTyVarsExBind(NEWExBind(_, _, vid, ty_opt, exbind_opt)) = + ?unguardedTyVarsTy ty_opt + ?unguardedTyVarsExBind exbind_opt + | unguardedTyVarsExBind(EQUALExBind(_, _, vid, _, longvid, exbind_opt)) = + ?unguardedTyVarsExBind exbind_opt + + and unguardedTyVarsAtPat(RECORDAtPat(_, patrow_opt)) = + ?unguardedTyVarsPatRow patrow_opt + | unguardedTyVarsAtPat(PARAtPat(_, pat)) = + unguardedTyVarsPat pat + | unguardedTyVarsAtPat _ = TyVarSet.empty + + and unguardedTyVarsPatRow(WILDCARDPatRow(_)) = TyVarSet.empty + | unguardedTyVarsPatRow(ROWPatRow(_, lab, pat, patrow_opt)) = + unguardedTyVarsPat pat + ?unguardedTyVarsPatRow patrow_opt + + and unguardedTyVarsPat(ATPATPat(_, atpat)) = + unguardedTyVarsAtPat atpat + | unguardedTyVarsPat(CONPat(_, _, longvid, atpat)) = + unguardedTyVarsAtPat atpat + | unguardedTyVarsPat(TYPEDPat(_, pat, ty)) = + unguardedTyVarsPat pat + unguardedTyVarsTy ty + | unguardedTyVarsPat(ASPat(_, _, vid, ty_opt, pat)) = + ?unguardedTyVarsTy ty_opt + unguardedTyVarsPat pat + + and unguardedTyVarsTy(TYVARTy(_, tyvar)) = TyVarSet.singleton tyvar + | unguardedTyVarsTy(RECORDTy(_, tyrow_opt)) = + ?unguardedTyVarsTyRow tyrow_opt + | unguardedTyVarsTy(TYCONTy(_, tyseq, longtycon)) = + unguardedTyVarsTyseq tyseq + | unguardedTyVarsTy(ARROWTy(_, ty, ty')) = + unguardedTyVarsTy ty + unguardedTyVarsTy ty' + | unguardedTyVarsTy(PARTy(_, ty)) = + unguardedTyVarsTy ty + + and unguardedTyVarsTyRow(TyRow(_, lab, ty, tyrow_opt)) = + unguardedTyVarsTy ty + ?unguardedTyVarsTyRow tyrow_opt + + and unguardedTyVarsTyseq(Tyseq(_, tys)) = + List.foldl (fn(ty,U) => unguardedTyVarsTy ty + U) TyVarSet.empty tys + + end (* local *) + + + + (* Check whether a pattern binds an identifier *) + + local + fun ? boundByX(NONE, vid) = false + | ? boundByX(SOME x, vid) = boundByX(x, vid) + in + + fun boundByAtPat(WILDCARDAtPat(_), vid) = false + | boundByAtPat(SCONAtPat(_, scon), vid) = false + | boundByAtPat(LONGVIDAtPat(_, _, longvid), vid) = + let + val (strids,vid') = LongVId.explode longvid + in + List.null strids andalso vid = vid' + end + | boundByAtPat(RECORDAtPat(_, patrow_opt), vid) = + ?boundByPatRow(patrow_opt, vid) + | boundByAtPat(PARAtPat(_, pat), vid) = boundByPat(pat, vid) + + and boundByPatRow(WILDCARDPatRow(_), vid) = false + | boundByPatRow(ROWPatRow(_, lab, pat, patrow_opt), vid) = + boundByPat(pat, vid) orelse ?boundByPatRow(patrow_opt, vid) + + and boundByPat(ATPATPat(_, atpat), vid) = boundByAtPat(atpat, vid) + | boundByPat(CONPat(_, _, longvid, atpat), vid) = boundByAtPat(atpat, vid) + | boundByPat(TYPEDPat(_, pat, ty), vid) = boundByPat(pat, vid) + | boundByPat(ASPat(_, _, vid', ty_opt, pat), vid) = + vid = vid' orelse boundByPat(pat, vid) + + end (* local *) + + + + (* Non-expansive expressions [Section 4.7] *) + + local + fun ? isNonExpansiveX C NONE = true + | ? isNonExpansiveX C (SOME x) = isNonExpansiveX C x + in + + fun isNonExpansiveAtExp C (SCONAtExp(_, scon)) = true + | isNonExpansiveAtExp C (LONGVIDAtExp(_, _, longvid)) = true + | isNonExpansiveAtExp C (RECORDAtExp(_, exprow_opt)) = + ?isNonExpansiveExpRow C exprow_opt + | isNonExpansiveAtExp C (PARAtExp(_, exp)) = isNonExpansiveExp C exp + | isNonExpansiveAtExp C _ = false + + and isNonExpansiveExpRow C (ExpRow(_, lab, exp, exprow_opt)) = + isNonExpansiveExp C exp andalso ?isNonExpansiveExpRow C exprow_opt + + and isNonExpansiveExp C (ATEXPExp(_, atexp)) = isNonExpansiveAtExp C atexp + | isNonExpansiveExp C (APPExp(_, exp, atexp)) = + isConExp C exp andalso isNonExpansiveAtExp C atexp + | isNonExpansiveExp C (TYPEDExp(_, exp, ty)) = isNonExpansiveExp C exp + | isNonExpansiveExp C (FNExp(_, match)) = true + | isNonExpansiveExp C _ = false + + and isConAtExp C (PARAtExp(_, exp)) = isConExp C exp + | isConAtExp C (LONGVIDAtExp(_, _, longvid)) = + LongVId.explode longvid <> ([],VId.fromString "ref") andalso + (case Context.findLongVId(C, longvid) + of SOME(_,is) => is=IdStatus.c orelse is=IdStatus.e + | NONE => false + ) + | isConAtExp C _ = false + + and isConExp C (ATEXPExp(_, atexp)) = isConAtExp C atexp + | isConExp C (TYPEDExp(_, ATEXPExp(_, atexp), ty)) = isConAtExp C atexp + | isConExp C _ = false + + end (* local *) + + + + (* Closure of value environments [Section 4.8] *) + + fun hasNonExpansiveRHS C (vid, PLAINValBind(I, pat, exp, valbind_opt)) = + if boundByPat(pat, vid) then + isNonExpansiveExp C exp + else + hasNonExpansiveRHS C (vid, valOf valbind_opt) + + | hasNonExpansiveRHS C (vid, RECValBind _) = + (* A rec valbind can only contain functions. *) + true + + fun Clos (C,valbind) VE = + let + val tyvarsC = Context.tyvars C + + fun alphas(vid, tau) = + if hasNonExpansiveRHS C (vid, valbind) then + TyVarSet.listItems + (TyVarSet.difference(Type.tyvars tau, tyvarsC)) + else + [] + in + VIdMap.mapi + (fn(vid, ((_,tau),is)) => ((alphas(vid,tau),tau),is)) + VE + end + + + (* Inference rules [Section 4.10] *) + + + (* Atomic Expressions *) + + fun elabAtExp(C, SCONAtExp(I, scon)) = + (* [Rule 1] *) + typeSCon scon + + | elabAtExp(C, LONGVIDAtExp(I, _, longvid)) = + (* [Rule 2] *) + let + val (sigma,is) = case Context.findLongVId(C, longvid) + of SOME valstr => valstr + | NONE => + errorLongVId(I, "unknown identifier ",longvid) + val tau = TypeScheme.instance sigma + in + tau + end + + | elabAtExp(C, RECORDAtExp(I, exprow_opt)) = + (* [Rule 3] *) + let + val rho = case exprow_opt + of NONE => Type.emptyRho + | SOME exprow => elabExpRow(C, exprow) + in + Type.fromRowType rho + end + + | elabAtExp(C, LETAtExp(I, dec, exp)) = + (* [Rule 4] *) + let + val E = elabDec(false, C, dec) + val tau = elabExp(C oplusE E, exp) + in + if TyNameSet.isSubset(Type.tynames tau, Context.Tof C) then + tau + else + error(I, "escaping local type name in let expression") + end + + | elabAtExp(C, PARAtExp(I, exp)) = + (* [Rule 5] *) + let + val tau = elabExp(C, exp) + in + tau + end + + + (* Expression Rows *) + + and elabExpRow(C, ExpRow(I, lab, exp, exprow_opt)) = + (* [Rule 6] *) + let + val tau = elabExp(C, exp) + val rho = case exprow_opt + of NONE => Type.emptyRho + | SOME exprow => elabExpRow(C, exprow) + in + if isSome(Type.findLab(rho, lab)) then + (* Syntactic restriction [Section 2.9, 1st bullet] *) + errorLab(I, "duplicate label ", lab) + else + Type.insertRho(rho, lab, tau) + end + + + (* Expressions *) + + and elabExp(C, ATEXPExp(I, atexp)) = + (* [Rule 7] *) + let + val tau = elabAtExp(C, atexp) + in + tau + end + + | elabExp(C, APPExp(I, exp, atexp)) = + (* [Rule 8] *) + let + val tau1 = elabExp(C, exp) + val tau' = elabAtExp(C, atexp) + val tau = Type.invent() + in + Type.unify(tau1, Type.fromFunType(tau',tau)) + handle Type.Unify => error(I, "type mismatch on application") + ; tau + end + + | elabExp(C, TYPEDExp(I, exp, ty)) = + (* [Rule 9] *) + let + val tau1 = elabExp(C, exp) + val tau = elabTy(C, ty) + in + Type.unify(tau1,tau) + handle Type.Unify => + error(I, "expression does not match annotation") + ; tau + end + + | elabExp(C, HANDLEExp(I, exp, match)) = + (* [Rule 10] *) + let + val tau1 = elabExp(C, exp) + val tau2 = elabMatch(C, match) + in + Type.unify(tau1,tau2) + handle Type.Unify => + error(I, "type mismatch between expression and handler") + ; tau1 + end + + | elabExp(C, RAISEExp(I, exp)) = + (* [Rule 11] *) + let + val tau1 = elabExp(C, exp) + in + Type.unify(tau1, InitialStaticEnv.tauExn) + handle Type.Unify => + error(I, "raised expression is not an exception") + ; Type.invent() + end + + | elabExp(C, FNExp(I, match)) = + (* [Rule 12] *) + let + val tau = elabMatch(C, match) + in + (* Further restriction [Section 4.11, item 2] *) + CheckPattern.checkMatch(Context.Eof C, match) + ; tau + end + + + (* Matches *) + + and elabMatch(C, Match(I, mrule, match_opt)) = + (* [Rule 13] *) + let + val tau = elabMrule(C, mrule) + in + case match_opt + of NONE => tau + | SOME match => + let + val tau2 = elabMatch(C, match) + in + Type.unify(tau, tau2) + handle Type.Unify => + error(I, "type mismatch between different matches") + ; tau + end + end + + + (* Match rules *) + + and elabMrule(C, Mrule(I, pat, exp)) = + (* [Rule 14] *) + let + val (VE,tau) = elabPat(C, pat) + val tau' = elabExp(C plusVE VE, exp) + (* Side condition on type names is always ensured. *) + in + Type.fromFunType(tau,tau') + end + + + (* Declarations *) + + and elabDec(toplevel, C, VALDec(I, tyvarseq, valbind)) = + (* [Rule 15] *) + let + val U' = #1(tyvars(tyvarseq)) + (* Collect implicitly bound tyvars [Section 4.6] *) + val U = TyVarSet.union(U', + TyVarSet.difference(unguardedTyVarsValBind valbind, + Context.Uof C)) + val VE = elabValBind(toplevel, C plusU U, valbind) + val VE' = Clos(C,valbind) VE + val _ = StaticEnv.defaultOverloaded VE' + in + if not(TyVarSet.isEmpty( + TyVarSet.intersection(Context.Uof C, U))) then + (* Syntactic restriction [Section 2.9, last bullet] *) + error(I, "some type variables shadow previous ones") + else if StaticEnv.containsFlexibleType VE' then + (* Further restriction [Section 4.11, item 1] *) + error(I, "unresolved flexible record type") + else if TyVarSet.isEmpty( + TyVarSet.intersection(U, StaticEnv.tyvarsVE VE')) then + StaticEnv.fromVE VE' + else + error(I, "some explicit type variables cannot be generalised") + end + + | elabDec(toplevel, C, TYPEDec(I, typbind)) = + (* [Rule 16] *) + let + val TE = elabTypBind(C, typbind) + in + StaticEnv.fromTE TE + end + + | elabDec(toplevel, C, DATATYPEDec(I, datbind)) = + (* [Rule 17] *) + let + val TE1 = lhsDatBind datbind + val (VE2,TE2) = elabDatBind(C oplusTE TE1, datbind) + val (TE, VE) = StaticEnv.maximiseEquality(TE2,VE2) + (* Side condition on type names is always ensured. *) + in + StaticEnv.fromVEandTE(VE,TE) + end + + | elabDec(toplevel, C, REPLICATIONDec(I, tycon, longtycon)) = + (* [Rule 18] *) + let + val (theta,VE) = case Context.findLongTyCon(C, longtycon) + of SOME tystr => tystr + | NONE => + errorLongTyCon(I, "unknown type ", longtycon) + val TE = TyConMap.singleton(tycon, (theta,VE)) + in + StaticEnv.fromVEandTE(VE,TE) + end + + | elabDec(toplevel, C, ABSTYPEDec(I, datbind, dec)) = + (* [Rule 19] *) + let + val TE1 = lhsDatBind datbind + val (VE2,TE2) = elabDatBind(C oplusTE TE1, datbind) + val (TE, VE) = StaticEnv.maximiseEquality(TE2,VE2) + val E = elabDec(false, C oplusVEandTE (VE,TE), dec) + (* Side condition on type names is always ensured. *) + in + StaticEnv.Abs(TE,E) + end + + | elabDec(toplevel, C, EXCEPTIONDec(I, exbind)) = + (* [Rule 20] *) + let + val VE = elabExBind(C, exbind) + in + StaticEnv.fromVE VE + end + + | elabDec(toplevel, C, LOCALDec(I, dec1, dec2)) = + (* [Rule 21] *) + let + val E1 = elabDec(false, C, dec1) + val E2 = elabDec(false, C oplusE E1, dec2) + in + E2 + end + + | elabDec(toplevel, C, OPENDec(I, longstrids)) = + (* [Rule 22] *) + let + val Es = + List.map + (fn longstrid => + case Context.findLongStrId(C, longstrid) + of SOME(StaticEnv.Str E) => E + | NONE => + errorLongStrId(I, "unknown structure ", longstrid)) + longstrids + in + List.foldl StaticEnv.plus StaticEnv.empty Es + end + + | elabDec(toplevel, C, EMPTYDec(I)) = + (* [Rule 23] *) + StaticEnv.empty + + | elabDec(toplevel, C, SEQDec(I, dec1, dec2)) = + (* [Rule 24] *) + let + val E1 = elabDec(toplevel, C, dec1) + val E2 = elabDec(toplevel, C oplusE E1, dec2) + in + StaticEnv.plus(E1, E2) + end + + + (* Value Bindings *) + + and elabValBind(toplevel, C, PLAINValBind(I, pat, exp, valbind_opt)) = + (* [Rule 25] *) + let + val (VE,tau1) = elabPat(C, pat) + val tau2 = elabExp(C, exp) + val VE' = case valbind_opt + of NONE => VIdMap.empty + | SOME valbind => elabValBind(toplevel, C, valbind) + in + Type.unify(tau1,tau2) + handle Type.Unify => + error(I, "type mismatch between pattern and expression") + ; if toplevel then () else + (* Further restriction [Section 4.11, item 3] *) + CheckPattern.checkPat(Context.Eof C, pat) + ; VIdMap.unionWithi + (fn(vid,_,_) => + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorVId(I, "duplicate variable ", vid)) + (VE,VE') + end + + | elabValBind(toplevel, C, RECValBind(I, valbind)) = + (* [Rule 26] *) + let + val VE1 = lhsRecValBind valbind + val VE = elabValBind(toplevel, C plusVE VE1, valbind) + (* Side condition on type names is always ensured. *) + in + VE + end + + + (* Type Bindings *) + + and elabTypBind(C, TypBind(I, tyvarseq, tycon, ty, typbind_opt)) = + (* [Rule 27] *) + let + val (U,alphas) = tyvars tyvarseq + val tau = elabTy(C, ty) + val TE = case typbind_opt + of NONE => TyConMap.empty + | SOME typbind => elabTypBind(C, typbind) + in + if not(TyVarSet.isSubset(Type.tyvars tau, U)) then + (* Syntactic restriction (missing in the Definition!) *) + error(I, "free type variables in type binding") + else if isSome(TyConMap.find(TE, tycon)) then + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorTyCon(I, "duplicate type constructor ", tycon) + else + TyConMap.insert(TE, tycon, ((alphas,tau),VIdMap.empty)) + end + + + (* Datatype Bindings *) + + and elabDatBind(C, DatBind(I, tyvarseq, tycon, conbind, datbind_opt)) = + (* [Rule 28, part 2] *) + let + val (U,alphas) = tyvars tyvarseq + val (alphas,tau) = case Context.findTyCon(C, tycon) + of SOME(theta,VE) => theta + | NONE => (* lhsDatBind inserted it! *) + raise Fail "ElabCore.elabDatBind: \ + \tycon not pre-bound" + val VE = elabConBind(C,tau, conbind) + val(VE',TE') = case datbind_opt + of NONE => ( VIdMap.empty, TyConMap.empty ) + | SOME datbind => elabDatBind(C, datbind) + (* Side condition on t is always true. *) + val ClosVE = if TyVarSet.isSubset(StaticEnv.tyvarsVE VE, U) then + StaticEnv.Clos VE + else + (* Syntactic restriction (missing in Definition!)*) + error(I, "free type variables in datatype binding") + in + if isSome(TyConMap.find(TE', tycon)) then + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorTyCon(I, "duplicate type constructor ", tycon) + else + ( VIdMap.unionWithi (fn(vid,_,_) => + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorVId(I, "duplicate data cnstructor ", vid)) (ClosVE,VE') + , TyConMap.insert(TE', tycon, ((alphas,tau),ClosVE)) + ) + end + + + (* Constructor Bindings *) + + and elabConBind(C,tau, ConBind(I, _, vid, ty_opt, conbind_opt)) = + (* [Rule 29] *) + let + val tau1 = case ty_opt + of NONE => tau + | SOME ty => + let + val tau' = elabTy(C, ty) + in + Type.fromFunType(tau',tau) + end + val VE = case conbind_opt + of NONE => VIdMap.empty + | SOME conbind => elabConBind(C,tau, conbind) + in + if isSome(VIdMap.find(VE, vid)) then + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorVId(I, "duplicate data constructor ", vid) + else if not(validConBindVId vid) then + (* Syntactic restriction [Section 2.9, 5th bullet] *) + errorVId(I, "illegal rebinding of identifier ", vid) + else + VIdMap.insert(VE, vid, (([],tau1),IdStatus.c)) + end + + + (* Exception Bindings *) + + and elabExBind(C, NEWExBind(I, _, vid, ty_opt, exbind_opt)) = + (* [Rule 30] *) + let + val tau1 = case ty_opt + of NONE => InitialStaticEnv.tauExn + | SOME ty => + let + val tau = elabTy(C, ty) + in + Type.fromFunType(tau, InitialStaticEnv.tauExn) + end + val VE = case exbind_opt + of NONE => VIdMap.empty + | SOME exbind => elabExBind(C, exbind) + in + if isSome(VIdMap.find(VE, vid)) then + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorVId(I, "duplicate exception constructor ", vid) + else if not(validConBindVId vid) then + (* Syntactic restriction [Section 2.9, 5th bullet] *) + errorVId(I, "illegal rebinding of identifier ", vid) + else + VIdMap.insert(VE, vid, (([],tau1),IdStatus.e)) + end + + | elabExBind(C, EQUALExBind(I, _, vid, _, longvid, exbind_opt)) = + (* [Rule 31] *) + let + val tau = case Context.findLongVId(C, longvid) + of SOME(([],tau),IdStatus.e) => tau + | SOME _ => + errorLongVId(I, "non-exception identifier ", longvid) + | NONE => + errorLongVId(I, "unknown identifier ", longvid) + val VE = case exbind_opt + of NONE => VIdMap.empty + | SOME exbind => elabExBind(C, exbind) + in + if isSome(VIdMap.find(VE, vid)) then + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorVId(I, "duplicate exception constructor ", vid) + else + VIdMap.insert(VE, vid, (([],tau),IdStatus.e)) + end + + + (* Atomic Patterns *) + + and elabAtPat(C, WILDCARDAtPat(I)) = + (* [Rule 32] *) + ( VIdMap.empty, Type.invent() ) + + | elabAtPat(C, SCONAtPat(I, scon)) = + (* [Rule 33] *) + (case scon + of SCon.REAL _ => + (* Syntactic restriction [Section 2.9, 6th bullet] *) + error(I, "real constant in pattern") + | _ => + ( VIdMap.empty, typeSCon scon ) + ) + + | elabAtPat(C, LONGVIDAtPat(I, _, longvid)) = + (* [Rule 34 and 35] *) + let + val (strids,vid) = LongVId.explode longvid + in + if List.null strids andalso + ( case Context.findVId(C, vid) + of NONE => true + | SOME(sigma,is) => is = IdStatus.v ) then + (* [Rule 34] *) + let + val tau = Type.invent() + in + ( VIdMap.singleton(vid, (([],tau),IdStatus.v)) + , tau ) + end + else + (* [Rule 35] *) + let + val (sigma,is) = case Context.findLongVId(C, longvid) + of SOME valstr => valstr + | NONE => + errorLongVId(I,"unknown constructor ", + longvid) + val tau = TypeScheme.instance sigma + (* Note that tau will always be a ConsType. *) + in + if is <> IdStatus.v then + ( VIdMap.empty, tau ) + else + error(I, "non-constructor long identifier in pattern") + end + end + + | elabAtPat(C, RECORDAtPat(I, patrow_opt)) = + (* [Rule 36] *) + let + val (VE,rho) = case patrow_opt + of NONE => ( VIdMap.empty, Type.emptyRho ) + | SOME patrow => elabPatRow(C, patrow) + in + (VE, Type.fromRowType rho) + end + + | elabAtPat(C, PARAtPat(I, pat)) = + (* [Rule 37] *) + let + val (VE,tau) = elabPat(C, pat) + in + (VE,tau) + end + + + (* Pattern Rows *) + + and elabPatRow(C, WILDCARDPatRow(I)) = + (* [Rule 38] *) + ( VIdMap.empty, Type.inventRho() ) + + | elabPatRow(C, ROWPatRow(I, lab, pat, patrow_opt)) = + (* [Rule 39] *) + let + val (VE,tau) = elabPat(C, pat) + val (VE',rho) = case patrow_opt + of NONE => ( VIdMap.empty, Type.emptyRho ) + | SOME patrow => elabPatRow(C, patrow) + in + if isSome(Type.findLab(rho, lab)) then + (* Syntactic restriction [Section 2.9, 1st bullet] *) + errorLab(I, "duplicate label ", lab) + else + ( VIdMap.unionWithi (fn(vid,_,_) => + errorVId(I, "duplicate variable ", vid)) (VE,VE') + , Type.insertRho(rho, lab, tau) + ) + end + + + (* Patterns *) + + and elabPat(C, ATPATPat(I, atpat)) = + (* [Rule 40] *) + let + val (VE,tau) = elabAtPat(C, atpat) + in + (VE,tau) + end + + | elabPat(C, CONPat(I, _, longvid, atpat)) = + (* [Rule 41] *) + let + val (sigma,is) = case Context.findLongVId(C, longvid) + of SOME valstr => valstr + | NONE => + errorLongVId(I, "unknown constructor ", longvid) + val _ = if is <> IdStatus.v then () else + errorLongVId(I, "non-constructor ", longvid) + val (tau',tau) = case !(TypeScheme.instance sigma) + of Type.FunType(tau',tau) => (tau', tau) + | _ => + errorLongVId(I,"misplaced nullary constructor ", + longvid) + val (VE,tau'2) = elabAtPat(C, atpat) + in + Type.unify(tau',tau'2) + handle Type.Unify => + error(I, "type mismatch in constructor pattern") + ; (VE,tau) + end + + | elabPat(C, TYPEDPat(I, pat, ty)) = + (* [Rule 42] *) + let + val (VE,tau1) = elabPat(C, pat) + val tau = elabTy(C, ty) + in + Type.unify(tau1,tau) + handle Type.Unify => error(I, "pattern does not match annotation") + ; (VE,tau) + end + + | elabPat(C, ASPat(I, _, vid, ty_opt, pat)) = + (* [Rule 43] *) + let + val (VE1,tau1) = elabPat(C, pat) + val (VE, tau) = + case ty_opt + of NONE => (VE1,tau1) + | SOME ty => + let + val tau = elabTy(C, ty) + in + Type.unify(tau1,tau) + handle Type.Unify => + error(I, "pattern does not match annotation") + ; (VE1,tau) + end + in + if not( case Context.findVId(C, vid) + of NONE => true + | SOME(sigma,is) => is = IdStatus.v ) then + errorVId(I, "misplaced constructor ", vid) + else if isSome(VIdMap.find(VE, vid)) then + errorVId(I, "duplicate variable ", vid) + else + ( VIdMap.insert(VE, vid, (([],tau),IdStatus.v)), tau ) + end + + + (* Type Expressions *) + + and elabTy(C, ty) = Type.normalise(elabTy'(C, ty)) + + and elabTy'(C, TYVARTy(I, tyvar)) = + (* [Rule 44] *) + let + val alpha = tyvar + in + Type.fromTyVar alpha + end + + | elabTy'(C, RECORDTy(I, tyrow_opt)) = + (* [Rule 45] *) + let + val rho = case tyrow_opt + of NONE => Type.emptyRho + | SOME tyrow => elabTyRow'(C, tyrow) + in + Type.fromRowType rho + end + + | elabTy'(C, TYCONTy(I, tyseq, longtycon)) = + (* [Rule 46] *) + let + val Tyseq(I',tys) = tyseq + val k = List.length tys + val taus = List.map (fn ty => elabTy'(C, ty)) tys + val (theta,VE) = + case Context.findLongTyCon(C, longtycon) + of SOME tystr => tystr + | NONE => + errorLongTyCon(I, "unknown type constructor ", longtycon) + in + TypeFcn.apply(taus, theta) + handle TypeFcn.Apply => + errorLongTyCon(I, "arity mismatch at type application ", + longtycon) + end + + | elabTy'(C, ARROWTy(I, ty, ty')) = + (* [Rule 47] *) + let + val tau = elabTy'(C, ty) + val tau' = elabTy'(C, ty') + in + Type.fromFunType(tau,tau') + end + + | elabTy'(C, PARTy(I, ty)) = + (* [Rule 48] *) + let + val tau = elabTy'(C, ty) + in + tau + end + + + (* Type-expression Rows *) + + and elabTyRow'(C, TyRow(I, lab, ty, tyrow_opt)) = + (* [Rule 49] *) + let + val tau = elabTy'(C, ty) + val rho = case tyrow_opt + of NONE => Type.emptyRho + | SOME tyrow => elabTyRow'(C, tyrow) + in + if isSome(Type.findLab(rho, lab)) then + (* Syntactic restriction [Section 2.9, 1st bullet] *) + errorLab(I, "duplicate label ", lab) + else + Type.insertRho(rho, lab, tau) + end + + + + (* Build tentative VE from LHSs of recursive valbind *) + + and lhsRecValBind(PLAINValBind(I, pat, exp, valbind_opt)) = + let + val VE = lhsRecValBindPat pat + val VE' = case valbind_opt + of NONE => VIdMap.empty + | SOME valbind => lhsRecValBind valbind + val _ = case exp + of FNExp _ => () + | _ => + (* Syntactic restriction [Section 2.9, 4th bullet] *) + error(I, "illegal expression within recursive \ + \value binding") + in + VIdMap.unionWithi + (fn(vid,_,_) => + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorVId(I, "duplicate variable ", vid)) (VE,VE') + end + + | lhsRecValBind(RECValBind(I, valbind)) = + lhsRecValBind valbind + + and lhsRecValBindPat(ATPATPat(I, atpat)) = + lhsRecValBindAtPat atpat + + | lhsRecValBindPat(CONPat(I, _, longvid, atpat)) = + lhsRecValBindAtPat atpat + + | lhsRecValBindPat(TYPEDPat(I, pat, ty)) = + lhsRecValBindPat pat + + | lhsRecValBindPat(ASPat(I, _, vid, ty_opt, pat)) = + let + val VE = lhsRecValBindPat pat + in + if isSome(VIdMap.find(VE, vid)) then + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorVId(I, "duplicate variable ", vid) + else if not(validBindVId vid) then + (* Syntactic restriction [Section 2.9, 5th bullet] *) + errorVId(I, "illegal rebinding of identifier ", vid) + else + VIdMap.insert(VE, vid, (([],Type.invent()), IdStatus.v)) + end + + and lhsRecValBindAtPat(WILDCARDAtPat(I)) = + VIdMap.empty + + | lhsRecValBindAtPat(SCONAtPat(I, scon)) = + VIdMap.empty + + | lhsRecValBindAtPat(LONGVIDAtPat(I, _, longvid)) = + (case LongVId.explode longvid + of ([], vid) => + if not(validBindVId vid) then + (* Syntactic restriction [Section 2.9, 5th bullet] *) + errorVId(I, "illegal rebinding of identifier ", vid) + else + VIdMap.singleton(vid, (([],Type.invent()),IdStatus.v)) + + | _ => VIdMap.empty + ) + + | lhsRecValBindAtPat(RECORDAtPat(I, patrow_opt)) = + (case patrow_opt + of NONE => VIdMap.empty + | SOME patrow => lhsRecValBindPatRow patrow + ) + + | lhsRecValBindAtPat(PARAtPat(I, pat)) = + lhsRecValBindPat pat + + and lhsRecValBindPatRow(WILDCARDPatRow(I)) = + VIdMap.empty + + | lhsRecValBindPatRow(ROWPatRow(I, lab, pat, patrow_opt)) = + let + val VE = lhsRecValBindPat pat + in + case patrow_opt + of NONE => VE + | SOME patrow => + let + val VE' = lhsRecValBindPatRow patrow + in + VIdMap.unionWithi (fn(vid,_,_) => + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorVId(I, "duplicate variable ", vid)) (VE,VE') + end + end + + + + (* Build tentative TE from LHSs of datbind *) + + and lhsDatBind(DatBind(I, tyvarseq, tycon, conbind, datbind_opt)) = + (* [Rule 28, part 1] *) + let + val (U,alphas) = tyvars tyvarseq + val k = List.length alphas + val span = lhsConBind conbind + val t = TyName.tyname(tycon, k, TyName.EQ, span) + val tau = Type.fromConsType(List.map Type.fromTyVar alphas,t) + val TE' = case datbind_opt + of NONE => TyConMap.empty + | SOME datbind => lhsDatBind datbind + in + if isSome(TyConMap.find(TE', tycon)) then + (* Syntactic restriction [Section 2.9, 2nd bullet] *) + errorTyCon(I, "duplicate type constructor ", tycon) + else + TyConMap.insert(TE', tycon, ((alphas,tau), VIdMap.empty)) + end + + and lhsConBind(ConBind(I, _, vid, ty_opt, conbind_opt)) = + case conbind_opt + of NONE => 1 + | SOME conbind => 1 + lhsConBind conbind + + end +(* stop of ElabCore.sml *) +(* start of ELAB_MODULE.sml *) +(* + * Standard ML modules elaboration + * + * Definition, sections 5.7 and 3.5 + * + * Note: + * Elaboration also checks the syntactic restrictions [Section 3.5]. + *) + +signature ELAB_MODULE = + sig + + (* Import types *) + + type TopDec = GrammarModule.TopDec + type Basis = StaticBasis.Basis + + + (* Export *) + + val elabTopDec: Basis * TopDec -> Basis + + end +(* stop of ELAB_MODULE.sml *) +(* start of ElabModule.sml *) +(* + * Standard ML modules elaboration + * + * Definition, sections 5.7 and 3.5 + * + * Notes: + * - Elaboration also checks the syntactic restrictions [Section 3.5]. + * - To implement the 3rd restriction in 4.11 some elab functions are + * passed an additional boolean argument to recognise being on the toplevel. + *) + +structure ElabModule :> ELAB_MODULE = + struct + + (* Import *) + + type TopDec = GrammarModule.TopDec + type Basis = StaticBasis.Basis + + + open GrammarModule + + + (* Helpers for error messages *) + + val error = Error.error + + fun errorVId (I, s, vid) = error(I, s ^ VId.toString vid) + fun errorTyCon(I, s, tycon) = error(I, s ^ TyCon.toString tycon) + fun errorStrId(I, s, strid) = error(I, s ^ StrId.toString strid) + fun errorSigId(I, s, sigid) = error(I, s ^ SigId.toString sigid) + fun errorFunId(I, s, funid) = error(I, s ^ FunId.toString funid) + + fun errorLongTyCon(I, s, longtycon) = + error(I, s ^ LongTyCon.toString longtycon) + fun errorLongStrId(I, s, longstrid) = + error(I, s ^ LongStrId.toString longstrid) + + + (* Helpers for basis modification *) + + val plus = StaticBasis.plus + val plusT = StaticBasis.plusT + val oplusSE = StaticBasis.oplusSE + val oplusG = StaticBasis.oplusG + val oplusF = StaticBasis.oplusF + val oplusE = StaticBasis.oplusE + + infix plus plusT oplusG oplusF oplusE oplusSE + + + + (* Inference rules [Section 5.7] *) + + + (* Structure Expressions *) + + fun elabStrExp(B, STRUCTStrExp(I, strdec)) = + (* [Rule 50] *) + let + val E = elabStrDec(false, B, strdec) + in + E + end + + | elabStrExp(B, LONGSTRIDStrExp(I, longstrid)) = + (* [Rule 51] *) + let + val E = case StaticBasis.findLongStrId(B, longstrid) + of SOME(StaticEnv.Str E) => E + | NONE => + errorLongStrId(I, "unknown structure ", longstrid) + in + E + end + + | elabStrExp(B, TRANSStrExp(I, strexp, sigexp)) = + (* [Rule 52] *) + let + val E = elabStrExp(B, strexp) + val Sigma = elabSigExp(B, sigexp) + val (E',_) = Sig.match(E, Sigma) + handle Sig.Match => + error(I, "structure does not match constraint") + in + E' + end + + | elabStrExp(B, OPAQStrExp(I, strexp, sigexp)) = + (* [Rule 53] *) + let + val E = elabStrExp(B, strexp) + val (T',E') = Sig.rename(elabSigExp(B, sigexp)) + val (E'',_) = Sig.match(E, (T',E')) + handle Sig.Match => + error(I, "structure does not match constraint") + (* Renaming ensures side condition on T' *) + in + E' + end + + | elabStrExp(B, APPStrExp(I, funid, strexp)) = + (* [Rule 54] *) + let + val E = elabStrExp(B, strexp) + val (T1'',(E1'',(T1',E1'))) = + case StaticBasis.findFunId(B, funid) + of SOME Phi => Phi + | NONE => errorFunId(I, "unknown functor ", funid) + val (E'',phi) = Sig.match(E, (T1'',E1'')) + handle Sig.Match => + error(I, "structure does not match constraint") + val (T',E') = Sig.rename (T1', StaticEnv.realise phi E1') + (* Renaming ensures side condition on T' *) + in + E' + end + + | elabStrExp(B, LETStrExp(I, strdec, strexp)) = + (* [Rule 55] *) + let + val E1 = elabStrDec(false, B, strdec) + val E2 = elabStrExp(B oplusE E1, strexp) + in + E2 + end + + + (* Structure-level Declarations *) + + and elabStrDec(toplevel, B, DECStrDec(I, dec)) = + (* [Rule 56] *) + let + val E = ElabCore.elabDec(toplevel, StaticBasis.Cof B, dec) + in + E + end + + | elabStrDec(toplevel, B, STRUCTUREStrDec(I, strbind)) = + (* [Rule 57] *) + let + val SE = elabStrBind(B, strbind) + in + StaticEnv.fromSE SE + end + + | elabStrDec(toplevel, B, LOCALStrDec(I, strdec1, strdec2)) = + (* [Rule 58] *) + let + val E1 = elabStrDec(false, B, strdec1) + val E2 = elabStrDec(false, B oplusE E1, strdec2) + in + E2 + end + + | elabStrDec(toplevel, B, EMPTYStrDec(I)) = + (* [Rule 59] *) + StaticEnv.empty + + | elabStrDec(toplevel, B, SEQStrDec(I, strdec1, strdec2)) = + (* [Rule 60] *) + let + val E1 = elabStrDec(toplevel, B, strdec1) + val E2 = elabStrDec(toplevel, B oplusE E1, strdec2) + in + StaticEnv.plus(E1,E2) + end + + + (* Structure Bindings *) + + and elabStrBind(B, StrBind(I, strid, strexp, strbind_opt)) = + (* [Rule 61] *) + let + val E = elabStrExp(B, strexp) + val SE = case strbind_opt + of NONE => StrIdMap.empty + | SOME strbind => + elabStrBind(B plusT StaticEnv.tynames E, strbind) + in + if isSome(StrIdMap.find(SE, strid)) then + (* Syntactic restriction [Section 3.5, 1st bullet] *) + errorStrId(I, "duplicate structure identifier ", strid) + else + StrIdMap.insert(SE, strid, StaticEnv.Str E) + end + + + (* Signature Expressions *) + + and elabSigExpE(B, SIGSigExp(I, spec)) = + (* [Rule 62] *) + let + val E = elabSpec(B, spec) + in + E + end + + | elabSigExpE(B, SIGIDSigExp(I, sigid)) = + (* [Rule 63] *) + let + val (T,E) = case StaticBasis.findSigId(B, sigid) + of SOME Sigma => Sig.rename Sigma + | NONE => errorSigId(I, "unknown signature ",sigid) + in + E + end + + | elabSigExpE(B, WHERETYPESigExp(I, sigexp, tyvarseq, longtycon, ty)) = + (* [Rule 64] *) + let + val E = elabSigExpE(B, sigexp) + val alphas = #2(ElabCore.tyvars tyvarseq) + val tau = ElabCore.elabTy(StaticBasis.Cof B, ty) + val t = case StaticEnv.findLongTyCon(E,longtycon) + of NONE => + errorLongTyCon(I, "unknown type ", longtycon) + | SOME(theta,VE) => + case TypeFcn.toTyName theta + of NONE => + errorLongTyCon(I, "non-flexible type ", longtycon) + | SOME t => t + val _ = if not(TyNameSet.member(StaticBasis.Tof B, t)) then () + else errorLongTyCon(I, "rigid type ", longtycon) + val phi = TyNameMap.singleton(t, (alphas,tau)) + val _ = if TyName.equality t = TyName.NOEQ + orelse TypeFcn.admitsEquality (alphas,tau) then () else + error(I, "type realisation does not respect equality") + val E' = StaticEnv.realise phi E + val _ = if StaticEnv.isWellFormed E' then () else + error(I, "type realisation does not respect datatype") + in + E' + end + + and elabSigExp(B, sigexp) = + (* [Rule 65] *) + let + val E = elabSigExpE(B, sigexp) + val T = TyNameSet.difference(StaticEnv.tynames E, StaticBasis.Tof B) + in + (T,E) + end + + + (* Signature Declarations *) + + and elabSigDec(B, SigDec(I, sigbind)) = + (* [Rule 66] *) + let + val G = elabSigBind(B, sigbind) + in + G + end + + + (* Signature Bindings *) + + and elabSigBind(B, SigBind(I, sigid, sigexp, sigbind_opt)) = + (* [Rule 67] *) + let + val Sigma = elabSigExp(B, sigexp) + val G = case sigbind_opt + of NONE => SigIdMap.empty + | SOME sigbind => elabSigBind(B, sigbind) + in + if isSome(SigIdMap.find(G, sigid)) then + (* Syntactic restriction [Section 3.5, 1st bullet] *) + errorSigId(I, "duplicate signature identifier ", sigid) + else + SigIdMap.insert(G, sigid, Sigma) + end + + + (* Specifications *) + + and elabSpec(B, VALSpec(I, valdesc)) = + (* [Rule 68] *) + let + val VE = elabValDesc(StaticBasis.Cof B, valdesc) + in + StaticEnv.fromVE(StaticEnv.Clos VE) + end + + | elabSpec(B, TYPESpec(I, typdesc)) = + (* [Rule 69] *) + let + val TE = elabTypDesc(StaticBasis.Cof B, typdesc) + (* Side condition on type names is always ensured. *) + in + StaticEnv.fromTE TE + end + + | elabSpec(B, EQTYPESpec(I, typdesc)) = + (* [Rule 70] *) + let + val TE = elabTypDesc(StaticBasis.Cof B, typdesc) + val _ = StaticEnv.makeEquality TE + in + StaticEnv.fromTE TE + end + + | elabSpec(B, DATATYPESpec(I, datdesc)) = + (* [Rule 71] *) + let + val TE1 = lhsDatDesc datdesc + val (VE2,TE2) = elabDatDesc(Context.oplusTE(StaticBasis.Cof B,TE1), + datdesc) + val (TE, VE) = StaticEnv.maximiseEquality(TE2,VE2) + (* Side condition on type names is always ensured. *) + in + StaticEnv.fromVEandTE(VE,TE) + end + + | elabSpec(B, REPLICATIONSpec(I, tycon, longtycon)) = + (* [Rule 72] *) + let + val (theta,VE) = case StaticBasis.findLongTyCon(B, longtycon) + of SOME tystr => tystr + | NONE => + errorLongTyCon(I, "unknown type ", longtycon) + val TE = TyConMap.singleton(tycon, (theta,VE)) + in + StaticEnv.fromVEandTE(VE,TE) + end + + | elabSpec(B, EXCEPTIONSpec(I, exdesc)) = + (* [Rule 73] *) + let + val VE = elabExDesc(StaticBasis.Cof B, exdesc) + in + StaticEnv.fromVE VE + end + + | elabSpec(B, STRUCTURESpec(I, strdesc)) = + (* [Rule 74] *) + let + val SE = elabStrDesc(B, strdesc) + in + StaticEnv.fromSE SE + end + + | elabSpec(B, INCLUDESpec(I, sigexp)) = + (* [Rule 75] *) + let + val E = elabSigExpE(B, sigexp) + in + E + end + + | elabSpec(B, EMPTYSpec(I)) = + (* [Rule 76] *) + StaticEnv.empty + + | elabSpec(B, SEQSpec(I, spec1, spec2)) = + (* [Rule 77] *) + let + val E1 = elabSpec(B, spec1) + val E2 = elabSpec(B oplusE E1, spec2) + val _ = if StaticEnv.disjoint(E1,E2) then () else + error(I, "duplicate specifications in signature") + in + StaticEnv.plus(E1,E2) + end + + | elabSpec(B, SHARINGTYPESpec(I, spec, longtycons)) = + (* [Rule 78] *) + let + val E = elabSpec(B, spec) + val ts = + List.map + (fn longtycon => + case StaticEnv.findLongTyCon(E, longtycon) + of NONE => + errorLongTyCon(I, "unknown type ", longtycon) + | SOME(theta,VE) => + case TypeFcn.toTyName theta + of NONE => + errorLongTyCon(I, "non-flexible type ", longtycon) + | SOME t => + if TyNameSet.member(StaticBasis.Tof B, t) then + errorLongTyCon(I, "rigid type ", longtycon) + else + t + ) + longtycons + val equality = if List.exists + (fn t => TyName.equality t <> TyName.NOEQ) ts + then TyName.EQ + else TyName.NOEQ + val span = List.foldl + (fn(t, span) => Int.max(TyName.span t, span)) + 0 ts + val t1 = List.hd ts + val t = TyName.tyname(TyName.tycon t1, TyName.arity t1, + equality, span) + val theta = TypeFcn.fromTyName t + val phi = List.foldl + (fn(ti, phi) => TyNameMap.insert(phi, ti, theta)) + TyNameMap.empty ts + in + StaticEnv.realise phi E + end + + | elabSpec(B, SHARINGSpec(I, spec, longstrids)) = + (* [Appendix A] *) + let + fun shareFlexibleTyName(t1, t2, phi) = + let + val equality = if TyName.equality t1 <> TyName.NOEQ + orelse TyName.equality t2 <> TyName.NOEQ + then TyName.EQ + else TyName.NOEQ + val t = TyName.tyname(TyName.tycon t1, + TyName.arity t1, + equality, + Int.max(TyName.span t1, + TyName.span t2)) + val theta = TypeFcn.fromTyName t + in + TyNameMap.insert(TyNameMap.insert(phi, + t1, theta), + t2, theta) + end + + fun shareTE(TE1, TE2, phi) = + TyConMap.foldli + (fn(tycon, (theta1,VE1), phi) => + case TyConMap.find(TE2, tycon) + of NONE => phi + | SOME(theta2,VE2) => + case (TypeFcn.toTyName(TypeFcn.realise phi theta1), + TypeFcn.toTyName(TypeFcn.realise phi theta2)) + of (SOME t1, SOME t2) => + if TyNameSet.member(StaticBasis.Tof B, t1) + orelse TyNameSet.member(StaticBasis.Tof B,t2) then + errorTyCon(I, "structure contains rigid type ", + tycon) + else + shareFlexibleTyName(t1, t2, phi) + | _ => + errorTyCon(I, "structure contains non-flexible \ + \type ", tycon) + ) + phi TE1 + + fun shareSE(SE1, SE2, phi) = + StrIdMap.foldli + (fn(strid, StaticEnv.Str E1, phi) => + case StrIdMap.find(SE2, strid) + of NONE => phi + | SOME(StaticEnv.Str E2) => shareE(E1, E2, phi) + ) + phi SE1 + + and shareE((SE1,TE1,VE1), (SE2,TE2,VE2), phi) = + let + val phi' = shareTE(TE1, TE2, phi) + val phi'' = shareSE(SE1, SE2, phi') + in + phi'' + end + + fun share1(E1, [], phi) = phi + | share1(E1, E2::Es, phi) = + let + val phi' = shareE(E1, E2, phi) + in + share1(E1, Es, phi') + end + + fun shareAll( [], phi) = phi + | shareAll(E::Es, phi) = + let + val phi' = share1(E, Es, phi) + in + shareAll(Es, phi') + end + + val E = elabSpec(B, spec) + val Es = List.map + (fn longstrid => + case StaticEnv.findLongStrId(E, longstrid) + of SOME(StaticEnv.Str E') => E' + | NONE => + errorLongStrId(I, "unknown structure ", longstrid) + ) longstrids + val phi = shareAll(Es, TyNameMap.empty) + in + StaticEnv.realise phi E + end + + + (* Value Descriptions *) + + and elabValDesc(C, ValDesc(I, vid, ty, valdesc_opt)) = + (* [Rule 79] *) + let + val tau = ElabCore.elabTy(C, ty) + val VE = case valdesc_opt + of NONE => VIdMap.empty + | SOME valdesc => elabValDesc(C, valdesc) + in + if isSome(VIdMap.find(VE, vid)) then + (* Syntactic restriction [Section 3.5, 2nd bullet] *) + errorVId(I, "duplicate variable ", vid) + else if not(ElabCore.validBindVId vid) then + (* Syntactic restriction [Section 3.5, 5th bullet] *) + errorVId(I, "illegal specification of identifier ", vid) + else + VIdMap.insert(VE, vid, (([],tau),IdStatus.v)) + end + + + (* Type Descriptions *) + + and elabTypDesc(C, TypDesc(I, tyvarseq, tycon, typdesc_opt)) = + (* [Rule 80] *) + let + val alphas = #2(ElabCore.tyvars tyvarseq) + val k = List.length alphas + val t = TyName.tyname(tycon, k, TyName.NOEQ, 0) + val TE = case typdesc_opt + of NONE => TyConMap.empty + | SOME typdesc => elabTypDesc(C, typdesc) + (* Side condition on t is always true. *) + val tau = Type.fromConsType (List.map Type.fromTyVar alphas, t) + in + if isSome(TyConMap.find(TE, tycon)) then + (* Syntactic restriction [Section 3.5, 2nd bullet] *) + errorTyCon(I, "duplicate type constructor ", tycon) + else + TyConMap.insert(TE, tycon, ((alphas,tau),VIdMap.empty)) + end + + + (* Datatype Descriptions *) + + and elabDatDesc(C, DatDesc(I, tyvarseq, tycon, condesc, datdesc_opt)) = + (* [Rule 81, part 2] *) + let + val (U,alphas) = ElabCore.tyvars tyvarseq + val (alphas,tau) = case Context.findTyCon(C, tycon) + of SOME(theta,VE) => theta + | NONE => (* lhsDatDesc inserted it! *) + raise Fail "ElabCore.elabDatDesc: \ + \tycon not pre-bound" + val VE = elabConDesc(C,tau, condesc) + val(VE',TE') = case datdesc_opt + of NONE => ( VIdMap.empty, TyConMap.empty ) + | SOME datdesc => elabDatDesc(C, datdesc) + (* Side condition on t is always true. *) + val ClosVE = if TyVarSet.isSubset(StaticEnv.tyvarsVE VE, U) then + StaticEnv.Clos VE + else + (* Syntactic restriction [Section 3.5,4th bullet]*) + error(I, "free type variables \ + \in datatype description") + in + if isSome(TyConMap.find(TE', tycon)) then + (* Syntactic restriction [Section 3.5, 2nd bullet] *) + errorTyCon(I, "duplicate type constructor ", tycon) + else + ( VIdMap.unionWithi (fn(vid,_,_) => + (* Syntactic restriction [Section 3.5, 2nd bullet] *) + errorVId(I, "duplicate data cnstructor ", vid)) (ClosVE,VE') + , TyConMap.insert(TE', tycon, ((alphas,tau),ClosVE)) + ) + end + + + (* Constructor Descriptions *) + + and elabConDesc(C,tau, ConDesc(I, vid, ty_opt, condesc_opt)) = + (* [Rule 82] *) + let + val tau1 = case ty_opt + of NONE => tau + | SOME ty => + let + val tau' = ElabCore.elabTy(C, ty) + in + Type.fromFunType(tau',tau) + end + val VE = case condesc_opt + of NONE => VIdMap.empty + | SOME condesc => elabConDesc(C,tau, condesc) + in + if isSome(VIdMap.find(VE, vid)) then + (* Syntactic restriction [Section 3.5, 2nd bullet] *) + errorVId(I, "duplicate data constructor ", vid) + else if not(ElabCore.validConBindVId vid) then + (* Syntactic restriction [Section 3.5, 5th bullet] *) + errorVId(I, "illegal specifiation of identifier ", vid) + else + VIdMap.insert(VE, vid, (([],tau1),IdStatus.c)) + end + + + (* Exception Description *) + + and elabExDesc(C, ExDesc(I, vid, ty_opt, exdesc_opt)) = + (* [Rule 83] *) + let + val tau1 = case ty_opt + of NONE => InitialStaticEnv.tauExn + | SOME ty => + let + val tau = ElabCore.elabTy(C, ty) + val _ = if TyVarSet.isEmpty(Type.tyvars tau) + then () else + error(I, "free type variables \ + \in exception description") + in + Type.fromFunType(tau, InitialStaticEnv.tauExn) + end + val VE = case exdesc_opt + of NONE => VIdMap.empty + | SOME exdesc => elabExDesc(C, exdesc) + in + if isSome(VIdMap.find(VE, vid)) then + (* Syntactic restriction [Section 3.5, 2nd bullet] *) + errorVId(I, "duplicate exception constructor ", vid) + else if not(ElabCore.validConBindVId vid) then + (* Syntactic restriction [Section 3.5, 5th bullet] *) + errorVId(I, "illegal specification of identifier ", vid) + else + VIdMap.insert(VE, vid, (([],tau1),IdStatus.e)) + end + + + (* Structure Descriptions *) + + and elabStrDesc(B, StrDesc(I, strid, sigexp, strdesc_opt)) = + (* [Rule 84] *) + let + val E = elabSigExpE(B, sigexp) + val SE = case strdesc_opt + of NONE => StrIdMap.empty + | SOME strdesc => + elabStrDesc(B plusT StaticEnv.tynames E, strdesc) + in + if isSome(StrIdMap.find(SE, strid)) then + (* Syntactic restriction [Section 3.5, 2nd bullet] *) + errorStrId(I, "duplicate structure identifier ", strid) + else + StrIdMap.insert(SE, strid, StaticEnv.Str E) + end + + + (* Functor Declarations *) + + and elabFunDec(B, FunDec(I, funbind)) = + (* [Rule 85] *) + let + val F = elabFunBind(B, funbind) + in + F + end + + + (* Functor Bindings *) + + and elabFunBind(B, FunBind(I, funid, strid, sigexp, strexp, funbind_opt)) = + (* [Rule 86] *) + let + val (T,E) = elabSigExp(B, sigexp) + val E' = elabStrExp( + B oplusSE StrIdMap.singleton(strid,StaticEnv.Str E), + strexp) + (* Side condition on T is always ensured. *) + val T' = TyNameSet.difference(StaticEnv.tynames E', + TyNameSet.union(StaticBasis.Tof B, T)) + val F = case funbind_opt + of NONE => FunIdMap.empty + | SOME funbind => elabFunBind(B, funbind) + in + if isSome(FunIdMap.find(F, funid)) then + (* Syntactic restriction [Section 3.5, 1st bullet] *) + errorFunId(I, "duplicate functor identifier ", funid) + else + FunIdMap.insert(F, funid, (T,(E,(T',E')))) + end + + + (* Top-level Declarations *) + + and elabTopDec(B, STRDECTopDec(I, strdec, topdec_opt)) = + (* [Rule 87] *) + let + val E = elabStrDec(true, B, strdec) + val B' = case topdec_opt + of NONE => StaticBasis.empty + | SOME topdec => elabTopDec(B oplusE E, topdec) + val B'' = StaticBasis.plus + (StaticBasis.fromTandE(StaticEnv.tynames E, E), B') + in + if TyVarSet.isEmpty(StaticBasis.tyvars B'') then + B'' + else + error(I, "free type variables on top-level") + end + + | elabTopDec(B, SIGDECTopDec(I, sigdec, topdec_opt)) = + (* [Rule 88] *) + let + val G = elabSigDec(B, sigdec) + val B' = case topdec_opt + of NONE => StaticBasis.empty + | SOME topdec => elabTopDec(B oplusG G, topdec) + val B'' = StaticBasis.plus + (StaticBasis.fromTandG(StaticBasis.tynamesG G, G), B') + in + B'' + end + + | elabTopDec(B, FUNDECTopDec(I, fundec, topdec_opt)) = + (* [Rule 89] *) + let + val F = elabFunDec(B, fundec) + val B' = case topdec_opt + of NONE => StaticBasis.empty + | SOME topdec => elabTopDec(B oplusF F, topdec) + val B'' = StaticBasis.plus + (StaticBasis.fromTandF(StaticBasis.tynamesF F, F), B') + in + if TyVarSet.isEmpty(StaticBasis.tyvars B'') then + B'' + else + error(I, "free type variables on top-level") + end + + + + (* Build tentative TE from LHSs of datdesc *) + + and lhsDatDesc(DatDesc(I, tyvarseq, tycon, condesc, datdesc_opt)) = + (* [Rule 81, part 1] *) + let + val (U,alphas) = ElabCore.tyvars tyvarseq + val k = List.length alphas + val span = lhsConDesc condesc + val t = TyName.tyname(tycon, k, TyName.EQ, span) + val tau = Type.fromConsType(List.map Type.fromTyVar alphas,t) + val TE' = case datdesc_opt + of NONE => TyConMap.empty + | SOME datdesc => lhsDatDesc datdesc + in + if isSome(TyConMap.find(TE', tycon)) then + (* Syntactic restriction [Section 3.5, 2nd bullet] *) + errorTyCon(I, "duplicate type constructor ", tycon) + else + TyConMap.insert(TE', tycon, ((alphas,tau), VIdMap.empty)) + end + + and lhsConDesc(ConDesc(I, vid, ty_opt, condesc_opt)) = + case condesc_opt + of NONE => 1 + | SOME condesc => 1 + lhsConDesc condesc + + end +(* stop of ElabModule.sml *) +(* start of PP_TYPE.sml *) +(* + * Standard ML pretty printing of types and type schemes + *) + +signature PP_TYPE = + sig + + type doc = PrettyPrint.doc + type Type = Type.Type + type TypeScheme = TypeScheme.TypeScheme + + val ppType: Type -> doc + val ppTypeScheme: TypeScheme -> doc + + end +(* stop of PP_TYPE.sml *) +(* start of PPType.sml *) +(* + * Standard ML pretty printing of types and type schemes + *) + +structure PPType :> PP_TYPE = + struct + + (* Import *) + + type TypeScheme = TypeScheme.TypeScheme + + open Type + open PrettyPrint + open PPMisc + + infixr ^^ ^/^ + + + (* Simple objects *) + + fun ppLab lab = text(Lab.toString lab) + fun ppTyVar alpha = text(TyVar.toString alpha) + fun ppTyName t = text(TyName.toString t) + + fun ppOverloadingClass O = + let + val T = OverloadingClass.set O + val t = OverloadingClass.default O + val ts = t :: TyNameSet.listItems(TyNameSet.delete(T,t)) + in + brack(ppCommaList ppTyName ts) + end + + + fun ppRowVar CLOSEDRow = empty + | ppRowVar(FLEXRow _) = text "," ^^ break ^^ text "..." + + + (* Types *) + + (* Precedence: + * 0 : function arrow (ty1 -> ty2) + * 1 : tuple (ty1 * ... * tyn) + * 2 : constructed type (tyseq tycon) + *) + + fun ppType tau = fbox(below(nest(ppTypePrec 0 tau))) + + and ppTypePrec p (ref tau') = ppType'Prec p tau' + + and ppType'Prec p (TyVar(alpha)) = ppTyVar alpha + + | ppType'Prec p (RowType(Rho,r)) = + let + fun isTuple( [], n) = n > 2 + | isTuple(lab::labs, n) = + lab = Lab.fromInt n andalso isTuple(labs, n+1) + + val labtaus = LabMap.listItemsi Rho + val (labs,taus) = ListPair.unzip labtaus + in + if r = CLOSEDRow andalso List.null labs then + text "unit" + else if r = CLOSEDRow andalso isTuple(labs, 1) then + let + val doc = ppStarList (ppTypePrec 2) taus + in + if p > 1 then + paren doc + else + fbox(below(nest doc)) + end + else + brace(ppCommaList ppLabType labtaus ^^ ppRowVar r) + end + + | ppType'Prec p (FunType(tau1,tau2)) = + let + val doc = ppTypePrec 1 tau1 ^/^ + text "->" ^/^ + ppTypePrec 0 tau2 + in + if p > 0 then + paren doc + else + doc + end + + | ppType'Prec p (ConsType(taus,t)) = + fbox(nest(ppSeqPrec ppTypePrec 2 taus ^/^ ppTyName t)) + + | ppType'Prec p (Overloaded(O)) = + text "'" ^^ ppOverloadingClass O + + | ppType'Prec p (Link tau) = + ppTypePrec p tau + + and ppLabType(lab, tau) = + abox( + hbox( + ppLab lab ^/^ + text ":" + ) ^^ + below(nest(break ^^ + ppType tau + )) + ) + + + (* Type schemes *) + + fun ppTypeScheme sigma = + let + val (alphas,tau) = TypeScheme.normalise sigma + in + ppType tau + end + + end +(* stop of PPType.sml *) +(* start of PP_STATIC_ENV.sml *) +(* + * Standard ML pretty printing of the static environment + *) + +signature PP_STATIC_ENV = + sig + + type doc = PrettyPrint.doc + type ValEnv = StaticEnv.ValEnv + type TyEnv = StaticEnv.TyEnv + type Env = StaticEnv.Env + type TyNameSet = TyNameSet.set + + val ppEnv: Env -> doc + val ppSig: TyNameSet * Env -> doc + + val ppTyEnv: TyNameSet * TyEnv -> doc + val ppExEnv: ValEnv -> doc + + end +(* stop of PP_STATIC_ENV.sml *) +(* start of PPStaticEnv.sml *) +(* + * Standard ML pretty printing of the static environment + *) + +structure PPStaticEnv :> PP_STATIC_ENV = + struct + + (* Import *) + + type ValEnv = StaticEnv.ValEnv + type TyEnv = StaticEnv.TyEnv + type Env = StaticEnv.Env + type TyNameSet = TyNameSet.set + + open PrettyPrint + open PPMisc + + infixr ^^ ^/^ + + + (* Simple objects *) + + fun ppVId vid = text(VId.toString vid) + fun ppTyCon tycon = text(TyCon.toString tycon) + fun ppTyVar alpha = text(TyVar.toString alpha) + fun ppStrId strid = text(StrId.toString strid) + + fun ppTyName t = text(TyName.toString t) + + + (* Environments *) + + fun ppConTypeScheme (_, ref(Type.FunType(tau,_))) = + text "of" ^^ break ^^ PPType.ppType tau + + | ppConTypeScheme _ = empty + + + fun ppValEnv VE = + VIdMap.foldri + (fn(vid, (sigma,IdStatus.v), doc) => + abox( + hbox( + text "val" ^/^ + ppVId vid ^/^ + text ":" + ) ^^ + nest(break ^^ + abox(PPType.ppTypeScheme sigma) + ) + ) ^/^ + doc + + | (vid, (sigma,_), doc) => doc + ) + empty VE + + fun ppExEnv VE = + VIdMap.foldri + (fn(vid, (sigma,IdStatus.e), doc) => + abox( + hbox( + text "exception" ^/^ + ppVId vid + ) ^^ + nest(break ^^ + abox(ppConTypeScheme sigma) + ) + ) ^/^ + doc + + | (vid, (sigma,_), doc) => doc + ) + empty VE + + fun ppConEnv VE = + VIdMap.foldli + (fn(vid, (sigma,_), doc) => + doc ^/^ + abox( + hbox( + (if isEmpty doc then empty else text "|") ^/^ + ppVId vid + ) ^^ + nest(text "" ^/^ + abox(ppConTypeScheme sigma) + ) + ) + ) + empty VE + + + fun absTy(T, tycon, theta) = + case TypeFcn.toTyName theta + of NONE => NONE + | SOME t => if TyName.tycon t = tycon + andalso TyNameSet.member(T, t) then + SOME(TyName.equality t <> TyName.NOEQ) + else + NONE + + fun ppAbsTyEnv(T,TE) = + TyConMap.foldri + (fn(tycon, (theta as (alphas,tau), VE), doc) => + if VIdMap.isEmpty VE then + case absTy(T, tycon, theta) + of NONE => doc + | SOME eq => + abox( + hbox( + text(if eq then "eqtype" else "type") ^/^ + ppSeq ppTyVar alphas ^/^ + ppTyCon tycon + ) + ) ^/^ + doc + else + doc + ) + empty TE + + fun ppSynTyEnv(T,TE) = + TyConMap.foldri + (fn(tycon, (theta as (alphas,tau), VE), doc) => + if VIdMap.isEmpty VE + andalso not(isSome(absTy(T, tycon, theta))) then + abox( + hbox( + text "type" ^/^ + ppSeq ppTyVar alphas ^/^ + ppTyCon tycon ^/^ + text "=" + ) ^^ + nest(break ^^ + abox(PPType.ppType tau) + ) + ) ^/^ + doc + else + doc + ) + empty TE + + fun ppDataTyEnv TE = + TyConMap.foldri + (fn(tycon, ((alphas,tau),VE), doc) => + if VIdMap.isEmpty VE then + doc + else + abox( + hbox( + text "datatype" ^/^ + ppSeq ppTyVar alphas ^/^ + ppTyCon tycon ^/^ + text "=" + ) ^^ + nest(break ^^ + abox(ppConEnv VE) + ) + ) ^/^ + doc + ) + empty TE + + fun ppTyEnv(T,TE) = + vbox( + ppAbsTyEnv(T,TE) ^/^ + ppSynTyEnv(T,TE) ^/^ + ppDataTyEnv TE + ) + + fun ppStrEnv(T,SE) = + StrIdMap.foldri + (fn(strid, StaticEnv.Str E, doc) => + abox( + hbox( + text "structure" ^/^ + ppStrId strid ^/^ + text ":" + ) ^^ + nest(break ^^ + ppSig (T,E) + ) + ) ^/^ + doc + ) + empty SE + + and ppEnv'(T,(SE,TE,VE)) = + vbox( + ppStrEnv(T,SE) ^/^ + ppTyEnv(T,TE) ^/^ + ppExEnv VE ^/^ + ppValEnv VE + ) + + and ppEnv E = ppEnv'(TyNameSet.empty,E) + + + (* Signatures *) + + and ppSig (T,E) = + let + val doc = ppEnv'(T, E) + in + abox(below( + text "sig" ^^ + brace(ppCommaList ppTyName (TyNameSet.listItems T)) ^^ + (if isEmpty doc then + empty + else + nest(vbox(break ^^ doc)) + ) ^^ break ^^ + text "end" + )) + end + + end +(* stop of PPStaticEnv.sml *) +(* start of PP_STATIC_BASIS.sml *) +(* + * Standard ML pretty printing of the static basis + *) + +signature PP_STATIC_BASIS = + sig + + type doc = PrettyPrint.doc + type Basis = StaticBasis.Basis + type SigEnv = StaticBasis.SigEnv + type FunEnv = StaticBasis.FunEnv + + val ppBasis: Basis -> doc + val ppSigEnv: SigEnv -> doc + val ppFunEnv: FunEnv -> doc + + end +(* stop of PP_STATIC_BASIS.sml *) +(* start of PPStaticBasis.sml *) +(* + * Standard ML pretty printing of the static basis + *) + +structure PPStaticBasis :> PP_STATIC_BASIS = + struct + + (* Import *) + + type Basis = StaticBasis.Basis + type SigEnv = StaticBasis.SigEnv + type FunEnv = StaticBasis.FunEnv + + open PrettyPrint + open PPMisc + + infixr ^^ ^/^ + + + (* Simple objects *) + + fun ppSigId sigid = text(SigId.toString sigid) + fun ppFunId funid = text(FunId.toString funid) + + + (* Environments *) + + fun ppSigEnv G = + SigIdMap.foldri + (fn(sigid, Sigma, doc) => + abox( + hbox( + text "signature" ^/^ + ppSigId sigid ^/^ + text "=" + ) ^^ + nest(break ^^ + PPStaticEnv.ppSig Sigma + ) + ) ^/^ + doc + ) + empty G + + fun ppFunEnv F = + FunIdMap.foldri + (fn(funid, (T,(E,Sigma)), doc) => + abox( + hbox( + text "functor" ^/^ + ppFunId funid + ) ^^ + nest(ebreak ^^ + abox( + hbox( + text "(" ^^ + text "Arg" ^/^ + text ":" + ) ^^ + nest(break ^^ + PPStaticEnv.ppSig(T,E) + ) ^^ ebreak ^^ + hbox( + text ")" ^/^ + text ":" + ) + ) ^/^ + PPStaticEnv.ppSig Sigma + ) + ) ^/^ + doc + ) + empty F + + + (* Basis *) + + fun ppBasis (T,F,G,E) = + vbox( + ppSigEnv G ^/^ + ppFunEnv F ^/^ + PPStaticEnv.ppEnv E ^/^ + text "" + ) + + end +(* stop of PPStaticBasis.sml *) +(* start of PP_ENV.sml *) +(* + * Standard ML pretty printing of the combined static/dynamic environment + *) + +signature PP_ENV = + sig + + type doc = PrettyPrint.doc + type Env = StaticEnv.Env * DynamicEnv.Env + type State = PPDynamicEnv.State + + val ppEnv: State * Env -> doc + + end +(* stop of PP_ENV.sml *) +(* start of PPEnv.sml *) +(* + * Standard ML pretty printing of the combined static/dynamic environment + *) + +structure PPEnv :> PP_ENV = + struct + + (* Import *) + + type Env = StaticEnv.Env * DynamicEnv.Env + type State = PPDynamicEnv.State + + open PrettyPrint + open PPMisc + + infixr ^^ ^/^ + + + (* Simple objects *) + + fun ppVId vid = text(VId.toString vid) + fun ppStrId strid = text(StrId.toString strid) + + + (* Environments *) + + fun ppValEnv(s, (VE_STAT,VE_DYN)) = + VIdMap.foldri + (fn(vid, (sigma,IdStatus.v), doc) => + let + val (v,is) = valOf(VIdMap.find(VE_DYN, vid)) + in + fbox( + hbox( + text "val" ^/^ + ppVId vid + ) ^^ + nest(break ^^ + text "=" ^/^ + below(abox(PPVal.ppVal(s, v))) ^/^ + text ":" ^/^ + below(abox(PPType.ppTypeScheme sigma)) + ) + ) ^/^ + doc + end + + | (vid, (sigma,_), doc) => doc + ) + empty VE_STAT + + fun ppStrEnv(s, T, (SE_STAT,SE_DYN)) = + StrIdMap.foldri + (fn(strid, StaticEnv.Str E_STAT, doc) => + let + val DynamicEnv.Str E_DYN = valOf(StrIdMap.find(SE_DYN, strid)) + in + abox( + hbox( + text "structure" ^/^ + ppStrId strid ^/^ + text "=" + ) ^^ + nest(break ^^ + ppStr (s, T, (E_STAT,E_DYN)) + ) + ) ^/^ + doc + end + ) + empty SE_STAT + + and ppEnv'(s, T, ((SE_STAT,TE_STAT,VE_STAT), (SE_DYN, TE_DYN, VE_DYN))) = + vbox( + ppStrEnv(s, T, (SE_STAT,SE_DYN)) ^/^ + PPStaticEnv.ppTyEnv(T,TE_STAT) ^/^ + PPStaticEnv.ppExEnv VE_STAT ^/^ + ppValEnv(s, (VE_STAT,VE_DYN)) + ) + + and ppEnv(s, E) = ppEnv'(s, TyNameSet.empty, E) + + + (* Structures *) + + and ppStr(s, T, E) = + let + val doc = ppEnv'(s, T, E) + in + abox(below( + text "struct" ^^ + (if isEmpty doc then + empty + else + nest(vbox(break ^^ doc)) + ) ^^ break ^^ + text "end" + )) + end + + end +(* stop of PPEnv.sml *) +(* start of PP_BASIS.sml *) +(* + * Standard ML pretty printing of the combined basis + *) + +signature PP_BASIS = + sig + + type doc = PrettyPrint.doc + type Basis = Basis.Basis + type State = PPEnv.State + + val ppBasis: State * Basis -> doc + + end +(* stop of PP_BASIS.sml *) +(* start of PPBasis.sml *) +(* + * Standard ML pretty printing of the combined basis + *) + +structure PPBasis :> PP_BASIS = + struct + + (* Import *) + + type Basis = Basis.Basis + type State = PPEnv.State + + open PrettyPrint + + infixr ^^ ^/^ + + + (* Basis *) + + fun ppBasis (s, ((T,F_STAT,G_STAT,E_STAT), (F_DYN,G_DYN,E_DYN))) = + vbox( + PPStaticBasis.ppSigEnv G_STAT ^/^ + PPStaticBasis.ppFunEnv F_STAT ^/^ + PPEnv.ppEnv(s, (E_STAT,E_DYN)) ^/^ + text "" + ) + + end +(* stop of PPBasis.sml *) +(* start of PROGRAM.sml *) +(* + * Standard ML programs + * + * Definition, section 8 + * + * Note: + * State is passed as reference and modified via side effects. This way + * expanding out the state and exception convention in the inference rules + * of modules and core can be avoided. Note that the state therefore + * never is returned. + *) + +signature PROGRAM = + sig + + (* Import types *) + + type Program = GrammarProgram.Program + type StaticBasis = StaticBasis.Basis + type DynamicBasis = DynamicBasis.Basis + type Basis = Basis.Basis + type State = EvalModule.State + + + (* Export *) + + val execProgram: State ref * Basis * Program -> Basis + val elabProgram: StaticBasis * Program -> StaticBasis + val evalProgram: State ref * DynamicBasis * Program -> DynamicBasis + + end +(* stop of PROGRAM.sml *) +(* start of Program.sml *) +(* + * Standard ML programs + * + * Definition, section 8 + * + * Note: + * State is passed as reference and modified via side effects. This way + * expanding out the state and exception convention in the inference rules + * of modules and core can be avoided. Note that the state therefore + * never is returned. + *) + +structure Program :> PROGRAM = + struct + + (* Import *) + + type StaticBasis = StaticBasis.Basis + type DynamicBasis = DynamicBasis.Basis + type Basis = Basis.Basis + type State = EvalModule.State + + + open GrammarProgram + + + (* Helpers for output *) + + val width = 79 + + fun printException(s, e) = + ( TextIO.output(TextIO.stdOut, "Uncaught exception: ") + ; PrettyPrint.output(TextIO.stdOut, PPVal.ppExVal(s, e), width) + ; TextIO.output1(TextIO.stdOut, #"\n") + ; TextIO.flushOut TextIO.stdOut + ) + + fun printStaticBasis B_STAT = + ( PrettyPrint.output(TextIO.stdOut, PPStaticBasis.ppBasis B_STAT, + width) + ; TextIO.flushOut TextIO.stdOut + ) + + fun printDynamicBasis(s, B_DYN) = + ( PrettyPrint.output(TextIO.stdOut, PPDynamicBasis.ppBasis(s, B_DYN), + width) + ; TextIO.flushOut TextIO.stdOut + ) + + fun printBasis(s, B) = + ( PrettyPrint.output(TextIO.stdOut, PPBasis.ppBasis(s, B), width) + ; TextIO.flushOut TextIO.stdOut + ) + + + (* Helpers for basis modification *) + + val oplus = Basis.oplus + + infix oplus + + + (* Inference rules [Section 8] *) + + fun execProgram(s,B, Program(I, topdec, program_opt)) = + (* [Rules 187 to 189] *) + let + val B_STAT1 = ElabModule.elabTopDec(Basis.B_STATof B, topdec) + val B_DYN1 = EvalModule.evalTopDec(s,Basis.B_DYNof B, topdec) + (* [Rule 189] *) + val _ = printBasis(!s, (B_STAT1,B_DYN1)) + val B' = B oplus (B_STAT1,B_DYN1) + val B'' = case program_opt + of NONE => B' + | SOME program => execProgram(s,B', program) + in + B'' + end + handle Error.Error m => + (* [Rule 187] *) + let + val B' = case program_opt + of NONE => B + | SOME program => execProgram(s,B, program) + in + B' + end + + | Pack.Pack e => + (* [Rule 188] *) + let + val _ = printException(!s, e) + val B' = case program_opt + of NONE => B + | SOME program => execProgram(s,B, program) + in + B' + end + + + (* Elaboration only *) + + fun elabProgram(B_STAT, Program(I, topdec, program_opt)) = + let + val B_STAT1 = ElabModule.elabTopDec(B_STAT, topdec) + val _ = printStaticBasis B_STAT1 + val B_STAT' = StaticBasis.plus(B_STAT, B_STAT1) + val B_STAT'' = case program_opt + of NONE => B_STAT' + | SOME program => elabProgram(B_STAT', program) + in + B_STAT'' + end + handle Error.Error m => + B_STAT + + + (* Evaluation only *) + + fun evalProgram(s,B_DYN, Program(I, topdec, program_opt)) = + let + val B_DYN1 = EvalModule.evalTopDec(s,B_DYN, topdec) + val _ = printDynamicBasis(!s, B_DYN1) + val B_DYN' = DynamicBasis.plus(B_DYN, B_DYN1) + val B_DYN'' = case program_opt + of NONE => B_DYN' + | SOME program => evalProgram(s,B_DYN', program) + in + B_DYN'' + end + handle Error.Error m => + (* Runtime error *) + let + val B_DYN' = case program_opt + of NONE => B_DYN + | SOME program => + evalProgram(s,B_DYN, program) + in + B_DYN' + end + + | Pack.Pack e => + let + val _ = printException(!s, e) + val B_DYN' = case program_opt + of NONE => B_DYN + | SOME program => + evalProgram(s,B_DYN, program) + in + B_DYN' + end + + end +(* stop of Program.sml *) +(* start of ml-yacc/lib/base.sig *) +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *) + +(* base.sig: Base signature file for SML-Yacc. This file contains signatures + that must be loaded before any of the files produced by ML-Yacc are loaded +*) + +(* STREAM: signature for a lazy stream.*) + +signature STREAM = + sig type 'xa stream + val streamify : (unit -> '_a) -> '_a stream + val cons : '_a * '_a stream -> '_a stream + val get : '_a stream -> '_a * '_a stream + end + +(* LR_TABLE: signature for an LR Table. + + The list of actions and gotos passed to mkLrTable must be ordered by state + number. The values for state 0 are the first in the list, the values for + state 1 are next, etc. +*) + +signature LR_TABLE = + sig + datatype ('a,'b) pairlist = EMPTY | PAIR of 'a * 'b * ('a,'b) pairlist + datatype state = STATE of int + datatype term = T of int + datatype nonterm = NT of int + datatype action = SHIFT of state + | REDUCE of int + | ACCEPT + | ERROR + type table + + val numStates : table -> int + val numRules : table -> int + val describeActions : table -> state -> + (term,action) pairlist * action + val describeGoto : table -> state -> (nonterm,state) pairlist + val action : table -> state * term -> action + val goto : table -> state * nonterm -> state + val initialState : table -> state + exception Goto of state * nonterm + + val mkLrTable : {actions : ((term,action) pairlist * action) array, + gotos : (nonterm,state) pairlist array, + numStates : int, numRules : int, + initialState : state} -> table + end + +(* TOKEN: signature revealing the internal structure of a token. This signature + TOKEN distinct from the signature {parser name}_TOKENS produced by ML-Yacc. + The {parser name}_TOKENS structures contain some types and functions to + construct tokens from values and positions. + + The representation of token was very carefully chosen here to allow the + polymorphic parser to work without knowing the types of semantic values + or line numbers. + + This has had an impact on the TOKENS structure produced by SML-Yacc, which + is a structure parameter to lexer functors. We would like to have some + type 'a token which functions to construct tokens would create. A + constructor function for a integer token might be + + INT: int * 'a * 'a -> 'a token. + + This is not possible because we need to have tokens with the representation + given below for the polymorphic parser. + + Thus our constructur functions for tokens have the form: + + INT: int * 'a * 'a -> (svalue,'a) token + + This in turn has had an impact on the signature that lexers for SML-Yacc + must match and the types that a user must declare in the user declarations + section of lexers. +*) + +signature TOKEN = + sig + structure LrTable : LR_TABLE + datatype ('a,'b) token = TOKEN of LrTable.term * ('a * 'b * 'b) + val sameToken : ('a,'b) token * ('a,'b) token -> bool + end + +(* LR_PARSER: signature for a polymorphic LR parser *) + +signature LR_PARSER = + sig + structure Stream: STREAM + structure LrTable : LR_TABLE + structure Token : TOKEN + + sharing LrTable = Token.LrTable + + exception ParseError + + val parse : {table : LrTable.table, + lexer : ('_b,'_c) Token.token Stream.stream, + arg: 'arg, + saction : int * + '_c * + (LrTable.state * ('_b * '_c * '_c)) list * + 'arg -> + LrTable.nonterm * + ('_b * '_c * '_c) * + ((LrTable.state *('_b * '_c * '_c)) list), + void : '_b, + ec : { is_keyword : LrTable.term -> bool, + noShift : LrTable.term -> bool, + preferred_change : (LrTable.term list * LrTable.term list) list, + errtermvalue : LrTable.term -> '_b, + showTerminal : LrTable.term -> string, + terms: LrTable.term list, + error : string * '_c * '_c -> unit + }, + lookahead : int (* max amount of lookahead used in *) + (* error correction *) + } -> '_b * + (('_b,'_c) Token.token Stream.stream) + end + +(* LEXER: a signature that most lexers produced for use with SML-Yacc's + output will match. The user is responsible for declaring type token, + type pos, and type svalue in the UserDeclarations section of a lexer. + + Note that type token is abstract in the lexer. This allows SML-Yacc to + create a TOKENS signature for use with lexers produced by ML-Lex that + treats the type token abstractly. Lexers that are functors parametrized by + a Tokens structure matching a TOKENS signature cannot examine the structure + of tokens. +*) + +signature LEXER = + sig + structure UserDeclarations : + sig + type ('a,'b) token + type pos + type svalue + end + val makeLexer : (int -> string) -> unit -> + (UserDeclarations.svalue,UserDeclarations.pos) UserDeclarations.token + end + +(* ARG_LEXER: the %arg option of ML-Lex allows users to produce lexers which + also take an argument before yielding a function from unit to a token +*) + +signature ARG_LEXER = + sig + structure UserDeclarations : + sig + type ('a,'b) token + type pos + type svalue + type arg + end + val makeLexer : (int -> string) -> UserDeclarations.arg -> unit -> + (UserDeclarations.svalue,UserDeclarations.pos) UserDeclarations.token + end + +(* PARSER_DATA: the signature of ParserData structures in {parser name}LrValsFun + produced by SML-Yacc. All such structures match this signature. + + The {parser name}LrValsFun produces a structure which contains all the values + except for the lexer needed to call the polymorphic parser mentioned + before. + +*) + +signature PARSER_DATA = + sig + (* the type of line numbers *) + + type pos + + (* the type of semantic values *) + + type svalue + + (* the type of the user-supplied argument to the parser *) + type arg + + (* the intended type of the result of the parser. This value is + produced by applying extract from the structure Actions to the + final semantic value resultiing from a parse. + *) + + type result + + structure LrTable : LR_TABLE + structure Token : TOKEN + sharing Token.LrTable = LrTable + + (* structure Actions contains the functions which mantain the + semantic values stack in the parser. Void is used to provide + a default value for the semantic stack. + *) + + structure Actions : + sig + val actions : int * pos * + (LrTable.state * (svalue * pos * pos)) list * arg-> + LrTable.nonterm * (svalue * pos * pos) * + ((LrTable.state *(svalue * pos * pos)) list) + val void : svalue + val extract : svalue -> result + end + + (* structure EC contains information used to improve error + recovery in an error-correcting parser *) + + structure EC : + sig + val is_keyword : LrTable.term -> bool + val noShift : LrTable.term -> bool + val preferred_change : (LrTable.term list * LrTable.term list) list + val errtermvalue : LrTable.term -> svalue + val showTerminal : LrTable.term -> string + val terms: LrTable.term list + end + + (* table is the LR table for the parser *) + + val table : LrTable.table + end + +(* signature PARSER is the signature that most user parsers created by + SML-Yacc will match. +*) + +signature PARSER = + sig + structure Token : TOKEN + structure Stream : STREAM + exception ParseError + + (* type pos is the type of line numbers *) + + type pos + + (* type result is the type of the result from the parser *) + + type result + + (* the type of the user-supplied argument to the parser *) + type arg + + (* type svalue is the type of semantic values for the semantic value + stack + *) + + type svalue + + (* val makeLexer is used to create a stream of tokens for the parser *) + + val makeLexer : (int -> string) -> + (svalue,pos) Token.token Stream.stream + + (* val parse takes a stream of tokens and a function to print + errors and returns a value of type result and a stream containing + the unused tokens + *) + + val parse : int * ((svalue,pos) Token.token Stream.stream) * + (string * pos * pos -> unit) * arg -> + result * (svalue,pos) Token.token Stream.stream + + val sameToken : (svalue,pos) Token.token * (svalue,pos) Token.token -> + bool + end + +(* signature ARG_PARSER is the signature that will be matched by parsers whose + lexer takes an additional argument. +*) + +signature ARG_PARSER = + sig + structure Token : TOKEN + structure Stream : STREAM + exception ParseError + + type arg + type lexarg + type pos + type result + type svalue + + val makeLexer : (int -> string) -> lexarg -> + (svalue,pos) Token.token Stream.stream + val parse : int * ((svalue,pos) Token.token Stream.stream) * + (string * pos * pos -> unit) * arg -> + result * (svalue,pos) Token.token Stream.stream + + val sameToken : (svalue,pos) Token.token * (svalue,pos) Token.token -> + bool + end + +(* stop of ml-yacc/lib/base.sig *) +(* start of ml-yacc/lib/join.sml *) +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *) + +(* functor Join creates a user parser by putting together a Lexer structure, + an LrValues structure, and a polymorphic parser structure. Note that + the Lexer and LrValues structure must share the type pos (i.e. the type + of line numbers), the type svalues for semantic values, and the type + of tokens. +*) + +functor Join(structure Lex : LEXER + structure ParserData: PARSER_DATA + structure LrParser : LR_PARSER + sharing ParserData.LrTable = LrParser.LrTable + sharing ParserData.Token = LrParser.Token + sharing type Lex.UserDeclarations.svalue = ParserData.svalue + sharing type Lex.UserDeclarations.pos = ParserData.pos + sharing type Lex.UserDeclarations.token = ParserData.Token.token) + : PARSER = +struct + structure Token = ParserData.Token + structure Stream = LrParser.Stream + + exception ParseError = LrParser.ParseError + + type arg = ParserData.arg + type pos = ParserData.pos + type result = ParserData.result + type svalue = ParserData.svalue + val makeLexer = LrParser.Stream.streamify o Lex.makeLexer + val parse = fn (lookahead,lexer,error,arg) => + (fn (a,b) => (ParserData.Actions.extract a,b)) + (LrParser.parse {table = ParserData.table, + lexer=lexer, + lookahead=lookahead, + saction = ParserData.Actions.actions, + arg=arg, + void= ParserData.Actions.void, + ec = {is_keyword = ParserData.EC.is_keyword, + noShift = ParserData.EC.noShift, + preferred_change = ParserData.EC.preferred_change, + errtermvalue = ParserData.EC.errtermvalue, + error=error, + showTerminal = ParserData.EC.showTerminal, + terms = ParserData.EC.terms}} + ) + val sameToken = Token.sameToken +end + +(* functor JoinWithArg creates a variant of the parser structure produced + above. In this case, the makeLexer take an additional argument before + yielding a value of type unit -> (svalue,pos) token + *) + +functor JoinWithArg(structure Lex : ARG_LEXER + structure ParserData: PARSER_DATA + structure LrParser : LR_PARSER + sharing ParserData.LrTable = LrParser.LrTable + sharing ParserData.Token = LrParser.Token + sharing type Lex.UserDeclarations.svalue = ParserData.svalue + sharing type Lex.UserDeclarations.pos = ParserData.pos + sharing type Lex.UserDeclarations.token = ParserData.Token.token) + : ARG_PARSER = +struct + structure Token = ParserData.Token + structure Stream = LrParser.Stream + + exception ParseError = LrParser.ParseError + + type arg = ParserData.arg + type lexarg = Lex.UserDeclarations.arg + type pos = ParserData.pos + type result = ParserData.result + type svalue = ParserData.svalue + + val makeLexer = fn s => fn arg => + LrParser.Stream.streamify (Lex.makeLexer s arg) + val parse = fn (lookahead,lexer,error,arg) => + (fn (a,b) => (ParserData.Actions.extract a,b)) + (LrParser.parse {table = ParserData.table, + lexer=lexer, + lookahead=lookahead, + saction = ParserData.Actions.actions, + arg=arg, + void= ParserData.Actions.void, + ec = {is_keyword = ParserData.EC.is_keyword, + noShift = ParserData.EC.noShift, + preferred_change = ParserData.EC.preferred_change, + errtermvalue = ParserData.EC.errtermvalue, + error=error, + showTerminal = ParserData.EC.showTerminal, + terms = ParserData.EC.terms}} + ) + val sameToken = Token.sameToken +end; +(* stop of ml-yacc/lib/join.sml *) +(* start of ml-yacc/lib/lrtable.sml *) +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *) +structure LrTable : LR_TABLE = + struct + open Array List + infix 9 sub + datatype ('a,'b) pairlist = EMPTY + | PAIR of 'a * 'b * ('a,'b) pairlist + datatype term = T of int + datatype nonterm = NT of int + datatype state = STATE of int + datatype action = SHIFT of state + | REDUCE of int (* rulenum from grammar *) + | ACCEPT + | ERROR + exception Goto of state * nonterm + type table = {states: int, rules : int,initialState: state, + action: ((term,action) pairlist * action) array, + goto : (nonterm,state) pairlist array} + val numStates = fn ({states,...} : table) => states + val numRules = fn ({rules,...} : table) => rules + val describeActions = + fn ({action,...} : table) => + fn (STATE s) => action sub s + val describeGoto = + fn ({goto,...} : table) => + fn (STATE s) => goto sub s + fun findTerm (T term,row,default) = + let fun find (PAIR (T key,data,r)) = + if key < term then find r + else if key=term then data + else default + | find EMPTY = default + in find row + end + fun findNonterm (NT nt,row) = + let fun find (PAIR (NT key,data,r)) = + if key < nt then find r + else if key=nt then SOME data + else NONE + | find EMPTY = NONE + in find row + end + val action = fn ({action,...} : table) => + fn (STATE state,term) => + let val (row,default) = action sub state + in findTerm(term,row,default) + end + val goto = fn ({goto,...} : table) => + fn (a as (STATE state,nonterm)) => + case findNonterm(nonterm,goto sub state) + of SOME state => state + | NONE => raise (Goto a) + val initialState = fn ({initialState,...} : table) => initialState + val mkLrTable = fn {actions,gotos,initialState,numStates,numRules} => + ({action=actions,goto=gotos, + states=numStates, + rules=numRules, + initialState=initialState} : table) +end; +(* stop of ml-yacc/lib/lrtable.sml *) +(* start of ml-yacc/lib/stream.sml *) +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *) + +(* Stream: a structure implementing a lazy stream. The signature STREAM + is found in base.sig *) + +structure Stream :> STREAM = +struct + datatype 'a str = EVAL of 'a * 'a str ref | UNEVAL of (unit->'a) + + type 'a stream = 'a str ref + + fun get(ref(EVAL t)) = t + | get(s as ref(UNEVAL f)) = + let val t = (f(), ref(UNEVAL f)) in s := EVAL t; t end + + fun streamify f = ref(UNEVAL f) + fun cons(a,s) = ref(EVAL(a,s)) + +end; +(* stop of ml-yacc/lib/stream.sml *) +(* start of ml-yacc/lib/parser2.sml *) +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *) + +(* parser.sml: This is a parser driver for LR tables with an error-recovery + routine added to it. The routine used is described in detail in this + article: + + 'A Practical Method for LR and LL Syntactic Error Diagnosis and + Recovery', by M. Burke and G. Fisher, ACM Transactions on + Programming Langauges and Systems, Vol. 9, No. 2, April 1987, + pp. 164-197. + + This program is an implementation is the partial, deferred method discussed + in the article. The algorithm and data structures used in the program + are described below. + + This program assumes that all semantic actions are delayed. A semantic + action should produce a function from unit -> value instead of producing the + normal value. The parser returns the semantic value on the top of the + stack when accept is encountered. The user can deconstruct this value + and apply the unit -> value function in it to get the answer. + + It also assumes that the lexer is a lazy stream. + + Data Structures: + ---------------- + + * The parser: + + The state stack has the type + + (state * (semantic value * line # * line #)) list + + The parser keeps a queue of (state stack * lexer pair). A lexer pair + consists of a terminal * value pair and a lexer. This allows the + parser to reconstruct the states for terminals to the left of a + syntax error, and attempt to make error corrections there. + + The queue consists of a pair of lists (x,y). New additions to + the queue are cons'ed onto y. The first element of x is the top + of the queue. If x is nil, then y is reversed and used + in place of x. + + Algorithm: + ---------- + + * The steady-state parser: + + This parser keeps the length of the queue of state stacks at + a steady state by always removing an element from the front when + another element is placed on the end. + + It has these arguments: + + stack: current stack + queue: value of the queue + lexPair ((terminal,value),lex stream) + + When SHIFT is encountered, the state to shift to and the value are + are pushed onto the state stack. The state stack and lexPair are + placed on the queue. The front element of the queue is removed. + + When REDUCTION is encountered, the rule is applied to the current + stack to yield a triple (nonterm,value,new stack). A new + stack is formed by adding (goto(top state of stack,nonterm),value) + to the stack. + + When ACCEPT is encountered, the top value from the stack and the + lexer are returned. + + When an ERROR is encountered, fixError is called. FixError + takes the arguments to the parser, fixes the error if possible and + returns a new set of arguments. + + * The distance-parser: + + This parser includes an additional argument distance. It pushes + elements on the queue until it has parsed distance tokens, or an + ACCEPT or ERROR occurs. It returns a stack, lexer, the number of + tokens left unparsed, a queue, and an action option. +*) + +signature FIFO = + sig type 'a queue + val empty : 'a queue + exception Empty + val get : 'a queue -> 'a * 'a queue + val put : 'a * 'a queue -> 'a queue + end + +(* drt (12/15/89) -- the functor should be used in development work, but + it wastes space in the release version. + +functor ParserGen(structure LrTable : LR_TABLE + structure Stream : STREAM) : LR_PARSER = +*) + +structure LrParser :> LR_PARSER = + struct + structure LrTable = LrTable + structure Stream = Stream + + structure Token : TOKEN = + struct + structure LrTable = LrTable + datatype ('a,'b) token = TOKEN of LrTable.term * ('a * 'b * 'b) + val sameToken = fn (TOKEN(t,_),TOKEN(t',_)) => t=t' + end + + open LrTable + open Token + + val DEBUG1 = false + val DEBUG2 = false + exception ParseError + exception ParseImpossible of int + + structure Fifo :> FIFO = + struct + type 'a queue = ('a list * 'a list) + val empty = (nil,nil) + exception Empty + fun get(a::x, y) = (a, (x,y)) + | get(nil, nil) = raise Empty + | get(nil, y) = get(rev y, nil) + fun put(a,(x,y)) = (x,a::y) + end + + type ('a,'b) elem = (state * ('a * 'b * 'b)) + type ('a,'b) stack = ('a,'b) elem list + type ('a,'b) lexv = ('a,'b) token + type ('a,'b) lexpair = ('a,'b) lexv * (('a,'b) lexv Stream.stream) + type ('a,'b) distanceParse = + ('a,'b) lexpair * + ('a,'b) stack * + (('a,'b) stack * ('a,'b) lexpair) Fifo.queue * + int -> + ('a,'b) lexpair * + ('a,'b) stack * + (('a,'b) stack * ('a,'b) lexpair) Fifo.queue * + int * + action option + + type ('a,'b) ecRecord = + {is_keyword : term -> bool, + preferred_change : (term list * term list) list, + error : string * 'b * 'b -> unit, + errtermvalue : term -> 'a, + terms : term list, + showTerminal : term -> string, + noShift : term -> bool} + + local + val print = fn s => TextIO.output(TextIO.stdOut,s) + val println = fn s => (print s; print "\n") + val showState = fn (STATE s) => "STATE " ^ (Int.toString s) + in + fun printStack(stack: ('a,'b) stack, n: int) = + case stack + of (state,_) :: rest => + (print("\t" ^ Int.toString n ^ ": "); + println(showState state); + printStack(rest, n+1)) + | nil => () + + fun prAction showTerminal + (stack as (state,_) :: _, next as (TOKEN (term,_),_), action) = + (println "Parse: state stack:"; + printStack(stack, 0); + print(" state=" + ^ showState state + ^ " next=" + ^ showTerminal term + ^ " action=" + ); + case action + of SHIFT state => println ("SHIFT " ^ (showState state)) + | REDUCE i => println ("REDUCE " ^ (Int.toString i)) + | ERROR => println "ERROR" + | ACCEPT => println "ACCEPT") + | prAction _ (_,_,action) = () + end + + (* ssParse: parser which maintains the queue of (state * lexvalues) in a + steady-state. It takes a table, showTerminal function, saction + function, and fixError function. It parses until an ACCEPT is + encountered, or an exception is raised. When an error is encountered, + fixError is called with the arguments of parseStep (lexv,stack,and + queue). It returns the lexv, and a new stack and queue adjusted so + that the lexv can be parsed *) + + val ssParse = + fn (table,showTerminal,saction,fixError,arg) => + let val prAction = prAction showTerminal + val action = LrTable.action table + val goto = LrTable.goto table + fun parseStep(args as + (lexPair as (TOKEN (terminal, value as (_,leftPos,_)), + lexer + ), + stack as (state,_) :: _, + queue)) = + let val nextAction = action (state,terminal) + val _ = if DEBUG1 then prAction(stack,lexPair,nextAction) + else () + in case nextAction + of SHIFT s => + let val newStack = (s,value) :: stack + val newLexPair = Stream.get lexer + val (_,newQueue) =Fifo.get(Fifo.put((newStack,newLexPair), + queue)) + in parseStep(newLexPair,(s,value)::stack,newQueue) + end + | REDUCE i => + (case saction(i,leftPos,stack,arg) + of (nonterm,value,stack as (state,_) :: _) => + parseStep(lexPair,(goto(state,nonterm),value)::stack, + queue) + | _ => raise (ParseImpossible 197)) + | ERROR => parseStep(fixError args) + | ACCEPT => + (case stack + of (_,(topvalue,_,_)) :: _ => + let val (token,restLexer) = lexPair + in (topvalue,Stream.cons(token,restLexer)) + end + | _ => raise (ParseImpossible 202)) + end + | parseStep _ = raise (ParseImpossible 204) + in parseStep + end + + (* distanceParse: parse until n tokens are shifted, or accept or + error are encountered. Takes a table, showTerminal function, and + semantic action function. Returns a parser which takes a lexPair + (lex result * lexer), a state stack, a queue, and a distance + (must be > 0) to parse. The parser returns a new lex-value, a stack + with the nth token shifted on top, a queue, a distance, and action + option. *) + + val distanceParse = + fn (table,showTerminal,saction,arg) => + let val prAction = prAction showTerminal + val action = LrTable.action table + val goto = LrTable.goto table + fun parseStep(lexPair,stack,queue,0) = (lexPair,stack,queue,0,NONE) + | parseStep(lexPair as (TOKEN (terminal, value as (_,leftPos,_)), + lexer + ), + stack as (state,_) :: _, + queue,distance) = + let val nextAction = action(state,terminal) + val _ = if DEBUG1 then prAction(stack,lexPair,nextAction) + else () + in case nextAction + of SHIFT s => + let val newStack = (s,value) :: stack + val newLexPair = Stream.get lexer + in parseStep(newLexPair,(s,value)::stack, + Fifo.put((newStack,newLexPair),queue),distance-1) + end + | REDUCE i => + (case saction(i,leftPos,stack,arg) + of (nonterm,value,stack as (state,_) :: _) => + parseStep(lexPair,(goto(state,nonterm),value)::stack, + queue,distance) + | _ => raise (ParseImpossible 240)) + | ERROR => (lexPair,stack,queue,distance,SOME nextAction) + | ACCEPT => (lexPair,stack,queue,distance,SOME nextAction) + end + | parseStep _ = raise (ParseImpossible 242) + in parseStep : ('_a,'_b) distanceParse + end + +(* mkFixError: function to create fixError function which adjusts parser state + so that parse may continue in the presence of an error *) + +fun mkFixError({is_keyword,terms,errtermvalue, + preferred_change,noShift, + showTerminal,error,...} : ('_a,'_b) ecRecord, + distanceParse : ('_a,'_b) distanceParse, + minAdvance,maxAdvance) + + (lexv as (TOKEN (term,value as (_,leftPos,_)),_),stack,queue) = + let val _ = if DEBUG2 then + error("syntax error found at " ^ (showTerminal term), + leftPos,leftPos) + else () + + fun tokAt(t,p) = TOKEN(t,(errtermvalue t,p,p)) + + val minDelta = 3 + + (* pull all the state * lexv elements from the queue *) + + val stateList = + let fun f q = let val (elem,newQueue) = Fifo.get q + in elem :: (f newQueue) + end handle Fifo.Empty => nil + in f queue + end + + (* now number elements of stateList, giving distance from + error token *) + + val (_, numStateList) = + List.foldr (fn (a,(num,r)) => (num+1,(a,num)::r)) (0, []) stateList + + (* Represent the set of potential changes as a linked list. + + Values of datatype Change hold information about a potential change. + + oper = oper to be applied + pos = the # of the element in stateList that would be altered. + distance = the number of tokens beyond the error token which the + change allows us to parse. + new = new terminal * value pair at that point + orig = original terminal * value pair at the point being changed. + *) + + datatype ('a,'b) change = CHANGE of + {pos : int, distance : int, leftPos: 'b, rightPos: 'b, + new : ('a,'b) lexv list, orig : ('a,'b) lexv list} + + + val showTerms = concat o map (fn TOKEN(t,_) => " " ^ showTerminal t) + + val printChange = fn c => + let val CHANGE {distance,new,orig,pos,...} = c + in (print ("{distance= " ^ (Int.toString distance)); + print (",orig ="); print(showTerms orig); + print (",new ="); print(showTerms new); + print (",pos= " ^ (Int.toString pos)); + print "}\n") + end + + val printChangeList = app printChange + +(* parse: given a lexPair, a stack, and the distance from the error + token, return the distance past the error token that we are able to parse.*) + + fun parse (lexPair,stack,queuePos : int) = + case distanceParse(lexPair,stack,Fifo.empty,queuePos+maxAdvance+1) + of (_,_,_,distance,SOME ACCEPT) => + if maxAdvance-distance-1 >= 0 + then maxAdvance + else maxAdvance-distance-1 + | (_,_,_,distance,_) => maxAdvance - distance - 1 + +(* catList: concatenate results of scanning list *) + + fun catList l f = List.foldr (fn(a,r)=> f a @ r) [] l + + fun keywordsDelta new = if List.exists (fn(TOKEN(t,_))=>is_keyword t) new + then minDelta else 0 + + fun tryChange{lex,stack,pos,leftPos,rightPos,orig,new} = + let val lex' = List.foldr (fn (t',p)=>(t',Stream.cons p)) lex new + val distance = parse(lex',stack,pos+length new-length orig) + in if distance >= minAdvance + keywordsDelta new + then [CHANGE{pos=pos,leftPos=leftPos,rightPos=rightPos, + distance=distance,orig=orig,new=new}] + else [] + end + + +(* tryDelete: Try to delete n terminals. + Return single-element [success] or nil. + Do not delete unshiftable terminals. *) + + + fun tryDelete n ((stack,lexPair as (TOKEN(term,(_,l,r)),_)),qPos) = + let fun del(0,accum,left,right,lexPair) = + tryChange{lex=lexPair,stack=stack, + pos=qPos,leftPos=left,rightPos=right, + orig=rev accum, new=[]} + | del(n,accum,left,right,(tok as TOKEN(term,(_,_,r)),lexer)) = + if noShift term then [] + else del(n-1,tok::accum,left,r,Stream.get lexer) + in del(n,[],l,r,lexPair) + end + +(* tryInsert: try to insert tokens before the current terminal; + return a list of the successes *) + + fun tryInsert((stack,lexPair as (TOKEN(_,(_,l,_)),_)),queuePos) = + catList terms (fn t => + tryChange{lex=lexPair,stack=stack, + pos=queuePos,orig=[],new=[tokAt(t,l)], + leftPos=l,rightPos=l}) + +(* trySubst: try to substitute tokens for the current terminal; + return a list of the successes *) + + fun trySubst ((stack,lexPair as (orig as TOKEN (term,(_,l,r)),lexer)), + queuePos) = + if noShift term then [] + else + catList terms (fn t => + tryChange{lex=Stream.get lexer,stack=stack, + pos=queuePos, + leftPos=l,rightPos=r,orig=[orig], + new=[tokAt(t,r)]}) + + (* do_delete(toks,lexPair) tries to delete tokens "toks" from "lexPair". + If it succeeds, returns SOME(toks',l,r,lp), where + toks' is the actual tokens (with positions and values) deleted, + (l,r) are the (leftmost,rightmost) position of toks', + lp is what remains of the stream after deletion + *) + fun do_delete(nil,lp as (TOKEN(_,(_,l,_)),_)) = SOME(nil,l,l,lp) + | do_delete([t],(tok as TOKEN(t',(_,l,r)),lp')) = + if t=t' + then SOME([tok],l,r,Stream.get lp') + else NONE + | do_delete(t::rest,(tok as TOKEN(t',(_,l,r)),lp')) = + if t=t' + then case do_delete(rest,Stream.get lp') + of SOME(deleted,l',r',lp'') => + SOME(tok::deleted,l,r',lp'') + | NONE => NONE + else NONE + + fun tryPreferred((stack,lexPair),queuePos) = + catList preferred_change (fn (delete,insert) => + if List.exists noShift delete then [] (* should give warning at + parser-generation time *) + else case do_delete(delete,lexPair) + of SOME(deleted,l,r,lp) => + tryChange{lex=lp,stack=stack,pos=queuePos, + leftPos=l,rightPos=r,orig=deleted, + new=map (fn t=>(tokAt(t,r))) insert} + | NONE => []) + + val changes = catList numStateList tryPreferred @ + catList numStateList tryInsert @ + catList numStateList trySubst @ + catList numStateList (tryDelete 1) @ + catList numStateList (tryDelete 2) @ + catList numStateList (tryDelete 3) + + val findMaxDist = fn l => + foldr (fn (CHANGE {distance,...},high) => Int.max(distance,high)) 0 l + +(* maxDist: max distance past error taken that we could parse *) + + val maxDist = findMaxDist changes + +(* remove changes which did not parse maxDist tokens past the error token *) + + val changes = catList changes + (fn(c as CHANGE{distance,...}) => + if distance=maxDist then [c] else []) + + in case changes + of (l as change :: _) => + let fun print_msg (CHANGE {new,orig,leftPos,rightPos,...}) = + let val s = + case (orig,new) + of (_::_,[]) => "deleting " ^ (showTerms orig) + | ([],_::_) => "inserting " ^ (showTerms new) + | _ => "replacing " ^ (showTerms orig) ^ + " with " ^ (showTerms new) + in error ("syntax error: " ^ s,leftPos,rightPos) + end + + val _ = + (if length l > 1 andalso DEBUG2 then + (print "multiple fixes possible; could fix it by:\n"; + app print_msg l; + print "chosen correction:\n") + else (); + print_msg change) + + (* findNth: find nth queue entry from the error + entry. Returns the Nth queue entry and the portion of + the queue from the beginning to the nth-1 entry. The + error entry is at the end of the queue. + + Examples: + + queue = a b c d e + findNth 0 = (e,a b c d) + findNth 1 = (d,a b c) + *) + + val findNth = fn n => + let fun f (h::t,0) = (h,rev t) + | f (h::t,n) = f(t,n-1) + | f (nil,_) = let exception FindNth + in raise FindNth + end + in f (rev stateList,n) + end + + val CHANGE {pos,orig,new,...} = change + val (last,queueFront) = findNth pos + val (stack,lexPair) = last + + val lp1 = foldl(fn (_,(_,r)) => Stream.get r) lexPair orig + val lp2 = foldr(fn(t,r)=>(t,Stream.cons r)) lp1 new + + val restQueue = + Fifo.put((stack,lp2), + foldl Fifo.put Fifo.empty queueFront) + + val (lexPair,stack,queue,_,_) = + distanceParse(lp2,stack,restQueue,pos) + + in (lexPair,stack,queue) + end + | nil => (error("syntax error found at " ^ (showTerminal term), + leftPos,leftPos); raise ParseError) + end + + val parse = fn {arg,table,lexer,saction,void,lookahead, + ec=ec as {showTerminal,...} : ('_a,'_b) ecRecord} => + let val distance = 15 (* defer distance tokens *) + val minAdvance = 1 (* must parse at least 1 token past error *) + val maxAdvance = Int.max(lookahead,0)(* max distance for parse check *) + val lexPair = Stream.get lexer + val (TOKEN (_,(_,leftPos,_)),_) = lexPair + val startStack = [(initialState table,(void,leftPos,leftPos))] + val startQueue = Fifo.put((startStack,lexPair),Fifo.empty) + val distanceParse = distanceParse(table,showTerminal,saction,arg) + val fixError = mkFixError(ec,distanceParse,minAdvance,maxAdvance) + val ssParse = ssParse(table,showTerminal,saction,fixError,arg) + fun loop (lexPair,stack,queue,_,SOME ACCEPT) = + ssParse(lexPair,stack,queue) + | loop (lexPair,stack,queue,0,_) = ssParse(lexPair,stack,queue) + | loop (lexPair,stack,queue,distance,SOME ERROR) = + let val (lexPair,stack,queue) = fixError(lexPair,stack,queue) + in loop (distanceParse(lexPair,stack,queue,distance)) + end + | loop _ = let exception ParseInternal + in raise ParseInternal + end + in loop (distanceParse(lexPair,startStack,startQueue,distance)) + end + end; + +(* stop of ml-yacc/lib/parser2.sml *) +(* start of DERIVED_FORMS_CORE.sml *) +(* + * Standard ML core derived forms + * + * Definition, Section 2.7 and appendix A + * + * Note: + * Two phrases named Fmatch and Fmrule have been added to factorize FvalBind. + *) + + +signature DERIVED_FORMS_CORE = + sig + + (* Import *) + + type Info = GrammarCore.Info + + type Lab = GrammarCore.Lab + type VId = GrammarCore.VId + + type Op = GrammarCore.Op + type AtExp = GrammarCore.AtExp + type AppExp = GrammarCore.AtExp list + type InfExp = GrammarCore.Exp + type Exp = GrammarCore.Exp + type Match = GrammarCore.Match + type Mrule = GrammarCore.Mrule + type Dec = GrammarCore.Dec + type ValBind = GrammarCore.ValBind + type FvalBind = GrammarCore.ValBind + type Fmatch = GrammarCore.Match * VId * int + type Fmrule = GrammarCore.Mrule * VId * int + type TypBind = GrammarCore.TypBind + type DatBind = GrammarCore.DatBind + type AtPat = GrammarCore.AtPat + type PatRow = GrammarCore.PatRow + type Pat = GrammarCore.Pat + type Ty = GrammarCore.Ty + type TyVarseq = GrammarCore.TyVarseq + + + (* Expressions [Figure 15] *) + + val UNITAtExp: Info -> AtExp + val TUPLEAtExp: Info * Exp list -> AtExp + val HASHAtExp: Info * Lab -> AtExp + val CASEExp: Info * Exp * Match -> Exp + val IFExp: Info * Exp * Exp * Exp -> Exp + val ANDALSOExp: Info * Exp * Exp -> Exp + val ORELSEExp: Info * Exp * Exp -> Exp + val SEQAtExp: Info * Exp list -> AtExp + val LETAtExp: Info * Dec * Exp list -> AtExp + val WHILEExp: Info * Exp * Exp -> Exp + val LISTAtExp: Info * Exp list -> AtExp + + (* Patterns [Figure 16] *) + + val UNITAtPat: Info -> AtPat + val TUPLEAtPat: Info * Pat list -> AtPat + val LISTAtPat: Info * Pat list -> AtPat + + val VIDPatRow: Info * VId * Ty option * Pat option * PatRow option + -> PatRow + (* Types [Figure 16] *) + + val TUPLETy: Info * Ty list -> Ty + + (* Function-value bindings [Figure 17] *) + + val FvalBind: Info * Fmatch * FvalBind option -> FvalBind + val Fmatch: Info * Fmrule * Fmatch option -> Fmatch + val Fmrule: Info * Op * VId * AtPat list * Ty option * Exp -> Fmrule + + (* Declarations [Figure 17] *) + + val FUNDec: Info * TyVarseq * FvalBind -> Dec + val DATATYPEDec: Info * DatBind * TypBind option -> Dec + val ABSTYPEDec: Info * DatBind * TypBind option * Dec -> Dec + + end +(* stop of DERIVED_FORMS_CORE.sml *) +(* start of DerivedFormsCore.sml *) +(* + * Standard ML core derived forms + * + * Definition, Section 2.7 and appendix A + * + * Notes: + * - Two phrases named Fmatch and Fmrule have been added to factorize FvalBind. + * - In Fvalbinds we do not enforce that all optional type annotations are + * syntactically identical (as the Definition enforces, although this seems + * to be a mistake). + * - The Definition is somewhat inaccurate about the derived forms of Exp + * [Definition, Appendix A, Figure 15] in that most forms are actually AtExp + * derived forms, as can be seen from the full grammar [Definition, + * Appendix B, Figure 20]. To achieve consistency, the equivalent forms must + * be put in parentheses in some cases. + * - The same goes for pattern derived forms [Definition, Appendix A, Figure 16; + * Appendix B, Figure 22]. + *) + + +structure DerivedFormsCore :> DERIVED_FORMS_CORE = + struct + + (* Import *) + + structure C = GrammarCore + + type Info = C.Info + + type Lab = C.Lab + type VId = C.VId + + type Op = C.Op + type AtExp = C.AtExp + type AppExp = C.AtExp list + type InfExp = C.Exp + type Exp = C.Exp + type Match = C.Match + type Mrule = C.Mrule + type Dec = C.Dec + type ValBind = C.ValBind + type FvalBind = C.ValBind + type Fmatch = C.Match * C.VId * int + type Fmrule = C.Mrule * C.VId * int + type TypBind = C.TypBind + type DatBind = C.DatBind + type AtPat = C.AtPat + type PatRow = C.PatRow + type Pat = C.Pat + type Ty = C.Ty + type TyVarseq = C.TyVarseq + + + (* Some helpers *) + + val vidFALSE = VId.fromString "false" + val vidTRUE = VId.fromString "true" + val vidNIL = VId.fromString "nil" + val vidCONS = VId.fromString "::" + + val longvidCONS = LongVId.fromId vidCONS + + + fun LONGVIDExp(I, longvid) = C.ATEXPExp(I, C.LONGVIDAtExp(I, C.SANSOp, + longvid)) + fun LONGVIDPat(I, longvid) = C.ATPATPat(I, C.LONGVIDAtPat(I, C.SANSOp, + longvid)) + + fun VIDExp(I, vid) = LONGVIDExp(I, LongVId.fromId vid) + fun VIDPat(I, vid) = LONGVIDPat(I, LongVId.fromId vid) + + fun FALSEExp(I) = VIDExp(I, vidFALSE) + fun TRUEExp(I) = VIDExp(I, vidTRUE) + fun NILExp(I) = VIDExp(I, vidNIL) + fun CONSExp(I) = VIDExp(I, vidCONS) + + fun FALSEPat(I) = VIDPat(I, vidFALSE) + fun TRUEPat(I) = VIDPat(I, vidTRUE) + fun NILPat(I) = VIDPat(I, vidNIL) + + + (* Rewriting of withtype declarations [Appendix A, 2nd bullet] *) + + fun lookupTyCon(tycon, C.TypBind(_, tyvarseq, tycon', ty, typbind_opt)) = + if tycon' = tycon then + (tyvarseq, ty) + else + lookupTyCon(tycon, Option.valOf typbind_opt) + (* may raise Option *) + + + fun replaceTy (C.TyVarseq(_,tyvars), C.Tyseq(i',tys)) (C.TYVARTy(i,tyvar)) = + let + fun loop(tyvar'::tyvars', ty'::tys') = + if tyvar' = tyvar then + ty' + else + loop(tyvars', tys') + | loop([],_) = + Error.error(i, "unbound type variable") + | loop(_,[]) = + Error.error(i', "type sequence has wrong arity") + in + loop(tyvars, tys) + end + + | replaceTy tyvarseq_tyseq (C.RECORDTy(I, tyrow_opt)) = + C.RECORDTy(I, Option.map (replaceTyRow tyvarseq_tyseq) tyrow_opt) + + | replaceTy tyvarseq_tyseq (C.TYCONTy(I, tyseq', tycon)) = + C.TYCONTy(I, replaceTyseq tyvarseq_tyseq tyseq', tycon) + + | replaceTy tyvarseq_tyseq (C.ARROWTy(I, ty1, ty2)) = + C.ARROWTy(I, replaceTy tyvarseq_tyseq ty1, + replaceTy tyvarseq_tyseq ty2) + + | replaceTy tyvarseq_tyseq (C.PARTy(I, ty)) = + C.PARTy(I, replaceTy tyvarseq_tyseq ty) + + and replaceTyRow tyvarseq_tyseq (C.TyRow(I, lab, ty, tyrow_opt)) = + C.TyRow(I, lab, replaceTy tyvarseq_tyseq ty, + Option.map (replaceTyRow tyvarseq_tyseq) tyrow_opt) + + and replaceTyseq tyvarseq_tyseq (C.Tyseq(I, tys)) = + C.Tyseq(I, List.map (replaceTy tyvarseq_tyseq) tys) + + + fun rewriteTy typbind (ty as C.TYVARTy _) = ty + + | rewriteTy typbind (C.RECORDTy(I, tyrow_opt)) = + C.RECORDTy(I, Option.map (rewriteTyRow typbind) tyrow_opt) + + | rewriteTy typbind (C.TYCONTy(I, tyseq, longtycon)) = + let + val tyseq' = rewriteTyseq typbind tyseq + val (strids, tycon) = LongTyCon.explode longtycon + in + if not(List.null strids) then + C.TYCONTy(I, tyseq', longtycon) + else + let + val (tyvarseq', ty') = lookupTyCon(tycon, typbind) + in + replaceTy (tyvarseq',tyseq') ty' + end + handle Option => C.TYCONTy(I, tyseq', longtycon) + end + + | rewriteTy typbind (C.ARROWTy(I, ty1, ty2)) = + C.ARROWTy(I, rewriteTy typbind ty1, rewriteTy typbind ty2) + + | rewriteTy typbind (C.PARTy(I, ty)) = + C.PARTy(I, rewriteTy typbind ty) + + and rewriteTyRow typbind (C.TyRow(I, lab, ty, tyrow_opt)) = + C.TyRow(I, lab, rewriteTy typbind ty, + Option.map (rewriteTyRow typbind) tyrow_opt) + + and rewriteTyseq typbind (C.Tyseq(I, tys)) = + C.Tyseq(I, List.map (rewriteTy typbind) tys) + + fun rewriteConBind typbind (C.ConBind(I, op_opt, vid, ty_opt, conbind_opt))= + C.ConBind(I, op_opt, vid, + Option.map (rewriteTy typbind) ty_opt, + Option.map (rewriteConBind typbind) conbind_opt) + + fun rewriteDatBind typbind (C.DatBind(I, tyvarseq, tycon, conbind, + datbind_opt)) = + C.DatBind(I, tyvarseq, tycon, rewriteConBind typbind conbind, + Option.map (rewriteDatBind typbind) datbind_opt) + + + (* Patterns [Figure 16] *) + + fun UNITAtPat(I) = C.RECORDAtPat(I, NONE) + + fun TUPLEAtPat(I, [pat]) = C.PARAtPat(I, pat) + | TUPLEAtPat(I, pats) = + let + fun toPatRow(n, [] ) = NONE + | toPatRow(n, pat::pats') = + SOME(C.ROWPatRow(I, Lab.fromInt n, pat, toPatRow(n+1,pats'))) + in + C.RECORDAtPat(I, toPatRow(1, pats)) + end + + fun LISTAtPat(I, pats) = + let + fun toPatList [] = NILPat(I) + | toPatList(pat::pats') = + C.CONPat(I, C.SANSOp, longvidCONS, + TUPLEAtPat(I, [pat,toPatList pats'])) + in + C.PARAtPat(I, toPatList pats) + end + + + (* Pattern Rows [Figure 16] *) + + fun VIDPatRow(I, vid, ty_opt, pat_opt, patrow_opt) = + let + val lab = Lab.fromString(VId.toString vid) + val vidPat = VIDPat(I, vid) + val pat = + case (ty_opt, pat_opt) + of (NONE, NONE) => vidPat + | (SOME ty, NONE) => C.TYPEDPat(I, vidPat, ty) + | ( _ , SOME pat) => C.ASPat(I, C.SANSOp,vid,ty_opt,pat) + in + C.ROWPatRow(I, lab, pat, patrow_opt) + end + + + (* Expressions [Figure 15] *) + + fun UNITAtExp(I) = C.RECORDAtExp(I, NONE) + + fun TUPLEAtExp(I, [exp]) = C.PARAtExp(I, exp) + | TUPLEAtExp(I, exps) = + let + fun toExpRow(n, [] ) = NONE + | toExpRow(n, exp::exps') = + SOME(C.ExpRow(I, Lab.fromInt n, exp, toExpRow(n+1, exps'))) + in + C.RECORDAtExp(I, toExpRow(1, exps)) + end + + fun HASHAtExp(I, lab) = + let + val vid = VId.invent() + val dots = C.WILDCARDPatRow(I) + val patrow = C.ROWPatRow(I, lab, VIDPat(I, vid), SOME dots) + val pat = C.ATPATPat(I, C.RECORDAtPat(I, SOME patrow)) + val mrule = C.Mrule(I, pat, VIDExp(I, vid)) + val match = C.Match(I, mrule, NONE) + in + C.PARAtExp(I, C.FNExp(I, match)) + end + + fun CASEExp(I, exp, match) = + let + val function = C.ATEXPExp(I, C.PARAtExp(I, C.FNExp(I, match))) + in + C.APPExp(I, function, C.PARAtExp(I, exp)) + end + + fun IFExp(I, exp1, exp2, exp3) = + let + val mruleTrue = C.Mrule(I, TRUEPat(I), exp2) + val mruleFalse = C.Mrule(I, FALSEPat(I), exp3) + val matchFalse = C.Match(I, mruleFalse, NONE) + val matchTrue = C.Match(I, mruleTrue, SOME matchFalse) + in + CASEExp(I, exp1, matchTrue) + end + + fun ORELSEExp (I, exp1, exp2) = IFExp(I, exp1, TRUEExp(I), exp2) + + fun ANDALSOExp(I, exp1, exp2) = IFExp(I, exp1, exp2, FALSEExp(I)) + + fun SEQAtExp(I, exps) = + let + val wildcard = C.ATPATPat(I, C.WILDCARDAtPat(I)) + + fun toExpSeq [] = raise Fail "DerivedFormsCore.SEQAtExp: \ + \empty exp list" + | toExpSeq [exp] = exp + | toExpSeq(exp::exps') = + let + val mrule = C.Mrule(I, wildcard, toExpSeq exps') + val match = C.Match(I, mrule, NONE) + in + CASEExp(I, exp, match) + end + in + C.PARAtExp(I, toExpSeq exps) + end + + fun LETAtExp(I, dec, [exp]) = C.LETAtExp(I, dec, exp) + | LETAtExp(I, dec, exps) = + C.LETAtExp(I, dec, C.ATEXPExp(I, SEQAtExp(I, exps))) + + fun WHILEExp(I, exp1, exp2) = + let + val vid = VId.invent() + val vidExp = VIDExp(I, vid) + val unitAtExp = UNITAtExp(I) + val unitExp = C.ATEXPExp(I, unitAtExp) + val callVid = C.APPExp(I, vidExp, unitAtExp) + + val seqExp = C.ATEXPExp(I, SEQAtExp(I, [exp2, callVid])) + val fnBody = IFExp(I, exp1, seqExp, unitExp) + val mrule = C.Mrule(I, C.ATPATPat(I, UNITAtPat(I)), fnBody) + val match = C.Match(I, mrule, NONE) + val fnExp = C.FNExp(I, match) + val fnBind = C.PLAINValBind(I, VIDPat(I, vid), fnExp, NONE) + val valbind = C.RECValBind(I, fnBind) + val dec = C.VALDec(I, C.TyVarseq(I, []), valbind) + in + C.ATEXPExp(I, C.LETAtExp(I, dec, callVid)) + end + + fun LISTAtExp(I, exps) = + let + fun toExpList [] = NILExp(I) + | toExpList(exp::exps') = + C.APPExp(I, CONSExp(I), TUPLEAtExp(I, [exp, toExpList exps'])) + in + C.PARAtExp(I, toExpList exps) + end + + + (* Type Expressions [Figure 16] *) + + fun TUPLETy(I, [ty]) = ty + | TUPLETy(I, tys) = + let + fun toTyRow(n, [] ) = NONE + | toTyRow(n, ty::tys') = + SOME(C.TyRow(I, Lab.fromInt n, ty, toTyRow(n+1, tys'))) + in + C.RECORDTy(I, toTyRow(1, tys)) + end + + + (* Function-value Bindings [Figure 17] *) + + fun FvalBind(I, (match, vid, arity), fvalbind_opt) = + let + fun abstract(0, vidExps) = + let + val exp = C.ATEXPExp(I, TUPLEAtExp(I, List.rev vidExps)) + in + CASEExp(I, exp, match) + end + + | abstract(n, vidExps) = + let + val vid = VId.invent() + val exp = VIDExp(I, vid) + val pat = VIDPat(I, vid) + val mrule = C.Mrule(I, pat, abstract(n-1, exp::vidExps)) + in + C.FNExp(I, C.Match(I, mrule, NONE)) + end + + val exp = abstract(arity, []) + val pat = VIDPat(I, vid) + in + C.PLAINValBind(I, pat, exp, fvalbind_opt) + end + + + fun Fmatch(I, (mrule, vid, arity), NONE) = + ( C.Match(I, mrule, NONE), vid, arity ) + + | Fmatch(I, (mrule, vid, arity), SOME(match, vid', arity')) = + if vid <> vid' then + Error.error(I, "inconsistent function identifier") + else if arity <> arity' then + Error.error(I, "inconsistent function arity") + else + ( C.Match(I, mrule, SOME match), vid, arity ) + + + fun Fmrule(I, _, vid, atpats, ty_opt, exp) = + let + val pats = List.map (fn atpat => C.ATPATPat(I, atpat)) atpats + val pat' = C.ATPATPat(I, TUPLEAtPat(I, pats)) + val exp' = case ty_opt + of NONE => exp + | SOME ty => C.TYPEDExp(I, exp, ty) + val arity = List.length atpats + in + ( C.Mrule(I, pat', exp'), vid, arity ) + end + + + (* Declarations [Figure 17] *) + + fun FUNDec(I, tyvarseq, fvalbind) = + C.VALDec(I, tyvarseq, C.RECValBind(I, fvalbind)) + + fun DATATYPEDec(I, datbind, NONE) = C.DATATYPEDec(I, datbind) + | DATATYPEDec(I, datbind, SOME typbind) = + let + val datbind' = rewriteDatBind typbind datbind + in + C.SEQDec(I, C.DATATYPEDec(C.infoDatBind datbind, datbind'), + C.TYPEDec(C.infoTypBind typbind, typbind)) + end + + fun ABSTYPEDec(I, datbind, NONE, dec) = C.ABSTYPEDec(I, datbind,dec) + | ABSTYPEDec(I, datbind, SOME typbind, dec) = + let + val I' = C.infoTypBind typbind + val datbind' = rewriteDatBind typbind datbind + in + C.ABSTYPEDec(I, datbind', C.SEQDec(I, C.TYPEDec(I', typbind), dec)) + end + + end +(* stop of DerivedFormsCore.sml *) +(* start of DERIVED_FORMS_MODULE.sml *) +(* + * Standard ML modules derived forms + * + * Definition, Appendix A + * + * Notes: + * - A phrase named SynDesc has been added to factorize type synonym + * specifications. + * - Similarly, a phrase named TyReaDesc has been added to factorize type + * realisation signature expressions. + * - The structure sharing derived form is missing since it cannot be resolved + * syntactically. It has been moved to the bare grammar. + *) + + +signature DERIVED_FORMS_MODULE = + sig + + (* Import *) + + type Info = GrammarModule.Info + + type VId = GrammarCore.VId + type TyCon = GrammarCore.TyCon + type StrId = GrammarCore.StrId + type SigId = GrammarModule.SigId + type FunId = GrammarModule.FunId + type longTyCon = GrammarCore.longTyCon + + type Ty = GrammarCore.Ty + type TyVarseq = GrammarCore.TyVarseq + + type StrExp = GrammarModule.StrExp + type StrDec = GrammarModule.StrDec + type StrBind = GrammarModule.StrBind + type SigExp = GrammarModule.SigExp + type TyReaDesc = (Info * TyVarseq * longTyCon * Ty) list + type Spec = GrammarModule.Spec + type SynDesc = (Info * TyVarseq * TyCon * Ty) list + type FunBind = GrammarModule.FunBind + + + (* Structure Bindings [Figure 18] *) + + val TRANSStrBind: Info * StrId * SigExp option * StrExp + * StrBind option -> StrBind + val OPAQStrBind: Info * StrId * SigExp * StrExp + * StrBind option -> StrBind + + (* Structure Expressions [Figure 18] *) + + val APPDECStrExp: Info * FunId * StrDec -> StrExp + + (* Functor Bindings [Figure 18] *) + + val TRANSFunBind: Info * FunId * StrId * SigExp * SigExp option + * StrExp * FunBind option -> FunBind + val OPAQFunBind: Info * FunId * StrId * SigExp * SigExp + * StrExp * FunBind option -> FunBind + val TRANSSPECFunBind: Info * FunId * Spec * SigExp option + * StrExp * FunBind option -> FunBind + val OPAQSPECFunBind: Info * FunId * Spec * SigExp + * StrExp * FunBind option -> FunBind + + (* Specifications [Figure 19] *) + + val SYNSpec: Info * SynDesc -> Spec + val INCLUDEMULTISpec: Info * SigId list -> Spec + + val SynDesc: Info * TyVarseq * TyCon * Ty + * SynDesc option -> SynDesc + + (* Signature Expressions [Figure 19] *) + + val WHERETYPESigExp: Info * SigExp * TyReaDesc -> SigExp + + val TyReaDesc: Info * TyVarseq * longTyCon * Ty + * TyReaDesc option -> TyReaDesc + end +(* stop of DERIVED_FORMS_MODULE.sml *) +(* start of DerivedFormsModule.sml *) +(* + * Standard ML modules derived forms + * + * Definition, Appendix A + * + * Notes: + * - A phrase named SynDesc has been added to factorize type synonym + * specifications. + * - Similarly, a phrase named TyReaDesc has been added to factorize type + * realisation signature expressions. + * - The structure sharing derived form is missing since it cannot be resolved + * syntactically. It has been moved to the bare grammar. + *) + + +structure DerivedFormsModule :> DERIVED_FORMS_MODULE = + struct + + (* Import *) + + structure C = GrammarCore + structure M = GrammarModule + + type Info = M.Info + + type VId = M.VId + type TyCon = M.TyCon + type StrId = M.StrId + type SigId = M.SigId + type FunId = M.FunId + type longTyCon = M.longTyCon + + type Ty = M.Ty + type TyVarseq = M.TyVarseq + + type StrExp = M.StrExp + type StrDec = M.StrDec + type StrBind = M.StrBind + type SigExp = M.SigExp + type TyReaDesc = (M.Info * M.TyVarseq * M.longTyCon * M.Ty) list + type Spec = M.Spec + type SynDesc = (M.Info * M.TyVarseq * M.TyCon * M.Ty) list + type FunBind = M.FunBind + + + (* Structure Bindings [Figure 18] *) + + fun TRANSStrBind(I, strid, NONE, strexp, strbind_opt) = + M.StrBind(I, strid, strexp, strbind_opt) + + | TRANSStrBind(I, strid, SOME sigexp, strexp, strbind_opt) = + M.StrBind(I, strid, M.TRANSStrExp(I, strexp, sigexp), strbind_opt) + + fun OPAQStrBind(I, strid, sigexp, strexp, strbind_opt) = + M.StrBind(I, strid, M.OPAQStrExp(I, strexp, sigexp), strbind_opt) + + + (* Structure Expressions [Figure 18] *) + + fun APPDECStrExp(I, funid, strdec) = + M.APPStrExp(I, funid, M.STRUCTStrExp(M.infoStrDec strdec, strdec)) + + + (* Functor Bindings [Figure 18] *) + + fun TRANSFunBind(I, funid, strid, sigexp, NONE, strexp, funbind_opt) = + M.FunBind(I, funid, strid, sigexp, strexp, funbind_opt) + + | TRANSFunBind(I, funid, strid,sigexp, SOME sigexp', strexp, funbind_opt)= + M.FunBind(I, funid, strid, sigexp, M.TRANSStrExp(I, strexp,sigexp'), + funbind_opt) + + fun OPAQFunBind(I, funid, strid, sigexp, sigexp', strexp, funbind_opt) = + M.FunBind(I, funid, strid, sigexp, M.OPAQStrExp(I, strexp, sigexp'), + funbind_opt) + + + fun TRANSSPECFunBind(I, funid, spec, sigexp_opt, strexp, funbind_opt) = + let + val I' = M.infoStrExp strexp + val strid = StrId.invent() + val sigexp = M.SIGSigExp(M.infoSpec spec, spec) + + val strdec = M.DECStrDec(I', C.OPENDec(I',[LongStrId.fromId strid])) + val strexp'= case sigexp_opt + of NONE => strexp + | SOME sigexp' => M.TRANSStrExp(I', strexp, sigexp') + val letexp = M.LETStrExp(I', strdec, strexp') + in + M.FunBind(I, funid, strid, sigexp, letexp, funbind_opt) + end + + fun OPAQSPECFunBind(I, funid, spec, sigexp', strexp, funbind_opt) = + let + val I' = M.infoStrExp strexp + val strid = StrId.invent() + val sigexp = M.SIGSigExp(M.infoSpec spec, spec) + + val strdec = M.DECStrDec(I', C.OPENDec(I',[LongStrId.fromId strid])) + val strexp'= M.TRANSStrExp(I', strexp, sigexp') + val letexp = M.LETStrExp(I', strdec, strexp') + in + M.FunBind(I, funid, strid, sigexp, letexp, funbind_opt) + end + + + (* Specifications [Figure 19] *) + + fun SYNSpec(I, []) = M.EMPTYSpec(I) + | SYNSpec(I, (I',tyvarseq,tycon,ty)::syns') = + let + val longtycon = LongTyCon.fromId tycon + val typdesc = M.TypDesc(I', tyvarseq, tycon, NONE) + val sigexp = M.SIGSigExp(I', M.TYPESpec(I', typdesc)) + val sigexp' = M.WHERETYPESigExp(I', sigexp, tyvarseq, longtycon, ty) + val spec1 = M.INCLUDESpec(I', sigexp') + in + M.SEQSpec(I, spec1, SYNSpec(I, syns')) + end + + fun INCLUDEMULTISpec(I, [] ) = M.EMPTYSpec(I) + | INCLUDEMULTISpec(I, sigid::sigids') = + let + val spec1 = M.INCLUDESpec(I, M.SIGIDSigExp(I, sigid)) + in + M.SEQSpec(I, spec1, INCLUDEMULTISpec(I, sigids')) + end + + + fun SynDesc(I, tyvarseq, tycon, ty, NONE) = + (I, tyvarseq, tycon, ty) :: [] + + | SynDesc(I, tyvarseq, tycon, ty, SOME syndesc) = + (I, tyvarseq, tycon, ty) :: syndesc + + + (* Signature Expressions [Figure 19] *) + + fun WHERETYPESigExp(I, sigexp, [] ) = sigexp + | WHERETYPESigExp(I, sigexp, (I',tyvarseq,longtycon,ty)::reas') = + let + val sigexp' = M.WHERETYPESigExp(I', sigexp, tyvarseq, longtycon, ty) + in + WHERETYPESigExp(I, sigexp', reas') + end + + + fun TyReaDesc(I, tyvarseq, longtycon, ty, NONE) = + (I, tyvarseq, longtycon, ty) :: [] + + | TyReaDesc(I, tyvarseq, longtycon, ty, SOME tyreadesc) = + (I, tyvarseq, longtycon, ty) :: tyreadesc + + end +(* stop of DerivedFormsModule.sml *) +(* start of DERIVED_FORMS_PROGRAM.sml *) +(* + * Standard ML program derived forms + * + * Definition, Appendix A + *) + + +signature DERIVED_FORMS_PROGRAM = + sig + + (* Import *) + + type Info = GrammarProgram.Info + + type Exp = GrammarCore.Exp + type TopDec = GrammarModule.TopDec + type Program = GrammarProgram.Program + + + (* Programs [Figure 18] *) + + val TOPDECProgram: Info * TopDec * Program option -> Program + val EXPProgram: Info * Exp * Program option -> Program + + end +(* stop of DERIVED_FORMS_PROGRAM.sml *) +(* start of DerivedFormsProgram.sml *) +(* + * Standard ML program derived forms + * + * Definition, Appendix A + *) + + +structure DerivedFormsProgram :> DERIVED_FORMS_PROGRAM = + struct + + (* Import *) + + structure C = GrammarCore + structure M = GrammarModule + structure P = GrammarProgram + + type Info = GrammarProgram.Info + + type Exp = GrammarCore.Exp + type TopDec = GrammarModule.TopDec + type Program = GrammarProgram.Program + + + (* Programs [Figure 18] *) + + fun TOPDECProgram(I, topdec, program_opt) = + P.Program(I, topdec, program_opt) + + fun EXPProgram(I, exp, program_opt) = + let + val longvid = LongVId.fromId(VId.fromString "it") + val pat = C.ATPATPat(I, C.LONGVIDAtPat(I, C.SANSOp, longvid)) + val valbind = C.PLAINValBind(I, pat, exp, NONE) + val dec = C.VALDec(I, C.TyVarseq(I, []), valbind) + val topdec = M.STRDECTopDec(I, M.DECStrDec(I, dec), NONE) + in + P.Program(I, topdec, program_opt) + end + + end +(* stop of DerivedFormsProgram.sml *) +(* start of Parser.grm.sig *) +signature Parser_TOKENS = +sig +type ('a,'b) token +type svalue +val LONGID: (string list*string) * 'a * 'a -> (svalue,'a) token +val ETYVAR: (string) * 'a * 'a -> (svalue,'a) token +val TYVAR: (string) * 'a * 'a -> (svalue,'a) token +val STAR: 'a * 'a -> (svalue,'a) token +val SYMBOL: (string) * 'a * 'a -> (svalue,'a) token +val ALPHA: (string) * 'a * 'a -> (svalue,'a) token +val CHAR: (char) * 'a * 'a -> (svalue,'a) token +val STRING: (string) * 'a * 'a -> (svalue,'a) token +val REAL: (real) * 'a * 'a -> (svalue,'a) token +val WORD: (word) * 'a * 'a -> (svalue,'a) token +val INT: (int) * 'a * 'a -> (svalue,'a) token +val NUMERIC: (int) * 'a * 'a -> (svalue,'a) token +val DIGIT: (int) * 'a * 'a -> (svalue,'a) token +val ZERO: 'a * 'a -> (svalue,'a) token +val COLONGREATER: 'a * 'a -> (svalue,'a) token +val WHERE: 'a * 'a -> (svalue,'a) token +val STRUCTURE: 'a * 'a -> (svalue,'a) token +val STRUCT: 'a * 'a -> (svalue,'a) token +val SIGNATURE: 'a * 'a -> (svalue,'a) token +val SIG: 'a * 'a -> (svalue,'a) token +val SHARING: 'a * 'a -> (svalue,'a) token +val INCLUDE: 'a * 'a -> (svalue,'a) token +val FUNCTOR: 'a * 'a -> (svalue,'a) token +val EQTYPE: 'a * 'a -> (svalue,'a) token +val HASH: 'a * 'a -> (svalue,'a) token +val ARROW: 'a * 'a -> (svalue,'a) token +val DARROW: 'a * 'a -> (svalue,'a) token +val EQUALS: 'a * 'a -> (svalue,'a) token +val BAR: 'a * 'a -> (svalue,'a) token +val UNDERBAR: 'a * 'a -> (svalue,'a) token +val DOTS: 'a * 'a -> (svalue,'a) token +val SEMICOLON: 'a * 'a -> (svalue,'a) token +val COLON: 'a * 'a -> (svalue,'a) token +val COMMA: 'a * 'a -> (svalue,'a) token +val RBRACE: 'a * 'a -> (svalue,'a) token +val LBRACE: 'a * 'a -> (svalue,'a) token +val RBRACK: 'a * 'a -> (svalue,'a) token +val LBRACK: 'a * 'a -> (svalue,'a) token +val RPAR: 'a * 'a -> (svalue,'a) token +val LPAR: 'a * 'a -> (svalue,'a) token +val WHILE: 'a * 'a -> (svalue,'a) token +val WITHTYPE: 'a * 'a -> (svalue,'a) token +val WITH: 'a * 'a -> (svalue,'a) token +val VAL: 'a * 'a -> (svalue,'a) token +val TYPE: 'a * 'a -> (svalue,'a) token +val THEN: 'a * 'a -> (svalue,'a) token +val REC: 'a * 'a -> (svalue,'a) token +val RAISE: 'a * 'a -> (svalue,'a) token +val ORELSE: 'a * 'a -> (svalue,'a) token +val OPEN: 'a * 'a -> (svalue,'a) token +val OP: 'a * 'a -> (svalue,'a) token +val OF: 'a * 'a -> (svalue,'a) token +val NONFIX: 'a * 'a -> (svalue,'a) token +val LOCAL: 'a * 'a -> (svalue,'a) token +val LET: 'a * 'a -> (svalue,'a) token +val INFIXR: 'a * 'a -> (svalue,'a) token +val INFIX: 'a * 'a -> (svalue,'a) token +val IN: 'a * 'a -> (svalue,'a) token +val IF: 'a * 'a -> (svalue,'a) token +val HANDLE: 'a * 'a -> (svalue,'a) token +val FUN: 'a * 'a -> (svalue,'a) token +val FN: 'a * 'a -> (svalue,'a) token +val EXCEPTION: 'a * 'a -> (svalue,'a) token +val END: 'a * 'a -> (svalue,'a) token +val ELSE: 'a * 'a -> (svalue,'a) token +val DATATYPE: 'a * 'a -> (svalue,'a) token +val DO: 'a * 'a -> (svalue,'a) token +val CASE: 'a * 'a -> (svalue,'a) token +val AS: 'a * 'a -> (svalue,'a) token +val ANDALSO: 'a * 'a -> (svalue,'a) token +val AND: 'a * 'a -> (svalue,'a) token +val ABSTYPE: 'a * 'a -> (svalue,'a) token +val EOF: 'a * 'a -> (svalue,'a) token +end +signature Parser_LRVALS= +sig +structure Tokens : Parser_TOKENS +structure ParserData:PARSER_DATA +sharing type ParserData.Token.token = Tokens.token +sharing type ParserData.svalue = Tokens.svalue +end +(* stop of Parser.grm.sig *) +(* start of Parser.grm.sml *) +functor LrValsFn(structure Token: TOKEN) = +struct +structure ParserData= +struct +structure Header = +struct +(* *) +(* Standard ML syntactical analysis *) +(* *) +(* Definition, sections 2, 3, and 8, Appendix A and B *) +(* *) +(* Notes: *) +(* - Two phrases named Fmatch and Fmrule have been added to factorize *) +(* Fvalbind. *) +(* - A phrase named SynDesc has been added to factorize type synonym *) +(* specifications. Similarly, a phrase named TyReaDesc has been added to *) +(* factorize type realisation signature expressions. *) +(* - Infix expressions [Definition, section 2.6] are resolved externally in *) +(* structure Infix. The parser just maintains the infix environment J by *) +(* side effect. To achieve correct treatment of scoped fixity directives, *) +(* a stack of environments is used. To handle `local' we even need a *) +(* second environment J' (together with a a second stack). *) +(* - Syntactic restrictions [Definition, sections 2.9 and 3.5] are checked *) +(* during elaboration, as well as the Fvalbind derived form. *) +(* - The Definition is not clear about whether `=' should also be legal as *) +(* a tycon. Since this would result in massive conflicts, and a type named *) +(* `=' could only be used legally if an implementation would be mad enough *) +(* to predefine it anyway, we simply disallow it. *) +(* - The Definition is also vague about what consists a non-infixed occurance *) +(* of an infix identifier: we assume any occurances in expressions *) +(* or patterns. This implies that uses of the keyword `op' in constructor *) +(* and exception bindings are completely redundant. *) +(* - Datatype replication requires rules for datatype to be duplicated to *) +(* avoid conflicts on empty tyvarseqs. *) +(* - Layered patterns require some grammar transformation hack, see pat. *) +(* - The messy `sigexp where type ... and type ...' syntax requires some *) +(* really ugly transformations (in absence of a lookahead of 2), watch out *) +(* for non-terminals of the form xxx__AND_yyybind_opt. *) +(* - ML-Yacc does not seem to like comments that stretch over several *) +(* lines... Similarly, comments in semantic actions make it puke... *) +(* *) +(* Bugs: *) +(* - We do NOT support declarations like *) +(* fun f p1 = case e1 of p2 => e2 *) +(* | f p3 = e3 *) +(* (without parentheses around the case) because the transformations *) +(* required to support this would be even a magnitude uglier than those *) +(* above. In fact, no compiler I know of supports this. *) +(* *) + + + + (* Import *) + + open GrammarCore + open GrammarModule + open GrammarProgram + open DerivedFormsCore + open DerivedFormsModule + open DerivedFormsProgram + + + (* Helper to build info fields *) + + fun I(left, right) = if right = 0 then (left, left) else (left, right) + + + (* Handling infix environments *) + + val J = ref Infix.empty (* context *) + val J' = ref Infix.empty (* local environment (+ enclosing one) *) + + val stackJ = ref [] : Infix.InfEnv list ref + val stackJ' = ref [] : Infix.InfEnv list ref + + fun initJandJ'(J0) = + ( + J := J0; + J' := J0; + stackJ := []; + stackJ' := [] + ) + + fun pushJ() = + ( + stackJ := !J :: !stackJ + ) + + fun popJ() = + ( + J := List.hd(!stackJ); + stackJ := List.tl(!stackJ) + ) + + fun pushJ'shiftJ() = + ( + stackJ' := !J' :: !stackJ'; + J' := List.hd(!stackJ) + ) + + fun popJandJ'() = + ( + J := !J'; + J' := List.hd(!stackJ'); + stackJ := List.tl(!stackJ); + stackJ' := List.tl(!stackJ') + ) + + + fun assignInfix(infstatus, vids) = + ( + J := Infix.assign(!J, vids, infstatus); + J' := Infix.assign(!J', vids, infstatus) + ) + + fun cancelInfix(vids) = + ( + J := Infix.cancel(!J, vids); + J' := Infix.cancel(!J', vids) + ) + + + (* Helper for long identifiers *) + + fun toLongId toId (strids, id) = + ( List.map StrId.fromString strids, toId id ) + + + (* Helper to handle typed patterns (needed because of layered patterns) *) + + fun typedPat(pat, [] ) = pat + | typedPat(pat, ty::tys) = + let + val I = Source.over(infoPat pat, infoTy ty) + in + typedPat(TYPEDPat(I, pat, ty), tys) + end + + + + +end +structure LrTable = Token.LrTable +structure Token = Token +local open LrTable in +val table=let val actionRows = +"\ +\\001\000\001\000\000\000\000\000\ +\\001\000\001\000\184\003\002\000\049\000\006\000\048\000\008\000\047\000\ +\\011\000\046\000\012\000\045\000\013\000\044\000\015\000\043\000\ +\\017\000\042\000\018\000\041\000\019\000\040\000\020\000\039\000\ +\\021\000\038\000\023\000\037\000\024\000\036\000\026\000\035\000\ +\\029\000\034\000\030\000\033\000\033\000\032\000\034\000\031\000\ +\\036\000\030\000\038\000\029\000\042\000\174\003\046\000\151\002\ +\\049\000\028\000\051\000\027\000\055\000\026\000\057\000\025\000\ +\\060\000\024\000\061\000\023\000\062\000\022\000\063\000\021\000\ +\\064\000\020\000\065\000\019\000\066\000\018\000\067\000\017\000\ +\\068\000\151\002\069\000\151\002\070\000\151\002\073\000\151\002\000\000\ +\\001\000\002\000\139\002\003\000\139\002\008\000\139\002\010\000\139\002\ +\\011\000\139\002\013\000\139\002\016\000\139\002\017\000\139\002\ +\\018\000\139\002\020\000\139\002\021\000\139\002\024\000\139\002\ +\\029\000\139\002\030\000\139\002\034\000\141\002\035\000\139\002\ +\\041\000\139\002\042\000\139\002\051\000\139\002\055\000\139\002\ +\\057\000\139\002\059\000\139\002\000\000\ +\\001\000\002\000\178\002\003\000\178\002\004\000\178\002\007\000\178\002\ +\\008\000\178\002\009\000\178\002\010\000\178\002\011\000\178\002\ +\\013\000\178\002\014\000\178\002\016\000\178\002\017\000\178\002\ +\\018\000\178\002\019\000\040\000\020\000\178\002\021\000\178\002\ +\\022\000\178\002\023\000\037\000\024\000\178\002\025\000\178\002\ +\\028\000\178\002\029\000\178\002\030\000\178\002\034\000\031\000\ +\\035\000\178\002\036\000\030\000\037\000\178\002\038\000\029\000\ +\\039\000\178\002\040\000\178\002\041\000\178\002\042\000\178\002\ +\\045\000\178\002\046\000\151\002\049\000\028\000\051\000\178\002\ +\\055\000\178\002\057\000\178\002\060\000\024\000\061\000\023\000\ +\\062\000\022\000\063\000\021\000\064\000\020\000\065\000\019\000\ +\\066\000\018\000\067\000\017\000\068\000\151\002\069\000\151\002\ +\\070\000\151\002\073\000\151\002\000\000\ +\\001\000\002\000\034\003\003\000\034\003\004\000\034\003\005\000\034\003\ +\\007\000\034\003\008\000\034\003\009\000\034\003\010\000\034\003\ +\\011\000\034\003\013\000\034\003\014\000\034\003\016\000\034\003\ +\\017\000\034\003\018\000\034\003\020\000\034\003\021\000\034\003\ +\\022\000\034\003\024\000\034\003\025\000\034\003\028\000\034\003\ +\\029\000\034\003\030\000\034\003\031\000\034\003\032\000\034\003\ +\\035\000\034\003\037\000\034\003\039\000\034\003\040\000\034\003\ +\\041\000\034\003\042\000\034\003\045\000\034\003\046\000\034\003\ +\\047\000\034\003\048\000\034\003\050\000\034\003\051\000\034\003\ +\\052\000\034\003\053\000\034\003\055\000\034\003\057\000\034\003\ +\\058\000\034\003\059\000\034\003\068\000\045\003\069\000\045\003\ +\\070\000\248\000\073\000\045\003\000\000\ +\\001\000\002\000\075\003\003\000\148\001\008\000\075\003\010\000\075\003\ +\\011\000\075\003\013\000\075\003\016\000\075\003\017\000\075\003\ +\\018\000\075\003\020\000\075\003\021\000\075\003\024\000\075\003\ +\\029\000\075\003\030\000\075\003\035\000\075\003\041\000\056\003\ +\\042\000\075\003\051\000\075\003\055\000\075\003\057\000\075\003\ +\\059\000\056\003\000\000\ +\\001\000\002\000\075\003\003\000\148\001\008\000\075\003\010\000\075\003\ +\\011\000\075\003\013\000\075\003\016\000\075\003\017\000\075\003\ +\\018\000\075\003\020\000\075\003\021\000\075\003\024\000\075\003\ +\\029\000\075\003\030\000\075\003\035\000\075\003\041\000\086\003\ +\\042\000\075\003\051\000\075\003\055\000\075\003\057\000\075\003\ +\\058\000\086\003\059\000\086\003\000\000\ +\\001\000\002\000\075\003\003\000\097\002\008\000\075\003\010\000\075\003\ +\\011\000\075\003\013\000\075\003\016\000\075\003\017\000\075\003\ +\\018\000\075\003\020\000\075\003\021\000\075\003\024\000\075\003\ +\\029\000\075\003\030\000\075\003\035\000\075\003\041\000\101\003\ +\\042\000\075\003\051\000\075\003\055\000\075\003\057\000\075\003\ +\\058\000\101\003\059\000\101\003\000\000\ +\\001\000\002\000\093\003\003\000\086\001\008\000\093\003\011\000\093\003\ +\\013\000\093\003\017\000\093\003\018\000\093\003\020\000\093\003\ +\\021\000\093\003\024\000\093\003\029\000\093\003\030\000\093\003\ +\\042\000\093\003\051\000\093\003\055\000\093\003\057\000\093\003\ +\\058\000\086\003\000\000\ +\\001\000\002\000\093\003\003\000\077\002\008\000\093\003\011\000\093\003\ +\\013\000\093\003\017\000\093\003\018\000\093\003\020\000\093\003\ +\\021\000\093\003\024\000\093\003\029\000\093\003\030\000\093\003\ +\\042\000\093\003\051\000\093\003\055\000\093\003\057\000\093\003\ +\\058\000\101\003\000\000\ +\\001\000\002\000\164\003\003\000\032\002\008\000\164\003\011\000\164\003\ +\\013\000\164\003\017\000\164\003\018\000\164\003\020\000\164\003\ +\\021\000\164\003\024\000\164\003\029\000\164\003\030\000\164\003\ +\\041\000\056\003\042\000\164\003\051\000\164\003\055\000\164\003\ +\\057\000\164\003\059\000\056\003\000\000\ +\\001\000\002\000\164\003\003\000\032\002\008\000\164\003\011\000\164\003\ +\\013\000\164\003\017\000\164\003\018\000\164\003\020\000\164\003\ +\\021\000\164\003\024\000\164\003\029\000\164\003\030\000\164\003\ +\\041\000\086\003\042\000\164\003\051\000\164\003\055\000\164\003\ +\\057\000\164\003\058\000\086\003\059\000\086\003\000\000\ +\\001\000\002\000\164\003\003\000\108\002\008\000\164\003\011\000\164\003\ +\\013\000\164\003\017\000\164\003\018\000\164\003\020\000\164\003\ +\\021\000\164\003\024\000\164\003\029\000\164\003\030\000\164\003\ +\\041\000\101\003\042\000\164\003\051\000\164\003\055\000\164\003\ +\\057\000\164\003\058\000\101\003\059\000\101\003\000\000\ +\\001\000\002\000\049\000\006\000\048\000\008\000\047\000\011\000\046\000\ +\\012\000\045\000\013\000\044\000\015\000\043\000\017\000\042\000\ +\\018\000\041\000\019\000\040\000\020\000\039\000\021\000\038\000\ +\\023\000\037\000\024\000\036\000\026\000\035\000\029\000\034\000\ +\\030\000\033\000\033\000\032\000\034\000\031\000\036\000\030\000\ +\\038\000\029\000\042\000\174\003\046\000\151\002\049\000\028\000\ +\\051\000\027\000\055\000\026\000\057\000\025\000\060\000\024\000\ +\\061\000\023\000\062\000\022\000\063\000\021\000\064\000\020\000\ +\\065\000\019\000\066\000\018\000\067\000\017\000\068\000\151\002\ +\\069\000\151\002\070\000\151\002\073\000\151\002\000\000\ +\\001\000\003\000\005\002\008\000\152\003\010\000\152\003\011\000\152\003\ +\\029\000\152\003\030\000\152\003\035\000\152\003\050\000\152\003\ +\\052\000\152\003\053\000\152\003\057\000\152\003\058\000\086\003\000\000\ +\\001\000\003\000\101\002\008\000\152\003\010\000\152\003\011\000\152\003\ +\\029\000\152\003\030\000\152\003\035\000\152\003\050\000\152\003\ +\\052\000\152\003\053\000\152\003\057\000\152\003\058\000\101\003\000\000\ +\\001\000\004\000\059\000\007\000\183\000\014\000\058\000\025\000\057\000\ +\\041\000\056\000\000\000\ +\\001\000\004\000\059\000\009\000\131\001\014\000\058\000\025\000\057\000\ +\\041\000\056\000\000\000\ +\\001\000\004\000\059\000\014\000\058\000\022\000\242\000\025\000\057\000\ +\\041\000\056\000\000\000\ +\\001\000\004\000\059\000\014\000\058\000\025\000\057\000\028\000\224\000\ +\\041\000\056\000\000\000\ +\\001\000\004\000\059\000\014\000\058\000\025\000\057\000\035\000\180\000\ +\\040\000\179\000\041\000\056\000\042\000\178\000\000\000\ +\\001\000\004\000\059\000\014\000\058\000\025\000\057\000\041\000\056\000\ +\\042\000\055\000\000\000\ +\\001\000\005\000\133\002\039\000\133\002\040\000\133\002\041\000\133\002\ +\\046\000\126\002\000\000\ +\\001\000\005\000\134\002\039\000\134\002\040\000\134\002\041\000\134\002\ +\\046\000\127\002\000\000\ +\\001\000\005\000\135\002\039\000\135\002\040\000\135\002\041\000\135\002\ +\\046\000\128\002\000\000\ +\\001\000\005\000\012\003\035\000\029\003\037\000\029\003\039\000\029\003\ +\\040\000\029\003\041\000\186\000\046\000\029\003\047\000\029\003\000\000\ +\\001\000\005\000\013\003\023\000\144\002\034\000\144\002\035\000\144\002\ +\\036\000\144\002\037\000\144\002\038\000\144\002\039\000\144\002\ +\\040\000\144\002\041\000\031\001\044\000\144\002\046\000\144\002\ +\\047\000\144\002\060\000\144\002\061\000\144\002\062\000\144\002\ +\\063\000\144\002\064\000\144\002\065\000\144\002\066\000\144\002\ +\\067\000\144\002\068\000\144\002\069\000\144\002\070\000\144\002\ +\\073\000\144\002\000\000\ +\\001\000\005\000\118\001\000\000\ +\\001\000\006\000\048\000\012\000\045\000\015\000\043\000\019\000\040\000\ +\\023\000\037\000\026\000\035\000\033\000\032\000\034\000\031\000\ +\\036\000\030\000\037\000\163\002\038\000\029\000\046\000\151\002\ +\\049\000\028\000\060\000\024\000\061\000\023\000\062\000\022\000\ +\\063\000\021\000\064\000\020\000\065\000\019\000\066\000\018\000\ +\\067\000\017\000\068\000\151\002\069\000\151\002\070\000\151\002\ +\\073\000\151\002\000\000\ +\\001\000\008\000\233\001\068\000\067\000\069\000\066\000\070\000\065\000\000\000\ +\\001\000\010\000\157\001\000\000\ +\\001\000\010\000\198\001\000\000\ +\\001\000\010\000\238\001\000\000\ +\\001\000\010\000\020\002\000\000\ +\\001\000\010\000\027\002\000\000\ +\\001\000\010\000\070\002\000\000\ +\\001\000\010\000\072\002\000\000\ +\\001\000\016\000\045\001\000\000\ +\\001\000\016\000\047\001\000\000\ +\\001\000\016\000\190\001\000\000\ +\\001\000\016\000\251\001\000\000\ +\\001\000\019\000\081\001\056\000\080\001\068\000\079\001\073\000\118\000\000\000\ +\\001\000\023\000\037\000\034\000\142\000\035\000\018\003\036\000\107\000\ +\\037\000\018\003\038\000\106\000\039\000\018\003\040\000\018\003\ +\\044\000\105\000\046\000\018\003\047\000\018\003\060\000\024\000\ +\\061\000\023\000\062\000\022\000\063\000\021\000\064\000\020\000\ +\\065\000\019\000\066\000\018\000\067\000\017\000\068\000\151\002\ +\\069\000\151\002\070\000\151\002\073\000\151\002\000\000\ +\\001\000\023\000\037\000\034\000\142\000\035\000\026\003\036\000\107\000\ +\\037\000\026\003\038\000\106\000\039\000\026\003\040\000\026\003\ +\\041\000\026\003\044\000\105\000\046\000\026\003\047\000\026\003\ +\\060\000\024\000\061\000\023\000\062\000\022\000\063\000\021\000\ +\\064\000\020\000\065\000\019\000\066\000\018\000\067\000\017\000\ +\\068\000\151\002\069\000\151\002\070\000\151\002\073\000\151\002\000\000\ +\\001\000\023\000\037\000\034\000\142\000\036\000\107\000\037\000\003\003\ +\\038\000\106\000\044\000\105\000\060\000\024\000\061\000\023\000\ +\\062\000\022\000\063\000\021\000\064\000\020\000\065\000\019\000\ +\\066\000\018\000\067\000\017\000\068\000\151\002\069\000\151\002\ +\\070\000\151\002\073\000\151\002\000\000\ +\\001\000\029\000\096\001\068\000\071\000\073\000\118\000\000\000\ +\\001\000\029\000\155\001\000\000\ +\\001\000\029\000\160\001\000\000\ +\\001\000\029\000\160\001\068\000\074\000\000\000\ +\\001\000\029\000\162\001\068\000\071\000\073\000\118\000\000\000\ +\\001\000\029\000\024\002\000\000\ +\\001\000\029\000\024\002\068\000\071\000\000\000\ +\\001\000\029\000\040\002\000\000\ +\\001\000\029\000\040\002\068\000\071\000\000\000\ +\\001\000\029\000\088\002\000\000\ +\\001\000\029\000\088\002\068\000\077\000\000\000\ +\\001\000\031\000\066\001\000\000\ +\\001\000\034\000\113\000\068\000\150\000\069\000\149\000\071\000\104\000\000\000\ +\\001\000\034\000\173\000\000\000\ +\\001\000\034\000\151\001\000\000\ +\\001\000\035\000\181\000\000\000\ +\\001\000\035\000\182\000\000\000\ +\\001\000\035\000\038\001\000\000\ +\\001\000\035\000\040\001\040\000\039\001\000\000\ +\\001\000\035\000\041\001\000\000\ +\\001\000\035\000\071\001\000\000\ +\\001\000\035\000\073\001\040\000\072\001\000\000\ +\\001\000\035\000\090\001\000\000\ +\\001\000\035\000\217\001\058\000\082\001\000\000\ +\\001\000\035\000\246\001\000\000\ +\\001\000\035\000\249\001\041\000\248\001\059\000\247\001\000\000\ +\\001\000\037\000\177\000\000\000\ +\\001\000\037\000\037\001\000\000\ +\\001\000\039\000\174\000\000\000\ +\\001\000\039\000\033\001\000\000\ +\\001\000\039\000\069\001\000\000\ +\\001\000\041\000\070\001\000\000\ +\\001\000\041\000\091\001\000\000\ +\\001\000\041\000\150\001\059\000\149\001\000\000\ +\\001\000\041\000\166\001\000\000\ +\\001\000\041\000\173\001\000\000\ +\\001\000\041\000\034\002\059\000\033\002\000\000\ +\\001\000\042\000\050\000\000\000\ +\\001\000\043\000\200\000\061\000\083\000\062\000\082\000\068\000\199\000\ +\\069\000\198\000\070\000\197\000\000\000\ +\\001\000\046\000\068\000\068\000\067\000\069\000\066\000\070\000\065\000\ +\\073\000\064\000\000\000\ +\\001\000\046\000\122\000\068\000\067\000\069\000\066\000\070\000\065\000\000\000\ +\\001\000\046\000\172\000\000\000\ +\\001\000\046\000\175\000\000\000\ +\\001\000\046\000\187\000\000\000\ +\\001\000\046\000\241\000\000\000\ +\\001\000\046\000\255\000\000\000\ +\\001\000\046\000\035\001\000\000\ +\\001\000\046\000\043\001\000\000\ +\\001\000\046\000\050\001\000\000\ +\\001\000\046\000\059\001\000\000\ +\\001\000\046\000\065\001\000\000\ +\\001\000\046\000\083\001\058\000\082\001\000\000\ +\\001\000\046\000\167\001\000\000\ +\\001\000\046\000\177\001\000\000\ +\\001\000\046\000\215\001\000\000\ +\\001\000\046\000\223\001\000\000\ +\\001\000\046\000\227\001\000\000\ +\\001\000\046\000\230\001\000\000\ +\\001\000\046\000\001\002\058\000\082\001\000\000\ +\\001\000\046\000\029\002\000\000\ +\\001\000\046\000\030\002\000\000\ +\\001\000\046\000\036\002\000\000\ +\\001\000\046\000\063\002\058\000\082\001\000\000\ +\\001\000\046\000\083\002\000\000\ +\\001\000\046\000\084\002\000\000\ +\\001\000\046\000\089\002\000\000\ +\\001\000\046\000\103\002\000\000\ +\\001\000\047\000\233\000\000\000\ +\\001\000\054\000\003\001\068\000\074\000\000\000\ +\\001\000\058\000\087\001\000\000\ +\\001\000\058\000\006\002\000\000\ +\\001\000\061\000\083\000\062\000\082\000\068\000\081\000\069\000\080\000\ +\\070\000\079\000\000\000\ +\\001\000\068\000\067\000\069\000\066\000\070\000\065\000\000\000\ +\\001\000\068\000\067\000\069\000\066\000\070\000\065\000\073\000\064\000\000\000\ +\\001\000\068\000\067\000\069\000\066\000\070\000\065\000\073\000\192\000\000\000\ +\\001\000\068\000\071\000\000\000\ +\\001\000\068\000\071\000\073\000\118\000\000\000\ +\\001\000\068\000\074\000\000\000\ +\\001\000\068\000\077\000\000\000\ +\\001\000\068\000\150\000\069\000\149\000\000\000\ +\\001\000\068\000\150\000\069\000\149\000\073\000\247\000\000\000\ +\\001\000\071\000\104\000\000\000\ +\\111\002\000\000\ +\\112\002\000\000\ +\\113\002\000\000\ +\\113\002\041\000\248\001\059\000\247\001\000\000\ +\\114\002\000\000\ +\\115\002\000\000\ +\\116\002\000\000\ +\\117\002\000\000\ +\\118\002\000\000\ +\\119\002\000\000\ +\\120\002\000\000\ +\\121\002\000\000\ +\\122\002\000\000\ +\\123\002\000\000\ +\\124\002\000\000\ +\\125\002\000\000\ +\\126\002\000\000\ +\\127\002\000\000\ +\\128\002\000\000\ +\\129\002\000\000\ +\\130\002\000\000\ +\\131\002\000\000\ +\\132\002\000\000\ +\\133\002\000\000\ +\\134\002\000\000\ +\\135\002\000\000\ +\\136\002\000\000\ +\\137\002\000\000\ +\\138\002\000\000\ +\\139\002\000\000\ +\\140\002\000\000\ +\\141\002\000\000\ +\\142\002\000\000\ +\\143\002\000\000\ +\\144\002\000\000\ +\\145\002\000\000\ +\\145\002\041\000\186\000\000\000\ +\\146\002\000\000\ +\\147\002\000\000\ +\\148\002\000\000\ +\\149\002\000\000\ +\\150\002\000\000\ +\\151\002\006\000\048\000\012\000\045\000\015\000\043\000\019\000\040\000\ +\\023\000\037\000\026\000\035\000\033\000\032\000\034\000\031\000\ +\\035\000\093\000\036\000\030\000\038\000\029\000\049\000\028\000\ +\\060\000\024\000\061\000\023\000\062\000\022\000\063\000\021\000\ +\\064\000\020\000\065\000\019\000\066\000\018\000\067\000\017\000\000\000\ +\\151\002\006\000\048\000\012\000\045\000\015\000\043\000\019\000\040\000\ +\\023\000\037\000\026\000\035\000\033\000\032\000\034\000\031\000\ +\\036\000\030\000\038\000\029\000\049\000\028\000\060\000\024\000\ +\\061\000\023\000\062\000\022\000\063\000\021\000\064\000\020\000\ +\\065\000\019\000\066\000\018\000\067\000\017\000\000\000\ +\\151\002\008\000\063\001\023\000\037\000\000\000\ +\\151\002\023\000\037\000\000\000\ +\\151\002\023\000\037\000\027\000\109\000\034\000\108\000\036\000\107\000\ +\\038\000\106\000\044\000\105\000\060\000\024\000\061\000\023\000\ +\\062\000\022\000\063\000\021\000\064\000\020\000\065\000\019\000\ +\\066\000\018\000\067\000\017\000\071\000\104\000\000\000\ +\\151\002\023\000\037\000\027\000\109\000\034\000\142\000\036\000\107\000\ +\\038\000\106\000\044\000\105\000\060\000\024\000\061\000\023\000\ +\\062\000\022\000\063\000\021\000\064\000\020\000\065\000\019\000\ +\\066\000\018\000\067\000\017\000\000\000\ +\\151\002\023\000\037\000\034\000\108\000\036\000\107\000\038\000\106\000\ +\\044\000\105\000\060\000\024\000\061\000\023\000\062\000\022\000\ +\\063\000\021\000\064\000\020\000\065\000\019\000\066\000\018\000\ +\\067\000\017\000\071\000\104\000\000\000\ +\\151\002\023\000\037\000\034\000\142\000\035\000\208\000\036\000\107\000\ +\\038\000\106\000\044\000\105\000\060\000\024\000\061\000\023\000\ +\\062\000\022\000\063\000\021\000\064\000\020\000\065\000\019\000\ +\\066\000\018\000\067\000\017\000\000\000\ +\\151\002\023\000\037\000\034\000\142\000\035\000\208\000\036\000\107\000\ +\\038\000\106\000\044\000\105\000\060\000\024\000\061\000\023\000\ +\\062\000\022\000\063\000\021\000\064\000\020\000\065\000\019\000\ +\\066\000\018\000\067\000\017\000\071\000\104\000\000\000\ +\\151\002\023\000\037\000\034\000\142\000\036\000\107\000\038\000\106\000\ +\\044\000\105\000\060\000\024\000\061\000\023\000\062\000\022\000\ +\\063\000\021\000\064\000\020\000\065\000\019\000\066\000\018\000\ +\\067\000\017\000\000\000\ +\\152\002\000\000\ +\\153\002\000\000\ +\\154\002\000\000\ +\\155\002\000\000\ +\\156\002\000\000\ +\\157\002\000\000\ +\\158\002\000\000\ +\\159\002\000\000\ +\\160\002\000\000\ +\\161\002\000\000\ +\\162\002\000\000\ +\\164\002\000\000\ +\\165\002\004\000\059\000\014\000\058\000\025\000\057\000\040\000\176\000\ +\\041\000\056\000\000\000\ +\\166\002\000\000\ +\\167\002\000\000\ +\\168\002\004\000\059\000\014\000\058\000\025\000\057\000\041\000\056\000\ +\\042\000\188\001\000\000\ +\\169\002\000\000\ +\\170\002\004\000\059\000\014\000\058\000\025\000\057\000\041\000\056\000\ +\\042\000\178\000\000\000\ +\\171\002\000\000\ +\\172\002\000\000\ +\\173\002\004\000\059\000\014\000\058\000\025\000\057\000\040\000\114\001\ +\\041\000\056\000\000\000\ +\\174\002\000\000\ +\\175\002\061\000\083\000\062\000\082\000\068\000\081\000\069\000\080\000\ +\\070\000\079\000\000\000\ +\\176\002\000\000\ +\\177\002\000\000\ +\\179\002\000\000\ +\\180\002\000\000\ +\\181\002\004\000\059\000\041\000\056\000\000\000\ +\\182\002\004\000\059\000\025\000\057\000\041\000\056\000\000\000\ +\\183\002\000\000\ +\\184\002\004\000\059\000\014\000\058\000\025\000\057\000\041\000\056\000\000\000\ +\\185\002\004\000\059\000\014\000\058\000\025\000\057\000\041\000\056\000\000\000\ +\\186\002\004\000\059\000\014\000\058\000\025\000\057\000\041\000\056\000\000\000\ +\\187\002\000\000\ +\\188\002\000\000\ +\\189\002\000\000\ +\\190\002\000\000\ +\\191\002\045\000\235\000\000\000\ +\\192\002\004\000\059\000\014\000\058\000\025\000\057\000\041\000\056\000\000\000\ +\\193\002\002\000\049\000\008\000\047\000\011\000\046\000\013\000\044\000\ +\\017\000\042\000\018\000\041\000\020\000\221\000\021\000\038\000\ +\\024\000\036\000\029\000\034\000\030\000\033\000\042\000\220\000\000\000\ +\\194\002\002\000\049\000\008\000\047\000\011\000\046\000\013\000\044\000\ +\\017\000\042\000\018\000\041\000\020\000\221\000\021\000\038\000\ +\\024\000\036\000\029\000\034\000\030\000\033\000\042\000\220\000\000\000\ +\\195\002\000\000\ +\\196\002\000\000\ +\\197\002\002\000\049\000\008\000\047\000\011\000\046\000\013\000\044\000\ +\\017\000\042\000\018\000\041\000\020\000\221\000\021\000\038\000\ +\\024\000\036\000\029\000\034\000\030\000\033\000\000\000\ +\\198\002\000\000\ +\\199\002\000\000\ +\\200\002\000\000\ +\\201\002\000\000\ +\\202\002\000\000\ +\\203\002\000\000\ +\\204\002\000\000\ +\\205\002\000\000\ +\\206\002\000\000\ +\\207\002\000\000\ +\\208\002\000\000\ +\\209\002\000\000\ +\\210\002\000\000\ +\\211\002\000\000\ +\\212\002\000\000\ +\\213\002\000\000\ +\\214\002\032\000\239\000\000\000\ +\\215\002\000\000\ +\\216\002\046\000\122\000\068\000\067\000\069\000\066\000\070\000\065\000\000\000\ +\\217\002\000\000\ +\\218\002\068\000\071\000\073\000\118\000\000\000\ +\\219\002\000\000\ +\\220\002\060\000\128\000\061\000\127\000\000\000\ +\\221\002\000\000\ +\\222\002\000\000\ +\\223\002\000\000\ +\\224\002\003\000\117\001\004\000\059\000\014\000\058\000\025\000\057\000\ +\\041\000\056\000\000\000\ +\\225\002\000\000\ +\\226\002\000\000\ +\\227\002\003\000\232\000\000\000\ +\\228\002\000\000\ +\\229\002\000\000\ +\\230\002\045\000\230\000\000\000\ +\\231\002\004\000\059\000\014\000\058\000\025\000\057\000\041\000\056\000\000\000\ +\\232\002\000\000\ +\\233\002\000\000\ +\\234\002\003\000\186\001\000\000\ +\\235\002\000\000\ +\\236\002\000\000\ +\\237\002\000\000\ +\\238\002\000\000\ +\\239\002\003\000\139\001\000\000\ +\\240\002\000\000\ +\\241\002\000\000\ +\\242\002\045\000\242\001\000\000\ +\\243\002\000\000\ +\\244\002\022\000\058\001\000\000\ +\\244\002\022\000\058\001\046\000\057\001\000\000\ +\\245\002\000\000\ +\\246\002\000\000\ +\\247\002\000\000\ +\\248\002\003\000\134\001\000\000\ +\\249\002\000\000\ +\\249\002\041\000\186\000\000\000\ +\\250\002\000\000\ +\\251\002\000\000\ +\\252\002\000\000\ +\\253\002\000\000\ +\\254\002\000\000\ +\\255\002\000\000\ +\\000\003\000\000\ +\\001\003\000\000\ +\\002\003\000\000\ +\\004\003\000\000\ +\\005\003\040\000\036\001\000\000\ +\\006\003\000\000\ +\\007\003\000\000\ +\\008\003\000\000\ +\\009\003\000\000\ +\\010\003\000\000\ +\\011\003\040\000\182\001\000\000\ +\\012\003\000\000\ +\\013\003\041\000\227\000\000\000\ +\\014\003\000\000\ +\\015\003\005\000\121\001\000\000\ +\\016\003\000\000\ +\\017\003\043\000\200\000\061\000\083\000\062\000\082\000\068\000\199\000\ +\\069\000\198\000\070\000\197\000\000\000\ +\\019\003\041\000\186\000\000\000\ +\\020\003\000\000\ +\\021\003\000\000\ +\\022\003\000\000\ +\\023\003\000\000\ +\\024\003\000\000\ +\\025\003\000\000\ +\\027\003\000\000\ +\\028\003\000\000\ +\\029\003\041\000\186\000\000\000\ +\\030\003\048\000\249\000\000\000\ +\\031\003\000\000\ +\\032\003\000\000\ +\\033\003\000\000\ +\\035\003\000\000\ +\\036\003\000\000\ +\\037\003\000\000\ +\\038\003\000\000\ +\\039\003\000\000\ +\\040\003\000\000\ +\\041\003\000\000\ +\\042\003\040\000\200\001\000\000\ +\\043\003\000\000\ +\\044\003\061\000\083\000\062\000\082\000\068\000\081\000\069\000\080\000\ +\\070\000\079\000\000\000\ +\\046\003\034\000\165\000\038\000\164\000\071\000\104\000\000\000\ +\\047\003\000\000\ +\\048\003\000\000\ +\\049\003\040\000\072\001\000\000\ +\\050\003\000\000\ +\\051\003\034\000\113\000\071\000\104\000\000\000\ +\\052\003\000\000\ +\\053\003\000\000\ +\\054\003\000\000\ +\\055\003\040\000\042\001\000\000\ +\\056\003\000\000\ +\\057\003\058\000\082\001\000\000\ +\\057\003\058\000\245\001\000\000\ +\\057\003\058\000\079\002\000\000\ +\\058\003\058\000\082\001\000\000\ +\\058\003\058\000\245\001\000\000\ +\\058\003\058\000\079\002\000\000\ +\\059\003\000\000\ +\\060\003\000\000\ +\\061\003\000\000\ +\\062\003\000\000\ +\\063\003\000\000\ +\\064\003\002\000\049\000\008\000\047\000\011\000\046\000\013\000\044\000\ +\\017\000\042\000\018\000\041\000\020\000\039\000\021\000\038\000\ +\\024\000\036\000\029\000\034\000\030\000\033\000\042\000\216\000\ +\\057\000\025\000\000\000\ +\\065\003\002\000\049\000\008\000\047\000\011\000\046\000\013\000\044\000\ +\\017\000\042\000\018\000\041\000\019\000\081\001\020\000\039\000\ +\\021\000\038\000\024\000\036\000\029\000\034\000\030\000\033\000\ +\\042\000\216\000\056\000\080\001\057\000\025\000\068\000\079\001\ +\\073\000\118\000\000\000\ +\\065\003\002\000\049\000\008\000\047\000\011\000\046\000\013\000\044\000\ +\\017\000\042\000\018\000\041\000\020\000\039\000\021\000\038\000\ +\\024\000\036\000\029\000\034\000\030\000\033\000\042\000\216\000\ +\\057\000\025\000\000\000\ +\\066\003\000\000\ +\\067\003\002\000\049\000\008\000\047\000\011\000\046\000\013\000\044\000\ +\\017\000\042\000\018\000\041\000\020\000\039\000\021\000\038\000\ +\\024\000\036\000\029\000\034\000\030\000\033\000\057\000\025\000\000\000\ +\\068\003\000\000\ +\\069\003\000\000\ +\\070\003\000\000\ +\\071\003\000\000\ +\\072\003\000\000\ +\\073\003\000\000\ +\\074\003\000\000\ +\\076\003\000\000\ +\\077\003\000\000\ +\\078\003\000\000\ +\\079\003\000\000\ +\\080\003\000\000\ +\\081\003\000\000\ +\\082\003\000\000\ +\\083\003\000\000\ +\\084\003\058\000\082\001\000\000\ +\\085\003\041\000\171\000\059\000\170\000\000\000\ +\\085\003\041\000\171\000\059\000\164\001\000\000\ +\\085\003\041\000\171\000\059\000\003\002\000\000\ +\\086\003\000\000\ +\\087\003\000\000\ +\\088\003\000\000\ +\\089\003\000\000\ +\\089\003\068\000\074\000\000\000\ +\\090\003\000\000\ +\\091\003\000\000\ +\\092\003\000\000\ +\\094\003\000\000\ +\\095\003\000\000\ +\\096\003\000\000\ +\\097\003\000\000\ +\\098\003\000\000\ +\\099\003\000\000\ +\\100\003\000\000\ +\\101\003\003\000\074\002\000\000\ +\\102\003\008\000\020\001\011\000\019\001\029\000\018\001\030\000\017\001\ +\\050\000\015\001\052\000\014\001\053\000\089\001\057\000\012\001\000\000\ +\\103\003\008\000\020\001\011\000\019\001\029\000\018\001\030\000\017\001\ +\\042\000\016\001\050\000\015\001\052\000\014\001\053\000\013\001\ +\\057\000\012\001\000\000\ +\\103\003\008\000\020\001\011\000\019\001\029\000\018\001\030\000\017\001\ +\\042\000\016\001\050\000\015\001\052\000\014\001\053\000\013\001\ +\\057\000\012\001\068\000\071\000\000\000\ +\\104\003\000\000\ +\\105\003\000\000\ +\\106\003\000\000\ +\\107\003\000\000\ +\\108\003\000\000\ +\\109\003\000\000\ +\\110\003\000\000\ +\\111\003\000\000\ +\\112\003\000\000\ +\\113\003\000\000\ +\\114\003\000\000\ +\\115\003\000\000\ +\\116\003\000\000\ +\\117\003\000\000\ +\\118\003\000\000\ +\\119\003\000\000\ +\\120\003\058\000\082\001\000\000\ +\\121\003\000\000\ +\\122\003\000\000\ +\\123\003\068\000\074\000\000\000\ +\\124\003\000\000\ +\\125\003\046\000\042\002\000\000\ +\\126\003\000\000\ +\\127\003\000\000\ +\\128\003\046\000\007\002\000\000\ +\\129\003\000\000\ +\\130\003\000\000\ +\\131\003\000\000\ +\\132\003\003\000\012\002\000\000\ +\\133\003\000\000\ +\\134\003\000\000\ +\\135\003\003\000\225\001\000\000\ +\\135\003\003\000\225\001\046\000\227\001\000\000\ +\\136\003\000\000\ +\\137\003\000\000\ +\\138\003\003\000\045\002\000\000\ +\\139\003\000\000\ +\\140\003\000\000\ +\\141\003\000\000\ +\\142\003\000\000\ +\\143\003\003\000\017\002\000\000\ +\\144\003\000\000\ +\\145\003\000\000\ +\\146\003\045\000\050\002\000\000\ +\\147\003\000\000\ +\\148\003\000\000\ +\\149\003\003\000\229\001\000\000\ +\\150\003\000\000\ +\\151\003\000\000\ +\\153\003\000\000\ +\\154\003\000\000\ +\\155\003\000\000\ +\\156\003\000\000\ +\\157\003\000\000\ +\\158\003\000\000\ +\\159\003\000\000\ +\\160\003\000\000\ +\\161\003\000\000\ +\\162\003\000\000\ +\\163\003\000\000\ +\\165\003\000\000\ +\\166\003\000\000\ +\\167\003\000\000\ +\\168\003\000\000\ +\\169\003\000\000\ +\\170\003\000\000\ +\\171\003\000\000\ +\\172\003\000\000\ +\\173\003\000\000\ +\\175\003\000\000\ +\\176\003\000\000\ +\\177\003\000\000\ +\\178\003\000\000\ +\\179\003\002\000\049\000\008\000\047\000\011\000\046\000\013\000\044\000\ +\\017\000\042\000\018\000\041\000\020\000\039\000\021\000\038\000\ +\\024\000\036\000\029\000\034\000\030\000\033\000\051\000\027\000\ +\\055\000\026\000\057\000\025\000\000\000\ +\\180\003\000\000\ +\\181\003\000\000\ +\\182\003\000\000\ +\\183\003\000\000\ +\" +val actionRowNumbers = +"\127\000\013\000\207\001\201\001\ +\\082\000\206\001\206\001\206\001\ +\\096\001\021\000\204\000\003\000\ +\\202\000\084\000\179\000\139\000\ +\\138\000\140\000\137\000\136\000\ +\\135\000\134\000\133\000\120\000\ +\\122\000\123\000\116\000\201\000\ +\\028\000\169\000\170\000\173\000\ +\\073\001\170\000\121\000\168\000\ +\\085\000\128\000\128\000\245\000\ +\\245\000\170\000\175\000\178\000\ +\\172\000\057\000\170\000\073\001\ +\\001\000\204\001\205\001\203\001\ +\\202\001\001\000\068\001\170\000\ +\\178\000\170\000\203\000\159\000\ +\\180\000\161\000\162\000\152\000\ +\\151\000\150\000\160\000\097\001\ +\\111\001\156\000\119\001\086\000\ +\\157\000\187\001\058\000\158\000\ +\\182\000\145\000\144\000\143\000\ +\\147\000\146\000\073\000\200\000\ +\\087\000\191\000\189\000\071\000\ +\\020\000\060\000\061\000\183\000\ +\\016\000\174\000\044\001\088\000\ +\\020\001\042\000\224\000\119\000\ +\\074\001\023\001\155\000\022\001\ +\\043\001\044\000\177\000\174\000\ +\\072\001\124\000\228\000\126\000\ +\\209\000\234\000\243\000\166\000\ +\\167\000\237\000\148\000\241\000\ +\\149\000\092\001\219\000\085\000\ +\\244\000\142\000\141\000\085\000\ +\\019\000\178\000\039\001\019\001\ +\\043\000\255\000\252\000\226\000\ +\\118\000\112\000\216\000\213\000\ +\\176\000\233\000\117\000\124\000\ +\\239\000\239\000\089\000\154\000\ +\\153\000\018\000\124\000\239\000\ +\\208\001\210\001\209\001\125\000\ +\\058\001\004\000\056\001\054\001\ +\\205\000\060\001\067\001\068\001\ +\\207\000\208\000\206\000\090\000\ +\\113\000\113\000\113\000\132\001\ +\\181\000\170\000\170\000\185\000\ +\\170\000\170\000\188\000\186\000\ +\\184\000\170\000\225\000\046\001\ +\\068\001\170\000\045\001\051\001\ +\\021\001\026\000\163\000\074\000\ +\\042\001\039\001\091\000\024\000\ +\\023\000\022\000\033\001\031\001\ +\\029\001\072\000\062\000\063\000\ +\\064\000\077\001\025\001\247\000\ +\\092\000\242\000\240\000\093\001\ +\\090\001\037\000\095\001\220\000\ +\\218\000\038\000\223\000\128\000\ +\\236\000\235\000\170\000\227\000\ +\\093\000\068\001\050\001\253\000\ +\\178\000\250\000\178\000\170\000\ +\\214\000\178\000\014\001\094\000\ +\\230\000\073\001\229\000\171\000\ +\\178\000\095\000\056\000\059\001\ +\\164\000\165\000\068\001\068\001\ +\\075\000\066\001\076\000\065\000\ +\\066\000\041\000\114\001\096\000\ +\\117\001\131\001\110\001\120\001\ +\\008\000\114\000\133\001\130\001\ +\\067\000\077\000\120\000\045\000\ +\\113\000\073\001\135\001\117\000\ +\\073\001\117\000\057\000\199\000\ +\\190\000\196\000\195\000\192\000\ +\\211\000\053\001\249\000\047\001\ +\\027\000\068\001\048\001\024\001\ +\\041\001\178\000\178\000\027\001\ +\\075\001\178\000\028\001\026\001\ +\\126\000\068\001\094\001\131\000\ +\\222\000\170\000\219\000\017\000\ +\\170\000\038\001\254\000\251\000\ +\\217\000\215\000\018\001\172\000\ +\\068\001\172\000\238\000\008\001\ +\\117\000\125\000\212\000\172\000\ +\\219\000\057\001\055\001\061\001\ +\\068\001\069\001\068\001\062\001\ +\\099\001\005\000\078\000\086\001\ +\\059\000\002\000\128\000\128\000\ +\\046\000\041\000\030\000\122\001\ +\\122\000\047\000\134\001\049\000\ +\\112\001\113\000\148\001\079\000\ +\\138\001\097\000\125\000\150\001\ +\\149\001\118\001\142\001\124\000\ +\\140\001\080\000\143\001\141\001\ +\\124\000\147\001\013\001\145\001\ +\\144\001\124\000\098\000\197\000\ +\\116\000\052\001\246\000\174\000\ +\\178\000\025\000\037\001\178\000\ +\\037\001\030\001\032\001\076\001\ +\\003\001\092\001\194\000\129\000\ +\\039\000\170\000\000\001\015\001\ +\\172\000\084\000\012\001\008\001\ +\\005\001\073\001\013\001\231\000\ +\\008\001\031\000\065\001\070\001\ +\\071\001\102\001\120\000\113\000\ +\\113\000\091\001\092\001\092\001\ +\\115\001\073\001\100\001\116\001\ +\\121\001\123\001\073\001\139\001\ +\\125\000\099\000\113\000\068\000\ +\\113\000\121\000\136\001\100\000\ +\\151\001\152\001\164\001\068\001\ +\\165\001\179\001\102\000\029\000\ +\\198\000\248\000\049\001\035\001\ +\\083\000\040\001\034\001\001\001\ +\\073\001\132\000\170\000\032\000\ +\\131\000\210\000\017\001\018\001\ +\\006\001\007\001\011\001\004\001\ +\\232\000\063\001\116\000\101\001\ +\\006\000\083\001\104\001\080\001\ +\\103\001\069\000\078\001\070\000\ +\\129\000\040\000\125\000\125\000\ +\\137\001\041\000\103\000\113\001\ +\\180\001\014\000\115\000\158\001\ +\\157\001\125\000\162\001\073\001\ +\\161\001\068\001\177\001\117\000\ +\\117\000\173\001\013\001\125\000\ +\\036\001\002\001\033\000\193\000\ +\\187\000\219\000\016\001\009\001\ +\\172\000\064\001\105\001\050\000\ +\\088\001\113\000\113\000\087\001\ +\\034\000\041\000\104\000\105\000\ +\\190\001\010\000\081\000\041\000\ +\\106\000\113\000\182\001\120\000\ +\\052\000\121\000\155\001\154\001\ +\\163\001\159\001\117\000\168\001\ +\\178\001\173\001\170\001\073\001\ +\\176\001\146\001\098\001\132\000\ +\\010\001\106\001\073\001\082\001\ +\\079\001\085\001\130\000\068\001\ +\\068\001\193\001\123\000\113\000\ +\\113\000\191\001\041\000\107\000\ +\\181\001\183\001\073\001\156\001\ +\\125\000\160\001\166\001\073\001\ +\\171\001\172\001\124\000\174\001\ +\\117\000\035\000\125\000\036\000\ +\\129\001\009\000\192\001\195\001\ +\\011\000\084\001\194\001\081\001\ +\\188\001\041\000\125\000\153\001\ +\\167\001\124\000\108\000\175\001\ +\\221\000\109\000\089\001\127\001\ +\\046\000\124\001\125\001\048\000\ +\\196\001\054\000\189\001\110\000\ +\\101\000\117\000\068\001\128\001\ +\\126\001\197\001\073\001\068\001\ +\\173\001\007\000\125\000\015\000\ +\\169\001\107\001\108\001\051\000\ +\\111\000\184\001\185\001\053\000\ +\\109\001\068\001\186\001\012\000\ +\\198\001\199\001\055\000\200\001\ +\\000\000" +val gotoT = +"\ +\\142\000\108\002\145\000\001\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\009\000\033\000\008\000\087\000\007\000\ +\\097\000\006\000\132\000\005\000\139\000\004\000\140\000\003\000\ +\\143\000\002\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\033\000\008\000\087\000\007\000\097\000\006\000\132\000\005\000\ +\\140\000\050\000\141\000\049\000\000\000\ +\\033\000\008\000\087\000\007\000\097\000\006\000\132\000\005\000\ +\\140\000\050\000\141\000\051\000\000\000\ +\\033\000\008\000\087\000\007\000\097\000\006\000\132\000\005\000\ +\\140\000\050\000\141\000\052\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\001\000\014\000\015\000\013\000\016\000\058\000\000\000\ +\\000\000\ +\\005\000\061\000\011\000\060\000\012\000\059\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\008\000\068\000\088\000\067\000\000\000\ +\\009\000\071\000\098\000\070\000\000\000\ +\\010\000\074\000\133\000\073\000\000\000\ +\\003\000\076\000\000\000\ +\\003\000\084\000\022\000\083\000\023\000\082\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\017\000\087\000\ +\\018\000\086\000\025\000\011\000\026\000\010\000\027\000\085\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\019\000\090\000\ +\\021\000\089\000\025\000\011\000\026\000\010\000\027\000\088\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\092\000\000\000\ +\\001\000\101\000\007\000\100\000\015\000\099\000\038\000\098\000\ +\\056\000\097\000\057\000\096\000\066\000\095\000\068\000\094\000\ +\\081\000\093\000\000\000\ +\\007\000\100\000\045\000\110\000\080\000\109\000\081\000\108\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\112\000\000\000\ +\\008\000\115\000\014\000\114\000\036\000\113\000\000\000\ +\\000\000\ +\\004\000\119\000\005\000\118\000\035\000\117\000\000\000\ +\\146\000\121\000\000\000\ +\\146\000\122\000\000\000\ +\\002\000\124\000\037\000\123\000\000\000\ +\\002\000\124\000\037\000\127\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\128\000\000\000\ +\\001\000\101\000\007\000\100\000\015\000\136\000\040\000\135\000\ +\\042\000\134\000\044\000\133\000\056\000\132\000\057\000\131\000\ +\\067\000\130\000\081\000\129\000\000\000\ +\\001\000\101\000\015\000\099\000\028\000\139\000\030\000\138\000\ +\\056\000\097\000\057\000\096\000\066\000\137\000\068\000\094\000\000\000\ +\\015\000\142\000\054\000\141\000\000\000\ +\\006\000\146\000\007\000\100\000\048\000\145\000\049\000\144\000\ +\\081\000\143\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\149\000\000\000\ +\\007\000\100\000\047\000\151\000\080\000\150\000\081\000\108\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\009\000\033\000\008\000\087\000\007\000\ +\\097\000\006\000\132\000\005\000\139\000\004\000\140\000\003\000\ +\\143\000\153\000\144\000\152\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\009\000\033\000\008\000\087\000\007\000\ +\\097\000\006\000\132\000\005\000\139\000\004\000\140\000\003\000\ +\\143\000\153\000\144\000\154\000\000\000\ +\\007\000\161\000\070\000\160\000\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\164\000\000\000\ +\\001\000\101\000\015\000\099\000\028\000\165\000\030\000\138\000\ +\\056\000\097\000\057\000\096\000\066\000\137\000\068\000\094\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\166\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\094\000\167\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\001\000\101\000\015\000\099\000\038\000\182\000\056\000\097\000\ +\\057\000\096\000\066\000\095\000\068\000\094\000\000\000\ +\\069\000\183\000\000\000\ +\\000\000\ +\\069\000\186\000\000\000\ +\\001\000\101\000\015\000\136\000\056\000\132\000\057\000\131\000\ +\\067\000\187\000\000\000\ +\\000\000\ +\\005\000\189\000\012\000\188\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\003\000\194\000\005\000\193\000\061\000\192\000\062\000\191\000\000\000\ +\\001\000\101\000\015\000\099\000\056\000\097\000\057\000\096\000\ +\\058\000\201\000\059\000\200\000\066\000\199\000\068\000\094\000\000\000\ +\\001\000\101\000\007\000\205\000\015\000\099\000\056\000\097\000\ +\\057\000\096\000\060\000\204\000\066\000\203\000\068\000\094\000\ +\\082\000\202\000\000\000\ +\\001\000\101\000\015\000\099\000\038\000\207\000\056\000\097\000\ +\\057\000\096\000\066\000\095\000\068\000\094\000\000\000\ +\\000\000\ +\\006\000\208\000\000\000\ +\\000\000\ +\\007\000\205\000\082\000\202\000\000\000\ +\\000\000\ +\\000\000\ +\\008\000\115\000\014\000\114\000\036\000\209\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\004\000\119\000\005\000\118\000\035\000\210\000\000\000\ +\\000\000\ +\\033\000\008\000\085\000\213\000\086\000\212\000\087\000\211\000\000\000\ +\\031\000\217\000\032\000\216\000\033\000\215\000\000\000\ +\\004\000\119\000\005\000\118\000\035\000\220\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\004\000\119\000\005\000\118\000\035\000\221\000\000\000\ +\\000\000\ +\\001\000\101\000\015\000\136\000\040\000\223\000\042\000\134\000\ +\\044\000\133\000\056\000\132\000\057\000\131\000\067\000\130\000\000\000\ +\\064\000\224\000\000\000\ +\\000\000\ +\\001\000\101\000\015\000\136\000\056\000\132\000\057\000\131\000\ +\\067\000\226\000\000\000\ +\\043\000\227\000\000\000\ +\\041\000\229\000\000\000\ +\\000\000\ +\\005\000\061\000\012\000\188\000\000\000\ +\\000\000\ +\\029\000\232\000\000\000\ +\\000\000\ +\\001\000\101\000\015\000\099\000\056\000\097\000\057\000\096\000\ +\\060\000\204\000\066\000\203\000\068\000\094\000\000\000\ +\\000\000\ +\\005\000\234\000\000\000\ +\\006\000\235\000\000\000\ +\\034\000\236\000\000\000\ +\\034\000\238\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\006\000\241\000\000\000\ +\\034\000\242\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\006\000\244\000\013\000\243\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\003\000\250\000\075\000\249\000\076\000\248\000\000\000\ +\\007\000\161\000\070\000\252\000\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\079\000\251\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\009\000\000\001\095\000\255\000\096\000\254\000\000\000\ +\\009\000\000\001\095\000\002\001\096\000\254\000\000\000\ +\\009\000\000\001\095\000\005\001\096\000\004\001\100\000\003\001\000\000\ +\\008\000\009\001\105\000\008\001\106\000\007\001\107\000\006\001\000\000\ +\\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\019\001\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\018\000\020\001\ +\\025\000\011\000\026\000\010\000\027\000\085\000\000\000\ +\\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\021\000\022\001\ +\\025\000\011\000\026\000\010\000\027\000\021\001\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\018\000\023\001\ +\\025\000\011\000\026\000\010\000\027\000\085\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\024\001\000\000\ +\\000\000\ +\\000\000\ +\\007\000\161\000\070\000\025\001\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\026\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\064\000\028\001\069\000\027\001\000\000\ +\\069\000\030\001\000\000\ +\\000\000\ +\\000\000\ +\\064\000\032\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\033\000\008\000\086\000\042\001\087\000\211\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\032\000\044\001\033\000\215\000\000\000\ +\\000\000\ +\\000\000\ +\\146\000\046\001\000\000\ +\\000\000\ +\\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\047\001\000\000\ +\\000\000\ +\\000\000\ +\\007\000\161\000\070\000\049\001\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\000\000\ +\\000\000\ +\\001\000\101\000\015\000\136\000\042\000\050\001\044\000\133\000\ +\\056\000\132\000\057\000\131\000\067\000\130\000\000\000\ +\\000\000\ +\\001\000\101\000\015\000\136\000\040\000\051\001\042\000\134\000\ +\\044\000\133\000\056\000\132\000\057\000\131\000\067\000\130\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\052\001\000\000\ +\\000\000\ +\\001\000\101\000\015\000\099\000\028\000\053\001\030\000\138\000\ +\\056\000\097\000\057\000\096\000\066\000\137\000\068\000\094\000\000\000\ +\\053\000\054\001\000\000\ +\\000\000\ +\\000\000\ +\\007\000\100\000\045\000\058\001\080\000\109\000\081\000\108\000\000\000\ +\\000\000\ +\\015\000\060\001\051\000\059\001\000\000\ +\\001\000\101\000\015\000\099\000\028\000\062\001\030\000\138\000\ +\\056\000\097\000\057\000\096\000\066\000\137\000\068\000\094\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\007\000\161\000\072\000\065\001\073\000\157\000\074\000\156\000\ +\\078\000\155\000\000\000\ +\\007\000\161\000\070\000\066\001\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\008\000\115\000\010\000\076\001\014\000\075\001\083\000\074\001\ +\\084\000\073\001\090\000\072\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\105\000\082\001\106\000\007\001\107\000\006\001\000\000\ +\\000\000\ +\\000\000\ +\\099\000\083\001\000\000\ +\\000\000\ +\\000\000\ +\\107\000\086\001\000\000\ +\\000\000\ +\\000\000\ +\\008\000\091\001\127\000\090\001\000\000\ +\\008\000\115\000\014\000\093\001\112\000\092\001\000\000\ +\\009\000\097\001\095\000\096\001\096\000\254\000\108\000\095\001\000\000\ +\\007\000\100\000\080\000\099\001\081\000\108\000\115\000\098\001\000\000\ +\\000\000\ +\\005\000\101\001\113\000\100\001\000\000\ +\\007\000\100\000\080\000\104\001\081\000\108\000\115\000\103\001\ +\\117\000\102\001\000\000\ +\\005\000\106\001\125\000\105\001\000\000\ +\\006\000\110\001\007\000\100\000\081\000\109\001\120\000\108\001\ +\\121\000\107\001\000\000\ +\\024\000\111\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\069\000\113\001\000\000\ +\\039\000\114\001\000\000\ +\\000\000\ +\\000\000\ +\\007\000\161\000\070\000\117\001\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\000\000\ +\\000\000\ +\\065\000\118\001\000\000\ +\\001\000\101\000\015\000\099\000\056\000\097\000\057\000\096\000\ +\\066\000\120\001\068\000\094\000\000\000\ +\\001\000\101\000\015\000\099\000\056\000\097\000\057\000\096\000\ +\\059\000\121\001\066\000\199\000\068\000\094\000\000\000\ +\\000\000\ +\\000\000\ +\\001\000\101\000\015\000\099\000\056\000\097\000\057\000\096\000\ +\\059\000\122\001\066\000\199\000\068\000\094\000\000\000\ +\\000\000\ +\\000\000\ +\\007\000\205\000\082\000\123\001\000\000\ +\\007\000\161\000\070\000\124\001\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\033\000\008\000\086\000\042\001\087\000\211\000\000\000\ +\\148\000\125\001\000\000\ +\\032\000\044\001\033\000\215\000\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\020\000\127\001\ +\\025\000\011\000\026\000\010\000\027\000\126\001\000\000\ +\\031\000\128\001\032\000\216\000\033\000\215\000\000\000\ +\\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\130\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\055\000\131\001\000\000\ +\\015\000\133\001\000\000\ +\\007\000\161\000\070\000\134\001\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\015\000\060\001\051\000\135\001\000\000\ +\\000\000\ +\\050\000\136\001\000\000\ +\\005\000\138\001\000\000\ +\\006\000\244\000\013\000\139\001\000\000\ +\\000\000\ +\\015\000\060\001\051\000\140\001\000\000\ +\\031\000\141\001\032\000\216\000\033\000\215\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\007\000\161\000\070\000\142\001\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\000\000\ +\\007\000\161\000\070\000\144\001\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\079\000\143\001\000\000\ +\\000\000\ +\\000\000\ +\\089\000\145\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\146\000\150\001\000\000\ +\\146\000\151\001\000\000\ +\\103\000\152\001\000\000\ +\\008\000\115\000\010\000\076\001\014\000\075\001\083\000\074\001\ +\\084\000\073\001\090\000\154\001\000\000\ +\\000\000\ +\\000\000\ +\\009\000\071\000\098\000\156\001\000\000\ +\\101\000\157\001\103\000\152\001\000\000\ +\\000\000\ +\\008\000\115\000\014\000\093\001\112\000\159\001\000\000\ +\\094\000\161\001\000\000\ +\\009\000\000\001\095\000\163\001\096\000\254\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\006\000\244\000\013\000\167\001\110\000\166\001\000\000\ +\\000\000\ +\\000\000\ +\\009\000\169\001\108\000\168\001\000\000\ +\\000\000\ +\\006\000\170\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\006\000\172\001\000\000\ +\\000\000\ +\\053\000\173\001\000\000\ +\\000\000\ +\\000\000\ +\\006\000\174\001\000\000\ +\\000\000\ +\\000\000\ +\\003\000\084\000\022\000\176\001\000\000\ +\\000\000\ +\\000\000\ +\\001\000\101\000\015\000\099\000\038\000\177\001\056\000\097\000\ +\\057\000\096\000\066\000\095\000\068\000\094\000\000\000\ +\\001\000\101\000\015\000\099\000\056\000\097\000\057\000\096\000\ +\\066\000\178\001\068\000\094\000\000\000\ +\\069\000\113\001\000\000\ +\\063\000\179\001\000\000\ +\\001\000\101\000\015\000\099\000\056\000\097\000\057\000\096\000\ +\\066\000\181\001\068\000\094\000\000\000\ +\\063\000\182\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\046\000\183\001\000\000\ +\\033\000\008\000\085\000\185\001\086\000\212\000\087\000\211\000\000\000\ +\\000\000\ +\\147\000\187\001\000\000\ +\\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\025\000\011\000\ +\\026\000\010\000\027\000\189\001\000\000\ +\\000\000\ +\\000\000\ +\\015\000\142\000\054\000\190\001\000\000\ +\\005\000\061\000\011\000\191\001\012\000\059\000\000\000\ +\\000\000\ +\\050\000\192\001\000\000\ +\\000\000\ +\\007\000\100\000\047\000\193\001\080\000\150\000\081\000\108\000\000\000\ +\\053\000\194\001\000\000\ +\\000\000\ +\\050\000\195\001\000\000\ +\\000\000\ +\\077\000\197\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\008\000\068\000\088\000\199\001\000\000\ +\\009\000\000\001\091\000\202\001\095\000\201\001\096\000\200\001\000\000\ +\\009\000\000\001\091\000\204\001\095\000\203\001\096\000\200\001\000\000\ +\\008\000\115\000\010\000\076\001\014\000\075\001\033\000\008\000\ +\\083\000\207\001\084\000\206\001\085\000\205\001\086\000\212\000\ +\\087\000\211\000\000\000\ +\\033\000\008\000\085\000\208\001\086\000\212\000\087\000\211\000\000\000\ +\\033\000\008\000\085\000\209\001\086\000\212\000\087\000\211\000\000\000\ +\\000\000\ +\\007\000\100\000\080\000\210\001\081\000\108\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\007\000\100\000\080\000\211\001\081\000\108\000\000\000\ +\\000\000\ +\\006\000\244\000\013\000\167\001\110\000\212\001\000\000\ +\\000\000\ +\\009\000\000\001\095\000\214\001\096\000\254\000\000\000\ +\\000\000\ +\\009\000\000\001\095\000\218\001\096\000\217\001\129\000\216\001\000\000\ +\\008\000\115\000\014\000\220\001\111\000\219\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\009\000\169\001\108\000\168\001\000\000\ +\\116\000\222\001\000\000\ +\\007\000\161\000\070\000\224\001\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\116\000\222\001\000\000\ +\\126\000\226\001\000\000\ +\\000\000\ +\\005\000\230\001\123\000\229\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\003\000\194\000\005\000\193\000\061\000\232\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\007\000\100\000\045\000\233\001\080\000\109\000\081\000\108\000\000\000\ +\\149\000\234\001\000\000\ +\\001\000\014\000\015\000\013\000\016\000\012\000\020\000\235\001\ +\\025\000\011\000\026\000\010\000\027\000\126\001\000\000\ +\\000\000\ +\\148\000\237\001\000\000\ +\\000\000\ +\\000\000\ +\\055\000\238\001\000\000\ +\\000\000\ +\\000\000\ +\\052\000\239\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\003\000\250\000\075\000\241\001\000\000\ +\\000\000\ +\\089\000\242\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\147\000\248\001\000\000\ +\\000\000\ +\\006\000\244\000\013\000\250\001\000\000\ +\\006\000\244\000\013\000\251\001\000\000\ +\\000\000\ +\\008\000\115\000\010\000\076\001\014\000\075\001\083\000\254\001\ +\\084\000\253\001\135\000\252\001\000\000\ +\\000\000\ +\\094\000\000\002\000\000\ +\\000\000\ +\\128\000\002\002\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\006\000\244\000\013\000\007\002\109\000\006\002\000\000\ +\\000\000\ +\\007\000\100\000\080\000\099\001\081\000\108\000\115\000\008\002\000\000\ +\\114\000\009\002\000\000\ +\\007\000\161\000\070\000\011\002\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\000\000\ +\\005\000\106\001\125\000\012\002\000\000\ +\\005\000\230\001\123\000\013\002\000\000\ +\\122\000\014\002\000\000\ +\\053\000\016\002\000\000\ +\\006\000\244\000\013\000\017\002\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\031\000\019\002\032\000\216\000\033\000\215\000\000\000\ +\\000\000\ +\\000\000\ +\\015\000\060\001\051\000\020\002\000\000\ +\\000\000\ +\\000\000\ +\\092\000\021\002\103\000\152\001\000\000\ +\\000\000\ +\\009\000\000\001\095\000\023\002\096\000\254\000\000\000\ +\\009\000\000\001\095\000\024\002\096\000\254\000\000\000\ +\\000\000\ +\\000\000\ +\\008\000\115\000\010\000\076\001\014\000\075\001\083\000\026\002\ +\\084\000\206\001\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\134\000\029\002\000\000\ +\\000\000\ +\\008\000\115\000\010\000\076\001\014\000\075\001\083\000\254\001\ +\\084\000\253\001\135\000\033\002\000\000\ +\\000\000\ +\\009\000\000\001\095\000\035\002\096\000\254\000\000\000\ +\\000\000\ +\\008\000\091\001\127\000\036\002\000\000\ +\\103\000\152\001\130\000\037\002\000\000\ +\\008\000\115\000\014\000\220\001\111\000\039\002\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\005\000\101\001\113\000\041\002\000\000\ +\\118\000\042\002\000\000\ +\\000\000\ +\\122\000\044\002\000\000\ +\\000\000\ +\\007\000\100\000\080\000\046\002\081\000\108\000\119\000\045\002\000\000\ +\\124\000\047\002\000\000\ +\\000\000\ +\\000\000\ +\\149\000\049\002\000\000\ +\\000\000\ +\\000\000\ +\\007\000\100\000\080\000\050\002\081\000\108\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\147\000\051\002\000\000\ +\\007\000\161\000\070\000\052\002\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\007\000\161\000\070\000\053\002\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\000\000\ +\\010\000\074\000\133\000\054\002\000\000\ +\\009\000\000\001\095\000\057\002\096\000\056\002\136\000\055\002\000\000\ +\\009\000\000\001\095\000\059\002\096\000\056\002\136\000\058\002\000\000\ +\\000\000\ +\\008\000\115\000\010\000\076\001\014\000\075\001\083\000\254\001\ +\\084\000\253\001\135\000\060\002\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\007\000\100\000\080\000\062\002\081\000\108\000\000\000\ +\\000\000\ +\\006\000\244\000\013\000\007\002\109\000\063\002\000\000\ +\\000\000\ +\\000\000\ +\\007\000\100\000\080\000\065\002\081\000\108\000\117\000\064\002\000\000\ +\\000\000\ +\\000\000\ +\\006\000\066\002\000\000\ +\\000\000\ +\\005\000\230\001\123\000\067\002\000\000\ +\\000\000\ +\\006\000\244\000\013\000\069\002\000\000\ +\\000\000\ +\\104\000\071\002\000\000\ +\\099\000\074\002\102\000\073\002\104\000\071\002\000\000\ +\\000\000\ +\\000\000\ +\\134\000\076\002\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\008\000\115\000\010\000\076\001\014\000\075\001\083\000\254\001\ +\\084\000\253\001\135\000\078\002\000\000\ +\\006\000\244\000\013\000\079\002\000\000\ +\\000\000\ +\\000\000\ +\\006\000\080\002\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\103\000\083\002\000\000\ +\\000\000\ +\\000\000\ +\\009\000\071\000\098\000\156\001\101\000\084\002\103\000\083\002\000\000\ +\\000\000\ +\\103\000\152\001\137\000\085\002\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\005\000\230\001\123\000\088\002\000\000\ +\\007\000\161\000\070\000\089\002\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\007\000\100\000\080\000\090\002\081\000\108\000\000\000\ +\\007\000\161\000\070\000\091\002\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\122\000\092\002\000\000\ +\\089\000\094\002\093\000\093\002\104\000\071\002\000\000\ +\\006\000\244\000\013\000\096\002\000\000\ +\\104\000\071\002\128\000\098\002\131\000\097\002\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\008\000\068\000\088\000\199\001\092\000\100\002\103\000\083\002\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\008\000\091\001\103\000\083\002\127\000\036\002\130\000\102\002\000\000\ +\\000\000\ +\\007\000\161\000\070\000\103\002\071\000\159\000\072\000\158\000\ +\\073\000\157\000\074\000\156\000\078\000\155\000\000\000\ +\\000\000\ +\\104\000\071\002\134\000\105\002\138\000\104\002\000\000\ +\\000\000\ +\\000\000\ +\\010\000\074\000\103\000\083\002\133\000\054\002\137\000\107\002\000\000\ +\\000\000\ +\\000\000\ +\" +val numstates = 621 +val numrules = 330 +val s = ref "" and index = ref 0 +val string_to_int = fn () => +let val i = !index +in index := i+2; Char.ord(String.sub(!s,i)) + Char.ord(String.sub(!s,i+1)) * 256 +end +val string_to_list = fn s' => + let val len = String.size s' + fun f () = + if !index < len then string_to_int() :: f() + else nil + in index := 0; s := s'; f () + end +val string_to_pairlist = fn (conv_key,conv_entry) => + let fun f () = + case string_to_int() + of 0 => EMPTY + | n => PAIR(conv_key (n-1),conv_entry (string_to_int()),f()) + in f + end +val string_to_pairlist_default = fn (conv_key,conv_entry) => + let val conv_row = string_to_pairlist(conv_key,conv_entry) + in fn () => + let val default = conv_entry(string_to_int()) + val row = conv_row() + in (row,default) + end + end +val string_to_table = fn (convert_row,s') => + let val len = String.size s' + fun f ()= + if !index < len then convert_row() :: f() + else nil + in (s := s'; index := 0; f ()) + end +local + val memo = Array.array(numstates+numrules,ERROR) + val _ =let fun g i=(Array.update(memo,i,REDUCE(i-numstates)); g(i+1)) + fun f i = + if i=numstates then g i + else (Array.update(memo,i,SHIFT (STATE i)); f (i+1)) + in f 0 handle Subscript => () + end +in +val entry_to_action = fn 0 => ACCEPT | 1 => ERROR | j => Array.sub(memo,(j-2)) +end +val gotoT=Array.fromList(string_to_table(string_to_pairlist(NT,STATE),gotoT)) +val actionRows=string_to_table(string_to_pairlist_default(T,entry_to_action),actionRows) +val actionRowNumbers = string_to_list actionRowNumbers +val actionT = let val actionRowLookUp= +let val a=Array.fromList(actionRows) in fn i=>Array.sub(a,i) end +in Array.fromList(map actionRowLookUp actionRowNumbers) +end +in LrTable.mkLrTable {actions=actionT,gotos=gotoT,numRules=numrules, +numStates=numstates,initialState=STATE 0} +end +end +local open Header in +type pos = int +type arg = Infix.InfEnv +structure MlyValue = +struct +datatype svalue = VOID | ntVOID of unit -> unit + | LONGID of unit -> (string list*string) + | ETYVAR of unit -> (string) | TYVAR of unit -> (string) + | SYMBOL of unit -> (string) | ALPHA of unit -> (string) + | CHAR of unit -> (char) | STRING of unit -> (string) + | REAL of unit -> (real) | WORD of unit -> (word) + | INT of unit -> (int) | NUMERIC of unit -> (int) + | DIGIT of unit -> (int) | popLocalInfix of unit -> (unit) + | pushLocalInfix of unit -> (unit) | popInfix of unit -> (unit) + | pushInfix of unit -> (unit) | initInfix of unit -> (unit) + | program_opt of unit -> (Program option) + | program' of unit -> (Program) + | program of unit -> (Program*Infix.InfEnv) + | topdec_opt of unit -> (TopDec option) + | topdec1 of unit -> (TopDec) | topdec of unit -> (TopDec) + | AND_tyreadesc_opt__AND_funbind_opt of unit -> (TyReaDesc option*FunBind option) + | tyreadesc__AND_funbind_opt of unit -> (TyReaDesc*FunBind option) + | sigexp__AND_funbind_opt of unit -> (SigExp*FunBind option) + | strexp__AND_funbind_opt of unit -> (StrExp*FunBind option) + | AND_funbind_opt of unit -> (FunBind option) + | funbind of unit -> (FunBind) | fundec of unit -> (FunDec) + | AND_tyreadesc_opt__AND_strdesc_opt of unit -> (TyReaDesc option*StrDesc option) + | tyreadesc__AND_strdesc_opt of unit -> (TyReaDesc*StrDesc option) + | sigexp__AND_strdesc_opt of unit -> (SigExp*StrDesc option) + | AND_strdesc_opt of unit -> (StrDesc option) + | strdesc of unit -> (StrDesc) + | AND_exdesc_opt of unit -> (ExDesc option) + | exdesc of unit -> (ExDesc) + | BAR_condesc_opt of unit -> (ConDesc option) + | condesc of unit -> (ConDesc) + | AND_datdesc_opt of unit -> (DatDesc option) + | datdesc1 of unit -> (DatDesc) | datdesc0 of unit -> (DatDesc) + | datdesc of unit -> (DatDesc) + | AND_syndesc_opt of unit -> (SynDesc option) + | syndesc of unit -> (SynDesc) + | AND_typdesc_opt of unit -> (TypDesc option) + | typdesc of unit -> (TypDesc) + | AND_valdesc_opt of unit -> (ValDesc option) + | valdesc of unit -> (ValDesc) + | longstrid_EQUALS_list2 of unit -> (longStrId list) + | longstrid_EQUALS_list1 of unit -> (longStrId list) + | longtycon_EQUALS_list2 of unit -> (longTyCon list) + | longtycon_EQUALS_list1 of unit -> (longTyCon list) + | sigid_list2 of unit -> (SigId list) | spec1' of unit -> (Spec) + | spec1 of unit -> (Spec) | spec of unit -> (Spec) + | AND_tyreadesc_opt of unit -> (TyReaDesc option) + | tyreadesc of unit -> (TyReaDesc) + | AND_tyreadesc_opt__AND_sigbind_opt of unit -> (TyReaDesc option*SigBind option) + | tyreadesc__AND_sigbind_opt of unit -> (TyReaDesc*SigBind option) + | sigexp__AND_sigbind_opt of unit -> (SigExp*SigBind option) + | AND_sigbind_opt of unit -> (SigBind option) + | sigbind of unit -> (SigBind) | sigdec of unit -> (SigDec) + | sigexp' of unit -> (SigExp) | sigexp of unit -> (SigExp) + | COLON_sigexp_opt of unit -> (SigExp option) + | AND_tyreadesc_opt__AND_strbind_opt of unit -> (TyReaDesc option*StrBind option) + | tyreadesc__AND_strbind_opt of unit -> (TyReaDesc*StrBind option) + | sigexp__AND_strbind_opt of unit -> (SigExp*StrBind option) + | strexp__AND_strbind_opt of unit -> (StrExp*StrBind option) + | AND_strbind_opt of unit -> (StrBind option) + | strbind of unit -> (StrBind) | strdec1' of unit -> (StrDec) + | strdec1 of unit -> (StrDec) | strdec of unit -> (StrDec) + | strexp' of unit -> (StrExp) | strexp of unit -> (StrExp) + | tyvar_COMMA_list1 of unit -> (TyVar list) + | tyvarseq1 of unit -> (TyVarseq) | tyvarseq of unit -> (TyVarseq) + | ty_COMMA_list2 of unit -> (Ty list) | tyseq of unit -> (Tyseq) + | COMMA_tyrow_opt of unit -> (TyRow option) + | tyrow_opt of unit -> (TyRow option) | tyrow of unit -> (TyRow) + | atty of unit -> (Ty) | consty of unit -> (Ty) + | ty_STAR_list of unit -> (Ty list) | tupty of unit -> (Ty) + | ty of unit -> (Ty) | COLON_ty_list1 of unit -> (Ty list) + | atpat_list2 of unit -> (AtPat list) + | atpat_list1 of unit -> (AtPat list) | pat of unit -> (Pat) + | AS_pat_opt of unit -> (Pat option) + | COLON_ty_opt of unit -> (Ty option) + | COMMA_patrow_opt of unit -> (PatRow option) + | patrow_opt of unit -> (PatRow option) + | patrow of unit -> (PatRow) + | pat_COMMA_list2 of unit -> (Pat list) + | pat_COMMA_list1 of unit -> (Pat list) + | pat_COMMA_list0 of unit -> (Pat list) | atpat' of unit -> (AtPat) + | atpat of unit -> (AtPat) + | AND_exbind_opt of unit -> (ExBind option) + | exbind of unit -> (ExBind) | OF_ty_opt of unit -> (Ty option) + | BAR_conbind_opt of unit -> (ConBind option) + | conbind of unit -> (ConBind) + | AND_datbind_opt of unit -> (DatBind option) + | datbind1 of unit -> (DatBind) | datbind0 of unit -> (DatBind) + | datbind of unit -> (DatBind) + | AND_typbind_opt of unit -> (TypBind option) + | typbind of unit -> (TypBind) | fmrule of unit -> (Fmrule) + | BAR_fmatch_opt of unit -> (Fmatch option) + | fmatch of unit -> (Fmatch) + | AND_fvalbind_opt of unit -> (FvalBind option) + | fvalbind of unit -> (FvalBind) + | AND_valbind_opt of unit -> (ValBind option) + | valbind of unit -> (ValBind) | d_opt of unit -> (int) + | longstrid_list1 of unit -> (longStrId list) + | vid_list1 of unit -> (VId list) + | WITHTYPE_typbind_opt of unit -> (TypBind option) + | dec1' of unit -> (Dec) | dec1 of unit -> (Dec) + | dec of unit -> (Dec) | mrule of unit -> (Mrule) + | BAR_match_opt of unit -> (Match option) + | match of unit -> (Match) | exp of unit -> (Exp) + | infexp of unit -> (InfExp) | appexp of unit -> (AppExp) + | COMMA_exprow_opt of unit -> (ExpRow option) + | exprow_opt of unit -> (ExpRow option) + | exprow of unit -> (ExpRow) + | exp_SEMICOLON_list2 of unit -> (Exp list) + | exp_SEMICOLON_list1 of unit -> (Exp list) + | exp_COMMA_list2 of unit -> (Exp list) + | exp_COMMA_list1 of unit -> (Exp list) + | exp_COMMA_list0 of unit -> (Exp list) | atexp of unit -> (AtExp) + | OP_opt of unit -> (Op) | longstrid of unit -> (longStrId) + | longtycon of unit -> (longTyCon) | longvid' of unit -> (longVId) + | longvid of unit -> (longVId) | funid of unit -> (FunId) + | sigid of unit -> (SigId) | strid of unit -> (StrId) + | tyvar of unit -> (TyVar) | tycon of unit -> (TyCon) + | vid' of unit -> (VId) | vid of unit -> (VId) + | lab of unit -> (Lab) | d of unit -> (int) + | scon of unit -> (SCon) +end +type svalue = MlyValue.svalue +type result = Program*Infix.InfEnv +end +structure EC= +struct +open LrTable +val is_keyword = +fn (T 1) => true | (T 2) => true | (T 3) => true | (T 4) => true | (T +5) => true | (T 6) => true | (T 7) => true | (T 8) => true | (T 9) + => true | (T 10) => true | (T 11) => true | (T 12) => true | (T 13) + => true | (T 14) => true | (T 15) => true | (T 16) => true | (T 17) + => true | (T 18) => true | (T 19) => true | (T 20) => true | (T 21) + => true | (T 22) => true | (T 23) => true | (T 24) => true | (T 25) + => true | (T 26) => true | (T 27) => true | (T 28) => true | (T 29) + => true | (T 30) => true | (T 31) => true | (T 32) => true | (T 49) + => true | (T 50) => true | (T 51) => true | (T 52) => true | (T 53) + => true | (T 54) => true | (T 55) => true | (T 56) => true | (T 57) + => true | _ => false +val preferred_change = +nil +val noShift = +fn (T 0) => true | _ => false +val showTerminal = +fn (T 0) => "EOF" + | (T 1) => "ABSTYPE" + | (T 2) => "AND" + | (T 3) => "ANDALSO" + | (T 4) => "AS" + | (T 5) => "CASE" + | (T 6) => "DO" + | (T 7) => "DATATYPE" + | (T 8) => "ELSE" + | (T 9) => "END" + | (T 10) => "EXCEPTION" + | (T 11) => "FN" + | (T 12) => "FUN" + | (T 13) => "HANDLE" + | (T 14) => "IF" + | (T 15) => "IN" + | (T 16) => "INFIX" + | (T 17) => "INFIXR" + | (T 18) => "LET" + | (T 19) => "LOCAL" + | (T 20) => "NONFIX" + | (T 21) => "OF" + | (T 22) => "OP" + | (T 23) => "OPEN" + | (T 24) => "ORELSE" + | (T 25) => "RAISE" + | (T 26) => "REC" + | (T 27) => "THEN" + | (T 28) => "TYPE" + | (T 29) => "VAL" + | (T 30) => "WITH" + | (T 31) => "WITHTYPE" + | (T 32) => "WHILE" + | (T 33) => "LPAR" + | (T 34) => "RPAR" + | (T 35) => "LBRACK" + | (T 36) => "RBRACK" + | (T 37) => "LBRACE" + | (T 38) => "RBRACE" + | (T 39) => "COMMA" + | (T 40) => "COLON" + | (T 41) => "SEMICOLON" + | (T 42) => "DOTS" + | (T 43) => "UNDERBAR" + | (T 44) => "BAR" + | (T 45) => "EQUALS" + | (T 46) => "DARROW" + | (T 47) => "ARROW" + | (T 48) => "HASH" + | (T 49) => "EQTYPE" + | (T 50) => "FUNCTOR" + | (T 51) => "INCLUDE" + | (T 52) => "SHARING" + | (T 53) => "SIG" + | (T 54) => "SIGNATURE" + | (T 55) => "STRUCT" + | (T 56) => "STRUCTURE" + | (T 57) => "WHERE" + | (T 58) => "COLONGREATER" + | (T 59) => "ZERO" + | (T 60) => "DIGIT" + | (T 61) => "NUMERIC" + | (T 62) => "INT" + | (T 63) => "WORD" + | (T 64) => "REAL" + | (T 65) => "STRING" + | (T 66) => "CHAR" + | (T 67) => "ALPHA" + | (T 68) => "SYMBOL" + | (T 69) => "STAR" + | (T 70) => "TYVAR" + | (T 71) => "ETYVAR" + | (T 72) => "LONGID" + | _ => "bogus-term" +local open Header in +val errtermvalue= +fn _ => MlyValue.VOID +end +val terms = (T 0) :: (T 1) :: (T 2) :: (T 3) :: (T 4) :: (T 5) :: (T 6 +) :: (T 7) :: (T 8) :: (T 9) :: (T 10) :: (T 11) :: (T 12) :: (T 13) + :: (T 14) :: (T 15) :: (T 16) :: (T 17) :: (T 18) :: (T 19) :: (T 20) + :: (T 21) :: (T 22) :: (T 23) :: (T 24) :: (T 25) :: (T 26) :: (T 27) + :: (T 28) :: (T 29) :: (T 30) :: (T 31) :: (T 32) :: (T 33) :: (T 34) + :: (T 35) :: (T 36) :: (T 37) :: (T 38) :: (T 39) :: (T 40) :: (T 41) + :: (T 42) :: (T 43) :: (T 44) :: (T 45) :: (T 46) :: (T 47) :: (T 48) + :: (T 49) :: (T 50) :: (T 51) :: (T 52) :: (T 53) :: (T 54) :: (T 55) + :: (T 56) :: (T 57) :: (T 58) :: (T 59) :: (T 69) :: nil +end +structure Actions = +struct +type int = Int.int +exception mlyAction of int +local open Header in +val actions = +fn (i392:int,defaultPos,stack, + (J0):arg) => +case (i392,stack) +of (0,rest671) => let val result=MlyValue.initInfix(fn _ => ( + initJandJ'(J0) )) + in (LrTable.NT 144,(result,defaultPos,defaultPos),rest671) end +| (1,rest671) => let val result=MlyValue.pushInfix(fn _ => ( pushJ() ) +) + in (LrTable.NT 145,(result,defaultPos,defaultPos),rest671) end +| (2,rest671) => let val result=MlyValue.popInfix(fn _ => ( popJ() )) + in (LrTable.NT 146,(result,defaultPos,defaultPos),rest671) end +| (3,rest671) => let val result=MlyValue.pushLocalInfix(fn _ => ( + pushJ'shiftJ() )) + in (LrTable.NT 147,(result,defaultPos,defaultPos),rest671) end +| (4,rest671) => let val result=MlyValue.popLocalInfix(fn _ => ( + popJandJ'() )) + in (LrTable.NT 148,(result,defaultPos,defaultPos),rest671) end +| (5,(_,(_,ZERO1left,ZERO1right))::rest671) => let val result= +MlyValue.scon(fn _ => ( SCon.fromInt 0 )) + in (LrTable.NT 0,(result,ZERO1left,ZERO1right),rest671) end +| (6,(_,(MlyValue.DIGIT DIGIT1,DIGIT1left,DIGIT1right))::rest671) => +let val result=MlyValue.scon(fn _ => let val DIGIT as DIGIT1=DIGIT1 () + in ( SCon.fromInt DIGIT ) end +) + in (LrTable.NT 0,(result,DIGIT1left,DIGIT1right),rest671) end +| (7,(_,(MlyValue.NUMERIC NUMERIC1,NUMERIC1left,NUMERIC1right)):: +rest671) => let val result=MlyValue.scon(fn _ => let val NUMERIC as +NUMERIC1=NUMERIC1 () + in ( SCon.fromInt NUMERIC ) end +) + in (LrTable.NT 0,(result,NUMERIC1left,NUMERIC1right),rest671) end +| (8,(_,(MlyValue.INT INT1,INT1left,INT1right))::rest671) => let val +result=MlyValue.scon(fn _ => let val INT as INT1=INT1 () + in ( SCon.fromInt INT ) end +) + in (LrTable.NT 0,(result,INT1left,INT1right),rest671) end +| (9,(_,(MlyValue.WORD WORD1,WORD1left,WORD1right))::rest671) => let +val result=MlyValue.scon(fn _ => let val WORD as WORD1=WORD1 () + in ( SCon.fromWord WORD ) end +) + in (LrTable.NT 0,(result,WORD1left,WORD1right),rest671) end +| (10,(_,(MlyValue.STRING STRING1,STRING1left,STRING1right))::rest671) + => let val result=MlyValue.scon(fn _ => let val STRING as STRING1= +STRING1 () + in ( SCon.fromString STRING ) end +) + in (LrTable.NT 0,(result,STRING1left,STRING1right),rest671) end +| (11,(_,(MlyValue.CHAR CHAR1,CHAR1left,CHAR1right))::rest671) => let +val result=MlyValue.scon(fn _ => let val CHAR as CHAR1=CHAR1 () + in ( SCon.fromChar CHAR ) end +) + in (LrTable.NT 0,(result,CHAR1left,CHAR1right),rest671) end +| (12,(_,(MlyValue.REAL REAL1,REAL1left,REAL1right))::rest671) => let +val result=MlyValue.scon(fn _ => let val REAL as REAL1=REAL1 () + in ( SCon.fromReal REAL ) end +) + in (LrTable.NT 0,(result,REAL1left,REAL1right),rest671) end +| (13,(_,(_,ZERO1left,ZERO1right))::rest671) => let val result= +MlyValue.d(fn _ => ( 0 )) + in (LrTable.NT 1,(result,ZERO1left,ZERO1right),rest671) end +| (14,(_,(MlyValue.DIGIT DIGIT1,DIGIT1left,DIGIT1right))::rest671) => +let val result=MlyValue.d(fn _ => let val DIGIT as DIGIT1=DIGIT1 () + in ( DIGIT ) end +) + in (LrTable.NT 1,(result,DIGIT1left,DIGIT1right),rest671) end +| (15,(_,(MlyValue.ALPHA ALPHA1,ALPHA1left,ALPHA1right))::rest671) => +let val result=MlyValue.lab(fn _ => let val ALPHA as ALPHA1=ALPHA1 () + in ( Lab.fromString ALPHA ) end +) + in (LrTable.NT 2,(result,ALPHA1left,ALPHA1right),rest671) end +| (16,(_,(MlyValue.SYMBOL SYMBOL1,SYMBOL1left,SYMBOL1right))::rest671) + => let val result=MlyValue.lab(fn _ => let val SYMBOL as SYMBOL1= +SYMBOL1 () + in ( Lab.fromString SYMBOL ) end +) + in (LrTable.NT 2,(result,SYMBOL1left,SYMBOL1right),rest671) end +| (17,(_,(_,STAR1left,STAR1right))::rest671) => let val result= +MlyValue.lab(fn _ => ( Lab.fromString "*" )) + in (LrTable.NT 2,(result,STAR1left,STAR1right),rest671) end +| (18,(_,(MlyValue.DIGIT DIGIT1,DIGIT1left,DIGIT1right))::rest671) => +let val result=MlyValue.lab(fn _ => let val DIGIT as DIGIT1=DIGIT1 () + in ( Lab.fromInt DIGIT ) end +) + in (LrTable.NT 2,(result,DIGIT1left,DIGIT1right),rest671) end +| (19,(_,(MlyValue.NUMERIC NUMERIC1,NUMERIC1left,NUMERIC1right)):: +rest671) => let val result=MlyValue.lab(fn _ => let val NUMERIC as +NUMERIC1=NUMERIC1 () + in ( Lab.fromInt NUMERIC ) end +) + in (LrTable.NT 2,(result,NUMERIC1left,NUMERIC1right),rest671) end +| (20,(_,(MlyValue.vid' vid'1,vid'1left,vid'1right))::rest671) => let +val result=MlyValue.vid(fn _ => let val vid' as vid'1=vid'1 () + in ( vid' ) end +) + in (LrTable.NT 3,(result,vid'1left,vid'1right),rest671) end +| (21,(_,(_,EQUALS1left,EQUALS1right))::rest671) => let val result= +MlyValue.vid(fn _ => ( VId.fromString "=" )) + in (LrTable.NT 3,(result,EQUALS1left,EQUALS1right),rest671) end +| (22,(_,(MlyValue.ALPHA ALPHA1,ALPHA1left,ALPHA1right))::rest671) => +let val result=MlyValue.vid'(fn _ => let val ALPHA as ALPHA1=ALPHA1 () + in ( VId.fromString ALPHA ) end +) + in (LrTable.NT 4,(result,ALPHA1left,ALPHA1right),rest671) end +| (23,(_,(MlyValue.SYMBOL SYMBOL1,SYMBOL1left,SYMBOL1right))::rest671) + => let val result=MlyValue.vid'(fn _ => let val SYMBOL as SYMBOL1= +SYMBOL1 () + in ( VId.fromString SYMBOL ) end +) + in (LrTable.NT 4,(result,SYMBOL1left,SYMBOL1right),rest671) end +| (24,(_,(_,STAR1left,STAR1right))::rest671) => let val result= +MlyValue.vid'(fn _ => ( VId.fromString "*" )) + in (LrTable.NT 4,(result,STAR1left,STAR1right),rest671) end +| (25,(_,(MlyValue.ALPHA ALPHA1,ALPHA1left,ALPHA1right))::rest671) => +let val result=MlyValue.tycon(fn _ => let val ALPHA as ALPHA1=ALPHA1 +() + in ( TyCon.fromString ALPHA ) end +) + in (LrTable.NT 5,(result,ALPHA1left,ALPHA1right),rest671) end +| (26,(_,(MlyValue.SYMBOL SYMBOL1,SYMBOL1left,SYMBOL1right))::rest671) + => let val result=MlyValue.tycon(fn _ => let val SYMBOL as SYMBOL1= +SYMBOL1 () + in ( TyCon.fromString SYMBOL ) end +) + in (LrTable.NT 5,(result,SYMBOL1left,SYMBOL1right),rest671) end +| (27,(_,(MlyValue.TYVAR TYVAR1,TYVAR1left,TYVAR1right))::rest671) => +let val result=MlyValue.tyvar(fn _ => let val TYVAR as TYVAR1=TYVAR1 +() + in ( TyVar.fromString TYVAR ) end +) + in (LrTable.NT 6,(result,TYVAR1left,TYVAR1right),rest671) end +| (28,(_,(MlyValue.ALPHA ALPHA1,ALPHA1left,ALPHA1right))::rest671) => +let val result=MlyValue.strid(fn _ => let val ALPHA as ALPHA1=ALPHA1 +() + in ( StrId.fromString ALPHA ) end +) + in (LrTable.NT 7,(result,ALPHA1left,ALPHA1right),rest671) end +| (29,(_,(MlyValue.ALPHA ALPHA1,ALPHA1left,ALPHA1right))::rest671) => +let val result=MlyValue.sigid(fn _ => let val ALPHA as ALPHA1=ALPHA1 +() + in ( SigId.fromString ALPHA ) end +) + in (LrTable.NT 8,(result,ALPHA1left,ALPHA1right),rest671) end +| (30,(_,(MlyValue.ALPHA ALPHA1,ALPHA1left,ALPHA1right))::rest671) => +let val result=MlyValue.funid(fn _ => let val ALPHA as ALPHA1=ALPHA1 +() + in ( FunId.fromString ALPHA ) end +) + in (LrTable.NT 9,(result,ALPHA1left,ALPHA1right),rest671) end +| (31,(_,(MlyValue.longvid' longvid'1,longvid'1left,longvid'1right)):: +rest671) => let val result=MlyValue.longvid(fn _ => let val longvid' + as longvid'1=longvid'1 () + in ( longvid' ) end +) + in (LrTable.NT 10,(result,longvid'1left,longvid'1right),rest671) end +| (32,(_,(_,EQUALS1left,EQUALS1right))::rest671) => let val result= +MlyValue.longvid(fn _ => ( LongVId.fromId(VId.fromString "=") )) + in (LrTable.NT 10,(result,EQUALS1left,EQUALS1right),rest671) end +| (33,(_,(MlyValue.vid' vid'1,vid'1left,vid'1right))::rest671) => let +val result=MlyValue.longvid'(fn _ => let val vid' as vid'1=vid'1 () + in ( LongVId.fromId vid' ) end +) + in (LrTable.NT 11,(result,vid'1left,vid'1right),rest671) end +| (34,(_,(MlyValue.LONGID LONGID1,LONGID1left,LONGID1right))::rest671) + => let val result=MlyValue.longvid'(fn _ => let val LONGID as LONGID1 +=LONGID1 () + in ( LongVId.implode(toLongId VId.fromString LONGID) ) end +) + in (LrTable.NT 11,(result,LONGID1left,LONGID1right),rest671) end +| (35,(_,(MlyValue.tycon tycon1,tycon1left,tycon1right))::rest671) => +let val result=MlyValue.longtycon(fn _ => let val tycon as tycon1= +tycon1 () + in ( LongTyCon.fromId tycon ) end +) + in (LrTable.NT 12,(result,tycon1left,tycon1right),rest671) end +| (36,(_,(MlyValue.LONGID LONGID1,LONGID1left,LONGID1right))::rest671) + => let val result=MlyValue.longtycon(fn _ => let val LONGID as +LONGID1=LONGID1 () + in ( LongTyCon.implode(toLongId TyCon.fromString LONGID) ) end +) + in (LrTable.NT 12,(result,LONGID1left,LONGID1right),rest671) end +| (37,(_,(MlyValue.strid strid1,strid1left,strid1right))::rest671) => +let val result=MlyValue.longstrid(fn _ => let val strid as strid1= +strid1 () + in ( LongStrId.fromId strid ) end +) + in (LrTable.NT 13,(result,strid1left,strid1right),rest671) end +| (38,(_,(MlyValue.LONGID LONGID1,LONGID1left,LONGID1right))::rest671) + => let val result=MlyValue.longstrid(fn _ => let val LONGID as +LONGID1=LONGID1 () + in ( LongStrId.implode(toLongId StrId.fromString LONGID) ) end +) + in (LrTable.NT 13,(result,LONGID1left,LONGID1right),rest671) end +| (39,(_,(_,OP1left,OP1right))::rest671) => let val result= +MlyValue.OP_opt(fn _ => ( WITHOp )) + in (LrTable.NT 14,(result,OP1left,OP1right),rest671) end +| (40,rest671) => let val result=MlyValue.OP_opt(fn _ => ( SANSOp )) + in (LrTable.NT 14,(result,defaultPos,defaultPos),rest671) end +| (41,(_,(MlyValue.scon scon1,sconleft as scon1left,sconright as +scon1right))::rest671) => let val result=MlyValue.atexp(fn _ => let +val scon as scon1=scon1 () + in ( SCONAtExp(I(sconleft,sconright), scon) ) end +) + in (LrTable.NT 15,(result,scon1left,scon1right),rest671) end +| (42,(_,(MlyValue.longvid longvid1,_,longvidright as longvid1right)) +::(_,(MlyValue.OP_opt OP_opt1,OP_optleft as OP_opt1left,_))::rest671) + => let val result=MlyValue.atexp(fn _ => let val OP_opt as OP_opt1= +OP_opt1 () +val longvid as longvid1=longvid1 () + in ( + LONGVIDAtExp(I(OP_optleft,longvidright), + OP_opt, longvid) +) end +) + in (LrTable.NT 15,(result,OP_opt1left,longvid1right),rest671) end +| (43,(_,(_,_,RBRACEright as RBRACE1right))::(_,(MlyValue.exprow_opt +exprow_opt1,_,_))::(_,(_,LBRACEleft as LBRACE1left,_))::rest671) => +let val result=MlyValue.atexp(fn _ => let val exprow_opt as +exprow_opt1=exprow_opt1 () + in ( RECORDAtExp(I(LBRACEleft,RBRACEright), exprow_opt) ) end +) + in (LrTable.NT 15,(result,LBRACE1left,RBRACE1right),rest671) end +| (44,(_,(MlyValue.lab lab1,_,labright as lab1right))::(_,(_,HASHleft + as HASH1left,_))::rest671) => let val result=MlyValue.atexp(fn _ => +let val lab as lab1=lab1 () + in ( HASHAtExp(I(HASHleft,labright), lab) ) end +) + in (LrTable.NT 15,(result,HASH1left,lab1right),rest671) end +| (45,(_,(_,_,RPARright as RPAR1right))::(_,(_,LPARleft as LPAR1left,_ +))::rest671) => let val result=MlyValue.atexp(fn _ => ( + UNITAtExp(I(LPARleft,RPARright)) )) + in (LrTable.NT 15,(result,LPAR1left,RPAR1right),rest671) end +| (46,(_,(_,_,RPARright as RPAR1right))::(_,(MlyValue.exp_COMMA_list2 +exp_COMMA_list21,_,_))::(_,(_,LPARleft as LPAR1left,_))::rest671) => +let val result=MlyValue.atexp(fn _ => let val exp_COMMA_list2 as +exp_COMMA_list21=exp_COMMA_list21 () + in ( TUPLEAtExp(I(LPARleft,RPARright), exp_COMMA_list2) ) end +) + in (LrTable.NT 15,(result,LPAR1left,RPAR1right),rest671) end +| (47,(_,(_,_,RBRACKright as RBRACK1right))::(_,( +MlyValue.exp_COMMA_list0 exp_COMMA_list01,_,_))::(_,(_,LBRACKleft as +LBRACK1left,_))::rest671) => let val result=MlyValue.atexp(fn _ => +let val exp_COMMA_list0 as exp_COMMA_list01=exp_COMMA_list01 () + in ( LISTAtExp(I(LBRACKleft,RBRACKright), + exp_COMMA_list0 )) + end +) + in (LrTable.NT 15,(result,LBRACK1left,RBRACK1right),rest671) end +| (48,(_,(_,_,RPARright as RPAR1right))::(_,( +MlyValue.exp_SEMICOLON_list2 exp_SEMICOLON_list21,_,_))::(_,(_, +LPARleft as LPAR1left,_))::rest671) => let val result=MlyValue.atexp( +fn _ => let val exp_SEMICOLON_list2 as exp_SEMICOLON_list21= +exp_SEMICOLON_list21 () + in ( SEQAtExp(I(LPARleft,RPARright), exp_SEMICOLON_list2) ) end +) + in (LrTable.NT 15,(result,LPAR1left,RPAR1right),rest671) end +| (49,(_,(_,_,ENDright as END1right))::(_,(MlyValue.popInfix popInfix1 +,_,_))::(_,(MlyValue.exp_SEMICOLON_list1 exp_SEMICOLON_list11,_,_))::_ +::(_,(MlyValue.dec dec1,_,_))::(_,(MlyValue.pushInfix pushInfix1,_,_)) +::(_,(_,LETleft as LET1left,_))::rest671) => let val result= +MlyValue.atexp(fn _ => let val pushInfix1=pushInfix1 () +val dec as dec1=dec1 () +val exp_SEMICOLON_list1 as exp_SEMICOLON_list11=exp_SEMICOLON_list11 +() +val popInfix1=popInfix1 () + in ( LETAtExp(I(LETleft,ENDright), + dec, exp_SEMICOLON_list1) ) + end +) + in (LrTable.NT 15,(result,LET1left,END1right),rest671) end +| (50,(_,(_,_,RPARright as RPAR1right))::(_,(MlyValue.exp exp1,_,_)):: +(_,(_,LPARleft as LPAR1left,_))::rest671) => let val result= +MlyValue.atexp(fn _ => let val exp as exp1=exp1 () + in ( PARAtExp(I(LPARleft,RPARright), exp) ) end +) + in (LrTable.NT 15,(result,LPAR1left,RPAR1right),rest671) end +| (51,(_,(MlyValue.exp_COMMA_list1 exp_COMMA_list11, +exp_COMMA_list11left,exp_COMMA_list11right))::rest671) => let val +result=MlyValue.exp_COMMA_list0(fn _ => let val exp_COMMA_list1 as +exp_COMMA_list11=exp_COMMA_list11 () + in ( exp_COMMA_list1 ) end +) + in (LrTable.NT 16,(result,exp_COMMA_list11left,exp_COMMA_list11right) +,rest671) end +| (52,rest671) => let val result=MlyValue.exp_COMMA_list0(fn _ => ( + [] )) + in (LrTable.NT 16,(result,defaultPos,defaultPos),rest671) end +| (53,(_,(MlyValue.exp_COMMA_list1 exp_COMMA_list11,_, +exp_COMMA_list11right))::_::(_,(MlyValue.exp exp1,exp1left,_)):: +rest671) => let val result=MlyValue.exp_COMMA_list1(fn _ => let val +exp as exp1=exp1 () +val exp_COMMA_list1 as exp_COMMA_list11=exp_COMMA_list11 () + in ( exp::exp_COMMA_list1 ) end +) + in (LrTable.NT 17,(result,exp1left,exp_COMMA_list11right),rest671) + end +| (54,(_,(MlyValue.exp exp1,exp1left,exp1right))::rest671) => let val +result=MlyValue.exp_COMMA_list1(fn _ => let val exp as exp1=exp1 () + in ( exp::[] ) end +) + in (LrTable.NT 17,(result,exp1left,exp1right),rest671) end +| (55,(_,(MlyValue.exp_COMMA_list1 exp_COMMA_list11,_, +exp_COMMA_list11right))::_::(_,(MlyValue.exp exp1,exp1left,_)):: +rest671) => let val result=MlyValue.exp_COMMA_list2(fn _ => let val +exp as exp1=exp1 () +val exp_COMMA_list1 as exp_COMMA_list11=exp_COMMA_list11 () + in ( exp::exp_COMMA_list1 ) end +) + in (LrTable.NT 18,(result,exp1left,exp_COMMA_list11right),rest671) + end +| (56,(_,(MlyValue.exp_SEMICOLON_list1 exp_SEMICOLON_list11,_, +exp_SEMICOLON_list11right))::_::(_,(MlyValue.exp exp1,exp1left,_)):: +rest671) => let val result=MlyValue.exp_SEMICOLON_list1(fn _ => let +val exp as exp1=exp1 () +val exp_SEMICOLON_list1 as exp_SEMICOLON_list11=exp_SEMICOLON_list11 +() + in ( exp::exp_SEMICOLON_list1 ) end +) + in (LrTable.NT 19,(result,exp1left,exp_SEMICOLON_list11right),rest671 +) end +| (57,(_,(MlyValue.exp exp1,exp1left,exp1right))::rest671) => let val +result=MlyValue.exp_SEMICOLON_list1(fn _ => let val exp as exp1=exp1 +() + in ( exp::[] ) end +) + in (LrTable.NT 19,(result,exp1left,exp1right),rest671) end +| (58,(_,(MlyValue.exp_SEMICOLON_list2 exp_SEMICOLON_list21,_, +exp_SEMICOLON_list21right))::_::(_,(MlyValue.exp exp1,exp1left,_)):: +rest671) => let val result=MlyValue.exp_SEMICOLON_list2(fn _ => let +val exp as exp1=exp1 () +val exp_SEMICOLON_list2 as exp_SEMICOLON_list21=exp_SEMICOLON_list21 +() + in ( exp::exp_SEMICOLON_list2 ) end +) + in (LrTable.NT 20,(result,exp1left,exp_SEMICOLON_list21right),rest671 +) end +| (59,(_,(MlyValue.exp exp2,_,exp2right))::_::(_,(MlyValue.exp exp1, +exp1left,_))::rest671) => let val result=MlyValue.exp_SEMICOLON_list2( +fn _ => let val exp1=exp1 () +val exp2=exp2 () + in ( [exp1, exp2] ) end +) + in (LrTable.NT 20,(result,exp1left,exp2right),rest671) end +| (60,(_,(MlyValue.COMMA_exprow_opt COMMA_exprow_opt1,_, +COMMA_exprow_optright as COMMA_exprow_opt1right))::(_,(MlyValue.exp +exp1,_,_))::_::(_,(MlyValue.lab lab1,lableft as lab1left,_))::rest671) + => let val result=MlyValue.exprow(fn _ => let val lab as lab1=lab1 () +val exp as exp1=exp1 () +val COMMA_exprow_opt as COMMA_exprow_opt1=COMMA_exprow_opt1 () + in ( + ExpRow(I(lableft,COMMA_exprow_optright), + lab, exp, COMMA_exprow_opt) +) end +) + in (LrTable.NT 21,(result,lab1left,COMMA_exprow_opt1right),rest671) + end +| (61,(_,(MlyValue.exprow exprow1,_,exprow1right))::(_,(_,COMMA1left,_ +))::rest671) => let val result=MlyValue.COMMA_exprow_opt(fn _ => let +val exprow as exprow1=exprow1 () + in ( SOME exprow ) end +) + in (LrTable.NT 23,(result,COMMA1left,exprow1right),rest671) end +| (62,rest671) => let val result=MlyValue.COMMA_exprow_opt(fn _ => ( + NONE )) + in (LrTable.NT 23,(result,defaultPos,defaultPos),rest671) end +| (63,(_,(MlyValue.exprow exprow1,exprow1left,exprow1right))::rest671) + => let val result=MlyValue.exprow_opt(fn _ => let val exprow as +exprow1=exprow1 () + in ( SOME exprow ) end +) + in (LrTable.NT 22,(result,exprow1left,exprow1right),rest671) end +| (64,rest671) => let val result=MlyValue.exprow_opt(fn _ => ( NONE )) + in (LrTable.NT 22,(result,defaultPos,defaultPos),rest671) end +| (65,(_,(MlyValue.atexp atexp1,atexp1left,atexp1right))::rest671) => +let val result=MlyValue.appexp(fn _ => let val atexp as atexp1=atexp1 +() + in ( atexp::[] ) end +) + in (LrTable.NT 24,(result,atexp1left,atexp1right),rest671) end +| (66,(_,(MlyValue.atexp atexp1,_,atexp1right))::(_,(MlyValue.appexp +appexp1,appexp1left,_))::rest671) => let val result=MlyValue.appexp( +fn _ => let val appexp as appexp1=appexp1 () +val atexp as atexp1=atexp1 () + in ( atexp::appexp ) end +) + in (LrTable.NT 24,(result,appexp1left,atexp1right),rest671) end +| (67,(_,(MlyValue.appexp appexp1,appexp1left,appexp1right))::rest671) + => let val result=MlyValue.infexp(fn _ => let val appexp as appexp1= +appexp1 () + in ( Infix.parseExp(!J, List.rev appexp) ) end +) + in (LrTable.NT 25,(result,appexp1left,appexp1right),rest671) end +| (68,(_,(MlyValue.infexp infexp1,infexp1left,infexp1right))::rest671) + => let val result=MlyValue.exp(fn _ => let val infexp as infexp1= +infexp1 () + in ( infexp ) end +) + in (LrTable.NT 26,(result,infexp1left,infexp1right),rest671) end +| (69,(_,(MlyValue.ty ty1,_,tyright as ty1right))::_::(_,(MlyValue.exp + exp1,expleft as exp1left,_))::rest671) => let val result=MlyValue.exp +(fn _ => let val exp as exp1=exp1 () +val ty as ty1=ty1 () + in ( TYPEDExp(I(expleft,tyright), exp, ty) ) end +) + in (LrTable.NT 26,(result,exp1left,ty1right),rest671) end +| (70,(_,(MlyValue.exp exp2,_,exp2right))::_::(_,(MlyValue.exp exp1, +exp1left,_))::rest671) => let val result=MlyValue.exp(fn _ => let val +exp1=exp1 () +val exp2=exp2 () + in ( ANDALSOExp(I(exp1left,exp2right), exp1, exp2)) end +) + in (LrTable.NT 26,(result,exp1left,exp2right),rest671) end +| (71,(_,(MlyValue.exp exp2,_,exp2right))::_::(_,(MlyValue.exp exp1, +exp1left,_))::rest671) => let val result=MlyValue.exp(fn _ => let val +exp1=exp1 () +val exp2=exp2 () + in ( ORELSEExp(I(exp1left,exp2right), exp1, exp2) ) end +) + in (LrTable.NT 26,(result,exp1left,exp2right),rest671) end +| (72,(_,(MlyValue.match match1,_,matchright as match1right))::_::(_,( +MlyValue.exp exp1,expleft as exp1left,_))::rest671) => let val result= +MlyValue.exp(fn _ => let val exp as exp1=exp1 () +val match as match1=match1 () + in ( HANDLEExp(I(expleft,matchright), exp, match) ) end +) + in (LrTable.NT 26,(result,exp1left,match1right),rest671) end +| (73,(_,(MlyValue.exp exp1,_,expright as exp1right))::(_,(_,RAISEleft + as RAISE1left,_))::rest671) => let val result=MlyValue.exp(fn _ => +let val exp as exp1=exp1 () + in ( RAISEExp(I(RAISEleft,expright), exp) ) end +) + in (LrTable.NT 26,(result,RAISE1left,exp1right),rest671) end +| (74,(_,(MlyValue.exp exp3,_,exp3right))::_::(_,(MlyValue.exp exp2,_, +_))::_::(_,(MlyValue.exp exp1,_,_))::(_,(_,IFleft as IF1left,_)):: +rest671) => let val result=MlyValue.exp(fn _ => let val exp1=exp1 () +val exp2=exp2 () +val exp3=exp3 () + in ( IFExp(I(IFleft,exp3right), exp1, exp2, exp3) ) end +) + in (LrTable.NT 26,(result,IF1left,exp3right),rest671) end +| (75,(_,(MlyValue.exp exp2,_,exp2right))::_::(_,(MlyValue.exp exp1,_, +_))::(_,(_,WHILEleft as WHILE1left,_))::rest671) => let val result= +MlyValue.exp(fn _ => let val exp1=exp1 () +val exp2=exp2 () + in ( WHILEExp(I(WHILEleft,exp2right), exp1, exp2) ) end +) + in (LrTable.NT 26,(result,WHILE1left,exp2right),rest671) end +| (76,(_,(MlyValue.match match1,_,matchright as match1right))::_::(_,( +MlyValue.exp exp1,_,_))::(_,(_,CASEleft as CASE1left,_))::rest671) => +let val result=MlyValue.exp(fn _ => let val exp as exp1=exp1 () +val match as match1=match1 () + in ( CASEExp(I(CASEleft,matchright), exp, match) ) end +) + in (LrTable.NT 26,(result,CASE1left,match1right),rest671) end +| (77,(_,(MlyValue.match match1,_,matchright as match1right))::(_,(_, +FNleft as FN1left,_))::rest671) => let val result=MlyValue.exp(fn _ + => let val match as match1=match1 () + in ( FNExp(I(FNleft,matchright), match) ) end +) + in (LrTable.NT 26,(result,FN1left,match1right),rest671) end +| (78,(_,(MlyValue.BAR_match_opt BAR_match_opt1,_,BAR_match_optright + as BAR_match_opt1right))::(_,(MlyValue.mrule mrule1,mruleleft as +mrule1left,_))::rest671) => let val result=MlyValue.match(fn _ => let +val mrule as mrule1=mrule1 () +val BAR_match_opt as BAR_match_opt1=BAR_match_opt1 () + in ( + Match(I(mruleleft,BAR_match_optright), + mrule, BAR_match_opt) ) + end +) + in (LrTable.NT 27,(result,mrule1left,BAR_match_opt1right),rest671) + end +| (79,(_,(MlyValue.match match1,_,match1right))::(_,(_,BAR1left,_)):: +rest671) => let val result=MlyValue.BAR_match_opt(fn _ => let val +match as match1=match1 () + in ( SOME match ) end +) + in (LrTable.NT 28,(result,BAR1left,match1right),rest671) end +| (80,rest671) => let val result=MlyValue.BAR_match_opt(fn _ => ( + NONE )) + in (LrTable.NT 28,(result,defaultPos,defaultPos),rest671) end +| (81,(_,(MlyValue.exp exp1,_,expright as exp1right))::_::(_,( +MlyValue.pat pat1,patleft as pat1left,_))::rest671) => let val result= +MlyValue.mrule(fn _ => let val pat as pat1=pat1 () +val exp as exp1=exp1 () + in ( Mrule(I(patleft,expright), pat, exp) ) end +) + in (LrTable.NT 29,(result,pat1left,exp1right),rest671) end +| (82,(_,(MlyValue.dec1 dec11,dec11left,dec11right))::rest671) => let +val result=MlyValue.dec(fn _ => let val dec1 as dec11=dec11 () + in ( dec1 ) end +) + in (LrTable.NT 30,(result,dec11left,dec11right),rest671) end +| (83,rest671) => let val result=MlyValue.dec(fn _ => ( + EMPTYDec(I(defaultPos,defaultPos)) )) + in (LrTable.NT 30,(result,defaultPos,defaultPos),rest671) end +| (84,(_,(MlyValue.dec1' dec1'1,dec1'1left,dec1'1right))::rest671) => +let val result=MlyValue.dec1(fn _ => let val dec1' as dec1'1=dec1'1 () + in ( dec1' ) end +) + in (LrTable.NT 31,(result,dec1'1left,dec1'1right),rest671) end +| (85,(_,(_,_,ENDright as END1right))::(_,(MlyValue.popLocalInfix +popLocalInfix1,_,_))::(_,(MlyValue.dec dec2,_,_))::(_,( +MlyValue.pushLocalInfix pushLocalInfix1,_,_))::_::(_,(MlyValue.dec +dec1,_,_))::(_,(MlyValue.pushInfix pushInfix1,_,_))::(_,(_,LOCALleft + as LOCAL1left,_))::rest671) => let val result=MlyValue.dec1(fn _ => +let val pushInfix1=pushInfix1 () +val dec1=dec1 () +val pushLocalInfix1=pushLocalInfix1 () +val dec2=dec2 () +val popLocalInfix1=popLocalInfix1 () + in ( LOCALDec(I(LOCALleft,ENDright), dec1, dec2) ) end +) + in (LrTable.NT 31,(result,LOCAL1left,END1right),rest671) end +| (86,(_,(MlyValue.dec1 dec12,_,dec12right))::(_,(MlyValue.dec1 dec11, +dec11left,_))::rest671) => let val result=MlyValue.dec1(fn _ => let +val dec11=dec11 () +val dec12=dec12 () + in ( SEQDec(I(dec11left,dec12right), dec11, dec12) ) end +) + in (LrTable.NT 31,(result,dec11left,dec12right),rest671) end +| (87,(_,(_,SEMICOLON1left,SEMICOLON1right))::rest671) => let val +result=MlyValue.dec1(fn _ => ( EMPTYDec(I(defaultPos,defaultPos)) )) + in (LrTable.NT 31,(result,SEMICOLON1left,SEMICOLON1right),rest671) + end +| (88,(_,(MlyValue.valbind valbind1,_,valbindright as valbind1right)) +::(_,(_,VALleft as VAL1left,_))::rest671) => let val result= +MlyValue.dec1'(fn _ => let val valbind as valbind1=valbind1 () + in ( + VALDec(I(VALleft,valbindright), + TyVarseq(I(defaultPos,defaultPos), []), valbind) +) end +) + in (LrTable.NT 32,(result,VAL1left,valbind1right),rest671) end +| (89,(_,(MlyValue.valbind valbind1,_,valbindright as valbind1right)) +::(_,(MlyValue.tyvarseq1 tyvarseq11,_,_))::(_,(_,VALleft as VAL1left,_ +))::rest671) => let val result=MlyValue.dec1'(fn _ => let val +tyvarseq1 as tyvarseq11=tyvarseq11 () +val valbind as valbind1=valbind1 () + in ( VALDec(I(VALleft,valbindright), tyvarseq1, valbind) ) end +) + in (LrTable.NT 32,(result,VAL1left,valbind1right),rest671) end +| (90,(_,(MlyValue.fvalbind fvalbind1,_,fvalbindright as +fvalbind1right))::(_,(_,FUNleft as FUN1left,_))::rest671) => let val +result=MlyValue.dec1'(fn _ => let val fvalbind as fvalbind1=fvalbind1 +() + in ( + FUNDec(I(FUNleft,fvalbindright), + TyVarseq(I(defaultPos,defaultPos), []), fvalbind) +) end +) + in (LrTable.NT 32,(result,FUN1left,fvalbind1right),rest671) end +| (91,(_,(MlyValue.fvalbind fvalbind1,_,fvalbindright as +fvalbind1right))::(_,(MlyValue.tyvarseq1 tyvarseq11,_,_))::(_,(_, +FUNleft as FUN1left,_))::rest671) => let val result=MlyValue.dec1'(fn +_ => let val tyvarseq1 as tyvarseq11=tyvarseq11 () +val fvalbind as fvalbind1=fvalbind1 () + in ( FUNDec(I(FUNleft,fvalbindright), tyvarseq1, fvalbind)) end +) + in (LrTable.NT 32,(result,FUN1left,fvalbind1right),rest671) end +| (92,(_,(MlyValue.typbind typbind1,_,typbindright as typbind1right)) +::(_,(_,TYPEleft as TYPE1left,_))::rest671) => let val result= +MlyValue.dec1'(fn _ => let val typbind as typbind1=typbind1 () + in ( TYPEDec(I(TYPEleft,typbindright), typbind) ) end +) + in (LrTable.NT 32,(result,TYPE1left,typbind1right),rest671) end +| (93,(_,(MlyValue.WITHTYPE_typbind_opt WITHTYPE_typbind_opt1,_, +WITHTYPE_typbind_optright as WITHTYPE_typbind_opt1right))::(_,( +MlyValue.datbind0 datbind01,_,_))::(_,(_,DATATYPEleft as DATATYPE1left +,_))::rest671) => let val result=MlyValue.dec1'(fn _ => let val +datbind0 as datbind01=datbind01 () +val WITHTYPE_typbind_opt as WITHTYPE_typbind_opt1= +WITHTYPE_typbind_opt1 () + in ( + DATATYPEDec(I(DATATYPEleft,WITHTYPE_typbind_optright), + datbind0, WITHTYPE_typbind_opt) +) end +) + in (LrTable.NT 32,(result,DATATYPE1left,WITHTYPE_typbind_opt1right), +rest671) end +| (94,(_,(MlyValue.WITHTYPE_typbind_opt WITHTYPE_typbind_opt1,_, +WITHTYPE_typbind_optright as WITHTYPE_typbind_opt1right))::(_,( +MlyValue.datbind1 datbind11,_,_))::(_,(_,DATATYPEleft as DATATYPE1left +,_))::rest671) => let val result=MlyValue.dec1'(fn _ => let val +datbind1 as datbind11=datbind11 () +val WITHTYPE_typbind_opt as WITHTYPE_typbind_opt1= +WITHTYPE_typbind_opt1 () + in ( + DATATYPEDec(I(DATATYPEleft,WITHTYPE_typbind_optright), + datbind1, WITHTYPE_typbind_opt) +) end +) + in (LrTable.NT 32,(result,DATATYPE1left,WITHTYPE_typbind_opt1right), +rest671) end +| (95,(_,(MlyValue.longtycon longtycon1,_,longtyconright as +longtycon1right))::_::_::(_,(MlyValue.tycon tycon1,_,_))::(_,(_, +DATATYPEleft as DATATYPE1left,_))::rest671) => let val result= +MlyValue.dec1'(fn _ => let val tycon as tycon1=tycon1 () +val longtycon as longtycon1=longtycon1 () + in ( + REPLICATIONDec(I(DATATYPEleft,longtyconright), + tycon, longtycon) +) end +) + in (LrTable.NT 32,(result,DATATYPE1left,longtycon1right),rest671) end +| (96,(_,(_,_,ENDright as END1right))::(_,(MlyValue.dec dec1,_,_))::_ +::(_,(MlyValue.WITHTYPE_typbind_opt WITHTYPE_typbind_opt1,_,_))::(_,( +MlyValue.datbind datbind1,_,_))::(_,(_,ABSTYPEleft as ABSTYPE1left,_)) +::rest671) => let val result=MlyValue.dec1'(fn _ => let val datbind + as datbind1=datbind1 () +val WITHTYPE_typbind_opt as WITHTYPE_typbind_opt1= +WITHTYPE_typbind_opt1 () +val dec as dec1=dec1 () + in ( + ABSTYPEDec(I(ABSTYPEleft,ENDright), datbind, + WITHTYPE_typbind_opt, dec) +) end +) + in (LrTable.NT 32,(result,ABSTYPE1left,END1right),rest671) end +| (97,(_,(MlyValue.exbind exbind1,_,exbindright as exbind1right))::(_, +(_,EXCEPTIONleft as EXCEPTION1left,_))::rest671) => let val result= +MlyValue.dec1'(fn _ => let val exbind as exbind1=exbind1 () + in ( EXCEPTIONDec(I(EXCEPTIONleft,exbindright), exbind) ) end +) + in (LrTable.NT 32,(result,EXCEPTION1left,exbind1right),rest671) end +| (98,(_,(MlyValue.longstrid_list1 longstrid_list11,_, +longstrid_list1right as longstrid_list11right))::(_,(_,OPENleft as +OPEN1left,_))::rest671) => let val result=MlyValue.dec1'(fn _ => let +val longstrid_list1 as longstrid_list11=longstrid_list11 () + in ( + OPENDec(I(OPENleft,longstrid_list1right), + longstrid_list1) ) + end +) + in (LrTable.NT 32,(result,OPEN1left,longstrid_list11right),rest671) + end +| (99,(_,(MlyValue.vid_list1 vid_list11,_,vid_list1right as +vid_list11right))::(_,(MlyValue.d_opt d_opt1,_,_))::(_,(_,INFIXleft + as INFIX1left,_))::rest671) => let val result=MlyValue.dec1'(fn _ => +let val d_opt as d_opt1=d_opt1 () +val vid_list1 as vid_list11=vid_list11 () + in ( + assignInfix((Infix.LEFT, d_opt), vid_list1); + EMPTYDec(I(INFIXleft,vid_list1right)) +) end +) + in (LrTable.NT 32,(result,INFIX1left,vid_list11right),rest671) end +| (100,(_,(MlyValue.vid_list1 vid_list11,_,vid_list1right as +vid_list11right))::(_,(MlyValue.d_opt d_opt1,_,_))::(_,(_,INFIXRleft + as INFIXR1left,_))::rest671) => let val result=MlyValue.dec1'(fn _ + => let val d_opt as d_opt1=d_opt1 () +val vid_list1 as vid_list11=vid_list11 () + in ( + assignInfix((Infix.RIGHT, d_opt), vid_list1); + EMPTYDec(I(INFIXRleft,vid_list1right)) +) end +) + in (LrTable.NT 32,(result,INFIXR1left,vid_list11right),rest671) end +| (101,(_,(MlyValue.vid_list1 vid_list11,_,vid_list1right as +vid_list11right))::(_,(_,NONFIXleft as NONFIX1left,_))::rest671) => +let val result=MlyValue.dec1'(fn _ => let val vid_list1 as vid_list11= +vid_list11 () + in ( + cancelInfix(vid_list1); + EMPTYDec(I(NONFIXleft,vid_list1right)) ) + end +) + in (LrTable.NT 32,(result,NONFIX1left,vid_list11right),rest671) end +| (102,(_,(MlyValue.typbind typbind1,_,typbind1right))::(_,(_, +WITHTYPE1left,_))::rest671) => let val result= +MlyValue.WITHTYPE_typbind_opt(fn _ => let val typbind as typbind1= +typbind1 () + in ( SOME typbind ) end +) + in (LrTable.NT 33,(result,WITHTYPE1left,typbind1right),rest671) end +| (103,rest671) => let val result=MlyValue.WITHTYPE_typbind_opt(fn _ + => ( NONE )) + in (LrTable.NT 33,(result,defaultPos,defaultPos),rest671) end +| (104,(_,(MlyValue.vid_list1 vid_list11,_,vid_list11right))::(_,( +MlyValue.vid vid1,vid1left,_))::rest671) => let val result= +MlyValue.vid_list1(fn _ => let val vid as vid1=vid1 () +val vid_list1 as vid_list11=vid_list11 () + in ( vid::vid_list1 ) end +) + in (LrTable.NT 34,(result,vid1left,vid_list11right),rest671) end +| (105,(_,(MlyValue.vid vid1,vid1left,vid1right))::rest671) => let +val result=MlyValue.vid_list1(fn _ => let val vid as vid1=vid1 () + in ( vid::[] ) end +) + in (LrTable.NT 34,(result,vid1left,vid1right),rest671) end +| (106,(_,(MlyValue.longstrid_list1 longstrid_list11,_, +longstrid_list11right))::(_,(MlyValue.longstrid longstrid1, +longstrid1left,_))::rest671) => let val result= +MlyValue.longstrid_list1(fn _ => let val longstrid as longstrid1= +longstrid1 () +val longstrid_list1 as longstrid_list11=longstrid_list11 () + in ( longstrid::longstrid_list1 ) end +) + in (LrTable.NT 35,(result,longstrid1left,longstrid_list11right), +rest671) end +| (107,(_,(MlyValue.longstrid longstrid1,longstrid1left, +longstrid1right))::rest671) => let val result=MlyValue.longstrid_list1 +(fn _ => let val longstrid as longstrid1=longstrid1 () + in ( longstrid::[] ) end +) + in (LrTable.NT 35,(result,longstrid1left,longstrid1right),rest671) + end +| (108,(_,(MlyValue.d d1,d1left,d1right))::rest671) => let val result= +MlyValue.d_opt(fn _ => let val d as d1=d1 () + in ( d ) end +) + in (LrTable.NT 36,(result,d1left,d1right),rest671) end +| (109,rest671) => let val result=MlyValue.d_opt(fn _ => ( 0 )) + in (LrTable.NT 36,(result,defaultPos,defaultPos),rest671) end +| (110,(_,(MlyValue.AND_valbind_opt AND_valbind_opt1,_, +AND_valbind_optright as AND_valbind_opt1right))::(_,(MlyValue.exp exp1 +,_,_))::_::(_,(MlyValue.pat pat1,patleft as pat1left,_))::rest671) => +let val result=MlyValue.valbind(fn _ => let val pat as pat1=pat1 () +val exp as exp1=exp1 () +val AND_valbind_opt as AND_valbind_opt1=AND_valbind_opt1 () + in ( + PLAINValBind(I(patleft,AND_valbind_optright), + pat, exp, AND_valbind_opt) +) end +) + in (LrTable.NT 37,(result,pat1left,AND_valbind_opt1right),rest671) + end +| (111,(_,(MlyValue.valbind valbind1,_,valbindright as valbind1right)) +::(_,(_,RECleft as REC1left,_))::rest671) => let val result= +MlyValue.valbind(fn _ => let val valbind as valbind1=valbind1 () + in ( RECValBind(I(RECleft,valbindright), valbind) ) end +) + in (LrTable.NT 37,(result,REC1left,valbind1right),rest671) end +| (112,(_,(MlyValue.valbind valbind1,_,valbind1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_valbind_opt(fn _ => let +val valbind as valbind1=valbind1 () + in ( SOME valbind ) end +) + in (LrTable.NT 38,(result,AND1left,valbind1right),rest671) end +| (113,rest671) => let val result=MlyValue.AND_valbind_opt(fn _ => ( + NONE )) + in (LrTable.NT 38,(result,defaultPos,defaultPos),rest671) end +| (114,(_,(MlyValue.AND_fvalbind_opt AND_fvalbind_opt1,_, +AND_fvalbind_optright as AND_fvalbind_opt1right))::(_,(MlyValue.fmatch + fmatch1,fmatchleft as fmatch1left,_))::rest671) => let val result= +MlyValue.fvalbind(fn _ => let val fmatch as fmatch1=fmatch1 () +val AND_fvalbind_opt as AND_fvalbind_opt1=AND_fvalbind_opt1 () + in ( + FvalBind(I(fmatchleft,AND_fvalbind_optright), + fmatch, AND_fvalbind_opt) +) end +) + in (LrTable.NT 39,(result,fmatch1left,AND_fvalbind_opt1right),rest671 +) end +| (115,(_,(MlyValue.fvalbind fvalbind1,_,fvalbind1right))::(_,(_, +AND1left,_))::rest671) => let val result=MlyValue.AND_fvalbind_opt(fn +_ => let val fvalbind as fvalbind1=fvalbind1 () + in ( SOME fvalbind ) end +) + in (LrTable.NT 40,(result,AND1left,fvalbind1right),rest671) end +| (116,rest671) => let val result=MlyValue.AND_fvalbind_opt(fn _ => ( + NONE )) + in (LrTable.NT 40,(result,defaultPos,defaultPos),rest671) end +| (117,(_,(MlyValue.BAR_fmatch_opt BAR_fmatch_opt1,_, +BAR_fmatch_optright as BAR_fmatch_opt1right))::(_,(MlyValue.fmrule +fmrule1,fmruleleft as fmrule1left,_))::rest671) => let val result= +MlyValue.fmatch(fn _ => let val fmrule as fmrule1=fmrule1 () +val BAR_fmatch_opt as BAR_fmatch_opt1=BAR_fmatch_opt1 () + in ( + Fmatch(I(fmruleleft,BAR_fmatch_optright), + fmrule, BAR_fmatch_opt) +) end +) + in (LrTable.NT 41,(result,fmrule1left,BAR_fmatch_opt1right),rest671) + end +| (118,(_,(MlyValue.fmatch fmatch1,_,fmatch1right))::(_,(_,BAR1left,_) +)::rest671) => let val result=MlyValue.BAR_fmatch_opt(fn _ => let val +fmatch as fmatch1=fmatch1 () + in ( SOME fmatch ) end +) + in (LrTable.NT 42,(result,BAR1left,fmatch1right),rest671) end +| (119,rest671) => let val result=MlyValue.BAR_fmatch_opt(fn _ => ( + NONE )) + in (LrTable.NT 42,(result,defaultPos,defaultPos),rest671) end +| (120,(_,(MlyValue.exp exp1,_,expright as exp1right))::_::(_,( +MlyValue.COLON_ty_opt COLON_ty_opt1,_,_))::(_,(MlyValue.atpat_list1 +atpat_list11,atpat_list1left as atpat_list11left,_))::rest671) => let +val result=MlyValue.fmrule(fn _ => let val atpat_list1 as atpat_list11 +=atpat_list11 () +val COLON_ty_opt as COLON_ty_opt1=COLON_ty_opt1 () +val exp as exp1=exp1 () + in ( + let + val (op_opt, vid, atpats) = + Infix.parseFmrule(!J, atpat_list1) + in + Fmrule(I(atpat_list1left,expright), + op_opt, vid, atpats, COLON_ty_opt, exp) + end +) end +) + in (LrTable.NT 43,(result,atpat_list11left,exp1right),rest671) end +| (121,(_,(MlyValue.AND_typbind_opt AND_typbind_opt1,_, +AND_typbind_optright as AND_typbind_opt1right))::(_,(MlyValue.ty ty1,_ +,_))::_::(_,(MlyValue.tycon tycon1,_,_))::(_,(MlyValue.tyvarseq +tyvarseq1,tyvarseqleft as tyvarseq1left,_))::rest671) => let val +result=MlyValue.typbind(fn _ => let val tyvarseq as tyvarseq1= +tyvarseq1 () +val tycon as tycon1=tycon1 () +val ty as ty1=ty1 () +val AND_typbind_opt as AND_typbind_opt1=AND_typbind_opt1 () + in ( + TypBind(I(tyvarseqleft,AND_typbind_optright), + tyvarseq, tycon, ty, AND_typbind_opt) +) end +) + in (LrTable.NT 44,(result,tyvarseq1left,AND_typbind_opt1right), +rest671) end +| (122,(_,(MlyValue.typbind typbind1,_,typbind1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_typbind_opt(fn _ => let +val typbind as typbind1=typbind1 () + in ( SOME typbind ) end +) + in (LrTable.NT 45,(result,AND1left,typbind1right),rest671) end +| (123,rest671) => let val result=MlyValue.AND_typbind_opt(fn _ => ( + NONE )) + in (LrTable.NT 45,(result,defaultPos,defaultPos),rest671) end +| (124,(_,(MlyValue.AND_datbind_opt AND_datbind_opt1,_, +AND_datbind_optright as AND_datbind_opt1right))::(_,(MlyValue.conbind +conbind1,_,_))::_::(_,(MlyValue.tycon tycon1,_,_))::(_,( +MlyValue.tyvarseq tyvarseq1,tyvarseqleft as tyvarseq1left,_))::rest671 +) => let val result=MlyValue.datbind(fn _ => let val tyvarseq as +tyvarseq1=tyvarseq1 () +val tycon as tycon1=tycon1 () +val conbind as conbind1=conbind1 () +val AND_datbind_opt as AND_datbind_opt1=AND_datbind_opt1 () + in ( + DatBind(I(tyvarseqleft,AND_datbind_optright), + tyvarseq, tycon, conbind, AND_datbind_opt) +) end +) + in (LrTable.NT 46,(result,tyvarseq1left,AND_datbind_opt1right), +rest671) end +| (125,(_,(MlyValue.AND_datbind_opt AND_datbind_opt1,_, +AND_datbind_optright as AND_datbind_opt1right))::(_,(MlyValue.conbind +conbind1,_,_))::_::(_,(MlyValue.tycon tycon1,tyconleft as tycon1left,_ +))::rest671) => let val result=MlyValue.datbind0(fn _ => let val tycon + as tycon1=tycon1 () +val conbind as conbind1=conbind1 () +val AND_datbind_opt as AND_datbind_opt1=AND_datbind_opt1 () + in ( + DatBind(I(tyconleft,AND_datbind_optright), + TyVarseq(I(defaultPos,defaultPos), []), + tycon, conbind, AND_datbind_opt) +) end +) + in (LrTable.NT 47,(result,tycon1left,AND_datbind_opt1right),rest671) + end +| (126,(_,(MlyValue.AND_datbind_opt AND_datbind_opt1,_, +AND_datbind_optright as AND_datbind_opt1right))::(_,(MlyValue.conbind +conbind1,_,_))::_::(_,(MlyValue.tycon tycon1,_,_))::(_,( +MlyValue.tyvarseq1 tyvarseq11,tyvarseq1left as tyvarseq11left,_)):: +rest671) => let val result=MlyValue.datbind1(fn _ => let val tyvarseq1 + as tyvarseq11=tyvarseq11 () +val tycon as tycon1=tycon1 () +val conbind as conbind1=conbind1 () +val AND_datbind_opt as AND_datbind_opt1=AND_datbind_opt1 () + in ( + DatBind(I(tyvarseq1left,AND_datbind_optright), + tyvarseq1, tycon, conbind, AND_datbind_opt) +) end +) + in (LrTable.NT 48,(result,tyvarseq11left,AND_datbind_opt1right), +rest671) end +| (127,(_,(MlyValue.datbind datbind1,_,datbind1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_datbind_opt(fn _ => let +val datbind as datbind1=datbind1 () + in ( SOME datbind ) end +) + in (LrTable.NT 49,(result,AND1left,datbind1right),rest671) end +| (128,rest671) => let val result=MlyValue.AND_datbind_opt(fn _ => ( + NONE )) + in (LrTable.NT 49,(result,defaultPos,defaultPos),rest671) end +| (129,(_,(MlyValue.BAR_conbind_opt BAR_conbind_opt1,_, +BAR_conbind_optright as BAR_conbind_opt1right))::(_,( +MlyValue.OF_ty_opt OF_ty_opt1,_,_))::(_,(MlyValue.vid' vid'1,_,_))::(_ +,(MlyValue.OP_opt OP_opt1,OP_optleft as OP_opt1left,_))::rest671) => +let val result=MlyValue.conbind(fn _ => let val OP_opt as OP_opt1= +OP_opt1 () +val vid' as vid'1=vid'1 () +val OF_ty_opt as OF_ty_opt1=OF_ty_opt1 () +val BAR_conbind_opt as BAR_conbind_opt1=BAR_conbind_opt1 () + in ( + ConBind(I(OP_optleft,BAR_conbind_optright), + OP_opt, vid', OF_ty_opt, BAR_conbind_opt) +) end +) + in (LrTable.NT 50,(result,OP_opt1left,BAR_conbind_opt1right),rest671) + end +| (130,(_,(MlyValue.conbind conbind1,_,conbind1right))::(_,(_,BAR1left +,_))::rest671) => let val result=MlyValue.BAR_conbind_opt(fn _ => let +val conbind as conbind1=conbind1 () + in ( SOME conbind ) end +) + in (LrTable.NT 51,(result,BAR1left,conbind1right),rest671) end +| (131,rest671) => let val result=MlyValue.BAR_conbind_opt(fn _ => ( + NONE )) + in (LrTable.NT 51,(result,defaultPos,defaultPos),rest671) end +| (132,(_,(MlyValue.ty ty1,_,ty1right))::(_,(_,OF1left,_))::rest671) + => let val result=MlyValue.OF_ty_opt(fn _ => let val ty as ty1=ty1 () + in ( SOME ty ) end +) + in (LrTable.NT 52,(result,OF1left,ty1right),rest671) end +| (133,rest671) => let val result=MlyValue.OF_ty_opt(fn _ => ( NONE )) + in (LrTable.NT 52,(result,defaultPos,defaultPos),rest671) end +| (134,(_,(MlyValue.AND_exbind_opt AND_exbind_opt1,_, +AND_exbind_optright as AND_exbind_opt1right))::(_,(MlyValue.OF_ty_opt +OF_ty_opt1,_,_))::(_,(MlyValue.vid' vid'1,_,_))::(_,(MlyValue.OP_opt +OP_opt1,OP_optleft as OP_opt1left,_))::rest671) => let val result= +MlyValue.exbind(fn _ => let val OP_opt as OP_opt1=OP_opt1 () +val vid' as vid'1=vid'1 () +val OF_ty_opt as OF_ty_opt1=OF_ty_opt1 () +val AND_exbind_opt as AND_exbind_opt1=AND_exbind_opt1 () + in ( + NEWExBind(I(OP_optleft,AND_exbind_optright), + OP_opt, vid', OF_ty_opt, AND_exbind_opt) +) end +) + in (LrTable.NT 53,(result,OP_opt1left,AND_exbind_opt1right),rest671) + end +| (135,(_,(MlyValue.AND_exbind_opt AND_exbind_opt1,_, +AND_exbind_optright as AND_exbind_opt1right))::(_,(MlyValue.longvid +longvid1,_,_))::(_,(MlyValue.OP_opt OP_opt2,_,_))::_::(_,( +MlyValue.vid' vid'1,_,_))::(_,(MlyValue.OP_opt OP_opt1,OP_opt1left,_)) +::rest671) => let val result=MlyValue.exbind(fn _ => let val OP_opt1= +OP_opt1 () +val vid' as vid'1=vid'1 () +val OP_opt2=OP_opt2 () +val longvid as longvid1=longvid1 () +val AND_exbind_opt as AND_exbind_opt1=AND_exbind_opt1 () + in ( + EQUALExBind(I(OP_opt1left,AND_exbind_optright), + OP_opt1, vid', OP_opt2, longvid, + AND_exbind_opt) +) end +) + in (LrTable.NT 53,(result,OP_opt1left,AND_exbind_opt1right),rest671) + end +| (136,(_,(MlyValue.exbind exbind1,_,exbind1right))::(_,(_,AND1left,_) +)::rest671) => let val result=MlyValue.AND_exbind_opt(fn _ => let val +exbind as exbind1=exbind1 () + in ( SOME exbind ) end +) + in (LrTable.NT 54,(result,AND1left,exbind1right),rest671) end +| (137,rest671) => let val result=MlyValue.AND_exbind_opt(fn _ => ( + NONE )) + in (LrTable.NT 54,(result,defaultPos,defaultPos),rest671) end +| (138,(_,(MlyValue.atpat' atpat'1,atpat'1left,atpat'1right))::rest671 +) => let val result=MlyValue.atpat(fn _ => let val atpat' as atpat'1= +atpat'1 () + in ( atpat' ) end +) + in (LrTable.NT 55,(result,atpat'1left,atpat'1right),rest671) end +| (139,(_,(MlyValue.longvid' longvid'1,_,longvid'right as +longvid'1right))::(_,(MlyValue.OP_opt OP_opt1,OP_optleft as +OP_opt1left,_))::rest671) => let val result=MlyValue.atpat(fn _ => +let val OP_opt as OP_opt1=OP_opt1 () +val longvid' as longvid'1=longvid'1 () + in ( + LONGVIDAtPat(I(OP_optleft,longvid'right), + OP_opt, longvid') +) end +) + in (LrTable.NT 55,(result,OP_opt1left,longvid'1right),rest671) end +| (140,(_,(_,UNDERBARleft as UNDERBAR1left,UNDERBARright as +UNDERBAR1right))::rest671) => let val result=MlyValue.atpat'(fn _ => ( + WILDCARDAtPat(I(UNDERBARleft,UNDERBARright)) )) + in (LrTable.NT 56,(result,UNDERBAR1left,UNDERBAR1right),rest671) end +| (141,(_,(MlyValue.scon scon1,sconleft as scon1left,sconright as +scon1right))::rest671) => let val result=MlyValue.atpat'(fn _ => let +val scon as scon1=scon1 () + in ( SCONAtPat(I(sconleft,sconright), scon) ) end +) + in (LrTable.NT 56,(result,scon1left,scon1right),rest671) end +| (142,(_,(_,_,RBRACEright as RBRACE1right))::(_,(MlyValue.patrow_opt +patrow_opt1,_,_))::(_,(_,LBRACEleft as LBRACE1left,_))::rest671) => +let val result=MlyValue.atpat'(fn _ => let val patrow_opt as +patrow_opt1=patrow_opt1 () + in ( RECORDAtPat(I(LBRACEleft,RBRACEright), patrow_opt) ) end +) + in (LrTable.NT 56,(result,LBRACE1left,RBRACE1right),rest671) end +| (143,(_,(_,_,RPARright as RPAR1right))::(_,(_,LPARleft as LPAR1left, +_))::rest671) => let val result=MlyValue.atpat'(fn _ => ( + UNITAtPat(I(LPARleft,RPARright)) )) + in (LrTable.NT 56,(result,LPAR1left,RPAR1right),rest671) end +| (144,(_,(_,_,RPARright as RPAR1right))::(_,(MlyValue.pat_COMMA_list2 + pat_COMMA_list21,_,_))::(_,(_,LPARleft as LPAR1left,_))::rest671) => +let val result=MlyValue.atpat'(fn _ => let val pat_COMMA_list2 as +pat_COMMA_list21=pat_COMMA_list21 () + in ( TUPLEAtPat(I(LPARleft,RPARright), pat_COMMA_list2) ) end +) + in (LrTable.NT 56,(result,LPAR1left,RPAR1right),rest671) end +| (145,(_,(_,_,RBRACKright as RBRACK1right))::(_,( +MlyValue.pat_COMMA_list0 pat_COMMA_list01,_,_))::(_,(_,LBRACKleft as +LBRACK1left,_))::rest671) => let val result=MlyValue.atpat'(fn _ => +let val pat_COMMA_list0 as pat_COMMA_list01=pat_COMMA_list01 () + in ( LISTAtPat(I(LBRACKleft,RBRACKright), + pat_COMMA_list0) ) + end +) + in (LrTable.NT 56,(result,LBRACK1left,RBRACK1right),rest671) end +| (146,(_,(_,_,RPARright as RPAR1right))::(_,(MlyValue.pat pat1,_,_)) +::(_,(_,LPARleft as LPAR1left,_))::rest671) => let val result= +MlyValue.atpat'(fn _ => let val pat as pat1=pat1 () + in ( PARAtPat(I(LPARleft,RPARright), pat) ) end +) + in (LrTable.NT 56,(result,LPAR1left,RPAR1right),rest671) end +| (147,(_,(MlyValue.pat_COMMA_list1 pat_COMMA_list11, +pat_COMMA_list11left,pat_COMMA_list11right))::rest671) => let val +result=MlyValue.pat_COMMA_list0(fn _ => let val pat_COMMA_list1 as +pat_COMMA_list11=pat_COMMA_list11 () + in ( pat_COMMA_list1 ) end +) + in (LrTable.NT 57,(result,pat_COMMA_list11left,pat_COMMA_list11right) +,rest671) end +| (148,rest671) => let val result=MlyValue.pat_COMMA_list0(fn _ => ( + [] )) + in (LrTable.NT 57,(result,defaultPos,defaultPos),rest671) end +| (149,(_,(MlyValue.pat_COMMA_list1 pat_COMMA_list11,_, +pat_COMMA_list11right))::_::(_,(MlyValue.pat pat1,pat1left,_)):: +rest671) => let val result=MlyValue.pat_COMMA_list1(fn _ => let val +pat as pat1=pat1 () +val pat_COMMA_list1 as pat_COMMA_list11=pat_COMMA_list11 () + in ( pat::pat_COMMA_list1 ) end +) + in (LrTable.NT 58,(result,pat1left,pat_COMMA_list11right),rest671) + end +| (150,(_,(MlyValue.pat pat1,pat1left,pat1right))::rest671) => let +val result=MlyValue.pat_COMMA_list1(fn _ => let val pat as pat1=pat1 +() + in ( pat::[] ) end +) + in (LrTable.NT 58,(result,pat1left,pat1right),rest671) end +| (151,(_,(MlyValue.pat_COMMA_list1 pat_COMMA_list11,_, +pat_COMMA_list11right))::_::(_,(MlyValue.pat pat1,pat1left,_)):: +rest671) => let val result=MlyValue.pat_COMMA_list2(fn _ => let val +pat as pat1=pat1 () +val pat_COMMA_list1 as pat_COMMA_list11=pat_COMMA_list11 () + in ( pat::pat_COMMA_list1 ) end +) + in (LrTable.NT 59,(result,pat1left,pat_COMMA_list11right),rest671) + end +| (152,(_,(_,DOTSleft as DOTS1left,DOTSright as DOTS1right))::rest671) + => let val result=MlyValue.patrow(fn _ => ( + WILDCARDPatRow(I(DOTSleft,DOTSright)) )) + in (LrTable.NT 60,(result,DOTS1left,DOTS1right),rest671) end +| (153,(_,(MlyValue.COMMA_patrow_opt COMMA_patrow_opt1,_, +COMMA_patrow_optright as COMMA_patrow_opt1right))::(_,(MlyValue.pat +pat1,_,_))::_::(_,(MlyValue.lab lab1,lableft as lab1left,_))::rest671) + => let val result=MlyValue.patrow(fn _ => let val lab as lab1=lab1 () +val pat as pat1=pat1 () +val COMMA_patrow_opt as COMMA_patrow_opt1=COMMA_patrow_opt1 () + in ( + ROWPatRow(I(lableft,COMMA_patrow_optright), + lab, pat, COMMA_patrow_opt) +) end +) + in (LrTable.NT 60,(result,lab1left,COMMA_patrow_opt1right),rest671) + end +| (154,(_,(MlyValue.COMMA_patrow_opt COMMA_patrow_opt1,_, +COMMA_patrow_optright as COMMA_patrow_opt1right))::(_,( +MlyValue.AS_pat_opt AS_pat_opt1,_,_))::(_,(MlyValue.COLON_ty_opt +COLON_ty_opt1,_,_))::(_,(MlyValue.vid' vid'1,vid'left as vid'1left,_)) +::rest671) => let val result=MlyValue.patrow(fn _ => let val vid' as +vid'1=vid'1 () +val COLON_ty_opt as COLON_ty_opt1=COLON_ty_opt1 () +val AS_pat_opt as AS_pat_opt1=AS_pat_opt1 () +val COMMA_patrow_opt as COMMA_patrow_opt1=COMMA_patrow_opt1 () + in ( + VIDPatRow(I(vid'left,COMMA_patrow_optright), + vid', COLON_ty_opt, AS_pat_opt, + COMMA_patrow_opt) +) end +) + in (LrTable.NT 60,(result,vid'1left,COMMA_patrow_opt1right),rest671) + end +| (155,(_,(MlyValue.patrow patrow1,_,patrow1right))::(_,(_,COMMA1left, +_))::rest671) => let val result=MlyValue.COMMA_patrow_opt(fn _ => let +val patrow as patrow1=patrow1 () + in ( SOME patrow ) end +) + in (LrTable.NT 62,(result,COMMA1left,patrow1right),rest671) end +| (156,rest671) => let val result=MlyValue.COMMA_patrow_opt(fn _ => ( + NONE )) + in (LrTable.NT 62,(result,defaultPos,defaultPos),rest671) end +| (157,(_,(MlyValue.ty ty1,_,ty1right))::(_,(_,COLON1left,_))::rest671 +) => let val result=MlyValue.COLON_ty_opt(fn _ => let val ty as ty1= +ty1 () + in ( SOME ty ) end +) + in (LrTable.NT 63,(result,COLON1left,ty1right),rest671) end +| (158,rest671) => let val result=MlyValue.COLON_ty_opt(fn _ => ( + NONE )) + in (LrTable.NT 63,(result,defaultPos,defaultPos),rest671) end +| (159,(_,(MlyValue.pat pat1,_,pat1right))::(_,(_,AS1left,_))::rest671 +) => let val result=MlyValue.AS_pat_opt(fn _ => let val pat as pat1= +pat1 () + in ( SOME pat ) end +) + in (LrTable.NT 64,(result,AS1left,pat1right),rest671) end +| (160,rest671) => let val result=MlyValue.AS_pat_opt(fn _ => ( NONE ) +) + in (LrTable.NT 64,(result,defaultPos,defaultPos),rest671) end +| (161,(_,(MlyValue.patrow patrow1,patrow1left,patrow1right))::rest671 +) => let val result=MlyValue.patrow_opt(fn _ => let val patrow as +patrow1=patrow1 () + in ( SOME patrow ) end +) + in (LrTable.NT 61,(result,patrow1left,patrow1right),rest671) end +| (162,rest671) => let val result=MlyValue.patrow_opt(fn _ => ( NONE ) +) + in (LrTable.NT 61,(result,defaultPos,defaultPos),rest671) end +| (163,(_,(MlyValue.atpat atpat1,atpat1left,atpat1right))::rest671) + => let val result=MlyValue.pat(fn _ => let val atpat as atpat1=atpat1 + () + in ( Infix.parsePat(!J, [atpat]) ) end +) + in (LrTable.NT 65,(result,atpat1left,atpat1right),rest671) end +| (164,(_,(MlyValue.atpat_list2 atpat_list21,atpat_list21left, +atpat_list21right))::rest671) => let val result=MlyValue.pat(fn _ => +let val atpat_list2 as atpat_list21=atpat_list21 () + in ( Infix.parsePat(!J, atpat_list2) ) end +) + in (LrTable.NT 65,(result,atpat_list21left,atpat_list21right),rest671 +) end +| (165,(_,(MlyValue.COLON_ty_list1 COLON_ty_list11,_, +COLON_ty_list11right))::(_,(MlyValue.atpat' atpat'1,atpat'1left,_)):: +rest671) => let val result=MlyValue.pat(fn _ => let val atpat' as +atpat'1=atpat'1 () +val COLON_ty_list1 as COLON_ty_list11=COLON_ty_list11 () + in ( + let val pat = Infix.parsePat(!J, [atpat']) + in typedPat(pat, COLON_ty_list1) end +) end +) + in (LrTable.NT 65,(result,atpat'1left,COLON_ty_list11right),rest671) + end +| (166,(_,(MlyValue.COLON_ty_list1 COLON_ty_list11,_, +COLON_ty_list11right))::(_,(MlyValue.atpat_list2 atpat_list21, +atpat_list21left,_))::rest671) => let val result=MlyValue.pat(fn _ => +let val atpat_list2 as atpat_list21=atpat_list21 () +val COLON_ty_list1 as COLON_ty_list11=COLON_ty_list11 () + in ( + let val pat = Infix.parsePat(!J, atpat_list2) + in typedPat(pat, COLON_ty_list1) end +) end +) + in (LrTable.NT 65,(result,atpat_list21left,COLON_ty_list11right), +rest671) end +| (167,(_,(MlyValue.COLON_ty_list1 COLON_ty_list11,_, +COLON_ty_list11right))::(_,(MlyValue.vid' vid'1,_,vid'right))::(_,( +MlyValue.OP_opt OP_opt1,OP_optleft as OP_opt1left,_))::rest671) => +let val result=MlyValue.pat(fn _ => let val OP_opt as OP_opt1=OP_opt1 +() +val vid' as vid'1=vid'1 () +val COLON_ty_list1 as COLON_ty_list11=COLON_ty_list11 () + in ( + let val atpat = LONGVIDAtPat(I(OP_optleft,vid'right), + OP_opt, + LongVId.fromId vid') + val pat = Infix.parsePat(!J, [atpat]) + in typedPat(pat, COLON_ty_list1) end +) end +) + in (LrTable.NT 65,(result,OP_opt1left,COLON_ty_list11right),rest671) + end +| (168,(_,(MlyValue.COLON_ty_list1 COLON_ty_list11,_, +COLON_ty_list11right))::(_,(MlyValue.LONGID LONGID1,_,LONGIDright))::( +_,(MlyValue.OP_opt OP_opt1,OP_optleft as OP_opt1left,_))::rest671) => +let val result=MlyValue.pat(fn _ => let val OP_opt as OP_opt1=OP_opt1 +() +val LONGID as LONGID1=LONGID1 () +val COLON_ty_list1 as COLON_ty_list11=COLON_ty_list11 () + in ( + let val longvid = LongVId.implode + (toLongId VId.fromString LONGID) + val atpat = LONGVIDAtPat(I(OP_optleft,LONGIDright), + OP_opt, longvid) + val pat = Infix.parsePat(!J, [atpat]) + in typedPat(pat, COLON_ty_list1) end +) end +) + in (LrTable.NT 65,(result,OP_opt1left,COLON_ty_list11right),rest671) + end +| (169,(_,(MlyValue.pat pat1,_,patright as pat1right))::_::(_,( +MlyValue.COLON_ty_opt COLON_ty_opt1,_,_))::(_,(MlyValue.vid' vid'1,_, +vid'right))::(_,(MlyValue.OP_opt OP_opt1,OP_optleft as OP_opt1left,_)) +::rest671) => let val result=MlyValue.pat(fn _ => let val OP_opt as +OP_opt1=OP_opt1 () +val vid' as vid'1=vid'1 () +val COLON_ty_opt as COLON_ty_opt1=COLON_ty_opt1 () +val pat as pat1=pat1 () + in ( + Infix.parsePat(!J, + [ LONGVIDAtPat(I(OP_optleft,vid'right), + OP_opt, + LongVId.implode([],vid')) ] ) ; + ASPat(I(OP_optleft,patright), + OP_opt, vid', COLON_ty_opt, pat) +) end +) + in (LrTable.NT 65,(result,OP_opt1left,pat1right),rest671) end +| (170,(_,(MlyValue.atpat_list1 atpat_list11,_,atpat_list11right))::(_ +,(MlyValue.atpat atpat1,atpat1left,_))::rest671) => let val result= +MlyValue.atpat_list1(fn _ => let val atpat as atpat1=atpat1 () +val atpat_list1 as atpat_list11=atpat_list11 () + in ( atpat::atpat_list1 ) end +) + in (LrTable.NT 66,(result,atpat1left,atpat_list11right),rest671) end +| (171,(_,(MlyValue.atpat atpat1,atpat1left,atpat1right))::rest671) + => let val result=MlyValue.atpat_list1(fn _ => let val atpat as +atpat1=atpat1 () + in ( atpat::[] ) end +) + in (LrTable.NT 66,(result,atpat1left,atpat1right),rest671) end +| (172,(_,(MlyValue.atpat_list1 atpat_list11,_,atpat_list11right))::(_ +,(MlyValue.atpat atpat1,atpat1left,_))::rest671) => let val result= +MlyValue.atpat_list2(fn _ => let val atpat as atpat1=atpat1 () +val atpat_list1 as atpat_list11=atpat_list11 () + in ( atpat::atpat_list1 ) end +) + in (LrTable.NT 67,(result,atpat1left,atpat_list11right),rest671) end +| (173,(_,(MlyValue.COLON_ty_list1 COLON_ty_list11,_, +COLON_ty_list11right))::(_,(MlyValue.ty ty1,_,_))::(_,(_,COLON1left,_) +)::rest671) => let val result=MlyValue.COLON_ty_list1(fn _ => let val +ty as ty1=ty1 () +val COLON_ty_list1 as COLON_ty_list11=COLON_ty_list11 () + in ( ty::COLON_ty_list1 ) end +) + in (LrTable.NT 68,(result,COLON1left,COLON_ty_list11right),rest671) + end +| (174,(_,(MlyValue.ty ty1,_,ty1right))::(_,(_,COLON1left,_))::rest671 +) => let val result=MlyValue.COLON_ty_list1(fn _ => let val ty as ty1= +ty1 () + in ( ty::[] ) end +) + in (LrTable.NT 68,(result,COLON1left,ty1right),rest671) end +| (175,(_,(MlyValue.tupty tupty1,tupty1left,tupty1right))::rest671) + => let val result=MlyValue.ty(fn _ => let val tupty as tupty1=tupty1 +() + in ( tupty ) end +) + in (LrTable.NT 69,(result,tupty1left,tupty1right),rest671) end +| (176,(_,(MlyValue.ty ty1,_,tyright as ty1right))::_::(_,( +MlyValue.tupty tupty1,tuptyleft as tupty1left,_))::rest671) => let +val result=MlyValue.ty(fn _ => let val tupty as tupty1=tupty1 () +val ty as ty1=ty1 () + in ( ARROWTy(I(tuptyleft,tyright), tupty, ty) ) end +) + in (LrTable.NT 69,(result,tupty1left,ty1right),rest671) end +| (177,(_,(MlyValue.ty_STAR_list ty_STAR_list1,ty_STAR_listleft as +ty_STAR_list1left,ty_STAR_listright as ty_STAR_list1right))::rest671) + => let val result=MlyValue.tupty(fn _ => let val ty_STAR_list as +ty_STAR_list1=ty_STAR_list1 () + in ( + TUPLETy(I(ty_STAR_listleft,ty_STAR_listright), + ty_STAR_list) ) + end +) + in (LrTable.NT 70,(result,ty_STAR_list1left,ty_STAR_list1right), +rest671) end +| (178,(_,(MlyValue.ty_STAR_list ty_STAR_list1,_,ty_STAR_list1right)) +::_::(_,(MlyValue.consty consty1,consty1left,_))::rest671) => let val +result=MlyValue.ty_STAR_list(fn _ => let val consty as consty1=consty1 + () +val ty_STAR_list as ty_STAR_list1=ty_STAR_list1 () + in ( consty::ty_STAR_list ) end +) + in (LrTable.NT 71,(result,consty1left,ty_STAR_list1right),rest671) + end +| (179,(_,(MlyValue.consty consty1,consty1left,consty1right))::rest671 +) => let val result=MlyValue.ty_STAR_list(fn _ => let val consty as +consty1=consty1 () + in ( consty::[] ) end +) + in (LrTable.NT 71,(result,consty1left,consty1right),rest671) end +| (180,(_,(MlyValue.atty atty1,atty1left,atty1right))::rest671) => +let val result=MlyValue.consty(fn _ => let val atty as atty1=atty1 () + in ( atty ) end +) + in (LrTable.NT 72,(result,atty1left,atty1right),rest671) end +| (181,(_,(MlyValue.longtycon longtycon1,_,longtyconright as +longtycon1right))::(_,(MlyValue.tyseq tyseq1,tyseqleft as tyseq1left,_ +))::rest671) => let val result=MlyValue.consty(fn _ => let val tyseq + as tyseq1=tyseq1 () +val longtycon as longtycon1=longtycon1 () + in ( TYCONTy(I(tyseqleft,longtyconright), + tyseq, longtycon) ) + end +) + in (LrTable.NT 72,(result,tyseq1left,longtycon1right),rest671) end +| (182,(_,(MlyValue.tyvar tyvar1,tyvarleft as tyvar1left,tyvarright + as tyvar1right))::rest671) => let val result=MlyValue.atty(fn _ => +let val tyvar as tyvar1=tyvar1 () + in ( TYVARTy(I(tyvarleft,tyvarright), tyvar) ) end +) + in (LrTable.NT 73,(result,tyvar1left,tyvar1right),rest671) end +| (183,(_,(_,_,RBRACEright as RBRACE1right))::(_,(MlyValue.tyrow_opt +tyrow_opt1,_,_))::(_,(_,LBRACEleft as LBRACE1left,_))::rest671) => +let val result=MlyValue.atty(fn _ => let val tyrow_opt as tyrow_opt1= +tyrow_opt1 () + in ( RECORDTy(I(LBRACEleft,RBRACEright), tyrow_opt) ) end +) + in (LrTable.NT 73,(result,LBRACE1left,RBRACE1right),rest671) end +| (184,(_,(_,_,RPARright as RPAR1right))::(_,(MlyValue.ty ty1,_,_))::( +_,(_,LPARleft as LPAR1left,_))::rest671) => let val result= +MlyValue.atty(fn _ => let val ty as ty1=ty1 () + in ( PARTy(I(LPARleft,RPARright), ty) ) end +) + in (LrTable.NT 73,(result,LPAR1left,RPAR1right),rest671) end +| (185,(_,(MlyValue.COMMA_tyrow_opt COMMA_tyrow_opt1,_, +COMMA_tyrow_optright as COMMA_tyrow_opt1right))::(_,(MlyValue.ty ty1,_ +,_))::_::(_,(MlyValue.lab lab1,lableft as lab1left,_))::rest671) => +let val result=MlyValue.tyrow(fn _ => let val lab as lab1=lab1 () +val ty as ty1=ty1 () +val COMMA_tyrow_opt as COMMA_tyrow_opt1=COMMA_tyrow_opt1 () + in ( + TyRow(I(lableft,COMMA_tyrow_optright), + lab, ty, COMMA_tyrow_opt) +) end +) + in (LrTable.NT 74,(result,lab1left,COMMA_tyrow_opt1right),rest671) + end +| (186,(_,(MlyValue.tyrow tyrow1,_,tyrow1right))::(_,(_,COMMA1left,_)) +::rest671) => let val result=MlyValue.COMMA_tyrow_opt(fn _ => let val +tyrow as tyrow1=tyrow1 () + in ( SOME tyrow ) end +) + in (LrTable.NT 76,(result,COMMA1left,tyrow1right),rest671) end +| (187,rest671) => let val result=MlyValue.COMMA_tyrow_opt(fn _ => ( + NONE )) + in (LrTable.NT 76,(result,defaultPos,defaultPos),rest671) end +| (188,(_,(MlyValue.tyrow tyrow1,tyrow1left,tyrow1right))::rest671) + => let val result=MlyValue.tyrow_opt(fn _ => let val tyrow as tyrow1= +tyrow1 () + in ( SOME tyrow ) end +) + in (LrTable.NT 75,(result,tyrow1left,tyrow1right),rest671) end +| (189,rest671) => let val result=MlyValue.tyrow_opt(fn _ => ( NONE )) + in (LrTable.NT 75,(result,defaultPos,defaultPos),rest671) end +| (190,(_,(MlyValue.consty consty1,constyleft as consty1left, +constyright as consty1right))::rest671) => let val result= +MlyValue.tyseq(fn _ => let val consty as consty1=consty1 () + in ( Tyseq(I(constyleft,constyright), + [consty]) ) end +) + in (LrTable.NT 77,(result,consty1left,consty1right),rest671) end +| (191,rest671) => let val result=MlyValue.tyseq(fn _ => ( + Tyseq(I(defaultPos,defaultPos), []) )) + in (LrTable.NT 77,(result,defaultPos,defaultPos),rest671) end +| (192,(_,(_,_,RPARright as RPAR1right))::(_,(MlyValue.ty_COMMA_list2 +ty_COMMA_list21,_,_))::(_,(_,LPARleft as LPAR1left,_))::rest671) => +let val result=MlyValue.tyseq(fn _ => let val ty_COMMA_list2 as +ty_COMMA_list21=ty_COMMA_list21 () + in ( Tyseq(I(LPARleft,RPARright), + ty_COMMA_list2) ) end +) + in (LrTable.NT 77,(result,LPAR1left,RPAR1right),rest671) end +| (193,(_,(MlyValue.ty_COMMA_list2 ty_COMMA_list21,_, +ty_COMMA_list21right))::_::(_,(MlyValue.ty ty1,ty1left,_))::rest671) + => let val result=MlyValue.ty_COMMA_list2(fn _ => let val ty as ty1= +ty1 () +val ty_COMMA_list2 as ty_COMMA_list21=ty_COMMA_list21 () + in ( ty::ty_COMMA_list2 ) end +) + in (LrTable.NT 78,(result,ty1left,ty_COMMA_list21right),rest671) end +| (194,(_,(MlyValue.ty ty2,_,ty2right))::_::(_,(MlyValue.ty ty1, +ty1left,_))::rest671) => let val result=MlyValue.ty_COMMA_list2(fn _ + => let val ty1=ty1 () +val ty2=ty2 () + in ( [ty1, ty2] ) end +) + in (LrTable.NT 78,(result,ty1left,ty2right),rest671) end +| (195,(_,(MlyValue.tyvarseq1 tyvarseq11,tyvarseq11left, +tyvarseq11right))::rest671) => let val result=MlyValue.tyvarseq(fn _ + => let val tyvarseq1 as tyvarseq11=tyvarseq11 () + in ( tyvarseq1 ) end +) + in (LrTable.NT 79,(result,tyvarseq11left,tyvarseq11right),rest671) + end +| (196,rest671) => let val result=MlyValue.tyvarseq(fn _ => ( + TyVarseq(I(defaultPos,defaultPos), + []) )) + in (LrTable.NT 79,(result,defaultPos,defaultPos),rest671) end +| (197,(_,(MlyValue.tyvar tyvar1,tyvarleft as tyvar1left,tyvarright + as tyvar1right))::rest671) => let val result=MlyValue.tyvarseq1(fn _ + => let val tyvar as tyvar1=tyvar1 () + in ( TyVarseq(I(tyvarleft,tyvarright), + [tyvar]) ) end +) + in (LrTable.NT 80,(result,tyvar1left,tyvar1right),rest671) end +| (198,(_,(_,_,RPARright as RPAR1right))::(_,( +MlyValue.tyvar_COMMA_list1 tyvar_COMMA_list11,_,_))::(_,(_,LPARleft + as LPAR1left,_))::rest671) => let val result=MlyValue.tyvarseq1(fn _ + => let val tyvar_COMMA_list1 as tyvar_COMMA_list11=tyvar_COMMA_list11 + () + in ( TyVarseq(I(LPARleft,RPARright), + tyvar_COMMA_list1) ) + end +) + in (LrTable.NT 80,(result,LPAR1left,RPAR1right),rest671) end +| (199,(_,(MlyValue.tyvar_COMMA_list1 tyvar_COMMA_list11,_, +tyvar_COMMA_list11right))::_::(_,(MlyValue.tyvar tyvar1,tyvar1left,_)) +::rest671) => let val result=MlyValue.tyvar_COMMA_list1(fn _ => let +val tyvar as tyvar1=tyvar1 () +val tyvar_COMMA_list1 as tyvar_COMMA_list11=tyvar_COMMA_list11 () + in ( tyvar::tyvar_COMMA_list1 ) end +) + in (LrTable.NT 81,(result,tyvar1left,tyvar_COMMA_list11right),rest671 +) end +| (200,(_,(MlyValue.tyvar tyvar1,tyvar1left,tyvar1right))::rest671) + => let val result=MlyValue.tyvar_COMMA_list1(fn _ => let val tyvar + as tyvar1=tyvar1 () + in ( tyvar::[] ) end +) + in (LrTable.NT 81,(result,tyvar1left,tyvar1right),rest671) end +| (201,(_,(MlyValue.strexp' strexp'1,strexp'1left,strexp'1right)):: +rest671) => let val result=MlyValue.strexp(fn _ => let val strexp' as +strexp'1=strexp'1 () + in ( strexp' ) end +) + in (LrTable.NT 82,(result,strexp'1left,strexp'1right),rest671) end +| (202,(_,(MlyValue.sigexp sigexp1,_,sigexpright as sigexp1right))::_ +::(_,(MlyValue.strexp strexp1,strexpleft as strexp1left,_))::rest671) + => let val result=MlyValue.strexp(fn _ => let val strexp as strexp1= +strexp1 () +val sigexp as sigexp1=sigexp1 () + in ( + TRANSStrExp(I(strexpleft,sigexpright), + strexp, sigexp) ) + end +) + in (LrTable.NT 82,(result,strexp1left,sigexp1right),rest671) end +| (203,(_,(MlyValue.sigexp sigexp1,_,sigexpright as sigexp1right))::_ +::(_,(MlyValue.strexp strexp1,strexpleft as strexp1left,_))::rest671) + => let val result=MlyValue.strexp(fn _ => let val strexp as strexp1= +strexp1 () +val sigexp as sigexp1=sigexp1 () + in ( OPAQStrExp(I(strexpleft,sigexpright), strexp, sigexp)) end +) + in (LrTable.NT 82,(result,strexp1left,sigexp1right),rest671) end +| (204,(_,(_,_,ENDright as END1right))::(_,(MlyValue.popInfix +popInfix1,_,_))::(_,(MlyValue.strdec strdec1,_,_))::(_,( +MlyValue.pushInfix pushInfix1,_,_))::(_,(_,STRUCTleft as STRUCT1left,_ +))::rest671) => let val result=MlyValue.strexp'(fn _ => let val +pushInfix1=pushInfix1 () +val strdec as strdec1=strdec1 () +val popInfix1=popInfix1 () + in ( STRUCTStrExp(I(STRUCTleft,ENDright), strdec) ) end +) + in (LrTable.NT 83,(result,STRUCT1left,END1right),rest671) end +| (205,(_,(MlyValue.longstrid longstrid1,longstridleft as +longstrid1left,longstridright as longstrid1right))::rest671) => let +val result=MlyValue.strexp'(fn _ => let val longstrid as longstrid1= +longstrid1 () + in ( + LONGSTRIDStrExp(I(longstridleft,longstridright), + longstrid) ) + end +) + in (LrTable.NT 83,(result,longstrid1left,longstrid1right),rest671) + end +| (206,(_,(_,_,RPARright as RPAR1right))::(_,(MlyValue.strexp strexp1, +_,_))::_::(_,(MlyValue.funid funid1,funidleft as funid1left,_)):: +rest671) => let val result=MlyValue.strexp'(fn _ => let val funid as +funid1=funid1 () +val strexp as strexp1=strexp1 () + in ( APPStrExp(I(funidleft,RPARright), funid, strexp) ) end +) + in (LrTable.NT 83,(result,funid1left,RPAR1right),rest671) end +| (207,(_,(_,_,RPARright as RPAR1right))::(_,(MlyValue.strdec strdec1, +_,_))::_::(_,(MlyValue.funid funid1,funidleft as funid1left,_)):: +rest671) => let val result=MlyValue.strexp'(fn _ => let val funid as +funid1=funid1 () +val strdec as strdec1=strdec1 () + in ( APPDECStrExp(I(funidleft,RPARright), funid, strdec) ) end +) + in (LrTable.NT 83,(result,funid1left,RPAR1right),rest671) end +| (208,(_,(_,_,ENDright as END1right))::(_,(MlyValue.popInfix +popInfix1,_,_))::(_,(MlyValue.strexp strexp1,_,_))::_::(_,( +MlyValue.strdec strdec1,_,_))::(_,(MlyValue.pushInfix pushInfix1,_,_)) +::(_,(_,LETleft as LET1left,_))::rest671) => let val result= +MlyValue.strexp'(fn _ => let val pushInfix1=pushInfix1 () +val strdec as strdec1=strdec1 () +val strexp as strexp1=strexp1 () +val popInfix1=popInfix1 () + in ( LETStrExp(I(LETleft,ENDright), strdec, strexp) ) end +) + in (LrTable.NT 83,(result,LET1left,END1right),rest671) end +| (209,(_,(MlyValue.strdec1 strdec11,strdec11left,strdec11right)):: +rest671) => let val result=MlyValue.strdec(fn _ => let val strdec1 as +strdec11=strdec11 () + in ( strdec1 ) end +) + in (LrTable.NT 84,(result,strdec11left,strdec11right),rest671) end +| (210,rest671) => let val result=MlyValue.strdec(fn _ => ( + EMPTYStrDec(I(defaultPos,defaultPos)) )) + in (LrTable.NT 84,(result,defaultPos,defaultPos),rest671) end +| (211,(_,(MlyValue.strdec1' strdec1'1,strdec1'1left,strdec1'1right)) +::rest671) => let val result=MlyValue.strdec1(fn _ => let val strdec1' + as strdec1'1=strdec1'1 () + in ( strdec1' ) end +) + in (LrTable.NT 85,(result,strdec1'1left,strdec1'1right),rest671) end +| (212,(_,(MlyValue.strdec1 strdec12,_,strdec12right))::(_,( +MlyValue.strdec1 strdec11,strdec11left,_))::rest671) => let val result +=MlyValue.strdec1(fn _ => let val strdec11=strdec11 () +val strdec12=strdec12 () + in ( + SEQStrDec(I(strdec11left,strdec12right), + strdec11, strdec12) +) end +) + in (LrTable.NT 85,(result,strdec11left,strdec12right),rest671) end +| (213,(_,(_,SEMICOLONleft as SEMICOLON1left,SEMICOLONright as +SEMICOLON1right))::rest671) => let val result=MlyValue.strdec1(fn _ + => ( EMPTYStrDec(I(SEMICOLONleft,SEMICOLONright)) )) + in (LrTable.NT 85,(result,SEMICOLON1left,SEMICOLON1right),rest671) + end +| (214,(_,(MlyValue.dec1' dec1'1,dec1'left as dec1'1left,dec1'right + as dec1'1right))::rest671) => let val result=MlyValue.strdec1'(fn _ + => let val dec1' as dec1'1=dec1'1 () + in ( DECStrDec(I(dec1'left,dec1'right), dec1') ) end +) + in (LrTable.NT 86,(result,dec1'1left,dec1'1right),rest671) end +| (215,(_,(MlyValue.strbind strbind1,_,strbindright as strbind1right)) +::(_,(_,STRUCTUREleft as STRUCTURE1left,_))::rest671) => let val +result=MlyValue.strdec1'(fn _ => let val strbind as strbind1=strbind1 +() + in ( STRUCTUREStrDec(I(STRUCTUREleft,strbindright), + strbind) ) + end +) + in (LrTable.NT 86,(result,STRUCTURE1left,strbind1right),rest671) end +| (216,(_,(_,_,ENDright as END1right))::(_,(MlyValue.popLocalInfix +popLocalInfix1,_,_))::(_,(MlyValue.strdec strdec2,_,_))::(_,( +MlyValue.pushLocalInfix pushLocalInfix1,_,_))::_::(_,(MlyValue.strdec +strdec1,_,_))::(_,(MlyValue.pushInfix pushInfix1,_,_))::(_,(_, +LOCALleft as LOCAL1left,_))::rest671) => let val result= +MlyValue.strdec1'(fn _ => let val pushInfix1=pushInfix1 () +val strdec1=strdec1 () +val pushLocalInfix1=pushLocalInfix1 () +val strdec2=strdec2 () +val popLocalInfix1=popLocalInfix1 () + in ( LOCALStrDec(I(LOCALleft,ENDright), strdec1, strdec2) ) end +) + in (LrTable.NT 86,(result,LOCAL1left,END1right),rest671) end +| (217,(_,(MlyValue.strexp__AND_strbind_opt strexp__AND_strbind_opt1,_ +,strexp__AND_strbind_optright as strexp__AND_strbind_opt1right))::_::( +_,(MlyValue.COLON_sigexp_opt COLON_sigexp_opt1,_,_))::(_,( +MlyValue.strid strid1,stridleft as strid1left,_))::rest671) => let +val result=MlyValue.strbind(fn _ => let val strid as strid1=strid1 () +val COLON_sigexp_opt as COLON_sigexp_opt1=COLON_sigexp_opt1 () +val strexp__AND_strbind_opt as strexp__AND_strbind_opt1= +strexp__AND_strbind_opt1 () + in ( + TRANSStrBind(I(stridleft, + strexp__AND_strbind_optright), + strid, COLON_sigexp_opt, + #1 strexp__AND_strbind_opt, + #2 strexp__AND_strbind_opt) +) end +) + in (LrTable.NT 87,(result,strid1left,strexp__AND_strbind_opt1right), +rest671) end +| (218,(_,(MlyValue.strexp__AND_strbind_opt strexp__AND_strbind_opt1,_ +,strexp__AND_strbind_optright as strexp__AND_strbind_opt1right))::_::( +_,(MlyValue.sigexp sigexp1,_,_))::_::(_,(MlyValue.strid strid1, +stridleft as strid1left,_))::rest671) => let val result= +MlyValue.strbind(fn _ => let val strid as strid1=strid1 () +val sigexp as sigexp1=sigexp1 () +val strexp__AND_strbind_opt as strexp__AND_strbind_opt1= +strexp__AND_strbind_opt1 () + in ( + OPAQStrBind(I(stridleft,strexp__AND_strbind_optright), + strid, sigexp, #1 strexp__AND_strbind_opt, + #2 strexp__AND_strbind_opt) +) end +) + in (LrTable.NT 87,(result,strid1left,strexp__AND_strbind_opt1right), +rest671) end +| (219,(_,(MlyValue.strbind strbind1,_,strbind1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_strbind_opt(fn _ => let +val strbind as strbind1=strbind1 () + in ( SOME strbind ) end +) + in (LrTable.NT 88,(result,AND1left,strbind1right),rest671) end +| (220,rest671) => let val result=MlyValue.AND_strbind_opt(fn _ => ( + NONE )) + in (LrTable.NT 88,(result,defaultPos,defaultPos),rest671) end +| (221,(_,(MlyValue.AND_strbind_opt AND_strbind_opt1,_, +AND_strbind_opt1right))::(_,(MlyValue.strexp' strexp'1,strexp'1left,_) +)::rest671) => let val result=MlyValue.strexp__AND_strbind_opt(fn _ + => let val strexp' as strexp'1=strexp'1 () +val AND_strbind_opt as AND_strbind_opt1=AND_strbind_opt1 () + in ( ( strexp', AND_strbind_opt ) ) end +) + in (LrTable.NT 89,(result,strexp'1left,AND_strbind_opt1right),rest671 +) end +| (222,(_,(MlyValue.sigexp__AND_strbind_opt sigexp__AND_strbind_opt1,_ +,sigexp__AND_strbind_optright as sigexp__AND_strbind_opt1right))::_::( +_,(MlyValue.strexp strexp1,strexpleft as strexp1left,_))::rest671) => +let val result=MlyValue.strexp__AND_strbind_opt(fn _ => let val strexp + as strexp1=strexp1 () +val sigexp__AND_strbind_opt as sigexp__AND_strbind_opt1= +sigexp__AND_strbind_opt1 () + in ( + ( TRANSStrExp(I(strexpleft, + sigexp__AND_strbind_optright), + strexp, #1 sigexp__AND_strbind_opt), + #2 sigexp__AND_strbind_opt ) +) end +) + in (LrTable.NT 89,(result,strexp1left,sigexp__AND_strbind_opt1right), +rest671) end +| (223,(_,(MlyValue.sigexp__AND_strbind_opt sigexp__AND_strbind_opt1,_ +,sigexp__AND_strbind_optright as sigexp__AND_strbind_opt1right))::_::( +_,(MlyValue.strexp strexp1,strexpleft as strexp1left,_))::rest671) => +let val result=MlyValue.strexp__AND_strbind_opt(fn _ => let val strexp + as strexp1=strexp1 () +val sigexp__AND_strbind_opt as sigexp__AND_strbind_opt1= +sigexp__AND_strbind_opt1 () + in ( + ( OPAQStrExp(I(strexpleft, + sigexp__AND_strbind_optright), + strexp, #1 sigexp__AND_strbind_opt), + #2 sigexp__AND_strbind_opt ) +) end +) + in (LrTable.NT 89,(result,strexp1left,sigexp__AND_strbind_opt1right), +rest671) end +| (224,(_,(MlyValue.AND_strbind_opt AND_strbind_opt1,_, +AND_strbind_opt1right))::(_,(MlyValue.sigexp' sigexp'1,sigexp'1left,_) +)::rest671) => let val result=MlyValue.sigexp__AND_strbind_opt(fn _ + => let val sigexp' as sigexp'1=sigexp'1 () +val AND_strbind_opt as AND_strbind_opt1=AND_strbind_opt1 () + in ( ( sigexp', AND_strbind_opt ) ) end +) + in (LrTable.NT 90,(result,sigexp'1left,AND_strbind_opt1right),rest671 +) end +| (225,(_,(MlyValue.tyreadesc__AND_strbind_opt +tyreadesc__AND_strbind_opt1,_,tyreadesc__AND_strbind_optright as +tyreadesc__AND_strbind_opt1right))::_::(_,(MlyValue.sigexp sigexp1, +sigexpleft as sigexp1left,_))::rest671) => let val result= +MlyValue.sigexp__AND_strbind_opt(fn _ => let val sigexp as sigexp1= +sigexp1 () +val tyreadesc__AND_strbind_opt as tyreadesc__AND_strbind_opt1= +tyreadesc__AND_strbind_opt1 () + in ( + ( WHERETYPESigExp(I(sigexpleft, + tyreadesc__AND_strbind_optright), + sigexp, + #1 tyreadesc__AND_strbind_opt), + #2 tyreadesc__AND_strbind_opt ) +) end +) + in (LrTable.NT 90,(result,sigexp1left, +tyreadesc__AND_strbind_opt1right),rest671) end +| (226,(_,(MlyValue.AND_tyreadesc_opt__AND_strbind_opt +AND_tyreadesc_opt__AND_strbind_opt1,_, +AND_tyreadesc_opt__AND_strbind_optright as +AND_tyreadesc_opt__AND_strbind_opt1right))::(_,(MlyValue.ty ty1,_,_)) +::_::(_,(MlyValue.longtycon longtycon1,_,_))::(_,(MlyValue.tyvarseq +tyvarseq1,_,_))::(_,(_,TYPEleft as TYPE1left,_))::rest671) => let val +result=MlyValue.tyreadesc__AND_strbind_opt(fn _ => let val tyvarseq + as tyvarseq1=tyvarseq1 () +val longtycon as longtycon1=longtycon1 () +val ty as ty1=ty1 () +val AND_tyreadesc_opt__AND_strbind_opt as +AND_tyreadesc_opt__AND_strbind_opt1= +AND_tyreadesc_opt__AND_strbind_opt1 () + in ( + ( TyReaDesc(I(TYPEleft, + AND_tyreadesc_opt__AND_strbind_optright), + tyvarseq, longtycon, ty, + #1 AND_tyreadesc_opt__AND_strbind_opt), + #2 AND_tyreadesc_opt__AND_strbind_opt ) +) end +) + in (LrTable.NT 91,(result,TYPE1left, +AND_tyreadesc_opt__AND_strbind_opt1right),rest671) end +| (227,(_,(MlyValue.AND_strbind_opt AND_strbind_opt1, +AND_strbind_opt1left,AND_strbind_opt1right))::rest671) => let val +result=MlyValue.AND_tyreadesc_opt__AND_strbind_opt(fn _ => let val +AND_strbind_opt as AND_strbind_opt1=AND_strbind_opt1 () + in ( ( NONE, AND_strbind_opt ) ) end +) + in (LrTable.NT 92,(result,AND_strbind_opt1left,AND_strbind_opt1right) +,rest671) end +| (228,(_,(MlyValue.tyreadesc__AND_strbind_opt +tyreadesc__AND_strbind_opt1,_,tyreadesc__AND_strbind_opt1right))::(_,( +_,AND1left,_))::rest671) => let val result= +MlyValue.AND_tyreadesc_opt__AND_strbind_opt(fn _ => let val +tyreadesc__AND_strbind_opt as tyreadesc__AND_strbind_opt1= +tyreadesc__AND_strbind_opt1 () + in ( + ( SOME(#1 tyreadesc__AND_strbind_opt), + #2 tyreadesc__AND_strbind_opt ) +) end +) + in (LrTable.NT 92,(result,AND1left,tyreadesc__AND_strbind_opt1right), +rest671) end +| (229,(_,(MlyValue.sigexp sigexp1,_,sigexp1right))::(_,(_,COLON1left, +_))::rest671) => let val result=MlyValue.COLON_sigexp_opt(fn _ => let +val sigexp as sigexp1=sigexp1 () + in ( SOME sigexp ) end +) + in (LrTable.NT 93,(result,COLON1left,sigexp1right),rest671) end +| (230,rest671) => let val result=MlyValue.COLON_sigexp_opt(fn _ => ( + NONE )) + in (LrTable.NT 93,(result,defaultPos,defaultPos),rest671) end +| (231,(_,(MlyValue.sigexp' sigexp'1,sigexp'1left,sigexp'1right)):: +rest671) => let val result=MlyValue.sigexp(fn _ => let val sigexp' as +sigexp'1=sigexp'1 () + in ( sigexp' ) end +) + in (LrTable.NT 94,(result,sigexp'1left,sigexp'1right),rest671) end +| (232,(_,(MlyValue.tyreadesc tyreadesc1,_,tyreadescright as +tyreadesc1right))::_::(_,(MlyValue.sigexp sigexp1,sigexpleft as +sigexp1left,_))::rest671) => let val result=MlyValue.sigexp(fn _ => +let val sigexp as sigexp1=sigexp1 () +val tyreadesc as tyreadesc1=tyreadesc1 () + in ( + WHERETYPESigExp(I(sigexpleft,tyreadescright), + sigexp, tyreadesc) +) end +) + in (LrTable.NT 94,(result,sigexp1left,tyreadesc1right),rest671) end +| (233,(_,(_,_,ENDright as END1right))::(_,(MlyValue.spec spec1,_,_)) +::(_,(_,SIGleft as SIG1left,_))::rest671) => let val result= +MlyValue.sigexp'(fn _ => let val spec as spec1=spec1 () + in ( SIGSigExp(I(SIGleft,ENDright), spec) ) end +) + in (LrTable.NT 95,(result,SIG1left,END1right),rest671) end +| (234,(_,(MlyValue.sigid sigid1,sigidleft as sigid1left,sigidright + as sigid1right))::rest671) => let val result=MlyValue.sigexp'(fn _ + => let val sigid as sigid1=sigid1 () + in ( SIGIDSigExp(I(sigidleft,sigidright), sigid) ) end +) + in (LrTable.NT 95,(result,sigid1left,sigid1right),rest671) end +| (235,(_,(MlyValue.sigbind sigbind1,_,sigbindright as sigbind1right)) +::(_,(_,SIGNATUREleft as SIGNATURE1left,_))::rest671) => let val +result=MlyValue.sigdec(fn _ => let val sigbind as sigbind1=sigbind1 () + in ( SigDec(I(SIGNATUREleft,sigbindright), sigbind) ) end +) + in (LrTable.NT 96,(result,SIGNATURE1left,sigbind1right),rest671) end +| (236,(_,(MlyValue.sigexp__AND_sigbind_opt sigexp__AND_sigbind_opt1,_ +,sigexp__AND_sigbind_optright as sigexp__AND_sigbind_opt1right))::_::( +_,(MlyValue.sigid sigid1,sigidleft as sigid1left,_))::rest671) => let +val result=MlyValue.sigbind(fn _ => let val sigid as sigid1=sigid1 () +val sigexp__AND_sigbind_opt as sigexp__AND_sigbind_opt1= +sigexp__AND_sigbind_opt1 () + in ( + SigBind(I(sigidleft,sigexp__AND_sigbind_optright), + sigid, #1 sigexp__AND_sigbind_opt, + #2 sigexp__AND_sigbind_opt) +) end +) + in (LrTable.NT 97,(result,sigid1left,sigexp__AND_sigbind_opt1right), +rest671) end +| (237,(_,(MlyValue.sigbind sigbind1,_,sigbind1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_sigbind_opt(fn _ => let +val sigbind as sigbind1=sigbind1 () + in ( SOME sigbind ) end +) + in (LrTable.NT 98,(result,AND1left,sigbind1right),rest671) end +| (238,rest671) => let val result=MlyValue.AND_sigbind_opt(fn _ => ( + NONE )) + in (LrTable.NT 98,(result,defaultPos,defaultPos),rest671) end +| (239,(_,(MlyValue.AND_sigbind_opt AND_sigbind_opt1,_, +AND_sigbind_opt1right))::(_,(MlyValue.sigexp' sigexp'1,sigexp'1left,_) +)::rest671) => let val result=MlyValue.sigexp__AND_sigbind_opt(fn _ + => let val sigexp' as sigexp'1=sigexp'1 () +val AND_sigbind_opt as AND_sigbind_opt1=AND_sigbind_opt1 () + in ( ( sigexp', AND_sigbind_opt ) ) end +) + in (LrTable.NT 99,(result,sigexp'1left,AND_sigbind_opt1right),rest671 +) end +| (240,(_,(MlyValue.tyreadesc__AND_sigbind_opt +tyreadesc__AND_sigbind_opt1,_,tyreadesc__AND_sigbind_optright as +tyreadesc__AND_sigbind_opt1right))::_::(_,(MlyValue.sigexp sigexp1, +sigexpleft as sigexp1left,_))::rest671) => let val result= +MlyValue.sigexp__AND_sigbind_opt(fn _ => let val sigexp as sigexp1= +sigexp1 () +val tyreadesc__AND_sigbind_opt as tyreadesc__AND_sigbind_opt1= +tyreadesc__AND_sigbind_opt1 () + in ( + ( WHERETYPESigExp(I(sigexpleft, + tyreadesc__AND_sigbind_optright), + sigexp, + #1 tyreadesc__AND_sigbind_opt), + #2 tyreadesc__AND_sigbind_opt ) +) end +) + in (LrTable.NT 99,(result,sigexp1left, +tyreadesc__AND_sigbind_opt1right),rest671) end +| (241,(_,(MlyValue.AND_tyreadesc_opt__AND_sigbind_opt +AND_tyreadesc_opt__AND_sigbind_opt1,_, +AND_tyreadesc_opt__AND_sigbind_optright as +AND_tyreadesc_opt__AND_sigbind_opt1right))::(_,(MlyValue.ty ty1,_,_)) +::_::(_,(MlyValue.longtycon longtycon1,_,_))::(_,(MlyValue.tyvarseq +tyvarseq1,_,_))::(_,(_,TYPEleft as TYPE1left,_))::rest671) => let val +result=MlyValue.tyreadesc__AND_sigbind_opt(fn _ => let val tyvarseq + as tyvarseq1=tyvarseq1 () +val longtycon as longtycon1=longtycon1 () +val ty as ty1=ty1 () +val AND_tyreadesc_opt__AND_sigbind_opt as +AND_tyreadesc_opt__AND_sigbind_opt1= +AND_tyreadesc_opt__AND_sigbind_opt1 () + in ( + ( TyReaDesc(I(TYPEleft, + AND_tyreadesc_opt__AND_sigbind_optright), + tyvarseq, longtycon, ty, + #1 AND_tyreadesc_opt__AND_sigbind_opt), + #2 AND_tyreadesc_opt__AND_sigbind_opt ) +) end +) + in (LrTable.NT 100,(result,TYPE1left, +AND_tyreadesc_opt__AND_sigbind_opt1right),rest671) end +| (242,(_,(MlyValue.AND_sigbind_opt AND_sigbind_opt1, +AND_sigbind_opt1left,AND_sigbind_opt1right))::rest671) => let val +result=MlyValue.AND_tyreadesc_opt__AND_sigbind_opt(fn _ => let val +AND_sigbind_opt as AND_sigbind_opt1=AND_sigbind_opt1 () + in ( ( NONE, AND_sigbind_opt) ) end +) + in (LrTable.NT 101,(result,AND_sigbind_opt1left,AND_sigbind_opt1right +),rest671) end +| (243,(_,(MlyValue.tyreadesc__AND_sigbind_opt +tyreadesc__AND_sigbind_opt1,_,tyreadesc__AND_sigbind_opt1right))::(_,( +_,AND1left,_))::rest671) => let val result= +MlyValue.AND_tyreadesc_opt__AND_sigbind_opt(fn _ => let val +tyreadesc__AND_sigbind_opt as tyreadesc__AND_sigbind_opt1= +tyreadesc__AND_sigbind_opt1 () + in ( + ( SOME(#1 tyreadesc__AND_sigbind_opt), + #2 tyreadesc__AND_sigbind_opt ) +) end +) + in (LrTable.NT 101,(result,AND1left,tyreadesc__AND_sigbind_opt1right) +,rest671) end +| (244,(_,(MlyValue.AND_tyreadesc_opt AND_tyreadesc_opt1,_, +AND_tyreadesc_optright as AND_tyreadesc_opt1right))::(_,(MlyValue.ty +ty1,_,_))::_::(_,(MlyValue.longtycon longtycon1,_,_))::(_,( +MlyValue.tyvarseq tyvarseq1,_,_))::(_,(_,TYPEleft as TYPE1left,_)):: +rest671) => let val result=MlyValue.tyreadesc(fn _ => let val tyvarseq + as tyvarseq1=tyvarseq1 () +val longtycon as longtycon1=longtycon1 () +val ty as ty1=ty1 () +val AND_tyreadesc_opt as AND_tyreadesc_opt1=AND_tyreadesc_opt1 () + in ( + TyReaDesc(I(TYPEleft,AND_tyreadesc_optright), + tyvarseq, longtycon, ty, + AND_tyreadesc_opt) +) end +) + in (LrTable.NT 102,(result,TYPE1left,AND_tyreadesc_opt1right),rest671 +) end +| (245,(_,(MlyValue.tyreadesc tyreadesc1,_,tyreadesc1right))::(_,(_, +AND1left,_))::rest671) => let val result=MlyValue.AND_tyreadesc_opt( +fn _ => let val tyreadesc as tyreadesc1=tyreadesc1 () + in ( SOME tyreadesc ) end +) + in (LrTable.NT 103,(result,AND1left,tyreadesc1right),rest671) end +| (246,rest671) => let val result=MlyValue.AND_tyreadesc_opt(fn _ => ( + NONE )) + in (LrTable.NT 103,(result,defaultPos,defaultPos),rest671) end +| (247,(_,(MlyValue.spec1 spec11,spec11left,spec11right))::rest671) + => let val result=MlyValue.spec(fn _ => let val spec1 as spec11= +spec11 () + in ( spec1 ) end +) + in (LrTable.NT 104,(result,spec11left,spec11right),rest671) end +| (248,rest671) => let val result=MlyValue.spec(fn _ => ( + EMPTYSpec(I(defaultPos,defaultPos)) )) + in (LrTable.NT 104,(result,defaultPos,defaultPos),rest671) end +| (249,(_,(MlyValue.spec1' spec1'1,spec1'1left,spec1'1right))::rest671 +) => let val result=MlyValue.spec1(fn _ => let val spec1' as spec1'1= +spec1'1 () + in ( spec1' ) end +) + in (LrTable.NT 105,(result,spec1'1left,spec1'1right),rest671) end +| (250,(_,(MlyValue.spec1' spec1'1,_,spec1'right as spec1'1right))::(_ +,(MlyValue.spec1 spec11,spec1left as spec11left,_))::rest671) => let +val result=MlyValue.spec1(fn _ => let val spec1 as spec11=spec11 () +val spec1' as spec1'1=spec1'1 () + in ( SEQSpec(I(spec1left,spec1'right), spec1, spec1') ) end +) + in (LrTable.NT 105,(result,spec11left,spec1'1right),rest671) end +| (251,(_,(_,SEMICOLON1left,SEMICOLON1right))::rest671) => let val +result=MlyValue.spec1(fn _ => ( EMPTYSpec(I(defaultPos,defaultPos)) )) + in (LrTable.NT 105,(result,SEMICOLON1left,SEMICOLON1right),rest671) + end +| (252,(_,(MlyValue.longtycon_EQUALS_list2 longtycon_EQUALS_list21,_, +longtycon_EQUALS_list2right as longtycon_EQUALS_list21right))::_::(_,( +_,SHARINGleft as SHARING1left,_))::rest671) => let val result= +MlyValue.spec1(fn _ => let val longtycon_EQUALS_list2 as +longtycon_EQUALS_list21=longtycon_EQUALS_list21 () + in ( + SHARINGTYPESpec(I(SHARINGleft, + longtycon_EQUALS_list2right), + EMPTYSpec(I(SHARINGleft,SHARINGleft)), + longtycon_EQUALS_list2) +) end +) + in (LrTable.NT 105,(result,SHARING1left,longtycon_EQUALS_list21right) +,rest671) end +| (253,(_,(MlyValue.longtycon_EQUALS_list2 longtycon_EQUALS_list21,_, +longtycon_EQUALS_list2right as longtycon_EQUALS_list21right))::_::_::( +_,(MlyValue.spec1 spec11,spec1left as spec11left,_))::rest671) => let +val result=MlyValue.spec1(fn _ => let val spec1 as spec11=spec11 () +val longtycon_EQUALS_list2 as longtycon_EQUALS_list21= +longtycon_EQUALS_list21 () + in ( + SHARINGTYPESpec(I(spec1left, + longtycon_EQUALS_list2right), + spec1, longtycon_EQUALS_list2) +) end +) + in (LrTable.NT 105,(result,spec11left,longtycon_EQUALS_list21right), +rest671) end +| (254,(_,(MlyValue.longstrid_EQUALS_list2 longstrid_EQUALS_list21,_, +longstrid_EQUALS_list2right as longstrid_EQUALS_list21right))::(_,(_, +SHARINGleft as SHARING1left,_))::rest671) => let val result= +MlyValue.spec1(fn _ => let val longstrid_EQUALS_list2 as +longstrid_EQUALS_list21=longstrid_EQUALS_list21 () + in ( + SHARINGSpec(I(SHARINGleft, + longstrid_EQUALS_list2right), + EMPTYSpec(I(SHARINGleft,SHARINGleft)), + longstrid_EQUALS_list2) +) end +) + in (LrTable.NT 105,(result,SHARING1left,longstrid_EQUALS_list21right) +,rest671) end +| (255,(_,(MlyValue.longstrid_EQUALS_list2 longstrid_EQUALS_list21,_, +longstrid_EQUALS_list2right as longstrid_EQUALS_list21right))::_::(_,( +MlyValue.spec1 spec11,spec1left as spec11left,_))::rest671) => let +val result=MlyValue.spec1(fn _ => let val spec1 as spec11=spec11 () +val longstrid_EQUALS_list2 as longstrid_EQUALS_list21= +longstrid_EQUALS_list21 () + in ( + SHARINGSpec(I(spec1left,longstrid_EQUALS_list2right), + spec1, longstrid_EQUALS_list2) +) end +) + in (LrTable.NT 105,(result,spec11left,longstrid_EQUALS_list21right), +rest671) end +| (256,(_,(MlyValue.valdesc valdesc1,_,valdescright as valdesc1right)) +::(_,(_,VALleft as VAL1left,_))::rest671) => let val result= +MlyValue.spec1'(fn _ => let val valdesc as valdesc1=valdesc1 () + in ( VALSpec(I(VALleft,valdescright), valdesc) ) end +) + in (LrTable.NT 106,(result,VAL1left,valdesc1right),rest671) end +| (257,(_,(MlyValue.typdesc typdesc1,_,typdescright as typdesc1right)) +::(_,(_,TYPEleft as TYPE1left,_))::rest671) => let val result= +MlyValue.spec1'(fn _ => let val typdesc as typdesc1=typdesc1 () + in ( TYPESpec(I(TYPEleft,typdescright), typdesc) ) end +) + in (LrTable.NT 106,(result,TYPE1left,typdesc1right),rest671) end +| (258,(_,(MlyValue.typdesc typdesc1,_,typdescright as typdesc1right)) +::(_,(_,EQTYPEleft as EQTYPE1left,_))::rest671) => let val result= +MlyValue.spec1'(fn _ => let val typdesc as typdesc1=typdesc1 () + in ( EQTYPESpec(I(EQTYPEleft,typdescright), typdesc) ) end +) + in (LrTable.NT 106,(result,EQTYPE1left,typdesc1right),rest671) end +| (259,(_,(MlyValue.syndesc syndesc1,_,syndescright as syndesc1right)) +::(_,(_,TYPEleft as TYPE1left,_))::rest671) => let val result= +MlyValue.spec1'(fn _ => let val syndesc as syndesc1=syndesc1 () + in ( SYNSpec(I(TYPEleft,syndescright), syndesc) ) end +) + in (LrTable.NT 106,(result,TYPE1left,syndesc1right),rest671) end +| (260,(_,(MlyValue.datdesc0 datdesc01,_,datdesc0right as +datdesc01right))::(_,(_,DATATYPEleft as DATATYPE1left,_))::rest671) + => let val result=MlyValue.spec1'(fn _ => let val datdesc0 as +datdesc01=datdesc01 () + in ( DATATYPESpec(I(DATATYPEleft,datdesc0right), datdesc0)) end +) + in (LrTable.NT 106,(result,DATATYPE1left,datdesc01right),rest671) end +| (261,(_,(MlyValue.datdesc1 datdesc11,_,datdesc1right as +datdesc11right))::(_,(_,DATATYPEleft as DATATYPE1left,_))::rest671) + => let val result=MlyValue.spec1'(fn _ => let val datdesc1 as +datdesc11=datdesc11 () + in ( DATATYPESpec(I(DATATYPEleft,datdesc1right), datdesc1)) end +) + in (LrTable.NT 106,(result,DATATYPE1left,datdesc11right),rest671) end +| (262,(_,(MlyValue.longtycon longtycon1,_,longtyconright as +longtycon1right))::_::_::(_,(MlyValue.tycon tycon1,_,_))::(_,(_, +DATATYPEleft as DATATYPE1left,_))::rest671) => let val result= +MlyValue.spec1'(fn _ => let val tycon as tycon1=tycon1 () +val longtycon as longtycon1=longtycon1 () + in ( + REPLICATIONSpec(I(DATATYPEleft,longtyconright), + tycon, longtycon) +) end +) + in (LrTable.NT 106,(result,DATATYPE1left,longtycon1right),rest671) + end +| (263,(_,(MlyValue.exdesc exdesc1,_,exdescright as exdesc1right))::(_ +,(_,EXCEPTIONleft as EXCEPTION1left,_))::rest671) => let val result= +MlyValue.spec1'(fn _ => let val exdesc as exdesc1=exdesc1 () + in ( EXCEPTIONSpec(I(EXCEPTIONleft,exdescright), exdesc) ) end +) + in (LrTable.NT 106,(result,EXCEPTION1left,exdesc1right),rest671) end +| (264,(_,(MlyValue.strdesc strdesc1,_,strdescright as strdesc1right)) +::(_,(_,STRUCTUREleft as STRUCTURE1left,_))::rest671) => let val +result=MlyValue.spec1'(fn _ => let val strdesc as strdesc1=strdesc1 () + in ( STRUCTURESpec(I(STRUCTUREleft,strdescright), strdesc)) end +) + in (LrTable.NT 106,(result,STRUCTURE1left,strdesc1right),rest671) end +| (265,(_,(MlyValue.sigexp sigexp1,_,sigexpright as sigexp1right))::(_ +,(_,INCLUDEleft as INCLUDE1left,_))::rest671) => let val result= +MlyValue.spec1'(fn _ => let val sigexp as sigexp1=sigexp1 () + in ( INCLUDESpec(I(INCLUDEleft,sigexpright), sigexp) ) end +) + in (LrTable.NT 106,(result,INCLUDE1left,sigexp1right),rest671) end +| (266,(_,(MlyValue.sigid_list2 sigid_list21,_,sigid_list2right as +sigid_list21right))::(_,(_,INCLUDEleft as INCLUDE1left,_))::rest671) + => let val result=MlyValue.spec1'(fn _ => let val sigid_list2 as +sigid_list21=sigid_list21 () + in ( + INCLUDEMULTISpec(I(INCLUDEleft,sigid_list2right), + sigid_list2) +) end +) + in (LrTable.NT 106,(result,INCLUDE1left,sigid_list21right),rest671) + end +| (267,(_,(MlyValue.sigid_list2 sigid_list21,_,sigid_list21right))::(_ +,(MlyValue.sigid sigid1,sigid1left,_))::rest671) => let val result= +MlyValue.sigid_list2(fn _ => let val sigid as sigid1=sigid1 () +val sigid_list2 as sigid_list21=sigid_list21 () + in ( sigid::sigid_list2 ) end +) + in (LrTable.NT 107,(result,sigid1left,sigid_list21right),rest671) end +| (268,(_,(MlyValue.sigid sigid2,_,sigid2right))::(_,(MlyValue.sigid +sigid1,sigid1left,_))::rest671) => let val result=MlyValue.sigid_list2 +(fn _ => let val sigid1=sigid1 () +val sigid2=sigid2 () + in ( sigid1::sigid2::[] ) end +) + in (LrTable.NT 107,(result,sigid1left,sigid2right),rest671) end +| (269,(_,(MlyValue.longtycon_EQUALS_list1 longtycon_EQUALS_list11,_, +longtycon_EQUALS_list11right))::_::(_,(MlyValue.longtycon longtycon1, +longtycon1left,_))::rest671) => let val result= +MlyValue.longtycon_EQUALS_list1(fn _ => let val longtycon as +longtycon1=longtycon1 () +val longtycon_EQUALS_list1 as longtycon_EQUALS_list11= +longtycon_EQUALS_list11 () + in ( longtycon::longtycon_EQUALS_list1 ) end +) + in (LrTable.NT 108,(result,longtycon1left, +longtycon_EQUALS_list11right),rest671) end +| (270,(_,(MlyValue.longtycon longtycon1,longtycon1left, +longtycon1right))::rest671) => let val result= +MlyValue.longtycon_EQUALS_list1(fn _ => let val longtycon as +longtycon1=longtycon1 () + in ( longtycon::[] ) end +) + in (LrTable.NT 108,(result,longtycon1left,longtycon1right),rest671) + end +| (271,(_,(MlyValue.longtycon_EQUALS_list1 longtycon_EQUALS_list11,_, +longtycon_EQUALS_list11right))::_::(_,(MlyValue.longtycon longtycon1, +longtycon1left,_))::rest671) => let val result= +MlyValue.longtycon_EQUALS_list2(fn _ => let val longtycon as +longtycon1=longtycon1 () +val longtycon_EQUALS_list1 as longtycon_EQUALS_list11= +longtycon_EQUALS_list11 () + in ( longtycon::longtycon_EQUALS_list1 ) end +) + in (LrTable.NT 109,(result,longtycon1left, +longtycon_EQUALS_list11right),rest671) end +| (272,(_,(MlyValue.longstrid_EQUALS_list1 longstrid_EQUALS_list11,_, +longstrid_EQUALS_list11right))::_::(_,(MlyValue.longstrid longstrid1, +longstrid1left,_))::rest671) => let val result= +MlyValue.longstrid_EQUALS_list1(fn _ => let val longstrid as +longstrid1=longstrid1 () +val longstrid_EQUALS_list1 as longstrid_EQUALS_list11= +longstrid_EQUALS_list11 () + in ( longstrid::longstrid_EQUALS_list1 ) end +) + in (LrTable.NT 110,(result,longstrid1left, +longstrid_EQUALS_list11right),rest671) end +| (273,(_,(MlyValue.longstrid longstrid1,longstrid1left, +longstrid1right))::rest671) => let val result= +MlyValue.longstrid_EQUALS_list1(fn _ => let val longstrid as +longstrid1=longstrid1 () + in ( longstrid::[] ) end +) + in (LrTable.NT 110,(result,longstrid1left,longstrid1right),rest671) + end +| (274,(_,(MlyValue.longstrid_EQUALS_list1 longstrid_EQUALS_list11,_, +longstrid_EQUALS_list11right))::_::(_,(MlyValue.longstrid longstrid1, +longstrid1left,_))::rest671) => let val result= +MlyValue.longstrid_EQUALS_list2(fn _ => let val longstrid as +longstrid1=longstrid1 () +val longstrid_EQUALS_list1 as longstrid_EQUALS_list11= +longstrid_EQUALS_list11 () + in ( longstrid::longstrid_EQUALS_list1 ) end +) + in (LrTable.NT 111,(result,longstrid1left, +longstrid_EQUALS_list11right),rest671) end +| (275,(_,(MlyValue.AND_valdesc_opt AND_valdesc_opt1,_, +AND_valdesc_optright as AND_valdesc_opt1right))::(_,(MlyValue.ty ty1,_ +,_))::_::(_,(MlyValue.vid' vid'1,vid'left as vid'1left,_))::rest671) + => let val result=MlyValue.valdesc(fn _ => let val vid' as vid'1= +vid'1 () +val ty as ty1=ty1 () +val AND_valdesc_opt as AND_valdesc_opt1=AND_valdesc_opt1 () + in ( + ValDesc(I(vid'left,AND_valdesc_optright), + vid', ty, AND_valdesc_opt) +) end +) + in (LrTable.NT 112,(result,vid'1left,AND_valdesc_opt1right),rest671) + end +| (276,(_,(MlyValue.valdesc valdesc1,_,valdesc1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_valdesc_opt(fn _ => let +val valdesc as valdesc1=valdesc1 () + in ( SOME valdesc ) end +) + in (LrTable.NT 113,(result,AND1left,valdesc1right),rest671) end +| (277,rest671) => let val result=MlyValue.AND_valdesc_opt(fn _ => ( + NONE )) + in (LrTable.NT 113,(result,defaultPos,defaultPos),rest671) end +| (278,(_,(MlyValue.AND_typdesc_opt AND_typdesc_opt1,_, +AND_typdesc_optright as AND_typdesc_opt1right))::(_,(MlyValue.tycon +tycon1,_,_))::(_,(MlyValue.tyvarseq tyvarseq1,tyvarseqleft as +tyvarseq1left,_))::rest671) => let val result=MlyValue.typdesc(fn _ + => let val tyvarseq as tyvarseq1=tyvarseq1 () +val tycon as tycon1=tycon1 () +val AND_typdesc_opt as AND_typdesc_opt1=AND_typdesc_opt1 () + in ( + TypDesc(I(tyvarseqleft,AND_typdesc_optright), + tyvarseq, tycon, AND_typdesc_opt) +) end +) + in (LrTable.NT 114,(result,tyvarseq1left,AND_typdesc_opt1right), +rest671) end +| (279,(_,(MlyValue.typdesc typdesc1,_,typdesc1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_typdesc_opt(fn _ => let +val typdesc as typdesc1=typdesc1 () + in ( SOME typdesc ) end +) + in (LrTable.NT 115,(result,AND1left,typdesc1right),rest671) end +| (280,rest671) => let val result=MlyValue.AND_typdesc_opt(fn _ => ( + NONE )) + in (LrTable.NT 115,(result,defaultPos,defaultPos),rest671) end +| (281,(_,(MlyValue.AND_syndesc_opt AND_syndesc_opt1,_, +AND_syndesc_optright as AND_syndesc_opt1right))::(_,(MlyValue.ty ty1,_ +,_))::_::(_,(MlyValue.tycon tycon1,_,_))::(_,(MlyValue.tyvarseq +tyvarseq1,tyvarseqleft as tyvarseq1left,_))::rest671) => let val +result=MlyValue.syndesc(fn _ => let val tyvarseq as tyvarseq1= +tyvarseq1 () +val tycon as tycon1=tycon1 () +val ty as ty1=ty1 () +val AND_syndesc_opt as AND_syndesc_opt1=AND_syndesc_opt1 () + in ( + SynDesc(I(tyvarseqleft,AND_syndesc_optright), + tyvarseq, tycon, ty, AND_syndesc_opt) +) end +) + in (LrTable.NT 116,(result,tyvarseq1left,AND_syndesc_opt1right), +rest671) end +| (282,(_,(MlyValue.syndesc syndesc1,_,syndesc1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_syndesc_opt(fn _ => let +val syndesc as syndesc1=syndesc1 () + in ( SOME syndesc ) end +) + in (LrTable.NT 117,(result,AND1left,syndesc1right),rest671) end +| (283,rest671) => let val result=MlyValue.AND_syndesc_opt(fn _ => ( + NONE )) + in (LrTable.NT 117,(result,defaultPos,defaultPos),rest671) end +| (284,(_,(MlyValue.AND_datdesc_opt AND_datdesc_opt1,_, +AND_datdesc_optright as AND_datdesc_opt1right))::(_,(MlyValue.condesc +condesc1,_,_))::_::(_,(MlyValue.tycon tycon1,_,_))::(_,( +MlyValue.tyvarseq tyvarseq1,tyvarseqleft as tyvarseq1left,_))::rest671 +) => let val result=MlyValue.datdesc(fn _ => let val tyvarseq as +tyvarseq1=tyvarseq1 () +val tycon as tycon1=tycon1 () +val condesc as condesc1=condesc1 () +val AND_datdesc_opt as AND_datdesc_opt1=AND_datdesc_opt1 () + in ( + DatDesc(I(tyvarseqleft,AND_datdesc_optright), + tyvarseq, tycon, condesc, AND_datdesc_opt) +) end +) + in (LrTable.NT 118,(result,tyvarseq1left,AND_datdesc_opt1right), +rest671) end +| (285,(_,(MlyValue.AND_datdesc_opt AND_datdesc_opt1,_, +AND_datdesc_optright as AND_datdesc_opt1right))::(_,(MlyValue.condesc +condesc1,_,_))::_::(_,(MlyValue.tycon tycon1,tyconleft as tycon1left,_ +))::rest671) => let val result=MlyValue.datdesc0(fn _ => let val tycon + as tycon1=tycon1 () +val condesc as condesc1=condesc1 () +val AND_datdesc_opt as AND_datdesc_opt1=AND_datdesc_opt1 () + in ( + DatDesc(I(tyconleft,AND_datdesc_optright), + TyVarseq(I(defaultPos,defaultPos), []), + tycon, condesc, AND_datdesc_opt) +) end +) + in (LrTable.NT 119,(result,tycon1left,AND_datdesc_opt1right),rest671) + end +| (286,(_,(MlyValue.AND_datdesc_opt AND_datdesc_opt1,_, +AND_datdesc_optright as AND_datdesc_opt1right))::(_,(MlyValue.condesc +condesc1,_,_))::_::(_,(MlyValue.tycon tycon1,_,_))::(_,( +MlyValue.tyvarseq1 tyvarseq11,tyvarseq1left as tyvarseq11left,_)):: +rest671) => let val result=MlyValue.datdesc1(fn _ => let val tyvarseq1 + as tyvarseq11=tyvarseq11 () +val tycon as tycon1=tycon1 () +val condesc as condesc1=condesc1 () +val AND_datdesc_opt as AND_datdesc_opt1=AND_datdesc_opt1 () + in ( + DatDesc(I(tyvarseq1left,AND_datdesc_optright), + tyvarseq1, tycon, condesc, AND_datdesc_opt) +) end +) + in (LrTable.NT 120,(result,tyvarseq11left,AND_datdesc_opt1right), +rest671) end +| (287,(_,(MlyValue.datdesc datdesc1,_,datdesc1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_datdesc_opt(fn _ => let +val datdesc as datdesc1=datdesc1 () + in ( SOME datdesc ) end +) + in (LrTable.NT 121,(result,AND1left,datdesc1right),rest671) end +| (288,rest671) => let val result=MlyValue.AND_datdesc_opt(fn _ => ( + NONE )) + in (LrTable.NT 121,(result,defaultPos,defaultPos),rest671) end +| (289,(_,(MlyValue.BAR_condesc_opt BAR_condesc_opt1,_, +BAR_condesc_optright as BAR_condesc_opt1right))::(_,( +MlyValue.OF_ty_opt OF_ty_opt1,_,_))::(_,(MlyValue.vid' vid'1,vid'left + as vid'1left,_))::rest671) => let val result=MlyValue.condesc(fn _ + => let val vid' as vid'1=vid'1 () +val OF_ty_opt as OF_ty_opt1=OF_ty_opt1 () +val BAR_condesc_opt as BAR_condesc_opt1=BAR_condesc_opt1 () + in ( + ConDesc(I(vid'left,BAR_condesc_optright), + vid', OF_ty_opt, BAR_condesc_opt) +) end +) + in (LrTable.NT 122,(result,vid'1left,BAR_condesc_opt1right),rest671) + end +| (290,(_,(MlyValue.condesc condesc1,_,condesc1right))::(_,(_,BAR1left +,_))::rest671) => let val result=MlyValue.BAR_condesc_opt(fn _ => let +val condesc as condesc1=condesc1 () + in ( SOME condesc ) end +) + in (LrTable.NT 123,(result,BAR1left,condesc1right),rest671) end +| (291,rest671) => let val result=MlyValue.BAR_condesc_opt(fn _ => ( + NONE )) + in (LrTable.NT 123,(result,defaultPos,defaultPos),rest671) end +| (292,(_,(MlyValue.AND_exdesc_opt AND_exdesc_opt1,_, +AND_exdesc_optright as AND_exdesc_opt1right))::(_,(MlyValue.OF_ty_opt +OF_ty_opt1,_,_))::(_,(MlyValue.vid' vid'1,vid'left as vid'1left,_)):: +rest671) => let val result=MlyValue.exdesc(fn _ => let val vid' as +vid'1=vid'1 () +val OF_ty_opt as OF_ty_opt1=OF_ty_opt1 () +val AND_exdesc_opt as AND_exdesc_opt1=AND_exdesc_opt1 () + in ( + ExDesc(I(vid'left,AND_exdesc_optright), + vid', OF_ty_opt, AND_exdesc_opt) +) end +) + in (LrTable.NT 124,(result,vid'1left,AND_exdesc_opt1right),rest671) + end +| (293,(_,(MlyValue.exdesc exdesc1,_,exdesc1right))::(_,(_,AND1left,_) +)::rest671) => let val result=MlyValue.AND_exdesc_opt(fn _ => let val +exdesc as exdesc1=exdesc1 () + in ( SOME exdesc ) end +) + in (LrTable.NT 125,(result,AND1left,exdesc1right),rest671) end +| (294,rest671) => let val result=MlyValue.AND_exdesc_opt(fn _ => ( + NONE )) + in (LrTable.NT 125,(result,defaultPos,defaultPos),rest671) end +| (295,(_,(MlyValue.sigexp__AND_strdesc_opt sigexp__AND_strdesc_opt1,_ +,sigexp__AND_strdesc_optright as sigexp__AND_strdesc_opt1right))::_::( +_,(MlyValue.strid strid1,stridleft as strid1left,_))::rest671) => let +val result=MlyValue.strdesc(fn _ => let val strid as strid1=strid1 () +val sigexp__AND_strdesc_opt as sigexp__AND_strdesc_opt1= +sigexp__AND_strdesc_opt1 () + in ( + StrDesc(I(stridleft,sigexp__AND_strdesc_optright), + strid, #1 sigexp__AND_strdesc_opt, + #2 sigexp__AND_strdesc_opt) +) end +) + in (LrTable.NT 126,(result,strid1left,sigexp__AND_strdesc_opt1right), +rest671) end +| (296,(_,(MlyValue.strdesc strdesc1,_,strdesc1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_strdesc_opt(fn _ => let +val strdesc as strdesc1=strdesc1 () + in ( SOME strdesc ) end +) + in (LrTable.NT 127,(result,AND1left,strdesc1right),rest671) end +| (297,rest671) => let val result=MlyValue.AND_strdesc_opt(fn _ => ( + NONE )) + in (LrTable.NT 127,(result,defaultPos,defaultPos),rest671) end +| (298,(_,(MlyValue.AND_strdesc_opt AND_strdesc_opt1,_, +AND_strdesc_opt1right))::(_,(MlyValue.sigexp' sigexp'1,sigexp'1left,_) +)::rest671) => let val result=MlyValue.sigexp__AND_strdesc_opt(fn _ + => let val sigexp' as sigexp'1=sigexp'1 () +val AND_strdesc_opt as AND_strdesc_opt1=AND_strdesc_opt1 () + in ( ( sigexp', AND_strdesc_opt ) ) end +) + in (LrTable.NT 128,(result,sigexp'1left,AND_strdesc_opt1right), +rest671) end +| (299,(_,(MlyValue.tyreadesc__AND_strdesc_opt +tyreadesc__AND_strdesc_opt1,_,tyreadesc__AND_strdesc_optright as +tyreadesc__AND_strdesc_opt1right))::_::(_,(MlyValue.sigexp sigexp1, +sigexpleft as sigexp1left,_))::rest671) => let val result= +MlyValue.sigexp__AND_strdesc_opt(fn _ => let val sigexp as sigexp1= +sigexp1 () +val tyreadesc__AND_strdesc_opt as tyreadesc__AND_strdesc_opt1= +tyreadesc__AND_strdesc_opt1 () + in ( + ( WHERETYPESigExp(I(sigexpleft, + tyreadesc__AND_strdesc_optright), + sigexp, + #1 tyreadesc__AND_strdesc_opt), + #2 tyreadesc__AND_strdesc_opt ) +) end +) + in (LrTable.NT 128,(result,sigexp1left, +tyreadesc__AND_strdesc_opt1right),rest671) end +| (300,(_,(MlyValue.AND_tyreadesc_opt__AND_strdesc_opt +AND_tyreadesc_opt__AND_strdesc_opt1,_, +AND_tyreadesc_opt__AND_strdesc_optright as +AND_tyreadesc_opt__AND_strdesc_opt1right))::(_,(MlyValue.ty ty1,_,_)) +::_::(_,(MlyValue.longtycon longtycon1,_,_))::(_,(MlyValue.tyvarseq +tyvarseq1,_,_))::(_,(_,TYPEleft as TYPE1left,_))::rest671) => let val +result=MlyValue.tyreadesc__AND_strdesc_opt(fn _ => let val tyvarseq + as tyvarseq1=tyvarseq1 () +val longtycon as longtycon1=longtycon1 () +val ty as ty1=ty1 () +val AND_tyreadesc_opt__AND_strdesc_opt as +AND_tyreadesc_opt__AND_strdesc_opt1= +AND_tyreadesc_opt__AND_strdesc_opt1 () + in ( + ( TyReaDesc(I(TYPEleft, + AND_tyreadesc_opt__AND_strdesc_optright), + tyvarseq, longtycon, ty, + #1 AND_tyreadesc_opt__AND_strdesc_opt), + #2 AND_tyreadesc_opt__AND_strdesc_opt ) +) end +) + in (LrTable.NT 129,(result,TYPE1left, +AND_tyreadesc_opt__AND_strdesc_opt1right),rest671) end +| (301,(_,(MlyValue.AND_strdesc_opt AND_strdesc_opt1, +AND_strdesc_opt1left,AND_strdesc_opt1right))::rest671) => let val +result=MlyValue.AND_tyreadesc_opt__AND_strdesc_opt(fn _ => let val +AND_strdesc_opt as AND_strdesc_opt1=AND_strdesc_opt1 () + in ( ( NONE, AND_strdesc_opt ) ) end +) + in (LrTable.NT 130,(result,AND_strdesc_opt1left,AND_strdesc_opt1right +),rest671) end +| (302,(_,(MlyValue.tyreadesc__AND_strdesc_opt +tyreadesc__AND_strdesc_opt1,_,tyreadesc__AND_strdesc_opt1right))::(_,( +_,AND1left,_))::rest671) => let val result= +MlyValue.AND_tyreadesc_opt__AND_strdesc_opt(fn _ => let val +tyreadesc__AND_strdesc_opt as tyreadesc__AND_strdesc_opt1= +tyreadesc__AND_strdesc_opt1 () + in ( + ( SOME(#1 tyreadesc__AND_strdesc_opt), + #2 tyreadesc__AND_strdesc_opt ) +) end +) + in (LrTable.NT 130,(result,AND1left,tyreadesc__AND_strdesc_opt1right) +,rest671) end +| (303,(_,(MlyValue.funbind funbind1,_,funbindright as funbind1right)) +::(_,(_,FUNCTORleft as FUNCTOR1left,_))::rest671) => let val result= +MlyValue.fundec(fn _ => let val funbind as funbind1=funbind1 () + in ( FunDec(I(FUNCTORleft,funbindright), funbind) ) end +) + in (LrTable.NT 131,(result,FUNCTOR1left,funbind1right),rest671) end +| (304,(_,(MlyValue.strexp__AND_funbind_opt strexp__AND_funbind_opt1,_ +,strexp__AND_funbind_optright as strexp__AND_funbind_opt1right))::_::( +_,(MlyValue.COLON_sigexp_opt COLON_sigexp_opt1,_,_))::_::(_,( +MlyValue.sigexp sigexp1,_,_))::_::(_,(MlyValue.strid strid1,_,_))::_:: +(_,(MlyValue.funid funid1,funidleft as funid1left,_))::rest671) => +let val result=MlyValue.funbind(fn _ => let val funid as funid1=funid1 + () +val strid as strid1=strid1 () +val sigexp as sigexp1=sigexp1 () +val COLON_sigexp_opt as COLON_sigexp_opt1=COLON_sigexp_opt1 () +val strexp__AND_funbind_opt as strexp__AND_funbind_opt1= +strexp__AND_funbind_opt1 () + in ( + TRANSFunBind(I(funidleft, + strexp__AND_funbind_optright), + funid, strid, sigexp, COLON_sigexp_opt, + #1 strexp__AND_funbind_opt, + #2 strexp__AND_funbind_opt) +) end +) + in (LrTable.NT 132,(result,funid1left,strexp__AND_funbind_opt1right), +rest671) end +| (305,(_,(MlyValue.strexp__AND_funbind_opt strexp__AND_funbind_opt1,_ +,strexp__AND_funbind_optright as strexp__AND_funbind_opt1right))::_::( +_,(MlyValue.sigexp sigexp2,_,_))::_::_::(_,(MlyValue.sigexp sigexp1,_, +_))::_::(_,(MlyValue.strid strid1,_,_))::_::(_,(MlyValue.funid funid1, +funidleft as funid1left,_))::rest671) => let val result= +MlyValue.funbind(fn _ => let val funid as funid1=funid1 () +val strid as strid1=strid1 () +val sigexp1=sigexp1 () +val sigexp2=sigexp2 () +val strexp__AND_funbind_opt as strexp__AND_funbind_opt1= +strexp__AND_funbind_opt1 () + in ( + OPAQFunBind(I(funidleft,strexp__AND_funbind_optright), + funid, strid, sigexp1, sigexp2, + #1 strexp__AND_funbind_opt, + #2 strexp__AND_funbind_opt) +) end +) + in (LrTable.NT 132,(result,funid1left,strexp__AND_funbind_opt1right), +rest671) end +| (306,(_,(MlyValue.strexp__AND_funbind_opt strexp__AND_funbind_opt1,_ +,strexp__AND_funbind_optright as strexp__AND_funbind_opt1right))::_::( +_,(MlyValue.COLON_sigexp_opt COLON_sigexp_opt1,_,_))::_::(_,( +MlyValue.spec spec1,_,_))::_::(_,(MlyValue.funid funid1,funidleft as +funid1left,_))::rest671) => let val result=MlyValue.funbind(fn _ => +let val funid as funid1=funid1 () +val spec as spec1=spec1 () +val COLON_sigexp_opt as COLON_sigexp_opt1=COLON_sigexp_opt1 () +val strexp__AND_funbind_opt as strexp__AND_funbind_opt1= +strexp__AND_funbind_opt1 () + in ( + TRANSSPECFunBind(I(funidleft, + strexp__AND_funbind_optright), + funid, spec, COLON_sigexp_opt, + #1 strexp__AND_funbind_opt, + #2 strexp__AND_funbind_opt) +) end +) + in (LrTable.NT 132,(result,funid1left,strexp__AND_funbind_opt1right), +rest671) end +| (307,(_,(MlyValue.strexp__AND_funbind_opt strexp__AND_funbind_opt1,_ +,strexp__AND_funbind_optright as strexp__AND_funbind_opt1right))::_::( +_,(MlyValue.sigexp sigexp1,_,_))::_::_::(_,(MlyValue.spec spec1,_,_)) +::_::(_,(MlyValue.funid funid1,funidleft as funid1left,_))::rest671) + => let val result=MlyValue.funbind(fn _ => let val funid as funid1= +funid1 () +val spec as spec1=spec1 () +val sigexp as sigexp1=sigexp1 () +val strexp__AND_funbind_opt as strexp__AND_funbind_opt1= +strexp__AND_funbind_opt1 () + in ( + OPAQSPECFunBind(I(funidleft, + strexp__AND_funbind_optright), + funid, spec, sigexp, + #1 strexp__AND_funbind_opt, + #2 strexp__AND_funbind_opt) +) end +) + in (LrTable.NT 132,(result,funid1left,strexp__AND_funbind_opt1right), +rest671) end +| (308,(_,(MlyValue.funbind funbind1,_,funbind1right))::(_,(_,AND1left +,_))::rest671) => let val result=MlyValue.AND_funbind_opt(fn _ => let +val funbind as funbind1=funbind1 () + in ( SOME funbind ) end +) + in (LrTable.NT 133,(result,AND1left,funbind1right),rest671) end +| (309,rest671) => let val result=MlyValue.AND_funbind_opt(fn _ => ( + NONE )) + in (LrTable.NT 133,(result,defaultPos,defaultPos),rest671) end +| (310,(_,(MlyValue.AND_funbind_opt AND_funbind_opt1,_, +AND_funbind_opt1right))::(_,(MlyValue.strexp' strexp'1,strexp'1left,_) +)::rest671) => let val result=MlyValue.strexp__AND_funbind_opt(fn _ + => let val strexp' as strexp'1=strexp'1 () +val AND_funbind_opt as AND_funbind_opt1=AND_funbind_opt1 () + in ( ( strexp', AND_funbind_opt ) ) end +) + in (LrTable.NT 134,(result,strexp'1left,AND_funbind_opt1right), +rest671) end +| (311,(_,(MlyValue.sigexp__AND_funbind_opt sigexp__AND_funbind_opt1,_ +,sigexp__AND_funbind_optright as sigexp__AND_funbind_opt1right))::_::( +_,(MlyValue.strexp strexp1,strexpleft as strexp1left,_))::rest671) => +let val result=MlyValue.strexp__AND_funbind_opt(fn _ => let val strexp + as strexp1=strexp1 () +val sigexp__AND_funbind_opt as sigexp__AND_funbind_opt1= +sigexp__AND_funbind_opt1 () + in ( + ( TRANSStrExp(I(strexpleft, + sigexp__AND_funbind_optright), + strexp, #1 sigexp__AND_funbind_opt), + #2 sigexp__AND_funbind_opt ) +) end +) + in (LrTable.NT 134,(result,strexp1left,sigexp__AND_funbind_opt1right) +,rest671) end +| (312,(_,(MlyValue.sigexp__AND_funbind_opt sigexp__AND_funbind_opt1,_ +,sigexp__AND_funbind_optright as sigexp__AND_funbind_opt1right))::_::( +_,(MlyValue.strexp strexp1,strexpleft as strexp1left,_))::rest671) => +let val result=MlyValue.strexp__AND_funbind_opt(fn _ => let val strexp + as strexp1=strexp1 () +val sigexp__AND_funbind_opt as sigexp__AND_funbind_opt1= +sigexp__AND_funbind_opt1 () + in ( + ( OPAQStrExp(I(strexpleft, + sigexp__AND_funbind_optright), + strexp, #1 sigexp__AND_funbind_opt), + #2 sigexp__AND_funbind_opt ) +) end +) + in (LrTable.NT 134,(result,strexp1left,sigexp__AND_funbind_opt1right) +,rest671) end +| (313,(_,(MlyValue.AND_funbind_opt AND_funbind_opt1,_, +AND_funbind_opt1right))::(_,(MlyValue.sigexp' sigexp'1,sigexp'1left,_) +)::rest671) => let val result=MlyValue.sigexp__AND_funbind_opt(fn _ + => let val sigexp' as sigexp'1=sigexp'1 () +val AND_funbind_opt as AND_funbind_opt1=AND_funbind_opt1 () + in ( ( sigexp', AND_funbind_opt ) ) end +) + in (LrTable.NT 135,(result,sigexp'1left,AND_funbind_opt1right), +rest671) end +| (314,(_,(MlyValue.tyreadesc__AND_funbind_opt +tyreadesc__AND_funbind_opt1,_,tyreadesc__AND_funbind_optright as +tyreadesc__AND_funbind_opt1right))::_::(_,(MlyValue.sigexp sigexp1, +sigexpleft as sigexp1left,_))::rest671) => let val result= +MlyValue.sigexp__AND_funbind_opt(fn _ => let val sigexp as sigexp1= +sigexp1 () +val tyreadesc__AND_funbind_opt as tyreadesc__AND_funbind_opt1= +tyreadesc__AND_funbind_opt1 () + in ( + ( WHERETYPESigExp(I(sigexpleft, + tyreadesc__AND_funbind_optright), + sigexp, + #1 tyreadesc__AND_funbind_opt), + #2 tyreadesc__AND_funbind_opt ) +) end +) + in (LrTable.NT 135,(result,sigexp1left, +tyreadesc__AND_funbind_opt1right),rest671) end +| (315,(_,(MlyValue.AND_tyreadesc_opt__AND_funbind_opt +AND_tyreadesc_opt__AND_funbind_opt1,_, +AND_tyreadesc_opt__AND_funbind_optright as +AND_tyreadesc_opt__AND_funbind_opt1right))::(_,(MlyValue.ty ty1,_,_)) +::_::(_,(MlyValue.longtycon longtycon1,_,_))::(_,(MlyValue.tyvarseq +tyvarseq1,_,_))::(_,(_,TYPEleft as TYPE1left,_))::rest671) => let val +result=MlyValue.tyreadesc__AND_funbind_opt(fn _ => let val tyvarseq + as tyvarseq1=tyvarseq1 () +val longtycon as longtycon1=longtycon1 () +val ty as ty1=ty1 () +val AND_tyreadesc_opt__AND_funbind_opt as +AND_tyreadesc_opt__AND_funbind_opt1= +AND_tyreadesc_opt__AND_funbind_opt1 () + in ( + ( TyReaDesc(I(TYPEleft, + AND_tyreadesc_opt__AND_funbind_optright), + tyvarseq, longtycon, ty, + #1 AND_tyreadesc_opt__AND_funbind_opt), + #2 AND_tyreadesc_opt__AND_funbind_opt ) +) end +) + in (LrTable.NT 136,(result,TYPE1left, +AND_tyreadesc_opt__AND_funbind_opt1right),rest671) end +| (316,(_,(MlyValue.AND_funbind_opt AND_funbind_opt1, +AND_funbind_opt1left,AND_funbind_opt1right))::rest671) => let val +result=MlyValue.AND_tyreadesc_opt__AND_funbind_opt(fn _ => let val +AND_funbind_opt as AND_funbind_opt1=AND_funbind_opt1 () + in ( ( NONE, AND_funbind_opt ) ) end +) + in (LrTable.NT 137,(result,AND_funbind_opt1left,AND_funbind_opt1right +),rest671) end +| (317,(_,(MlyValue.tyreadesc__AND_funbind_opt +tyreadesc__AND_funbind_opt1,_,tyreadesc__AND_funbind_opt1right))::(_,( +_,AND1left,_))::rest671) => let val result= +MlyValue.AND_tyreadesc_opt__AND_funbind_opt(fn _ => let val +tyreadesc__AND_funbind_opt as tyreadesc__AND_funbind_opt1= +tyreadesc__AND_funbind_opt1 () + in ( + ( SOME(#1 tyreadesc__AND_funbind_opt), + #2 tyreadesc__AND_funbind_opt ) +) end +) + in (LrTable.NT 137,(result,AND1left,tyreadesc__AND_funbind_opt1right) +,rest671) end +| (318,(_,(MlyValue.topdec1 topdec11,topdec11left,topdec11right)):: +rest671) => let val result=MlyValue.topdec(fn _ => let val topdec1 as +topdec11=topdec11 () + in ( topdec1 ) end +) + in (LrTable.NT 138,(result,topdec11left,topdec11right),rest671) end +| (319,rest671) => let val result=MlyValue.topdec(fn _ => ( + STRDECTopDec(I(defaultPos,defaultPos), + EMPTYStrDec(I(defaultPos,defaultPos)), + NONE) +)) + in (LrTable.NT 138,(result,defaultPos,defaultPos),rest671) end +| (320,(_,(MlyValue.topdec_opt topdec_opt1,_,topdec_optright as +topdec_opt1right))::(_,(MlyValue.strdec1' strdec1'1,strdec1'left as +strdec1'1left,_))::rest671) => let val result=MlyValue.topdec1(fn _ + => let val strdec1' as strdec1'1=strdec1'1 () +val topdec_opt as topdec_opt1=topdec_opt1 () + in ( + STRDECTopDec(I(strdec1'left,topdec_optright), + strdec1', topdec_opt) +) end +) + in (LrTable.NT 139,(result,strdec1'1left,topdec_opt1right),rest671) + end +| (321,(_,(MlyValue.topdec_opt topdec_opt1,_,topdec_optright as +topdec_opt1right))::(_,(MlyValue.sigdec sigdec1,sigdecleft as +sigdec1left,_))::rest671) => let val result=MlyValue.topdec1(fn _ => +let val sigdec as sigdec1=sigdec1 () +val topdec_opt as topdec_opt1=topdec_opt1 () + in ( + SIGDECTopDec(I(sigdecleft,topdec_optright), + sigdec, topdec_opt) +) end +) + in (LrTable.NT 139,(result,sigdec1left,topdec_opt1right),rest671) end +| (322,(_,(MlyValue.topdec_opt topdec_opt1,_,topdec_optright as +topdec_opt1right))::(_,(MlyValue.fundec fundec1,fundecleft as +fundec1left,_))::rest671) => let val result=MlyValue.topdec1(fn _ => +let val fundec as fundec1=fundec1 () +val topdec_opt as topdec_opt1=topdec_opt1 () + in ( + FUNDECTopDec(I(fundecleft,topdec_optright), + fundec, topdec_opt) +) end +) + in (LrTable.NT 139,(result,fundec1left,topdec_opt1right),rest671) end +| (323,(_,(MlyValue.topdec1 topdec11,topdec11left,topdec11right)):: +rest671) => let val result=MlyValue.topdec_opt(fn _ => let val topdec1 + as topdec11=topdec11 () + in ( SOME topdec1 ) end +) + in (LrTable.NT 140,(result,topdec11left,topdec11right),rest671) end +| (324,rest671) => let val result=MlyValue.topdec_opt(fn _ => ( NONE ) +) + in (LrTable.NT 140,(result,defaultPos,defaultPos),rest671) end +| (325,(_,(MlyValue.program' program'1,_,program'1right))::(_,( +MlyValue.initInfix initInfix1,initInfix1left,_))::rest671) => let val +result=MlyValue.program(fn _ => let val initInfix1=initInfix1 () +val program' as program'1=program'1 () + in ( (program', !J) ) end +) + in (LrTable.NT 141,(result,initInfix1left,program'1right),rest671) + end +| (326,(_,(MlyValue.program_opt program_opt1,_,program_opt1right))::(_ +,(_,_,SEMICOLONright))::(_,(MlyValue.topdec topdec1,topdecleft as +topdec1left,_))::rest671) => let val result=MlyValue.program'(fn _ => +let val topdec as topdec1=topdec1 () +val program_opt as program_opt1=program_opt1 () + in ( + TOPDECProgram(I(topdecleft,SEMICOLONright), + topdec, program_opt) +) end +) + in (LrTable.NT 142,(result,topdec1left,program_opt1right),rest671) + end +| (327,(_,(MlyValue.program_opt program_opt1,_,program_opt1right))::(_ +,(_,_,SEMICOLONright))::(_,(MlyValue.exp exp1,expleft as exp1left,_)) +::rest671) => let val result=MlyValue.program'(fn _ => let val exp as +exp1=exp1 () +val program_opt as program_opt1=program_opt1 () + in ( + EXPProgram(I(expleft,SEMICOLONright), + exp, program_opt) ) + end +) + in (LrTable.NT 142,(result,exp1left,program_opt1right),rest671) end +| (328,(_,(MlyValue.program' program'1,program'1left,program'1right)) +::rest671) => let val result=MlyValue.program_opt(fn _ => let val +program' as program'1=program'1 () + in ( SOME program' ) end +) + in (LrTable.NT 143,(result,program'1left,program'1right),rest671) end +| (329,rest671) => let val result=MlyValue.program_opt(fn _ => ( NONE +)) + in (LrTable.NT 143,(result,defaultPos,defaultPos),rest671) end +| _ => raise (mlyAction i392) +end +val void = MlyValue.VOID +val extract = fn a => (fn MlyValue.program x => x +| _ => let exception ParseInternal + in raise ParseInternal end) a () +end +end +structure Tokens : Parser_TOKENS = +struct +type svalue = ParserData.svalue +type ('a,'b) token = ('a,'b) Token.token +fun EOF (p1,p2) = Token.TOKEN (ParserData.LrTable.T 0,( +ParserData.MlyValue.VOID,p1,p2)) +fun ABSTYPE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 1,( +ParserData.MlyValue.VOID,p1,p2)) +fun AND (p1,p2) = Token.TOKEN (ParserData.LrTable.T 2,( +ParserData.MlyValue.VOID,p1,p2)) +fun ANDALSO (p1,p2) = Token.TOKEN (ParserData.LrTable.T 3,( +ParserData.MlyValue.VOID,p1,p2)) +fun AS (p1,p2) = Token.TOKEN (ParserData.LrTable.T 4,( +ParserData.MlyValue.VOID,p1,p2)) +fun CASE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 5,( +ParserData.MlyValue.VOID,p1,p2)) +fun DO (p1,p2) = Token.TOKEN (ParserData.LrTable.T 6,( +ParserData.MlyValue.VOID,p1,p2)) +fun DATATYPE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 7,( +ParserData.MlyValue.VOID,p1,p2)) +fun ELSE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 8,( +ParserData.MlyValue.VOID,p1,p2)) +fun END (p1,p2) = Token.TOKEN (ParserData.LrTable.T 9,( +ParserData.MlyValue.VOID,p1,p2)) +fun EXCEPTION (p1,p2) = Token.TOKEN (ParserData.LrTable.T 10,( +ParserData.MlyValue.VOID,p1,p2)) +fun FN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 11,( +ParserData.MlyValue.VOID,p1,p2)) +fun FUN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 12,( +ParserData.MlyValue.VOID,p1,p2)) +fun HANDLE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 13,( +ParserData.MlyValue.VOID,p1,p2)) +fun IF (p1,p2) = Token.TOKEN (ParserData.LrTable.T 14,( +ParserData.MlyValue.VOID,p1,p2)) +fun IN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 15,( +ParserData.MlyValue.VOID,p1,p2)) +fun INFIX (p1,p2) = Token.TOKEN (ParserData.LrTable.T 16,( +ParserData.MlyValue.VOID,p1,p2)) +fun INFIXR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 17,( +ParserData.MlyValue.VOID,p1,p2)) +fun LET (p1,p2) = Token.TOKEN (ParserData.LrTable.T 18,( +ParserData.MlyValue.VOID,p1,p2)) +fun LOCAL (p1,p2) = Token.TOKEN (ParserData.LrTable.T 19,( +ParserData.MlyValue.VOID,p1,p2)) +fun NONFIX (p1,p2) = Token.TOKEN (ParserData.LrTable.T 20,( +ParserData.MlyValue.VOID,p1,p2)) +fun OF (p1,p2) = Token.TOKEN (ParserData.LrTable.T 21,( +ParserData.MlyValue.VOID,p1,p2)) +fun OP (p1,p2) = Token.TOKEN (ParserData.LrTable.T 22,( +ParserData.MlyValue.VOID,p1,p2)) +fun OPEN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 23,( +ParserData.MlyValue.VOID,p1,p2)) +fun ORELSE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 24,( +ParserData.MlyValue.VOID,p1,p2)) +fun RAISE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 25,( +ParserData.MlyValue.VOID,p1,p2)) +fun REC (p1,p2) = Token.TOKEN (ParserData.LrTable.T 26,( +ParserData.MlyValue.VOID,p1,p2)) +fun THEN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 27,( +ParserData.MlyValue.VOID,p1,p2)) +fun TYPE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 28,( +ParserData.MlyValue.VOID,p1,p2)) +fun VAL (p1,p2) = Token.TOKEN (ParserData.LrTable.T 29,( +ParserData.MlyValue.VOID,p1,p2)) +fun WITH (p1,p2) = Token.TOKEN (ParserData.LrTable.T 30,( +ParserData.MlyValue.VOID,p1,p2)) +fun WITHTYPE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 31,( +ParserData.MlyValue.VOID,p1,p2)) +fun WHILE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 32,( +ParserData.MlyValue.VOID,p1,p2)) +fun LPAR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 33,( +ParserData.MlyValue.VOID,p1,p2)) +fun RPAR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 34,( +ParserData.MlyValue.VOID,p1,p2)) +fun LBRACK (p1,p2) = Token.TOKEN (ParserData.LrTable.T 35,( +ParserData.MlyValue.VOID,p1,p2)) +fun RBRACK (p1,p2) = Token.TOKEN (ParserData.LrTable.T 36,( +ParserData.MlyValue.VOID,p1,p2)) +fun LBRACE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 37,( +ParserData.MlyValue.VOID,p1,p2)) +fun RBRACE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 38,( +ParserData.MlyValue.VOID,p1,p2)) +fun COMMA (p1,p2) = Token.TOKEN (ParserData.LrTable.T 39,( +ParserData.MlyValue.VOID,p1,p2)) +fun COLON (p1,p2) = Token.TOKEN (ParserData.LrTable.T 40,( +ParserData.MlyValue.VOID,p1,p2)) +fun SEMICOLON (p1,p2) = Token.TOKEN (ParserData.LrTable.T 41,( +ParserData.MlyValue.VOID,p1,p2)) +fun DOTS (p1,p2) = Token.TOKEN (ParserData.LrTable.T 42,( +ParserData.MlyValue.VOID,p1,p2)) +fun UNDERBAR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 43,( +ParserData.MlyValue.VOID,p1,p2)) +fun BAR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 44,( +ParserData.MlyValue.VOID,p1,p2)) +fun EQUALS (p1,p2) = Token.TOKEN (ParserData.LrTable.T 45,( +ParserData.MlyValue.VOID,p1,p2)) +fun DARROW (p1,p2) = Token.TOKEN (ParserData.LrTable.T 46,( +ParserData.MlyValue.VOID,p1,p2)) +fun ARROW (p1,p2) = Token.TOKEN (ParserData.LrTable.T 47,( +ParserData.MlyValue.VOID,p1,p2)) +fun HASH (p1,p2) = Token.TOKEN (ParserData.LrTable.T 48,( +ParserData.MlyValue.VOID,p1,p2)) +fun EQTYPE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 49,( +ParserData.MlyValue.VOID,p1,p2)) +fun FUNCTOR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 50,( +ParserData.MlyValue.VOID,p1,p2)) +fun INCLUDE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 51,( +ParserData.MlyValue.VOID,p1,p2)) +fun SHARING (p1,p2) = Token.TOKEN (ParserData.LrTable.T 52,( +ParserData.MlyValue.VOID,p1,p2)) +fun SIG (p1,p2) = Token.TOKEN (ParserData.LrTable.T 53,( +ParserData.MlyValue.VOID,p1,p2)) +fun SIGNATURE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 54,( +ParserData.MlyValue.VOID,p1,p2)) +fun STRUCT (p1,p2) = Token.TOKEN (ParserData.LrTable.T 55,( +ParserData.MlyValue.VOID,p1,p2)) +fun STRUCTURE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 56,( +ParserData.MlyValue.VOID,p1,p2)) +fun WHERE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 57,( +ParserData.MlyValue.VOID,p1,p2)) +fun COLONGREATER (p1,p2) = Token.TOKEN (ParserData.LrTable.T 58,( +ParserData.MlyValue.VOID,p1,p2)) +fun ZERO (p1,p2) = Token.TOKEN (ParserData.LrTable.T 59,( +ParserData.MlyValue.VOID,p1,p2)) +fun DIGIT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 60,( +ParserData.MlyValue.DIGIT (fn () => i),p1,p2)) +fun NUMERIC (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 61,( +ParserData.MlyValue.NUMERIC (fn () => i),p1,p2)) +fun INT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 62,( +ParserData.MlyValue.INT (fn () => i),p1,p2)) +fun WORD (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 63,( +ParserData.MlyValue.WORD (fn () => i),p1,p2)) +fun REAL (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 64,( +ParserData.MlyValue.REAL (fn () => i),p1,p2)) +fun STRING (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 65,( +ParserData.MlyValue.STRING (fn () => i),p1,p2)) +fun CHAR (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 66,( +ParserData.MlyValue.CHAR (fn () => i),p1,p2)) +fun ALPHA (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 67,( +ParserData.MlyValue.ALPHA (fn () => i),p1,p2)) +fun SYMBOL (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 68,( +ParserData.MlyValue.SYMBOL (fn () => i),p1,p2)) +fun STAR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 69,( +ParserData.MlyValue.VOID,p1,p2)) +fun TYVAR (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 70,( +ParserData.MlyValue.TYVAR (fn () => i),p1,p2)) +fun ETYVAR (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 71,( +ParserData.MlyValue.ETYVAR (fn () => i),p1,p2)) +fun LONGID (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 72,( +ParserData.MlyValue.LONGID (fn () => i),p1,p2)) +end +end +(* stop of Parser.grm.sml *) +(* start of Lexer.lex.sml *) +type int = Int.int + functor LexerFn(structure Tokens: Parser_TOKENS) = + struct + structure UserDeclarations = + struct +(* + * Standard ML lexical analysis + * + * Definition, sections 2.1-2.5, 3.1 + * + * Notes: + * Since all lexical classes must be disjoint: + * - There is no single class ID, use ALPHA|SYMBOL|STAR|EQUALS. + * - There is no class LAB, use ALPHA|SYMBOL|NUMERIC|DIGIT|STAR. + * - ID does not contain `=' and `*', those are EQUALS and STAR. + * - LONGID does not contain unqualified ids (but allows for `=' and `*'). + * - INT does not contain positive decimal integers without leading 0, + * and single DIGIT integers, those are in NUMERIC, DIGIT, and ZERO. + * - NUMERIC does not contain single digit numbers, those are in DIGIT. + * - DIGIT does not contain 0, that is ZERO. + * + * The parser uses a global variable to recognise nested comments, so it is + * not reentrant. + *) + + + open Tokens + + + (* Types to match structure LEXER.UserDeclaration *) + + type ('a,'b) token = ('a,'b) Tokens.token + type pos = int + type svalue = Tokens.svalue + type lexresult = (svalue, pos) token + + + + (* Handling nested comments *) + + val nesting = ref 0 (* non-reentrant side-effect way :-P *) + + + fun eof() = + if !nesting = 0 then + Tokens.EOF(0, 0) + else + Error.error((0,0), "unclosed comment") + + + + (* Some helpers to create tokens *) + + open Tokens + + + fun toLRPos(yypos, yytext) = + let + val yypos = yypos - 2 (* bug in ML-Lex... *) + in + (yypos, yypos + String.size yytext) + end + + fun token(TOKEN, yypos, yytext) = + TOKEN(toLRPos(yypos, yytext)) + + fun tokenOf(TOKEN, toVal, yypos, yytext) = + let + val i as (l,r) = toLRPos(yypos, yytext) + in + TOKEN(toVal(yytext, i), l, r) + end + + fun error(yypos, yytext, s) = + Error.error(toLRPos(yypos,yytext), s) + + fun invalid(yypos, yytext) = + let + val s = "invalid character `" ^ String.toCString yytext ^ "'" + in + error(yypos, yytext, s) + end + + + + (* Convert identifiers *) + + fun toId(s, i) = s + + fun toLongId(s, i) = + let + fun split [] = raise Fail "Lexer.toLongId: empty longid" + | split [x] = ([],x) + | split(x::xs) = let val (ys,y) = split xs in (x::ys,y) end + in + split(String.fields (fn c => c = #".") s) + end + + + (* Convert constants [Section 2.2] *) + + local open StringCvt in + + fun toInt(s,i) = + (case String.explode s + of #"0" :: #"x" :: s' => + valOf(scanString (Int.scan HEX) (String.implode s')) + | #"~" :: #"0" :: #"x" :: s' => + ~(valOf(scanString (Int.scan HEX) (String.implode s'))) + | _ => valOf(scanString (Int.scan DEC) s) + ) handle Overflow => + Error.error(i, "integer constant too big") + + fun toWord(s,i) = + (case String.explode s + of #"0" :: #"w" :: #"x" :: s' => + valOf(scanString (Word.scan HEX) (String.implode s')) + | #"0" :: #"w" :: s' => + valOf(scanString (Word.scan DEC) (String.implode s')) + | _ => raise Fail "Lexer.toWord: invalid word constant" + ) handle Overflow => + Error.error(i, "word constant too big") + + fun toReal(s,i) = valOf(scanString Real.scan s) + + + fun toString(s,i) = + let + fun convert(#"\\"::s, cs) = escape(s, cs) + | convert([#"\""], cs) = cs + | convert(c::s, cs) = convert(s, c::cs) + | convert([], cs) = + raise Fail "Lexer.toString: unclosed string literal" + + and escape(#"a"::s, cs) = convert(s, #"\a"::cs) + | escape(#"b"::s, cs) = convert(s, #"\b"::cs) + | escape(#"t"::s, cs) = convert(s, #"\t"::cs) + | escape(#"n"::s, cs) = convert(s, #"\n"::cs) + | escape(#"v"::s, cs) = convert(s, #"\v"::cs) + | escape(#"f"::s, cs) = convert(s, #"\f"::cs) + | escape(#"r"::s, cs) = convert(s, #"\r"::cs) + | escape(#"\""::s, cs) = convert(s, #"\""::cs) + | escape(#"\\"::s, cs) = convert(s, #"\\"::cs) + | escape(#"^"::c::s, cs) = + convert(s, Char.chr(Char.ord c - 64)::cs) + + | escape(#"u"::x1::x2::x3::x4::s, cs) = + convert(s, unicode[x1,x2,x3,x4]::cs) + + | escape(c::s, cs) = + if Char.isDigit c then + case s + of c2::c3::s => convert(s, ascii[c,c2,c3]::cs) + | _ => raise Fail + "Lexer.toString: invalid ASCII escape sequence" + else if Char.isSpace c then + escapeGap(s,cs) + else + raise Fail "Lexer.toString: invalid escape sequence" + + | escape([], cs) = + raise Fail "Lexer.toString: empty escape character" + + and escapeGap(c::s, cs) = + if Char.isSpace c then + escapeGap(s, cs) + else (* c = #"\\" *) + convert(s, cs) + + | escapeGap([], cs) = + raise Fail "Lexer.toString: invalid string gap" + + and ascii s = + Char.chr(valOf(scanString (Int.scan DEC) (String.implode s))) + handle Chr => + Error.error(i, "ASCII escape character too big") + | Overflow => + Error.error(i, "ASCII escape character too big") + + and unicode s = + Char.chr(valOf(scanString (Int.scan HEX) (String.implode s))) + handle Chr => + Error.error(i, "unicode escape character too big") + | Overflow => + Error.error(i, "unicode escape character too big") + + val cs = List.tl(String.explode s) + in + String.implode(List.rev(convert(cs, []))) + end + + + fun toChar(s,i) = + let + val s' = String.substring(s, 1, String.size s-1) + val ss' = toString(s',i) + in + if String.size ss' = 1 then + String.sub(ss',0) + else if ss' = "" then + Error.error(i, "empty character constant") + else + Error.error(i, "character constant too long") + end + + end (* local *) + + +end (* end of user routines *) +exception LexError (* raised if illegal leaf action tried *) +structure Internal = + struct + +datatype yyfinstate = N of int +type statedata = {fin : yyfinstate list, trans: string} +(* transition & final state table *) +val tab = let +val s = [ + (0, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (1, +"\005\005\005\005\005\005\005\005\005\235\236\235\235\235\005\005\ +\\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\ +\\235\180\223\211\180\180\180\209\207\206\205\180\204\202\199\180\ +\\191\189\189\189\189\189\189\189\189\189\187\186\180\184\180\180\ +\\180\025\025\025\025\025\025\025\025\025\025\025\025\025\025\025\ +\\025\025\025\025\025\025\025\025\025\025\025\183\180\182\180\181\ +\\180\166\025\162\153\134\126\025\120\108\025\025\101\025\095\085\ +\\025\025\078\055\048\025\045\030\025\025\025\024\023\022\006\005\ +\\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\ +\\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\ +\\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\ +\\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\ +\\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\ +\\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\ +\\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\ +\\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005\005" +), + (3, +"\237\237\237\237\237\237\237\237\237\237\242\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\240\237\238\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\ +\\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237\237" +), + (6, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\007\000\007\007\007\007\000\000\000\007\007\000\007\000\007\ +\\019\008\008\008\008\008\008\008\008\008\007\000\007\007\007\007\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (7, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\007\000\007\007\007\007\000\000\000\007\007\000\007\000\007\ +\\000\000\000\000\000\000\000\000\000\000\007\000\007\007\007\007\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (8, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\013\000\ +\\008\008\008\008\008\008\008\008\008\008\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (9, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\012\012\012\012\012\012\012\012\012\012\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\010\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (10, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\011\011\011\011\011\011\011\011\011\011\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (12, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\012\012\012\012\012\012\012\012\012\012\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (13, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\014\014\014\014\014\014\014\014\014\014\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (14, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\014\014\014\014\014\014\014\014\014\014\000\000\000\000\000\000\ +\\000\000\000\000\000\015\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\015\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (15, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\018\018\018\018\018\018\018\018\018\018\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (16, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\017\017\017\017\017\017\017\017\017\017\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (18, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\018\018\018\018\018\018\018\018\018\018\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (19, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\013\000\ +\\008\008\008\008\008\008\008\008\008\008\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\020\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (20, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\021\021\021\021\021\021\021\021\021\021\000\000\000\000\000\000\ +\\000\021\021\021\021\021\021\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\021\021\021\021\021\021\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (25, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (27, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\028\000\028\028\028\028\000\000\000\028\028\000\028\000\028\ +\\000\000\000\000\000\000\000\000\000\000\028\000\028\028\028\028\ +\\028\029\029\029\029\029\029\029\029\029\029\029\029\029\029\029\ +\\029\029\029\029\029\029\029\029\029\029\029\000\028\000\028\000\ +\\028\029\029\029\029\029\029\029\029\029\029\029\029\029\029\029\ +\\029\029\029\029\029\029\029\029\029\029\029\000\028\000\028\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (28, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\028\000\028\028\028\028\000\000\000\028\028\000\028\000\028\ +\\000\000\000\000\000\000\000\000\000\000\028\000\028\028\028\028\ +\\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\028\000\028\000\ +\\028\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\028\000\028\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (29, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\029\000\000\000\000\000\000\027\000\ +\\029\029\029\029\029\029\029\029\029\029\000\000\000\000\000\000\ +\\000\029\029\029\029\029\029\029\029\029\029\029\029\029\029\029\ +\\029\029\029\029\029\029\029\029\029\029\029\000\000\000\000\029\ +\\000\029\029\029\029\029\029\029\029\029\029\029\029\029\029\029\ +\\029\029\029\029\029\029\029\029\029\029\029\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (30, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\038\031\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (31, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\032\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (32, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\033\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (33, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\034\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (34, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\035\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (35, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\036\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (36, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\037\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (38, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\042\026\026\026\039\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (39, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\040\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (40, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\041\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (42, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\043\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (43, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\044\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (45, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\046\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (46, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\047\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (48, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\052\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\049\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (49, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\050\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (50, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\051\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (52, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\053\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (53, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\054\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (55, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\072\064\026\026\026\026\026\026\ +\\026\026\026\026\056\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (56, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\057\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (57, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\058\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (58, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\059\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (59, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\060\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (60, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\061\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (61, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\062\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (62, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\063\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (64, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\065\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (65, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\066\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (66, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\067\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (67, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\068\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (68, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\069\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (69, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\070\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (70, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\071\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (72, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\073\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (73, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\074\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (74, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\075\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (75, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\076\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (76, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\077\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (78, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\081\026\026\026\079\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (79, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\080\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (81, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\082\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (82, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\083\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (83, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\084\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (85, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\094\026\026\026\026\026\026\026\026\026\ +\\091\026\086\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (86, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\087\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (87, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\088\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (88, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\089\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (89, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\090\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (91, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\092\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (92, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\093\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (95, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\096\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (96, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\097\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (97, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\098\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (98, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\099\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (99, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\100\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (101, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\106\026\026\026\026\026\026\026\026\026\102\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (102, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\103\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (103, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\104\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (104, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\105\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (106, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\107\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (108, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\119\026\026\026\026\026\026\026\109\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (109, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\114\026\026\110\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (110, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\111\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (111, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\112\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (112, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\113\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (114, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\115\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (115, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\116\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (116, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\117\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (117, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\118\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (120, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\121\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (121, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\122\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (122, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\123\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (123, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\124\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (124, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\125\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (126, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\133\026\ +\\026\026\026\026\026\127\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (127, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\128\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (128, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\129\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (129, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\130\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (130, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\131\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (131, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\132\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (134, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\150\026\148\026\ +\\026\143\026\026\026\026\026\026\135\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (135, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\136\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (136, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\137\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (137, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\138\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (138, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\139\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (139, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\140\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (140, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\141\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (141, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\142\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (143, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\144\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (144, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\145\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (145, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\146\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (146, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\147\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (148, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\149\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (150, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\151\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (151, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\152\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (153, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\155\026\026\026\026\026\026\026\026\026\026\026\026\026\154\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (155, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\156\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (156, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\157\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (157, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\158\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (158, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\159\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (159, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\160\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (160, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\161\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (162, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\163\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (163, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\164\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (164, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\165\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (166, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\174\026\026\026\026\026\026\026\026\026\026\026\168\026\ +\\026\026\026\167\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (168, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\169\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (169, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\170\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (170, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\171\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (171, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\172\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (172, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\173\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (174, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\175\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (175, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\176\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (176, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\177\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (177, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\178\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (178, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\026\000\000\000\000\000\000\027\000\ +\\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\000\ +\\000\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\026\ +\\000\026\026\026\026\179\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (184, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\007\000\007\007\007\007\000\000\000\007\007\000\007\000\007\ +\\000\000\000\000\000\000\000\000\000\000\007\000\007\007\185\007\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (187, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\007\000\007\007\007\007\000\000\000\007\007\000\007\000\007\ +\\000\000\000\000\000\000\000\000\000\000\007\000\007\007\188\007\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (189, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\013\000\ +\\190\190\190\190\190\190\190\190\190\190\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (191, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\013\000\ +\\198\198\198\198\198\198\198\198\198\198\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\194\192\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (192, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\193\193\193\193\193\193\193\193\193\193\000\000\000\000\000\000\ +\\000\193\193\193\193\193\193\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\193\193\193\193\193\193\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (194, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\197\197\197\197\197\197\197\197\197\197\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\195\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (195, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\196\196\196\196\196\196\196\196\196\196\000\000\000\000\000\000\ +\\000\196\196\196\196\196\196\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\196\196\196\196\196\196\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (197, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\197\197\197\197\197\197\197\197\197\197\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (198, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\013\000\ +\\198\198\198\198\198\198\198\198\198\198\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (199, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\200\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (200, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\201\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (202, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\007\000\007\007\007\007\000\000\000\007\007\000\007\000\007\ +\\000\000\000\000\000\000\000\000\000\000\007\000\007\007\203\007\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (207, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\208\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (209, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\210\000\000\000\000\000\000\000\000\ +\\210\210\210\210\210\210\210\210\210\210\000\000\000\000\000\000\ +\\000\210\210\210\210\210\210\210\210\210\210\210\210\210\210\210\ +\\210\210\210\210\210\210\210\210\210\210\210\000\000\000\000\210\ +\\000\210\210\210\210\210\210\210\210\210\210\210\210\210\210\210\ +\\210\210\210\210\210\210\210\210\210\210\210\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (211, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\007\212\007\007\007\007\000\000\000\007\007\000\007\000\007\ +\\000\000\000\000\000\000\000\000\000\000\007\000\007\007\007\007\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\007\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\007\000\007\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (212, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\212\212\222\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\213\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\000\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212" +), + (213, +"\000\000\000\000\000\000\000\000\000\221\221\221\221\221\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\221\000\212\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\219\219\219\219\219\219\219\219\219\219\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\212\000\218\000\ +\\000\212\212\000\000\000\212\000\000\000\000\000\000\000\212\000\ +\\000\000\212\000\212\214\212\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (214, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\215\215\215\215\215\215\215\215\215\215\000\000\000\000\000\000\ +\\000\215\215\215\215\215\215\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\215\215\215\215\215\215\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (215, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\216\216\216\216\216\216\216\216\216\216\000\000\000\000\000\000\ +\\000\216\216\216\216\216\216\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\216\216\216\216\216\216\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (216, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\217\217\217\217\217\217\217\217\217\217\000\000\000\000\000\000\ +\\000\217\217\217\217\217\217\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\217\217\217\217\217\217\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (217, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\212\212\212\212\212\212\212\212\212\212\000\000\000\000\000\000\ +\\000\212\212\212\212\212\212\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\212\212\212\212\212\212\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (218, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\212\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (219, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\220\220\220\220\220\220\220\220\220\220\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (220, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\212\212\212\212\212\212\212\212\212\212\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (221, +"\000\000\000\000\000\000\000\000\000\221\221\221\221\221\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\221\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\212\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (223, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\224\224\234\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\225\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\000\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224" +), + (225, +"\000\000\000\000\000\000\000\000\000\233\233\233\233\233\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\233\000\224\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\231\231\231\231\231\231\231\231\231\231\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\224\000\230\000\ +\\000\224\224\000\000\000\224\000\000\000\000\000\000\000\224\000\ +\\000\000\224\000\224\226\224\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (226, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\227\227\227\227\227\227\227\227\227\227\000\000\000\000\000\000\ +\\000\227\227\227\227\227\227\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\227\227\227\227\227\227\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (227, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\228\228\228\228\228\228\228\228\228\228\000\000\000\000\000\000\ +\\000\228\228\228\228\228\228\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\228\228\228\228\228\228\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (228, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\229\229\229\229\229\229\229\229\229\229\000\000\000\000\000\000\ +\\000\229\229\229\229\229\229\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\229\229\229\229\229\229\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (229, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\224\224\224\224\224\224\224\224\224\224\000\000\000\000\000\000\ +\\000\224\224\224\224\224\224\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\224\224\224\224\224\224\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (230, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\224\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (231, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\232\232\232\232\232\232\232\232\232\232\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (232, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\224\224\224\224\224\224\224\224\224\224\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (233, +"\000\000\000\000\000\000\000\000\000\233\233\233\233\233\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\233\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\224\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (235, +"\000\000\000\000\000\000\000\000\000\236\236\236\236\236\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\236\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (238, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\239\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), + (240, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\241\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" +), +(0, "")] +fun f x = x +val s = map f (rev (tl (rev s))) +exception LexHackingError +fun look ((j,x)::r, i) = if i = j then x else look(r, i) + | look ([], i) = raise LexHackingError +fun g {fin=x, trans=i} = {fin=x, trans=look(s,i)} +in Vector.fromList(map g +[{fin = [], trans = 0}, +{fin = [], trans = 1}, +{fin = [], trans = 1}, +{fin = [], trans = 3}, +{fin = [], trans = 3}, +{fin = [(N 472)], trans = 0}, +{fin = [(N 436),(N 472)], trans = 6}, +{fin = [(N 436)], trans = 7}, +{fin = [(N 304)], trans = 8}, +{fin = [], trans = 9}, +{fin = [], trans = 10}, +{fin = [(N 342)], trans = 10}, +{fin = [(N 342)], trans = 12}, +{fin = [], trans = 13}, +{fin = [(N 342)], trans = 14}, +{fin = [], trans = 15}, +{fin = [], trans = 16}, +{fin = [(N 342)], trans = 16}, +{fin = [(N 342)], trans = 18}, +{fin = [(N 304)], trans = 19}, +{fin = [], trans = 20}, +{fin = [(N 304)], trans = 20}, +{fin = [(N 43),(N 472)], trans = 0}, +{fin = [(N 41),(N 436),(N 472)], trans = 7}, +{fin = [(N 39),(N 472)], trans = 0}, +{fin = [(N 433),(N 472)], trans = 25}, +{fin = [(N 433)], trans = 25}, +{fin = [], trans = 27}, +{fin = [(N 455)], trans = 28}, +{fin = [(N 455)], trans = 29}, +{fin = [(N 433),(N 472)], trans = 30}, +{fin = [(N 433)], trans = 31}, +{fin = [(N 433)], trans = 32}, +{fin = [(N 273),(N 433)], trans = 33}, +{fin = [(N 433)], trans = 34}, +{fin = [(N 433)], trans = 35}, +{fin = [(N 433)], trans = 36}, +{fin = [(N 282),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 38}, +{fin = [(N 433)], trans = 39}, +{fin = [(N 433)], trans = 40}, +{fin = [(N 268),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 42}, +{fin = [(N 433)], trans = 43}, +{fin = [(N 262),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 45}, +{fin = [(N 433)], trans = 46}, +{fin = [(N 256),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 48}, +{fin = [(N 433)], trans = 49}, +{fin = [(N 433)], trans = 50}, +{fin = [(N 252),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 52}, +{fin = [(N 433)], trans = 53}, +{fin = [(N 247),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 55}, +{fin = [(N 433)], trans = 56}, +{fin = [(N 433)], trans = 57}, +{fin = [(N 433)], trans = 58}, +{fin = [(N 433)], trans = 59}, +{fin = [(N 232),(N 433)], trans = 60}, +{fin = [(N 433)], trans = 61}, +{fin = [(N 433)], trans = 62}, +{fin = [(N 242),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 64}, +{fin = [(N 215),(N 433)], trans = 65}, +{fin = [(N 433)], trans = 66}, +{fin = [(N 433)], trans = 67}, +{fin = [(N 433)], trans = 68}, +{fin = [(N 433)], trans = 69}, +{fin = [(N 433)], trans = 70}, +{fin = [(N 225),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 72}, +{fin = [(N 433)], trans = 73}, +{fin = [(N 433)], trans = 74}, +{fin = [(N 433)], trans = 75}, +{fin = [(N 433)], trans = 76}, +{fin = [(N 211),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 78}, +{fin = [(N 433)], trans = 79}, +{fin = [(N 203),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 81}, +{fin = [(N 433)], trans = 82}, +{fin = [(N 433)], trans = 83}, +{fin = [(N 199),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 85}, +{fin = [(N 433)], trans = 86}, +{fin = [(N 433)], trans = 87}, +{fin = [(N 433)], trans = 88}, +{fin = [(N 433)], trans = 89}, +{fin = [(N 193),(N 433)], trans = 25}, +{fin = [(N 181),(N 433)], trans = 91}, +{fin = [(N 433)], trans = 92}, +{fin = [(N 186),(N 433)], trans = 25}, +{fin = [(N 178),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 95}, +{fin = [(N 433)], trans = 96}, +{fin = [(N 433)], trans = 97}, +{fin = [(N 433)], trans = 98}, +{fin = [(N 433)], trans = 99}, +{fin = [(N 175),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 101}, +{fin = [(N 433)], trans = 102}, +{fin = [(N 433)], trans = 103}, +{fin = [(N 433)], trans = 104}, +{fin = [(N 168),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 106}, +{fin = [(N 162),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 108}, +{fin = [(N 137),(N 433)], trans = 109}, +{fin = [(N 433)], trans = 110}, +{fin = [(N 433)], trans = 111}, +{fin = [(N 151),(N 433)], trans = 112}, +{fin = [(N 158),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 114}, +{fin = [(N 433)], trans = 115}, +{fin = [(N 433)], trans = 116}, +{fin = [(N 433)], trans = 117}, +{fin = [(N 145),(N 433)], trans = 25}, +{fin = [(N 134),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 120}, +{fin = [(N 433)], trans = 121}, +{fin = [(N 433)], trans = 122}, +{fin = [(N 433)], trans = 123}, +{fin = [(N 433)], trans = 124}, +{fin = [(N 131),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 126}, +{fin = [(N 433)], trans = 127}, +{fin = [(N 116),(N 433)], trans = 128}, +{fin = [(N 433)], trans = 129}, +{fin = [(N 433)], trans = 130}, +{fin = [(N 433)], trans = 131}, +{fin = [(N 124),(N 433)], trans = 25}, +{fin = [(N 112),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 134}, +{fin = [(N 433)], trans = 135}, +{fin = [(N 433)], trans = 136}, +{fin = [(N 433)], trans = 137}, +{fin = [(N 433)], trans = 138}, +{fin = [(N 433)], trans = 139}, +{fin = [(N 433)], trans = 140}, +{fin = [(N 433)], trans = 141}, +{fin = [(N 109),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 143}, +{fin = [(N 433)], trans = 144}, +{fin = [(N 433)], trans = 145}, +{fin = [(N 433)], trans = 146}, +{fin = [(N 99),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 148}, +{fin = [(N 92),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 150}, +{fin = [(N 433)], trans = 151}, +{fin = [(N 88),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 153}, +{fin = [(N 83),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 155}, +{fin = [(N 433)], trans = 156}, +{fin = [(N 433)], trans = 157}, +{fin = [(N 433)], trans = 158}, +{fin = [(N 433)], trans = 159}, +{fin = [(N 433)], trans = 160}, +{fin = [(N 80),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 162}, +{fin = [(N 433)], trans = 163}, +{fin = [(N 433)], trans = 164}, +{fin = [(N 71),(N 433)], trans = 25}, +{fin = [(N 433),(N 472)], trans = 166}, +{fin = [(N 66),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 168}, +{fin = [(N 55),(N 433)], trans = 169}, +{fin = [(N 433)], trans = 170}, +{fin = [(N 433)], trans = 171}, +{fin = [(N 433)], trans = 172}, +{fin = [(N 63),(N 433)], trans = 25}, +{fin = [(N 433)], trans = 174}, +{fin = [(N 433)], trans = 175}, +{fin = [(N 433)], trans = 176}, +{fin = [(N 433)], trans = 177}, +{fin = [(N 433)], trans = 178}, +{fin = [(N 51),(N 433)], trans = 25}, +{fin = [(N 436),(N 472)], trans = 7}, +{fin = [(N 37),(N 472)], trans = 0}, +{fin = [(N 35),(N 472)], trans = 0}, +{fin = [(N 33),(N 472)], trans = 0}, +{fin = [(N 28),(N 436),(N 472)], trans = 184}, +{fin = [(N 31),(N 436)], trans = 7}, +{fin = [(N 26),(N 472)], trans = 0}, +{fin = [(N 21),(N 436),(N 472)], trans = 187}, +{fin = [(N 24),(N 436)], trans = 7}, +{fin = [(N 286),(N 289),(N 304),(N 472)], trans = 189}, +{fin = [(N 289),(N 304)], trans = 189}, +{fin = [(N 284),(N 304),(N 472)], trans = 191}, +{fin = [], trans = 192}, +{fin = [(N 304)], trans = 192}, +{fin = [], trans = 194}, +{fin = [], trans = 195}, +{fin = [(N 314)], trans = 195}, +{fin = [(N 314)], trans = 197}, +{fin = [(N 304)], trans = 198}, +{fin = [(N 472)], trans = 199}, +{fin = [], trans = 200}, +{fin = [(N 19)], trans = 0}, +{fin = [(N 436),(N 472)], trans = 202}, +{fin = [(N 15),(N 436)], trans = 7}, +{fin = [(N 12),(N 472)], trans = 0}, +{fin = [(N 10),(N 436),(N 472)], trans = 7}, +{fin = [(N 8),(N 472)], trans = 0}, +{fin = [(N 6),(N 472)], trans = 207}, +{fin = [(N 458)], trans = 0}, +{fin = [(N 428),(N 472)], trans = 209}, +{fin = [(N 428)], trans = 209}, +{fin = [(N 4),(N 436),(N 472)], trans = 211}, +{fin = [], trans = 212}, +{fin = [], trans = 213}, +{fin = [], trans = 214}, +{fin = [], trans = 215}, +{fin = [], trans = 216}, +{fin = [], trans = 217}, +{fin = [], trans = 218}, +{fin = [], trans = 219}, +{fin = [], trans = 220}, +{fin = [], trans = 221}, +{fin = [(N 423)], trans = 0}, +{fin = [(N 470),(N 472)], trans = 223}, +{fin = [], trans = 223}, +{fin = [], trans = 225}, +{fin = [], trans = 226}, +{fin = [], trans = 227}, +{fin = [], trans = 228}, +{fin = [], trans = 229}, +{fin = [], trans = 230}, +{fin = [], trans = 231}, +{fin = [], trans = 232}, +{fin = [], trans = 233}, +{fin = [(N 382)], trans = 0}, +{fin = [(N 2),(N 472)], trans = 235}, +{fin = [(N 2)], trans = 235}, +{fin = [(N 466)], trans = 0}, +{fin = [(N 466)], trans = 238}, +{fin = [(N 464)], trans = 0}, +{fin = [(N 466)], trans = 240}, +{fin = [(N 461)], trans = 0}, +{fin = [(N 468)], trans = 0}]) +end +structure StartStates = + struct + datatype yystartstate = STARTSTATE of int + +(* start state definitions *) + +val COMMENT = STARTSTATE 3; +val INITIAL = STARTSTATE 1; + +end +type result = UserDeclarations.lexresult + exception LexerError (* raised if illegal leaf action tried *) +end + +type int = Int.int +fun makeLexer (yyinput: int -> string) = +let val yygone0:int=1 + val yyb = ref "\n" (* buffer *) + val yybl: int ref = ref 1 (*buffer length *) + val yybufpos: int ref = ref 1 (* location of next character to use *) + val yygone: int ref = ref yygone0 (* position in file of beginning of buffer *) + val yydone = ref false (* eof found yet? *) + val yybegin: int ref = ref 1 (*Current 'start state' for lexer *) + + val YYBEGIN = fn (Internal.StartStates.STARTSTATE x) => + yybegin := x + +fun lex () : Internal.result = +let fun continue() = lex() in + let fun scan (s,AcceptingLeaves : Internal.yyfinstate list list,l,i0: int) = + let fun action (i: int,nil) = raise LexError + | action (i,nil::l) = action (i-1,l) + | action (i,(node::acts)::l) = + case node of + Internal.N yyk => + (let fun yymktext() = String.substring(!yyb,i0,i-i0) + val yypos: int = i0+ !yygone + open UserDeclarations Internal.StartStates + in (yybufpos := i; case yyk of + + (* Application actions *) + + 10 => let val yytext=yymktext() in token(STAR, yypos, yytext) end +| 109 => let val yytext=yymktext() in token(EXCEPTION, yypos, yytext) end +| 112 => let val yytext=yymktext() in token(FN, yypos, yytext) end +| 116 => let val yytext=yymktext() in token(FUN, yypos, yytext) end +| 12 => let val yytext=yymktext() in token(COMMA, yypos, yytext) end +| 124 => let val yytext=yymktext() in token(FUNCTOR, yypos, yytext) end +| 131 => let val yytext=yymktext() in token(HANDLE, yypos, yytext) end +| 134 => let val yytext=yymktext() in token(IF, yypos, yytext) end +| 137 => let val yytext=yymktext() in token(IN, yypos, yytext) end +| 145 => let val yytext=yymktext() in token(INCLUDE, yypos, yytext) end +| 15 => let val yytext=yymktext() in token(ARROW, yypos, yytext) end +| 151 => let val yytext=yymktext() in token(INFIX, yypos, yytext) end +| 158 => let val yytext=yymktext() in token(INFIXR, yypos, yytext) end +| 162 => let val yytext=yymktext() in token(LET, yypos, yytext) end +| 168 => let val yytext=yymktext() in token(LOCAL, yypos, yytext) end +| 175 => let val yytext=yymktext() in token(NONFIX, yypos, yytext) end +| 178 => let val yytext=yymktext() in token(OF, yypos, yytext) end +| 181 => let val yytext=yymktext() in token(OP, yypos, yytext) end +| 186 => let val yytext=yymktext() in token(OPEN, yypos, yytext) end +| 19 => let val yytext=yymktext() in token(DOTS, yypos, yytext) end +| 193 => let val yytext=yymktext() in token(ORELSE, yypos, yytext) end +| 199 => let val yytext=yymktext() in token(RAISE, yypos, yytext) end +| 2 => ( continue() ) +| 203 => let val yytext=yymktext() in token(REC, yypos, yytext) end +| 21 => let val yytext=yymktext() in token(COLON, yypos, yytext) end +| 211 => let val yytext=yymktext() in token(SHARING, yypos, yytext) end +| 215 => let val yytext=yymktext() in token(SIG, yypos, yytext) end +| 225 => let val yytext=yymktext() in token(SIGNATURE, yypos, yytext) end +| 232 => let val yytext=yymktext() in token(STRUCT, yypos, yytext) end +| 24 => let val yytext=yymktext() in token(COLONGREATER, yypos, yytext) end +| 242 => let val yytext=yymktext() in token(STRUCTURE, yypos, yytext) end +| 247 => let val yytext=yymktext() in token(THEN, yypos, yytext) end +| 252 => let val yytext=yymktext() in token(TYPE, yypos, yytext) end +| 256 => let val yytext=yymktext() in token(VAL, yypos, yytext) end +| 26 => let val yytext=yymktext() in token(SEMICOLON, yypos, yytext) end +| 262 => let val yytext=yymktext() in token(WHERE, yypos, yytext) end +| 268 => let val yytext=yymktext() in token(WHILE, yypos, yytext) end +| 273 => let val yytext=yymktext() in token(WITH, yypos, yytext) end +| 28 => let val yytext=yymktext() in token(EQUALS, yypos, yytext) end +| 282 => let val yytext=yymktext() in token(WITHTYPE, yypos, yytext) end +| 284 => let val yytext=yymktext() in token (ZERO, yypos, yytext) end +| 286 => let val yytext=yymktext() in tokenOf(DIGIT, toInt, yypos, yytext) end +| 289 => let val yytext=yymktext() in tokenOf(NUMERIC, toInt, yypos, yytext) end +| 304 => let val yytext=yymktext() in tokenOf(INT, toInt, yypos, yytext) end +| 31 => let val yytext=yymktext() in token(DARROW, yypos, yytext) end +| 314 => let val yytext=yymktext() in tokenOf(WORD, toWord, yypos, yytext) end +| 33 => let val yytext=yymktext() in token(LBRACK, yypos, yytext) end +| 342 => let val yytext=yymktext() in tokenOf(REAL, toReal, yypos, yytext) end +| 35 => let val yytext=yymktext() in token(RBRACK, yypos, yytext) end +| 37 => let val yytext=yymktext() in token(UNDERBAR, yypos, yytext) end +| 382 => let val yytext=yymktext() in tokenOf(STRING, toString, yypos, yytext) end +| 39 => let val yytext=yymktext() in token(LBRACE, yypos, yytext) end +| 4 => let val yytext=yymktext() in token(HASH, yypos, yytext) end +| 41 => let val yytext=yymktext() in token(BAR, yypos, yytext) end +| 423 => let val yytext=yymktext() in tokenOf(CHAR, toChar, yypos, yytext) end +| 428 => let val yytext=yymktext() in tokenOf(TYVAR, toId, yypos, yytext) end +| 43 => let val yytext=yymktext() in token(RBRACE, yypos, yytext) end +| 433 => let val yytext=yymktext() in tokenOf(ALPHA, toId, yypos, yytext) end +| 436 => let val yytext=yymktext() in tokenOf(SYMBOL, toId, yypos, yytext) end +| 455 => let val yytext=yymktext() in tokenOf(LONGID, toLongId, yypos, yytext) end +| 458 => ( nesting := 1 ; YYBEGIN COMMENT ; continue() ) +| 461 => ( nesting := !nesting+1 ; continue() ) +| 464 => ( nesting := !nesting-1 ; + if !nesting = 0 then YYBEGIN INITIAL else () ; + continue() ) +| 466 => ( continue() ) +| 468 => ( continue() ) +| 470 => let val yytext=yymktext() in error(yypos, yytext, "invalid string") end +| 472 => let val yytext=yymktext() in invalid(yypos, yytext) end +| 51 => let val yytext=yymktext() in token(ABSTYPE, yypos, yytext) end +| 55 => let val yytext=yymktext() in token(AND, yypos, yytext) end +| 6 => let val yytext=yymktext() in token(LPAR, yypos, yytext) end +| 63 => let val yytext=yymktext() in token(ANDALSO, yypos, yytext) end +| 66 => let val yytext=yymktext() in token(AS, yypos, yytext) end +| 71 => let val yytext=yymktext() in token(CASE, yypos, yytext) end +| 8 => let val yytext=yymktext() in token(RPAR, yypos, yytext) end +| 80 => let val yytext=yymktext() in token(DATATYPE, yypos, yytext) end +| 83 => let val yytext=yymktext() in token(DO, yypos, yytext) end +| 88 => let val yytext=yymktext() in token(ELSE, yypos, yytext) end +| 92 => let val yytext=yymktext() in token(END, yypos, yytext) end +| 99 => let val yytext=yymktext() in token(EQTYPE, yypos, yytext) end +| _ => raise Internal.LexerError + + ) end ) + + val {fin,trans} = Vector.sub(Internal.tab, s) + val NewAcceptingLeaves = fin::AcceptingLeaves + in if l = !yybl then + if trans = #trans(Vector.sub(Internal.tab,0)) + then action(l,NewAcceptingLeaves +) else let val newchars= if !yydone then "" else yyinput 1024 + in if (String.size newchars)=0 + then (yydone := true; + if (l=i0) then UserDeclarations.eof () + else action(l,NewAcceptingLeaves)) + else (if i0=l then yyb := newchars + else yyb := String.substring(!yyb,i0,l-i0)^newchars; + yygone := !yygone+i0; + yybl := String.size (!yyb); + scan (s,AcceptingLeaves,l-i0,0)) + end + else let val NewChar = Char.ord(CharVector.sub(!yyb,l)) + val NewState = Char.ord(CharVector.sub(trans,NewChar)) + in if NewState=0 then action(l,NewAcceptingLeaves) + else scan(NewState,NewAcceptingLeaves,l+1,i0) + end + end +(* + val start= if String.substring(!yyb,!yybufpos-1,1)="\n" +then !yybegin+1 else !yybegin +*) + in scan(!yybegin (* start *),nil,!yybufpos,!yybufpos) + end +end + in lex + end +end +(* stop of Lexer.lex.sml *) +(* start of PARSE.sml *) +signature PARSE = + sig + + (* Import *) + + type source = Source.source + type InfEnv = Infix.InfEnv + type Program = GrammarProgram.Program + + + (* Export *) + + val parse: InfEnv * source -> InfEnv * Program + + end +(* stop of PARSE.sml *) +(* start of Parse.sml *) +structure Parse :> PARSE = + struct + + (* Import *) + + type source = Source.source + type InfEnv = Infix.InfEnv + type Program = GrammarProgram.Program + + + (* Build Yacc parser *) + + structure LrVals = LrValsFn(structure Token = LrParser.Token) + structure Lexer = LexerFn (structure Tokens = LrVals.Tokens) + structure Parser = Join (structure LrParser = LrParser + structure ParserData = LrVals.ParserData + structure Lex = Lexer) + + + (* The actual parsing function *) + + fun parse(J, source) = + let + val yyread = ref false + fun yyinput _ = + if !yyread then + "" + else + ( yyread := true; source ) + + val lexer = Parser.makeLexer yyinput + + fun onError(s, pos1, pos2) = Error.error((pos1,pos2), s) + + val ((program,J'), lexer') = Parser.parse(0, lexer, onError, J) + in + (J',program) + end + + end +(* stop of Parse.sml *) +(* start of SML.sml *) +(* + * Standard ML implementation main structure + *) + +signature SML = + sig + + val parseString: string -> unit (* Parse only *) + val elabString: string -> unit (* Parse and elaborate *) + val evalString: string -> unit (* Parse and evaluate *) + val execString: string -> unit (* Parse, elaborate, and evaluate *) + + val parseFile: string -> unit + val elabFile: string -> unit + val evalFile: string -> unit + val execFile: string -> unit + + val parseFiles: string -> unit + val elabFiles: string -> unit + val evalFiles: string -> unit + val execFiles: string -> unit + + val parseSession: unit -> unit + val elabSession: unit -> unit + val evalSession: unit -> unit + val execSession: unit -> unit + + end +(* stop of SML.sml *) +(* start of Sml.sml *) +(* + * Standard ML implementation main structure + *) + +structure Sml :> SML = + struct + + (* Initial arguments *) + + val J0 = InitialInfixEnv.J0 + val B_STAT0 = InitialStaticBasis.B0 + val B_DYN0 = InitialDynamicBasis.B0 + val B0 = (B_STAT0, B_DYN0) + val s0 = InitialDynamicBasis.s + + + (* Parsing only *) + + fun parse J source = + let + val (J',program) = Parse.parse(J, source) + val _ = TextIO.output(TextIO.stdOut, "OK\n") + in + J' + end + + val parseInitialArg = J0 + val parseInitial = parse parseInitialArg + + + (* Parsing and elaboration *) + + val elabInitialArg = (J0, B_STAT0) + + fun elab (J, B_STAT) source = + let + val (J',program) = Parse.parse(J, source) + val B_STAT' = Program.elabProgram(B_STAT, program) + in + (J', B_STAT') + end + + + (* Parsing and evaluation *) + + val evalInitialArg = (J0, B_DYN0, s0) + + fun eval (J, B_DYN, s) source = + let + val (J',program) = Parse.parse(J, source) + val s' = ref s + val B_DYN' = Program.evalProgram(s', B_DYN, program) + in + (J', B_DYN', !s') + end + + + (* Parsing, elaboration, and evaluation *) + + val execInitialArg = (J0, B0, s0) + + fun exec (J, B, s) source = + let + val (J',program) = Parse.parse(J, source) + val s' = ref s + val B' = Program.execProgram(s', B, program) + in + (J', B', !s' ) + end + + + (* Processing of strings *) + + fun processString (process, arg) source = + ignore(process arg source) + handle Error.Error _ => () (* Syntax error *) + + val parseString = processString(parse, parseInitialArg) + val elabString = processString(elab, elabInitialArg) + val evalString = processString(eval, evalInitialArg) + val execString = processString(exec, execInitialArg) + + + (* Processing of files *) + + fun processFile (process, arg) name = + let + val file = TextIO.openIn name + val source = TextIO.inputAll file + val _ = TextIO.closeIn file + in + ignore(process arg source) + handle Error.Error _ => () (* Syntax error *) + end + + val parseFile = processFile(parse, parseInitialArg) + val elabFile = processFile(elab, elabInitialArg) + val evalFile = processFile(eval, evalInitialArg) + val execFile = processFile(exec, execInitialArg) + + + (* Processing several files mentioned in a list file *) + + fun processFiles (process, initialArg) name = + let + val file = TextIO.openIn name + val content = TextIO.inputAll file + val _ = TextIO.closeIn file + + val _ = Stamp.reset() + + fun loop(arg, [] ) = () + | loop(arg, "" ::names) = loop(arg, names) + | loop(arg, name::names) = + let + val file = TextIO.openIn name + val source = TextIO.inputAll file + val _ = TextIO.closeIn file + val _ = TextIO.output(TextIO.stdOut, + ">> File \"" ^ name ^ "\":\n") + in + loop(process arg source, names) + handle Error.Error _ => (* Syntax error *) + loop(arg, names) + end + in + loop(initialArg, String.fields Char.isSpace content) + end + + val parseFiles = processFiles(parse, parseInitialArg) + val elabFiles = processFiles(elab, elabInitialArg) + val evalFiles = processFiles(eval, evalInitialArg) + val execFiles = processFiles(exec, execInitialArg) + + + (* Session *) + + fun processSession(process, initialArg) = + let + val ins = !ins + fun loop arg = + let + val _ = TextIO.output(TextIO.stdOut, "SML> ") + val _ = TextIO.flushOut TextIO.stdOut + in + case TextIO.inputLine ins of + NONE => () + | SOME source => + loop(process arg source) + handle Error.Error _ => (* Syntax error *) + loop arg + end + in + loop initialArg + end + + fun parseSession() = processSession(parse, parseInitialArg) + fun elabSession() = processSession(elab, elabInitialArg) + fun evalSession() = processSession(eval, evalInitialArg) + fun execSession() = processSession(exec, execInitialArg) + + end +(* stop of Sml.sml *) +(* start of Main.sml *) +(* + * Standard ML implementation stand-alone + *) + +structure Main = + struct + + val version = "0.5" + + fun usage() = + ( TextIO.output(TextIO.stdErr, + "Usage: hamlet -\n\ + \where is one of:\n\ + \ h help: print this message\n\ + \ p parse mode: just parse input\n\ + \ l elab mode: parse and elaborate\n\ + \ v eval mode: parse and evaluate (no type checking!)\n\ + \ x exec mode: parse, elaborate, and evaluate\n" + ) + ; TextIO.flushOut TextIO.stdErr + ; OS.Process.failure + ) + + fun start process = + ( TextIO.output(TextIO.stdOut, "HaMLet " ^ version ^ + " - to be or not to be SML\n") + ; TextIO.flushOut TextIO.stdOut + ; process() + ; TextIO.output(TextIO.stdOut, "\n") + ; TextIO.flushOut TextIO.stdOut + ; OS.Process.success + ) + + fun main' ["-h"] = ( usage() ; OS.Process.success ) + | main' ["-p"] = start Sml.parseSession + | main' ["-l"] = start Sml.elabSession + | main' ["-v"] = start Sml.evalSession + | main' ["-x"] = start Sml.execSession + | main' _ = usage() + + fun main() = OS.Process.exit(main'(CommandLine.arguments())) + + end +(* stop of Main.sml *) + +(* Here begins the simple test case. *) + +structure Main = + struct + fun doit size = + let + open TextIO + fun loop n = + if n < 0 + then () + else + let + val _ = ins := openIn "DATA/hamlet-input.sml" + val _ = Main.main' ["-x"] + val _ = closeIn (!ins) + in loop (n - 1) + end + in + loop size + end + end diff --git a/benchmark/tests/imp-for.sml b/benchmark/tests/imp-for.sml new file mode 100644 index 0000000..6185d30 --- /dev/null +++ b/benchmark/tests/imp-for.sml @@ -0,0 +1,32 @@ + +fun for (start, stop, f) + = let + val i = ref start + fun loop () = if !i >= stop + then () + else (f (!i) ; i := !i + 1 ; loop ()) + in + loop () + end + +structure Main = +struct + fun doit () + = let + val x = ref 0 + + val _ = for (0, 10, fn _ => + for (0, 10, fn _ => + for (0, 10, fn _ => + for (0, 10, fn _ => + for (0, 10, fn _ => + for (0, 10, fn _ => + for (0, 10, fn _ => + x := !x + 1))))))) + in + if (!x) <> 10000000 + then raise Fail "bug" + else () + end + val doit = fn size => for (0, size, fn _ => doit ()) +end diff --git a/benchmark/tests/knuth-bendix.sml b/benchmark/tests/knuth-bendix.sml new file mode 100644 index 0000000..e6719b1 --- /dev/null +++ b/benchmark/tests/knuth-bendix.sml @@ -0,0 +1,602 @@ +(* From the SML/NJ benchmark suite. *) +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; +(* knuth-bendix.sml + *) + +signature KB = + sig + datatype term = Var of int | Term of string * term list; + datatype ordering = Greater | Equal | NotGE; + val rpo: (string -> string -> ordering) -> + ((term * term -> ordering) -> term * term -> ordering) -> + term * term -> ordering; + val lex_ext: (term * term -> ordering) -> term * term -> ordering; + val kb_complete: + (term * term -> bool) -> (int * (int * (term * term))) list -> + ('a * ('b * (term * term))) list -> unit; + include BMARK + end; + +structure Main : KB = + struct + + val name = "Knuth-Bendix" + + fun length l = let + fun j(k, nil) = k + | j(k, a::x) = j(k+1,x) + in + j(0,l) + end + fun op @ (nil, l) = l + | op @ (a::r, l) = a :: (r@l) + fun rev l = let + fun f (nil, h) = h + | f (a::r, h) = f(r, a::h) + in + f(l,nil) + end + fun app f = let + fun app_rec [] = () + | app_rec (a::L) = (f a; app_rec L) + in + app_rec + end + fun map f = let + fun map_rec [] = [] + | map_rec (a::L) = f a :: map_rec L + in + map_rec + end + +(******* Quelques definitions du prelude CAML **************) + + exception Failure of string; + + fun failwith s = raise(Failure s) + + fun fst (x,y) = x + and snd (x,y) = y + + +fun it_list f = + let fun it_rec a [] = a + | it_rec a (b::L) = it_rec (f a b) L + in it_rec + end + +fun it_list2 f = + let fun it_rec a [] [] = a + | it_rec a (a1::L1) (a2::L2) = it_rec (f a (a1,a2)) L1 L2 + | it_rec _ _ _ = failwith "it_list2" + in it_rec + end + +fun exists p = + let fun exists_rec [] = false + | exists_rec (a::L) = (p a) orelse (exists_rec L) + in exists_rec + end + +fun for_all p = + let fun for_all_rec [] = true + | for_all_rec (a::L) = (p a) andalso (for_all_rec L) + in for_all_rec + end + +fun rev_append [] L = L + | rev_append (x::L1) L2 = rev_append L1 (x::L2) + +fun try_find f = + let fun try_find_rec [] = failwith "try_find" + | try_find_rec (a::L) = (f a) handle Failure _ => try_find_rec L + in try_find_rec + end + +fun partition p = + let fun part_rec [] = ([],[]) + | part_rec (a::L) = + let val (pos,neg) = part_rec L in + if p a then ((a::pos), neg) else (pos, (a::neg)) + end + in part_rec + end + +(* 3- Les ensembles et les listes d'association *) + +fun mem a = + let fun mem_rec [] = false + | mem_rec (b::L) = (a=b) orelse mem_rec L + in mem_rec + end + +fun union L1 L2 = + let fun union_rec [] = L2 + | union_rec (a::L) = + if mem a L2 then union_rec L else a :: union_rec L + in union_rec L1 + end + +fun mem_assoc a = + let fun mem_rec [] = false + | mem_rec ((b,_)::L) = (a=b) orelse mem_rec L + in mem_rec + end + +fun assoc a = + let fun assoc_rec [] = failwith "find" + | assoc_rec ((b,d)::L) = if a=b then d else assoc_rec L + in assoc_rec + end + +(* 4- Les sorties *) + +fun print s = TextIO.output(TextIO.stdOut, s) +fun print _ = () +val print_string = print +val print_num = print o Int.toString +fun print_newline () = print "\n"; +fun message s = (print s; print "\n"); + +(* 5- Les ensembles *) + +fun union L1 = + let fun union_rec [] = L1 + | union_rec (a::L) = if mem a L1 then union_rec L else a :: union_rec L + in union_rec + end + +(****************** Term manipulations *****************) + +datatype term + = Var of int + | Term of string * term list + +fun vars (Var n) = [n] + | vars (Term(_,L)) = vars_of_list L +and vars_of_list [] = [] + | vars_of_list (t::r) = union (vars t) (vars_of_list r) + +fun substitute subst = + let fun subst_rec (Term(oper,sons)) = Term(oper, map subst_rec sons) + | subst_rec (t as (Var n)) = (assoc n subst) handle Failure _ => t + in subst_rec + end + +fun change f = + let fun change_rec (h::t) n = if n=1 then f h :: t + else h :: change_rec t (n-1) + | change_rec _ _ = failwith "change" + in change_rec + end + +(* Term replacement replace M u N => M[u<-N] *) +fun replace M u N = + let fun reprec (_, []) = N + | reprec (Term(oper,sons), (n::u)) = + Term(oper, change (fn P => reprec(P,u)) sons n) + | reprec _ = failwith "replace" + in reprec(M,u) + end + +(* matching = - : (term -> term -> subst) *) +fun matching term1 term2 = + let fun match_rec subst (Var v, M) = + if mem_assoc v subst then + if M = assoc v subst then subst else failwith "matching" + else + (v,M) :: subst + | match_rec subst (Term(op1,sons1), Term(op2,sons2)) = + if op1 = op2 then it_list2 match_rec subst sons1 sons2 + else failwith "matching" + | match_rec _ _ = failwith "matching" + in match_rec [] (term1,term2) + end + +(* A naive unification algorithm *) + +fun compsubst subst1 subst2 = + (map (fn (v,t) => (v, substitute subst1 t)) subst2) @ subst1 + +fun occurs n = + let fun occur_rec (Var m) = (m=n) + | occur_rec (Term(_,sons)) = exists occur_rec sons + in occur_rec + end + +fun unify ((term1 as (Var n1)), term2) = + if term1 = term2 then [] + else if occurs n1 term2 then failwith "unify" + else [(n1,term2)] + | unify (term1, Var n2) = + if occurs n2 term1 then failwith "unify" + else [(n2,term1)] + | unify (Term(op1,sons1), Term(op2,sons2)) = + if op1 = op2 then + it_list2 (fn s => fn (t1,t2) => compsubst (unify(substitute s t1, + substitute s t2)) s) + [] sons1 sons2 + else failwith "unify" + +(* We need to print terms with variables independently from input terms + obtained by parsing. We give arbitrary names v1,v2,... to their variables. *) + +val INFIXES = ["+","*"]; + +fun pretty_term (Var n) = + (print_string "v"; print_num n) + | pretty_term (Term (oper,sons)) = + if mem oper INFIXES then + case sons of + [s1,s2] => + (pretty_close s1; print_string oper; pretty_close s2) + | _ => + failwith "pretty_term : infix arity <> 2" + else + (print_string oper; + case sons of + [] => () + | t::lt =>(print_string "("; + pretty_term t; + app (fn t => (print_string ","; pretty_term t)) lt; + print_string ")")) +and pretty_close (M as Term(oper, _)) = + if mem oper INFIXES then + (print_string "("; pretty_term M; print_string ")") + else pretty_term M + | pretty_close M = pretty_term M + +(****************** Equation manipulations *************) + +(* standardizes an equation so its variables are 1,2,... *) + +fun mk_rule M N = + let val all_vars = union (vars M) (vars N); + val (k,subst) = + it_list (fn (i,sigma) => fn v => (i+1,(v,Var(i))::sigma)) + (1,[]) all_vars + in (k-1, (substitute subst M, substitute subst N)) + end + +(* checks that rules are numbered in sequence and returns their number *) +fun check_rules l = it_list (fn n => fn (k,_) => + if k=n+1 then k else failwith "Rule numbers not in sequence") + 0 l + +fun pretty_rule (k,(n,(M,N))) = + (print_num k; print_string " : "; + pretty_term M; print_string " = "; pretty_term N; + print_newline()) + +fun pretty_rules l = app pretty_rule l + + +(****************** Rewriting **************************) + +(* Top-level rewriting. Let eq:L=R be an equation, M be a term such that L<=M. + With sigma = matching L M, we define the image of M by eq as sigma(R) *) +fun reduce L M = + substitute (matching L M) + +(* A more efficient version of can (rewrite1 (L,R)) for R arbitrary *) +fun reducible L = + let fun redrec M = + (matching L M; true) + handle Failure _ => + case M of Term(_,sons) => exists redrec sons + | _ => false + in redrec + end + +(* mreduce : rules -> term -> term *) +fun mreduce rules M = + let fun redex (_,(_,(L,R))) = reduce L M R in try_find redex rules end + +(* One step of rewriting in leftmost-outermost strategy, with multiple rules *) +(* fails if no redex is found *) +(* mrewrite1 : rules -> term -> term *) +fun mrewrite1 rules = + let fun rewrec M = + (mreduce rules M) handle Failure _ => + let fun tryrec [] = failwith "mrewrite1" + | tryrec (son::rest) = + (rewrec son :: rest) handle Failure _ => son :: tryrec rest + in case M of + Term(f, sons) => Term(f, tryrec sons) + | _ => failwith "mrewrite1" + end + in rewrec + end + +(* Iterating rewrite1. Returns a normal form. May loop forever *) +(* mrewrite_all : rules -> term -> term *) +fun mrewrite_all rules M = + let fun rew_loop M = + rew_loop(mrewrite1 rules M) handle Failure _ => M + in rew_loop M + end + +(* +pretty_term (mrewrite_all Group_rules M where M,_=<>);; +==> A*U +*) + + +(************************ Recursive Path Ordering ****************************) + +datatype ordering = Greater | Equal | NotGE; + +fun ge_ord order pair = case order pair of NotGE => false | _ => true +and gt_ord order pair = case order pair of Greater => true | _ => false +and eq_ord order pair = case order pair of Equal => true | _ => false + +fun rem_eq equiv = + let fun remrec x [] = failwith "rem_eq" + | remrec x (y::l) = if equiv (x,y) then l else y :: remrec x l + in remrec + end + +fun diff_eq equiv (x,y) = + let fun diffrec (p as ([],_)) = p + | diffrec ((h::t), y) = + diffrec (t,rem_eq equiv h y) handle Failure _ => + let val (x',y') = diffrec (t,y) in (h::x',y') end + in if length x > length y then diffrec(y,x) else diffrec(x,y) + end + +(* multiset extension of order *) +fun mult_ext order (Term(_,sons1), Term(_,sons2)) = + (case diff_eq (eq_ord order) (sons1,sons2) of + ([],[]) => Equal + | (l1,l2) => + if for_all (fn N => exists (fn M => order (M,N) = Greater) l1) l2 + then Greater else NotGE) + | mult_ext order (_, _) = failwith "mult_ext" + +(* lexicographic extension of order *) +fun lex_ext order ((M as Term(_,sons1)), (N as Term(_,sons2))) = + let fun lexrec ([] , []) = Equal + | lexrec ([] , _ ) = NotGE + | lexrec ( _ , []) = Greater + | lexrec (x1::l1, x2::l2) = + case order (x1,x2) of + Greater => if for_all (fn N' => gt_ord order (M,N')) l2 + then Greater else NotGE + | Equal => lexrec (l1,l2) + | NotGE => if exists (fn M' => ge_ord order (M',N)) l1 + then Greater else NotGE + in lexrec (sons1, sons2) + end + | lex_ext order _ = failwith "lex_ext" + +(* recursive path ordering *) + +fun rpo op_order ext = + let fun rporec (M,N) = + if M=N then Equal else + case M of + Var m => NotGE + | Term(op1,sons1) => + case N of + Var n => + if occurs n M then Greater else NotGE + | Term(op2,sons2) => + case (op_order op1 op2) of + Greater => + if for_all (fn N' => gt_ord rporec (M,N')) sons2 + then Greater else NotGE + | Equal => + ext rporec (M,N) + | NotGE => + if exists (fn M' => ge_ord rporec (M',N)) sons1 + then Greater else NotGE + in rporec + end + +(****************** Critical pairs *********************) + +(* All (u,sig) such that N/u (&var) unifies with M, + with principal unifier sig *) + +fun super M = + let fun suprec (N as Term(_,sons)) = + let fun collate (pairs,n) son = + (pairs @ map (fn (u,sigma) => (n::u,sigma)) (suprec son), n+1); + val insides = + fst (it_list collate ([],1) sons) + in ([], unify(M,N)) :: insides handle Failure _ => insides + end + | suprec _ = [] + in suprec end + +(* Ex : +let (M,_) = <> +and (N,_) = <> in super M N;; +==> [[1],[2,Term ("B",[])]; x <- B + [2],[2,Term ("A",[]); 1,Term ("B",[])]] x <- A y <- B +*) + +(* All (u,sigma), u&[], such that N/u unifies with M *) +(* super_strict : term -> term -> (num list & subst) list *) + +fun super_strict M (Term(_,sons)) = + let fun collate (pairs,n) son = + (pairs @ map (fn (u,sigma) => (n::u,sigma)) (super M son), n+1) + in fst (it_list collate ([],1) sons) end + | super_strict _ _ = [] + +(* Critical pairs of L1=R1 with L2=R2 *) +(* critical_pairs : term_pair -> term_pair -> term_pair list *) +fun critical_pairs (L1,R1) (L2,R2) = + let fun mk_pair (u,sigma) = + (substitute sigma (replace L2 u R1), substitute sigma R2) in + map mk_pair (super L1 L2) + end + +(* Strict critical pairs of L1=R1 with L2=R2 *) +(* strict_critical_pairs : term_pair -> term_pair -> term_pair list *) +fun strict_critical_pairs (L1,R1) (L2,R2) = + let fun mk_pair (u,sigma) = + (substitute sigma (replace L2 u R1), substitute sigma R2) in + map mk_pair (super_strict L1 L2) + end + +(* All critical pairs of eq1 with eq2 *) +fun mutual_critical_pairs eq1 eq2 = + (strict_critical_pairs eq1 eq2) @ (critical_pairs eq2 eq1) + +(* Renaming of variables *) + +fun rename n (t1,t2) = + let fun ren_rec (Var k) = Var(k+n) + | ren_rec (Term(oper,sons)) = Term(oper, map ren_rec sons) + in (ren_rec t1, ren_rec t2) + end + +(************************ Completion ******************************) + +fun deletion_message (k,_) = + (print_string "Rule ";print_num k; message " deleted") + +(* Generate failure message *) +fun non_orientable (M,N) = + (pretty_term M; print_string " = "; pretty_term N; print_newline()) + +(* Improved Knuth-Bendix completion procedure *) +(* kb_completion : (term_pair -> bool) -> num -> rules -> term_pair list -> (num & num) -> term_pair list -> rules *) +fun kb_completion greater = + let fun kbrec n rules = + let val normal_form = mrewrite_all rules; + fun get_rule k = assoc k rules; + fun process failures = + let fun processf (k,l) = + let fun processkl [] = + if k rules (* successful completion *) + | _ => (message "Non-orientable equations :"; + app non_orientable failures; + failwith "kb_completion")) + | processkl ((M,N)::eqs) = + let val M' = normal_form M; + val N' = normal_form N; + fun enter_rule(left,right) = + let val new_rule = (n+1, mk_rule left right) in + (pretty_rule new_rule; + let fun left_reducible (_,(_,(L,_))) = reducible left L; + val (redl,irredl) = partition left_reducible rules + in (app deletion_message redl; + let fun right_reduce (m,(_,(L,R))) = + (m,mk_rule L (mrewrite_all (new_rule::rules) R)); + val irreds = map right_reduce irredl; + val eqs' = map (fn (_,(_,pair)) => pair) redl + in kbrec (n+1) (new_rule::irreds) [] (k,l) + (eqs @ eqs' @ failures) + end) + end) + end + in if M'=N' then processkl eqs else + if greater(M',N') then enter_rule(M',N') else + if greater(N',M') then enter_rule(N',M') else + process ((M',N')::failures) (k,l) eqs + end + in processkl + end + and next_criticals (k,l) = + (let val (v,el) = get_rule l in + if k=l then + processf (k,l) (strict_critical_pairs el (rename v el)) + else + (let val (_,ek) = get_rule k in + processf (k,l) (mutual_critical_pairs el (rename v ek)) + end + handle Failure "find" (*rule k deleted*) => + next_criticals (k+1,l)) + end + handle Failure "find" (*rule l deleted*) => + next_criticals (1,l+1)) + in processf + end + in process + end + in kbrec + end + +fun kb_complete greater complete_rules rules = + let val n = check_rules complete_rules; + val eqs = map (fn (_,(_,pair)) => pair) rules; + val completed_rules = + kb_completion greater n complete_rules [] (n,n) eqs + in (message "Canonical set found :"; + pretty_rules (rev completed_rules); + ()) + end + +val Group_rules = [ + (1, (1, (Term("*", [Term("U",[]), Var 1]), Var 1))), + (2, (1, (Term("*", [Term("I",[Var 1]), Var 1]), Term("U",[])))), + (3, (3, (Term("*", [Term("*", [Var 1, Var 2]), Var 3]), + Term("*", [Var 1, Term("*", [Var 2, Var 3])]))))]; + +val Geom_rules = [ + (1,(1,(Term ("*",[(Term ("U",[])), (Var 1)]),(Var 1)))), + (2,(1,(Term ("*",[(Term ("I",[(Var 1)])), (Var 1)]),(Term ("U",[]))))), + (3,(3,(Term ("*",[(Term ("*",[(Var 1), (Var 2)])), (Var 3)]), + (Term ("*",[(Var 1), (Term ("*",[(Var 2), (Var 3)]))]))))), + (4,(0,(Term ("*",[(Term ("A",[])), (Term ("B",[]))]), + (Term ("*",[(Term ("B",[])), (Term ("A",[]))]))))), + (5,(0,(Term ("*",[(Term ("C",[])), (Term ("C",[]))]),(Term ("U",[]))))), + (6,(0, + (Term + ("*", + [(Term ("C",[])), + (Term ("*",[(Term ("A",[])), (Term ("I",[(Term ("C",[]))]))]))]), + (Term ("I",[(Term ("A",[]))]))))), + (7,(0, + (Term + ("*", + [(Term ("C",[])), + (Term ("*",[(Term ("B",[])), (Term ("I",[(Term ("C",[]))]))]))]), + (Term ("B",[]))))) +]; + +fun Group_rank "U" = 0 + | Group_rank "*" = 1 + | Group_rank "I" = 2 + | Group_rank "B" = 3 + | Group_rank "C" = 4 + | Group_rank "A" = 5 + +fun Group_precedence op1 op2 = + let val r1 = Group_rank op1; + val r2 = Group_rank op2 + in + if r1 = r2 then Equal else + if r1 > r2 then Greater else NotGE + end + + val Group_order = rpo Group_precedence lex_ext + + fun greater pair = (case Group_order pair of Greater => true | _ => false) + + fun doit() = kb_complete greater [] Geom_rules + + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop size + end + + fun testit _ = () + + end (* Main *) diff --git a/benchmark/tests/lexgen.sml b/benchmark/tests/lexgen.sml new file mode 100644 index 0000000..20e03f6 --- /dev/null +++ b/benchmark/tests/lexgen.sml @@ -0,0 +1,1325 @@ +(* From the SML/NJ benchmark suite. *) +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; +(* Lexical analyzer generator for Standard ML. + Version 1.6.0, October 1994 + +Copyright (c) 1989-1992 by Andrew W. Appel, + David R. Tarditi, James S. Mattson + +This software comes with ABSOLUTELY NO WARRANTY. +This software is subject only to the PRINCETON STANDARD ML SOFTWARE LIBRARY +COPYRIGHT NOTICE, LICENSE AND DISCLAIMER, (in the file "COPYRIGHT", +distributed with this software). You may copy and distribute this software; +see the COPYRIGHT NOTICE for details and restrictions. + + Changes: + 07/25/89 (drt): added %header declaration, code to place + user declarations at same level as makeLexer, etc. + This is needed for the parser generator. + /10/89 (appel): added %arg declaration (see lexgen.doc). + /04/90 (drt): fixed following bug: couldn't use the lexer after an + error occurred -- NextTok and inquote weren't being reset + 10/22/91 (drt): disabled use of lookahead + 10/23/92 (drt): disabled use of $ operator (which involves lookahead), + added handlers for dictionary lookup routine + 11/02/92 (drt): changed handler for exception Reject in generated lexer + to Internal.Reject + 02/01/94 (appel): Moved the exception handler for Reject in such + a way as to allow tail-recursion (improves performance + wonderfully!). + 02/01/94 (appel): Fixed a bug in parsing of state names. + 05/19/94 (Mikael Pettersson, mpe@ida.liu.se): + Transition tables are usually represented as strings, but + when the range is too large, int vectors constructed by + code like "Vector.vector[1,2,3,...]" are used instead. + The problem with this isn't that the vector itself takes + a lot of space, but that the code generated by SML/NJ to + construct the intermediate list at run-time is *HUGE*. My + fix is to encode an int vector as a string literal (using + two bytes per int) and emit code to decode the string to + a vector at run-time. SML/NJ compiles string literals into + substrings in the code, so this uses much less space. + 06/02/94 (jhr): Modified export-lex.sml to conform to new installation + scheme. Also removed tab characters from string literals. + 10/05/94 (jhr): Changed generator to produce code that uses the new + basis style strings and characters. + 10/06/94 (jhr) Modified code to compile under new basis style strings + and characters. + 02/08/95 (jhr) Modified to use new List module interface. + 05/18/95 (jhr) changed Vector.vector to Vector.fromList +* + * $Log: lexgen.sml,v $ + * Revision 1.6 1996/10/03 14:57:30 jhr + * Qualified use of Int.quot, since it is no longer available at top-level; improved + * the code that prints the tables. + * + * Revision 1.5 1996/09/16 12:25:14 george + * here is a bug in ml-lex (109.17) when using the %count flag. The yylineno + * variable should get reinitialized to zero on each call to makeLexer, but + * instead is globally allocated and never reset. + * + * Revision 1.4 1996/08/13 13:50:36 george + * Fixed bugs in counting lines (from jhr) + * + * Revision 1.3 1996/07/25 20:38:52 jhr + * Fixed bug in ungetch that caused Subscript exceptions. + * + * Revision 1.2 1996/02/26 15:02:27 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:15 george + * Version 109 + * + *) + +(* Subject: lookahead in sml-lex + Reply-to: david.tarditi@CS.CMU.EDU + Date: Mon, 21 Oct 91 14:13:26 -0400 + +There is a serious bug in the implementation of lookahead, +as done in sml-lex, and described in Aho, Sethi, and Ullman, +p. 134 "Implementing the Lookahead Operator" + +We have disallowed the use of lookahead for now because +of this bug. + +As a counter-example to the implementation described in +ASU, consider the following specification with the +input string "aba" (this example is taken from +a comp.compilers message from Dec. 1989, I think): + +type lexresult=unit +val linenum = ref 1 +fun error x = TextIO.output(TextIO.stdErr, x ^ "\n") +val eof = fn () => () +%% +%structure Lex +%% +(a|ab)/ba => (print yytext; print "\n"; ()); + +The ASU proposal works as follows. Suppose that we are +using NFA's to represent our regular expressions. Then to +build an NFA for e1 / e2, we build an NFA n1 for e1 +and an NFA n2 for e2, and add an epsilon transition +from e1 to e2. + +When lexing, when we encounter the end state of e1e2, +we take as the end of the string the position in +the string that was the last occurrence of the state of +the NFA having a transition on the epsilon introduced +for /. + +Using the example we have above, we'll have an NFA +with the following states: + + + 1 -- a --> 2 -- b --> 3 + | | + | epsilon | epsilon + | | + |------------> 4 -- b --> 5 -- a --> 6 + +On our example, we get the following list of transitions: + +a : 2, 4 (make an epsilon transition from 2 to 4) +ab : 3, 4, 5 (make an epsilon transition from 3 to 4) +aba : 6 + +If we chose the last state in which we made an epsilon transition, +we'll chose the transition from 3 to 4, and end up with "ab" +as our token, when we should have "a" as our token. + +*) + +functor RedBlack(B : sig type key + val > : key*key->bool + end): + sig type tree + type key + val empty : tree + val insert : key * tree -> tree + val lookup : key * tree -> key + exception notfound of key + end = +struct + open B + datatype color = RED | BLACK + datatype tree = empty | tree of key * color * tree * tree + exception notfound of key + + fun insert (key,t) = + let fun f empty = tree(key,RED,empty,empty) + | f (tree(k,BLACK,l,r)) = + if key>k + then case f r + of r as tree(rk,RED, rl as tree(rlk,RED,rll,rlr),rr) => + (case l + of tree(lk,RED,ll,lr) => + tree(k,RED,tree(lk,BLACK,ll,lr), + tree(rk,BLACK,rl,rr)) + | _ => tree(rlk,BLACK,tree(k,RED,l,rll), + tree(rk,RED,rlr,rr))) + | r as tree(rk,RED,rl, rr as tree(rrk,RED,rrl,rrr)) => + (case l + of tree(lk,RED,ll,lr) => + tree(k,RED,tree(lk,BLACK,ll,lr), + tree(rk,BLACK,rl,rr)) + | _ => tree(rk,BLACK,tree(k,RED,l,rl),rr)) + | r => tree(k,BLACK,l,r) + else if k>key + then case f l + of l as tree(lk,RED,ll, lr as tree(lrk,RED,lrl,lrr)) => + (case r + of tree(rk,RED,rl,rr) => + tree(k,RED,tree(lk,BLACK,ll,lr), + tree(rk,BLACK,rl,rr)) + | _ => tree(lrk,BLACK,tree(lk,RED,ll,lrl), + tree(k,RED,lrr,r))) + | l as tree(lk,RED, ll as tree(llk,RED,lll,llr), lr) => + (case r + of tree(rk,RED,rl,rr) => + tree(k,RED,tree(lk,BLACK,ll,lr), + tree(rk,BLACK,rl,rr)) + | _ => tree(lk,BLACK,ll,tree(k,RED,lr,r))) + | l => tree(k,BLACK,l,r) + else tree(key,BLACK,l,r) + | f (tree(k,RED,l,r)) = + if key>k then tree(k,RED,l, f r) + else if k>key then tree(k,RED, f l, r) + else tree(key,RED,l,r) + in case f t + of tree(k,RED, l as tree(_,RED,_,_), r) => tree(k,BLACK,l,r) + | tree(k,RED, l, r as tree(_,RED,_,_)) => tree(k,BLACK,l,r) + | t => t + end + + + fun lookup (key,t) = + let fun look empty = raise (notfound key) + | look (tree(k,_,l,r)) = + if k>key then look l + else if key>k then look r + else k + in look t + end + +end + +signature LEXGEN = + sig + val lexGen: string -> unit + end + +structure LexGen: LEXGEN = + struct + open Array List + infix 9 sub + + datatype token = CHARS of bool array | QMARK | STAR | PLUS | BAR + | LP | RP | CARAT | DOLLAR | SLASH | STATE of string list + | REPS of int * int | ID of string | ACTION of string + | BOF | EOF | ASSIGN | SEMI | ARROW | LEXMARK | LEXSTATES | + COUNT | REJECT | FULLCHARSET | STRUCT | HEADER | ARG + + datatype exp = EPS | CLASS of bool array * int | CLOSURE of exp + | ALT of exp * exp | CAT of exp * exp | TRAIL of int + | END of int + + (* flags describing input Lex spec. - unnecessary code is omitted *) + (* if possible *) + + val CharFormat = ref false; + val UsesTrailingContext = ref false; + val UsesPrevNewLine = ref false; + + (* flags for various bells & whistles that Lex has. These slow the + lexer down and should be omitted from production lexers (if you + really want speed) *) + + val CountNewLines = ref false; + val HaveReject = ref false; + + (* Can increase size of character set *) + + val CharSetSize = ref 129; + + (* Can name structure or declare header code *) + + val StrName = ref "Mlex" + val HeaderCode = ref "" + val HeaderDecl = ref false + val ArgCode = ref (NONE: string option) + val StrDecl = ref false + + val ResetFlags = fn () => (CountNewLines := false; HaveReject := false; + UsesTrailingContext := false; + CharSetSize := 129; StrName := "Mlex"; + HeaderCode := ""; HeaderDecl:= false; + ArgCode := NONE; + StrDecl := false) + + val LexOut = ref(TextIO.stdOut) + fun say x = TextIO.output(!LexOut, x) + +(* Union: merge two sorted lists of integers *) + +fun union(a,b) = let val rec merge = fn + (nil,nil,z) => z + | (nil,el::more,z) => merge(nil,more,el::z) + | (el::more,nil,z) => merge(more,nil,el::z) + | (x::morex,y::morey,z) => if (x:int)=(y:int) + then merge(morex,morey,x::z) + else if x>y then merge(morex,y::morey,x::z) + else merge(x::morex,morey,y::z) + in merge(rev a,rev b,nil) +end + +(* Nullable: compute if a important expression parse tree node is nullable *) + +val rec nullable = fn + EPS => true + | CLASS(_) => false + | CLOSURE(_) => true + | ALT(n1,n2) => nullable(n1) orelse nullable(n2) + | CAT(n1,n2) => nullable(n1) andalso nullable(n2) + | TRAIL(_) => true + | END(_) => false + +(* FIRSTPOS: firstpos function for parse tree expressions *) + +and firstpos = fn + EPS => nil + | CLASS(_,i) => [i] + | CLOSURE(n) => firstpos(n) + | ALT(n1,n2) => union(firstpos(n1),firstpos(n2)) + | CAT(n1,n2) => if nullable(n1) then union(firstpos(n1),firstpos(n2)) + else firstpos(n1) + | TRAIL(i) => [i] + | END(i) => [i] + +(* LASTPOS: Lastpos function for parse tree expressions *) + +and lastpos = fn + EPS => nil + | CLASS(_,i) => [i] + | CLOSURE(n) => lastpos(n) + | ALT(n1,n2) => union(lastpos(n1),lastpos(n2)) + | CAT(n1,n2) => if nullable(n2) then union(lastpos(n1),lastpos(n2)) + else lastpos(n2) + | TRAIL(i) => [i] + | END(i) => [i] + ; + +(* ++: Increment an integer reference *) + +fun ++(x) : int = (x := !x + 1; !x); + +structure Dict = +struct + type 'a relation = 'a * 'a -> bool + abstype ('b,'a) dictionary = DATA of {Table : ('b * 'a) list, + Leq : 'b * 'b -> bool } + with + exception LOOKUP + fun create Leqfunc = DATA { Table = nil, Leq = Leqfunc } + + fun lookup (DATA { Table = entrylist, Leq = leq }) key = + let fun search [] = raise LOOKUP + | search((k,item)::entries) = + if leq(key,k) + then if leq(k,key) then item else raise LOOKUP + else search entries + in search entrylist + end + + fun enter (DATA { Table = entrylist, Leq = leq }) + (newentry as (key : 'b,item :'a)) : ('b,'a) dictionary = + let val gt = fn a => fn b => not (leq(a,b)) + val eq = fn k => fn k' => (leq(k,k')) andalso (leq(k',k)) + fun update nil = [ newentry ] + | update ((entry as (k,_))::entries) = + if (eq key k) then newentry::entries + else if gt k key then newentry::(entry::entries) + else entry::(update entries) + in DATA { Table = update entrylist, Leq = leq } + end + + fun listofdict (DATA { Table = entrylist,Leq = leq}) = + let fun f (nil,r) = rev r + | f (a::b,r) = f (b,a::r) + in f(entrylist,nil) + end + end +end (* structure Dict *) + +open Dict; + +(* INPUT.ML : Input w/ one character push back capability *) + +val LineNum = ref 1; + +abstype ibuf = + BUF of TextIO.instream * {b : string ref, p : int ref} +with + fun make_ibuf(s) = BUF (s, {b=ref"", p = ref 0}) + fun close_ibuf (BUF (s,_)) = TextIO.closeIn(s) + exception eof + fun getch (a as (BUF(s,{b,p}))) = + if (!p = (size (!b))) + then (b := TextIO.inputN(s, 1024); + p := 0; + if (size (!b))=0 + then raise eof + else getch a) + else (let val ch = String.sub(!b,!p) + in (if ch = #"\n" + then LineNum := !LineNum + 1 + else (); + p := !p + 1; + ch) + end) + + fun ungetch(BUF(s,{b,p})) = ( + p := !p - 1; + if String.sub(!b,!p) = #"\n" + then LineNum := !LineNum - 1 + else ()) +end; + +exception Error + +fun prErr x = ( + TextIO.output (TextIO.stdErr, String.concat [ + "ml-lex: error, line ", (Int.toString (!LineNum)), ": ", x, "\n" + ]); + raise Error) +fun prSynErr x = ( + TextIO.output (TextIO.stdErr, String.concat [ + "ml-lex: syntax error, line ", (Int.toString (!LineNum)), ": ", x, "\n" + ]); + raise Error) + +exception SyntaxError; (* error in user's input file *) + +exception LexError; (* unexpected error in lexer *) + +val LexBuf = ref(make_ibuf(TextIO.stdIn)); +val LexState = ref 0; +val NextTok = ref BOF; +val inquote = ref false; + +fun AdvanceTok () : unit = let + fun isLetter c = + ((c >= #"a") andalso (c <= #"z")) orelse + ((c >= #"A") andalso (c <= #"Z")) + fun isDigit c = (c >= #"0") andalso (c <= #"9") + (* check for valid (non-leading) identifier character (added by JHR) *) + fun isIdentChr c = + ((isLetter c) orelse (isDigit c) orelse (c = #"_") orelse (c = #"'")) + fun atoi s = let + fun num (c::r, n) = if isDigit c + then num (r, 10*n + (Char.ord c - Char.ord #"0")) + else n + | num ([], n) = n + in + num (explode s, 0) + end + + fun skipws () = (case nextch() + of #" " => skipws() + | #"\t" => skipws() + | #"\n" => skipws() + | x => x + (* end case *)) + + and nextch () = getch(!LexBuf) + + and escaped () = (case nextch() + of #"b" => #"\008" + | #"n" => #"\n" + | #"t" => #"\t" + | #"h" => #"\128" + | x => let + fun err t = prErr("illegal ascii escape '"^(implode(rev t))^"'") + fun cvt c = (Char.ord c - Char.ord #"0") + fun f (n, c, t) = if c=3 + then if n >= (!CharSetSize) + then err t + else Char.chr n + else let val ch=nextch() + in + if isDigit ch + then f(n*10+(cvt ch), c+1, ch::t) + else err t + end + in + if isDigit x then f(cvt x, 1, [x]) else x + end + (* end case *)) + + and onechar x = + let val c = array(!CharSetSize, false) + in + update(c, Char.ord(x), true); + CHARS(c) + end + + in case !LexState of 0 => let val makeTok = fn () => + case skipws() + (* Lex % operators *) + of #"%" => (case nextch() of + #"%" => LEXMARK + | a => let fun f s = + let val a = nextch() + in if isLetter a then f(a::s) + else (ungetch(!LexBuf); + implode(rev s)) + end + val command = f [a] + in if command = "reject" then REJECT + else if command = "count" then COUNT + else if command = "full" then FULLCHARSET + else if command = "s" then LEXSTATES + else if command = "S" then LEXSTATES + else if command = "structure" then STRUCT + else if command = "header" then HEADER + else if command = "arg" then ARG + else prErr "unknown % operator " + end + ) + (* semicolon (for end of LEXSTATES) *) + | #";" => SEMI + (* anything else *) + | ch => if isLetter(ch) then + let fun getID matched = + let val x = nextch() +(**** fix by JHR + in if isLetter(x) orelse isDigit(x) orelse + x = "_" orelse x = "'" +****) + in if (isIdentChr x) + then getID (x::matched) + else (ungetch(!LexBuf); implode(rev matched)) + end + in ID(getID [ch]) + end + else (prSynErr ("bad character: " ^ String.str ch)) + in NextTok := makeTok() + end + | 1 => let val rec makeTok = fn () => + if !inquote then case nextch() of + (* inside quoted string *) + #"\\" => onechar(escaped()) + | #"\"" => (inquote := false; makeTok()) + | x => onechar(x) + else case skipws() of + (* single character operators *) + #"?" => QMARK + | #"*" => STAR + | #"+" => PLUS + | #"|" => BAR + | #"(" => LP + | #")" => RP + | #"^" => CARAT + | #"$" => DOLLAR + | #"/" => SLASH + | #";" => SEMI + | #"." => let val c = array(!CharSetSize,true) in + update(c,10,false); CHARS(c) + end + (* assign and arrow *) + | #"=" => let val c = nextch() in + if c = #">" then ARROW else (ungetch(!LexBuf); ASSIGN) + end + (* character set *) + | #"[" => let val rec classch = fn () => let val x = skipws() + in if x = #"\\" then escaped() else x + end; + val first = classch(); + val flag = (first <> #"^"); + val c = array(!CharSetSize,not flag); + fun add NONE = () + | add (SOME x) = update(c, Char.ord(x), flag) + and range (x, y) = if x>y + then (prErr "bad char. range") + else let + val i = ref(Char.ord(x)) and j = Char.ord(y) + in while !i<=j do ( + add (SOME(Char.chr(!i))); + i := !i + 1) + end + and getClass last = (case classch() + of #"]" => (add(last); c) + | #"-" => (case last + of NONE => getClass(SOME #"-") + | (SOME last') => let val x = classch() + in + if x = #"]" + then (add(last); add(SOME #"-"); c) + else (range(last',x); getClass(NONE)) + end + (* end case *)) + | x => (add(last); getClass(SOME x)) + (* end case *)) + in CHARS(getClass(if first = #"^" then NONE else SOME first)) + end + (* Start States specification *) + | #"<" => let val rec get_state = fn (prev,matched) => + case nextch() of + #">" => matched::prev + | #"," => get_state(matched::prev,"") + | x => if isIdentChr(x) + then get_state(prev,matched ^ String.str x) + else (prSynErr "bad start state list") + in STATE(get_state(nil,"")) + end + (* {id} or repititions *) + | #"{" => let val ch = nextch() in if isLetter(ch) then + let fun getID matched = (case nextch() + of #"}" => matched + | x => if (isIdentChr x) then + getID(matched ^ String.str x) + else (prErr "invalid char. class name") + (* end case *)) + in ID(getID(String.str ch)) + end + else if isDigit(ch) then + let fun get_r (matched, r1) = (case nextch() + of #"}" => let val n = atoi(matched) in + if r1 = ~1 then (n,n) else (r1,n) + end + | #"," => if r1 = ~1 then get_r("",atoi(matched)) + else (prErr "invalid repetitions spec.") + | x => if isDigit(x) + then get_r(matched ^ String.str x,r1) + else (prErr "invalid char in repetitions spec") + (* end case *)) + in REPS(get_r(String.str ch,~1)) + end + else (prErr "bad repetitions spec") + end + (* Lex % operators *) + | #"%" => if nextch() = #"%" then LEXMARK else + (ungetch(!LexBuf); onechar (#"%")) + (* backslash escape *) + | #"\\" => onechar(escaped()) + (* start quoted string *) + | #"\"" => (inquote := true; makeTok()) + (* anything else *) + | ch => onechar(ch) + in NextTok := makeTok() + end + | 2 => NextTok := + (case skipws() + of #"(" => let + fun GetAct (lpct,x) = (case getch(!LexBuf) + of #"(" => GetAct (lpct+1, #"("::x) + | #")" => if lpct = 0 then (implode (rev x)) + else GetAct(lpct-1, #")"::x) + | y => GetAct(lpct,y::x) + (* end case *)) + in ACTION (GetAct (0,nil)) + end + | #";" => SEMI + | c => (prSynErr ("invalid character " ^ String.str c))) + | _ => raise LexError +end +handle eof => NextTok := EOF ; + +fun GetTok (_:unit) : token = + let val t = !NextTok in AdvanceTok(); t + end; +val SymTab = ref (create String.<=) : (string,exp) dictionary ref + +fun GetExp () : exp = + + let val rec optional = fn e => ALT(EPS,e) + + and lookup' = fn name => + lookup(!SymTab) name + handle LOOKUP => prErr ("bad regular expression name: "^ + name) + + and newline = fn () => let val c = array(!CharSetSize,false) in + update(c,10,true); c + end + + and endline = fn e => trail(e,CLASS(newline(),0)) + + and trail = fn (e1,e2) => CAT(CAT(e1,TRAIL(0)),e2) + + and closure1 = fn e => CAT(e,CLOSURE(e)) + + and repeat = fn (min,max,e) => let val rec rep = fn + (0,0) => EPS + | (0,1) => ALT(e,EPS) + | (0,i) => CAT(rep(0,1),rep(0,i-1)) + | (i,j) => CAT(e,rep(i-1,j-1)) + in rep(min,max) + end + + and exp0 = fn () => case GetTok() of + CHARS(c) => exp1(CLASS(c,0)) + | LP => let val e = exp0() in + if !NextTok = RP then + (AdvanceTok(); exp1(e)) + else (prSynErr "missing '('") end + | ID(name) => exp1(lookup' name) + | _ => raise SyntaxError + + and exp1 = fn (e) => case !NextTok of + SEMI => e + | ARROW => e + | EOF => e + | LP => exp2(e,exp0()) + | RP => e + | t => (AdvanceTok(); case t of + QMARK => exp1(optional(e)) + | STAR => exp1(CLOSURE(e)) + | PLUS => exp1(closure1(e)) + | CHARS(c) => exp2(e,CLASS(c,0)) + | BAR => ALT(e,exp0()) + | DOLLAR => (UsesTrailingContext := true; endline(e)) + | SLASH => (UsesTrailingContext := true; + trail(e,exp0())) + | REPS(i,j) => exp1(repeat(i,j,e)) + | ID(name) => exp2(e,lookup' name) + | _ => raise SyntaxError) + + and exp2 = fn (e1,e2) => case !NextTok of + SEMI => CAT(e1,e2) + | ARROW => CAT(e1,e2) + | EOF => CAT(e1,e2) + | LP => exp2(CAT(e1,e2),exp0()) + | RP => CAT(e1,e2) + | t => (AdvanceTok(); case t of + QMARK => exp1(CAT(e1,optional(e2))) + | STAR => exp1(CAT(e1,CLOSURE(e2))) + | PLUS => exp1(CAT(e1,closure1(e2))) + | CHARS(c) => exp2(CAT(e1,e2),CLASS(c,0)) + | BAR => ALT(CAT(e1,e2),exp0()) + | DOLLAR => (UsesTrailingContext := true; + endline(CAT(e1,e2))) + | SLASH => (UsesTrailingContext := true; + trail(CAT(e1,e2),exp0())) + | REPS(i,j) => exp1(CAT(e1,repeat(i,j,e2))) + | ID(name) => exp2(CAT(e1,e2),lookup' name) + | _ => raise SyntaxError) +in exp0() +end; +val StateTab = ref(create(String.<=)) : (string,int) dictionary ref + +val StateNum = ref 0; + +fun GetStates () : int list = + + let fun add nil sl = sl + | add (x::y) sl = add y (union ([lookup (!StateTab)(x) + handle LOOKUP => + prErr ("bad state name: "^x) + ],sl)) + + fun addall i sl = + if i <= !StateNum then addall (i+2) (union ([i],sl)) + else sl + + fun incall (x::y) = (x+1)::incall y + | incall nil = nil + + fun addincs nil = nil + | addincs (x::y) = x::(x+1)::addincs y + + val state_list = + case !NextTok of + STATE s => (AdvanceTok(); LexState := 1; add s nil) + | _ => addall 1 nil + + in case !NextTok + of CARAT => (LexState := 1; AdvanceTok(); UsesPrevNewLine := true; + incall state_list) + | _ => addincs state_list + end + +val LeafNum = ref ~1; + +fun renum(e : exp) : exp = + let val rec label = fn + EPS => EPS + | CLASS(x,_) => CLASS(x,++LeafNum) + | CLOSURE(e) => CLOSURE(label(e)) + | ALT(e1,e2) => ALT(label(e1),label(e2)) + | CAT(e1,e2) => CAT(label(e1),label(e2)) + | TRAIL(i) => TRAIL(++LeafNum) + | END(i) => END(++LeafNum) +in label(e) +end; + +exception ParseError; + +fun parse() : (string * (int list * exp) list * ((string,string) dictionary)) = + let val Accept = ref (create String.<=) : (string,string) dictionary ref + val rec ParseRtns = fn l => case getch(!LexBuf) of + #"%" => let val c = getch(!LexBuf) in + if c = #"%" then (implode (rev l)) + else ParseRtns(c :: #"%" :: l) + end + | c => ParseRtns(c::l) + and ParseDefs = fn () => + (LexState:=0; AdvanceTok(); case !NextTok of + LEXMARK => () + | LEXSTATES => + let fun f () = (case !NextTok of (ID i) => + (StateTab := enter(!StateTab)(i,++StateNum); + ++StateNum; AdvanceTok(); f()) + | _ => ()) + in AdvanceTok(); f (); + if !NextTok=SEMI then ParseDefs() else + (prSynErr "expected ';'") + end + | ID x => (LexState:=1; AdvanceTok(); if GetTok() = ASSIGN + then (SymTab := enter(!SymTab)(x,GetExp()); + if !NextTok = SEMI then ParseDefs() + else (prSynErr "expected ';'")) + else raise SyntaxError) + | REJECT => (HaveReject := true; ParseDefs()) + | COUNT => (CountNewLines := true; ParseDefs()) + | FULLCHARSET => (CharSetSize := 256; ParseDefs()) + | HEADER => (LexState := 2; AdvanceTok(); + case GetTok() + of ACTION s => + if (!StrDecl) then + (prErr "cannot have both %s and %header \ + \declarations") + else if (!HeaderDecl) then + (prErr "duplicate %header declarations") + else + (HeaderCode := s; LexState := 0; + HeaderDecl := true; ParseDefs()) + | _ => raise SyntaxError) + | ARG => (LexState := 2; AdvanceTok(); + case GetTok() + of ACTION s => + (case !ArgCode + of SOME _ => prErr "duplicate %arg declarations" + | NONE => ArgCode := SOME s; + LexState := 0; + ParseDefs()) + | _ => raise SyntaxError) + | STRUCT => (AdvanceTok(); + case !NextTok of + (ID i) => + if (!HeaderDecl) then + (prErr "cannot have both %s and %header \ + \declarations") + else if (!StrDecl) then + (prErr "duplicate %s declarations") + else StrName := i + | _ => (prErr "expected ID"); + ParseDefs()) + | _ => raise SyntaxError) + and ParseRules = + fn rules => (LexState:=1; AdvanceTok(); case !NextTok of + LEXMARK => rules + | EOF => rules + | _ => + let val s = GetStates() + val e = renum(CAT(GetExp(),END(0))) + in + if !NextTok = ARROW then + (LexState:=2; AdvanceTok(); + case GetTok() of ACTION(act) => + if !NextTok=SEMI then + (Accept:=enter(!Accept) (Int.toString (!LeafNum),act); + ParseRules((s,e)::rules)) + else (prSynErr "expected ';'") + | _ => raise SyntaxError) + else (prSynErr "expected '=>'") + end) +in let val usercode = ParseRtns nil + in (ParseDefs(); (usercode,ParseRules(nil),!Accept)) + end +end handle SyntaxError => (prSynErr "") + +fun makebegin () : unit = + let fun make nil = () + | make ((x,n:int)::y)=(say "val "; say x; say " = " ; + say "STARTSTATE "; + say (Int.toString n); say ";\n"; make y) + in say "\n(* start state definitions *)\n\n"; make(listofdict(!StateTab)) + end + +structure L = + struct + nonfix > + type key = int list * string + fun > ((key,item:string),(key',item')) = + let fun f ((a:int)::a') (b::b') = if Int.> (a,b) then true + else if a=b then f a' b' + else false + | f _ _ = false + in f key key' + end + end + +structure RB = RedBlack(L) + +fun maketable (fins:(int * (int list)) list, + tcs :(int * (int list)) list, + tcpairs: (int * int) list, + trans : (int*(int list)) list) : unit = + +(* Fins = (state #, list of final leaves for the state) list + tcs = (state #, list of trailing context leaves which begin in this state) + list + tcpairs = (trailing context leaf, end leaf) list + trans = (state #,list of transitions for state) list *) + + let datatype elem = N of int | T of int | D of int + val count = ref 0 + val _ = (if length(trans)<256 then CharFormat := true + else CharFormat := false; + if !UsesTrailingContext then + (say "\ndatatype yyfinstate = N of int | \ + \ T of int | D of int\n") + else say "\ndatatype yyfinstate = N of int"; + say "\ntype statedata = {fin : yyfinstate list, trans: "; + case !CharFormat of + true => say "string}" + | false => say "int Vector.vector}"; + say "\n(* transition & final state table *)\nval tab = let\n"; + case !CharFormat of + true => () + | false => + (say "fun decode s k =\n"; + say " let val k' = k + k\n"; + say " val hi = Char.ord(String.sub(s, k'))\n"; + say " val lo = Char.ord(String.sub(s, k' + 1))\n"; + say " in hi * 256 + lo end\n")) + val newfins = + let fun IsEndLeaf t = + let fun f ((l,e)::r) = if (e=t) then true else f r + | f nil = false in f tcpairs end + + fun GetEndLeaf t = + let fun f ((tl,el)::r) = if (tl=t) then el else f r + in f tcpairs + end + fun GetTrConLeaves s = + let fun f ((s',l)::r) = if (s = s') then l else f r + | f nil = nil + in f tcs + end + fun sort_leaves s = + let fun insert (x:int) (a::b) = + if (x <= a) then x::(a::b) + else a::(insert x b) + | insert x nil = [x] + in List.foldr (fn (x,r) => insert x r) [] s + end + fun conv a = if (IsEndLeaf a) then (D a) else (N a) + fun merge (a::a',b::b') = + if (a <= b) then (conv a)::merge(a',b::b') + else (T b)::(merge(a::a',b')) + | merge (a::a',nil) = (conv a)::(merge (a',nil)) + | merge (nil,b::b') = (T b)::(merge (b',nil)) + | merge (nil,nil) = nil + + in map (fn (x,l) => + rev (merge (l, + sort_leaves (map (fn x => GetEndLeaf x) (GetTrConLeaves x))))) + fins + end + + val rs = + let open RB + fun makeItems x = + let fun emit8(x, pos) = let + val s = StringCvt.padLeft #"0" 3 (Int.toString x) + in + case pos + of 16 => (say "\\\n\\\\"; say s; 1) + | _ => (say "\\"; say s; pos+1) + end + fun emit16(x, pos) = + let val hi8 = x div 256 + val lo8 = x - hi8 * 256 (* x rem 256 *) + in + emit8(lo8, emit8(hi8, pos)) + end + fun MakeString([], _, _) = () + | MakeString(x::xs, emitter, pos) = + MakeString(xs, emitter, emitter(x, pos)) + in case !CharFormat of + true => (say " =\n\""; MakeString(x,emit8,0); say "\"\n") + | false => (say " = Vector.tabulate("; say (Int.toString(length x)); + say ", decode\n\""; MakeString(x,emit16,0); say "\")\n") + end + fun makeEntry(nil,rs,t) = rev rs + | makeEntry(((l:int,x)::y),rs,t) = + let val name = "s" ^ (Int.toString l) + in let val (r,n) = lookup ((x,name),t) + in makeEntry(y,(n::rs),t) + end handle notfound _ => (count := !count+1; + say "val "; say name; makeItems x; + makeEntry(y,(name::rs),(insert ((x,name),t)))) + end + in (makeEntry(trans,nil,empty)) + end + + fun makeTable(nil,nil) = () + | makeTable(a::a',b::b') = + let fun makeItems nil = () + | makeItems (hd::tl) = + let val (t,n) = + case hd of + (N i) => ("(N ",i) + | (T i) => ("(T ",i) + | (D i) => ("(D ",i) + in (say t; say (Int.toString n); say ")"; + if null tl + then () + else (say ","; makeItems tl)) + end + in (say "{fin = ["; makeItems b; + say "], trans = "; say a; say "}"; + if null a' + then () + else (say ",\n"; makeTable(a',b'))) + end + + fun msg x = () (*TextIO.output(TextIO.stdOut, x)*) + + in (say "in Vector.fromList\n["; makeTable(rs,newfins); say "]\nend\n"; + msg ("\nNumber of states = " ^ (Int.toString (length trans))); + msg ("\nNumber of distinct rows = " ^ (Int.toString (!count))); + msg ("\nApprox. memory size of trans. table = " ^ + (Int.toString (!count*(!CharSetSize)*(if !CharFormat then 1 else 8)))); + msg " bytes\n") +end + +(* makeaccept: Takes a (string,string) dictionary, prints case statement for + accepting leaf actions. The key strings are the leaf #'s, the data strings + are the actions *) + +fun makeaccept ends = + let fun startline f = if f then say " " else say "| " + fun make(nil,f) = (startline f; say "_ => raise Internal.LexerError\n") + | make((x,a)::y,f) = (startline f; say x; say " => ("; + say a; say ")\n"; make(y,false)) + in make (listofdict(ends),true) + end + +fun leafdata(e:(int list * exp) list) = + let val fp = array(!LeafNum + 1,nil) + and leaf = array(!LeafNum + 1,EPS) + and tcpairs = ref nil + and trailmark = ref ~1; + val rec add = fn + (nil,x) => () + | (hd::tl,x) => (update(fp,hd,union(fp sub hd,x)); + add(tl,x)) + and moredata = fn + CLOSURE(e1) => + (moredata(e1); add(lastpos(e1),firstpos(e1))) + | ALT(e1,e2) => (moredata(e1); moredata(e2)) + | CAT(e1,e2) => (moredata(e1); moredata(e2); + add(lastpos(e1),firstpos(e2))) + | CLASS(x,i) => update(leaf,i,CLASS(x,i)) + | TRAIL(i) => (update(leaf,i,TRAIL(i)); if !trailmark = ~1 + then trailmark := i else ()) + | END(i) => (update(leaf,i,END(i)); if !trailmark <> ~1 + then (tcpairs := (!trailmark,i)::(!tcpairs); + trailmark := ~1) else ()) + | _ => () + and makedata = fn + nil => () + | (_,x)::tl => (moredata(x);makedata(tl)) + in trailmark := ~1; makedata(e); (fp,leaf,!tcpairs) + end; + +fun makedfa(rules) = +let val StateTab = ref (create(String.<=)) : (string,int) dictionary ref + val fintab = ref (create(Int.<=)) : (int,(int list)) dictionary ref + val transtab = ref (create(Int.<=)) : (int,int list) dictionary ref + val tctab = ref (create(Int.<=)) : (int,(int list)) dictionary ref + val (fp, leaf, tcpairs) = leafdata(rules); + +fun visit (state,statenum) = + let val transitions = gettrans(state) in + fintab := enter(!fintab)(statenum,getfin(state)); + tctab := enter(!tctab)(statenum,gettc(state)); + transtab := enter(!transtab)(statenum,transitions) + end + +and visitstarts (states) = + let fun vs nil i = () + | vs (hd::tl) i = (visit (hd,i); vs tl (i+1)) + in vs states 0 + end + +and hashstate(s: int list) = + let val rec hs = + fn (nil,z) => z + | ((x:int)::y,z) => hs(y,z ^ " " ^ (Int.toString x)) + in hs(s,"") + end + +and find(s) = lookup(!StateTab)(hashstate(s)) + +and add(s,n) = StateTab := enter(!StateTab)(hashstate(s),n) + +and getstate (state) = + find(state) + handle LOOKUP => let val n = ++StateNum in + add(state,n); visit(state,n); n + end + +and getfin state = + let fun f nil fins = fins + | f (hd::tl) fins = + case (leaf sub hd) + of END _ => f tl (hd::fins) + | _ => f tl fins + in f state nil + end + +and gettc state = + let fun f nil fins = fins + | f (hd::tl) fins = + case (leaf sub hd) + of TRAIL _ => f tl (hd::fins) + | _ => f tl fins + in f state nil + end + +and gettrans (state) = + let fun loop c tlist = + let fun cktrans nil r = r + | cktrans (hd::tl) r = + case (leaf sub hd) of + CLASS(i,_)=> + (if (i sub c) then cktrans tl (union(r,fp sub hd)) + else cktrans tl r handle Subscript => + cktrans tl r + ) + | _ => cktrans tl r + in if c >= 0 then + let val v=cktrans state nil + in loop (c-1) (if v=nil then 0::tlist else (getstate v)::tlist) + end + else tlist + end + in loop ((!CharSetSize) - 1) nil + end + +and startstates() = + let val startarray = array(!StateNum + 1, nil); + fun listofarray(a,n) = + let fun f i l = if i >= 0 then f (i-1) ((a sub i)::l) else l + in f (n-1) nil end + val rec makess = fn + nil => () + | (startlist,e)::tl => (fix(startlist,firstpos(e));makess(tl)) + and fix = fn + (nil,_) => () + | (s::tl,firsts) => (update(startarray,s, + union(firsts,startarray sub s)); + fix(tl,firsts)) + in makess(rules);listofarray(startarray, !StateNum + 1) + end + +in visitstarts(startstates()); +(listofdict(!fintab),listofdict(!transtab),listofdict(!tctab),tcpairs) +end + +val skel_hd = +" struct\n\ +\ structure UserDeclarations =\n\ +\ struct\n\ +\" + +val skel_mid2 = +" | Internal.D k => action (i,(acts::l),k::rs)\n\ +\ | Internal.T k =>\n\ +\ let fun f (a::b,r) =\n\ +\ if a=k\n\ +\ then action(i,(((Internal.N a)::acts)::l),(b@r))\n\ +\ else f (b,a::r)\n\ +\ | f (nil,r) = action(i,(acts::l),rs)\n\ +\ in f (rs,nil)\n\ +\ end\n\ +\" + +fun lexGen(infile) = + let val outfile = infile ^ ".sml" + fun PrintLexer (ends) = + let val sayln = fn x => (say x; say "\n") + in case !ArgCode + of NONE => (sayln "fun lex () : Internal.result ="; + sayln "let fun continue() = lex() in") + | SOME s => (say "fun lex "; say "(yyarg as ("; say s; sayln ")) ="; + sayln "let fun continue() : Internal.result = "); + say " let fun scan (s,AcceptingLeaves : Internal.yyfinstate"; + sayln " list list,l,i0) ="; + if !UsesTrailingContext + then say "\tlet fun action (i,nil,rs)" + else say "\tlet fun action (i,nil)"; + sayln " = raise LexError"; + if !UsesTrailingContext + then sayln "\t| action (i,nil::l,rs) = action(i-1,l,rs)" + else sayln "\t| action (i,nil::l) = action (i-1,l)"; + if !UsesTrailingContext + then sayln "\t| action (i,(node::acts)::l,rs) =" + else sayln "\t| action (i,(node::acts)::l) ="; + sayln "\t\tcase node of"; + sayln "\t\t Internal.N yyk => "; + sayln "\t\t\t(let val yytext = substring(!yyb,i0,i-i0)\n\ + \\t\t\t val yypos = i0+ !yygone"; + if !CountNewLines + then (sayln "\t\t\tval _ = yylineno := CharVector.foldl"; + sayln "\t\t\t\t(fn (#\"\\n\", n) => n+1 | (_, n) => n) (!yylineno) yytext") + else (); + if !HaveReject + then (say "\t\t\tfun REJECT() = action(i,acts::l"; + if !UsesTrailingContext + then sayln ",rs)" else sayln ")") + else (); + sayln "\t\t\topen UserDeclarations Internal.StartStates"; + sayln " in (yybufpos := i; case yyk of "; + sayln ""; + sayln "\t\t\t(* Application actions *)\n"; + makeaccept(ends); + say "\n\t\t) end "; + say ")\n\n"; + if (!UsesTrailingContext) then say skel_mid2 else (); + sayln "\tval {fin,trans} = Vector.sub(Internal.tab, s)"; + sayln "\tval NewAcceptingLeaves = fin::AcceptingLeaves"; + sayln "\tin if l = !yybl then"; + sayln "\t if trans = #trans(Vector.sub(Internal.tab,0))"; + sayln "\t then action(l,NewAcceptingLeaves"; + if !UsesTrailingContext then say ",nil" else (); + say ") else"; + sayln "\t let val newchars= if !yydone then \"\" else yyinput 1024"; + sayln "\t in if (size newchars)=0"; + sayln "\t\t then (yydone := true;"; + say "\t\t if (l=i0) then UserDeclarations.eof "; + sayln (case !ArgCode of NONE => "()" | SOME _ => "yyarg"); + say "\t\t else action(l,NewAcceptingLeaves"; + if !UsesTrailingContext then + sayln ",nil))" else sayln "))"; + sayln "\t\t else (if i0=l then yyb := newchars"; + sayln "\t\t else yyb := substring(!yyb,i0,l-i0)^newchars;"; + sayln "\t\t yygone := !yygone+i0;"; + sayln "\t\t yybl := size (!yyb);"; + sayln "\t\t scan (s,AcceptingLeaves,l-i0,0))"; + sayln "\t end"; + sayln "\t else let val NewChar = Char.ord(String.sub(!yyb,l))"; + say "\t\tval NewState = "; + case (!CharFormat,!CharSetSize) + of (true,129) => sayln "if NewChar<128 then Char.ord(String.sub(trans,NewChar)) else Char.ord(String.sub(trans,128))" + | (true,256) => sayln "Char.ord(String.sub(trans,NewChar))" + | (false,129) => sayln "if NewChar<128 then Vector.sub(trans, NewChar) else Vector.sub(trans, 128)" + | (false,256) => sayln "Vector.sub(trans, NewChar)"; + say "\t\tin if NewState=0 then action(l,NewAcceptingLeaves"; + if !UsesTrailingContext then sayln ",nil)" else sayln ")"; + sayln "\t\telse scan(NewState,NewAcceptingLeaves,l+1,i0)"; + sayln "\tend"; + sayln "\tend"; + if !UsesPrevNewLine then () else sayln "(*"; + sayln "\tval start= if substring(!yyb,!yybufpos-1,1)=\"\\n\""; + sayln "then !yybegin+1 else !yybegin"; + if !UsesPrevNewLine then () else sayln "*)"; + say "\tin scan("; + if !UsesPrevNewLine then say "start" + else say "!yybegin (* start *)"; + sayln ",nil,!yybufpos,!yybufpos)"; + sayln " end"; + sayln (case !ArgCode of NONE => "end" | SOME _ => "in continue end"); + sayln " in lex"; + sayln " end"; + sayln "end" + end + + in (UsesPrevNewLine := false; + ResetFlags(); + LexBuf := make_ibuf(TextIO.openIn infile); + NextTok := BOF; + inquote := false; + LexOut := TextIO.openOut(outfile); + StateNum := 2; + LineNum := 1; + StateTab := enter(create(String.<=))("INITIAL",1); + LeafNum := ~1; + let + val (user_code,rules,ends) = + parse() handle x => + (close_ibuf(!LexBuf); + TextIO.closeOut(!LexOut); + raise x) + val (fins,trans,tctab,tcpairs) = makedfa(rules) + val _ = if !UsesTrailingContext then + (close_ibuf(!LexBuf); + TextIO.closeOut(!LexOut); + prErr "lookahead is unimplemented") + else () + in + if (!HeaderDecl) + then say (!HeaderCode) + else say ("structure " ^ (!StrName)); + say "=\n"; + say skel_hd; + say user_code; + say "end (* end of user routines *)\n"; + say "exception LexError (* raised if illegal leaf "; + say "action tried *)\n"; + say "structure Internal =\n\tstruct\n"; + maketable(fins,tctab,tcpairs,trans); + say "structure StartStates =\n\tstruct\n"; + say "\tdatatype yystartstate = STARTSTATE of int\n"; + makebegin(); + say "\nend\n"; + say "type result = UserDeclarations.lexresult\n"; + say "\texception LexerError (* raised if illegal leaf "; + say "action tried *)\n"; + say "end\n\n"; + say "fun makeLexer yyinput = \n"; + say "let \n"; + if !CountNewLines then say "\tval yylineno = ref 0\n\n" else (); + say "\tval yyb = ref \"\\n\" \t\t(* buffer *)\n\ + \\tval yybl = ref 1\t\t(*buffer length *)\n\ + \\tval yybufpos = ref 1\t\t(* location of next character to use *)\n\ + \\tval yygone = ref 1\t\t(* position in file of beginning of buffer *)\n\ + \\tval yydone = ref false\t\t(* eof found yet? *)\n\ + \\tval yybegin = ref 1\t\t(*Current 'start state' for lexer *)\n\ + \\n\tval YYBEGIN = fn (Internal.StartStates.STARTSTATE x) =>\n\ + \\t\t yybegin := x\n\n"; + PrintLexer(ends); + close_ibuf(!LexBuf); + TextIO.closeOut(!LexOut) + end) + end +end + +structure Main : BMARK = + struct + val s = OS.FileSys.getDir() + fun doit () = LexGen.lexGen (s^"/DATA/ml.lex"); + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop size + end + + fun testit _ = LexGen.lexGen (s^"DATA/ml.lex") + end (* Main *) diff --git a/benchmark/tests/life.sml b/benchmark/tests/life.sml new file mode 100644 index 0000000..8aad8a0 --- /dev/null +++ b/benchmark/tests/life.sml @@ -0,0 +1,157 @@ +(* From the SML/NJ benchmark suite. *) +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; +structure Main : BMARK = + struct + + fun map f [] = [] + | map f (a::x) = f a :: map f x + + exception ex_undefined of string + fun error str = raise ex_undefined str + + fun accumulate f = let + fun foldf a [] = a + | foldf a (b::x) = foldf (f a b) x + in + foldf + end + + fun filter p = let + fun consifp x a = if p a then a::x else x + in + rev o accumulate consifp [] + end + + + fun exists p = let fun existsp [] = false + | existsp (a::x) = if p a then true else existsp x + in existsp end + + fun equal a b = (a = b) + + fun member x a = exists (equal a) x + + fun C f x y = f y x + + fun cons a x = a::x + + fun revonto x = accumulate (C cons) x + + fun length x = let fun count n a = n+1 in accumulate count 0 x end + + fun repeat f = let fun rptf n x = if n=0 then x else rptf(n-1)(f x) + fun check n = if n<0 then error "repeat<0" else n + in rptf o check end + + fun copy n x = repeat (cons x) n [] + + fun spaces n = concat (copy n " ") + + local + fun lexordset [] = [] + | lexordset (a::x) = lexordset (filter (lexless a) x) @ [a] @ + lexordset (filter (lexgreater a) x) + and lexless(a1:int,b1:int)(a2,b2) = + if a2=xstart andalso y>=ystart + in fun plot coordlist = plotfrom(xstart,ystart) "" + (filter good coordlist) + end + + + infix 6 at + fun coordlist at (x:int,y:int) = let fun move(a,b) = (a+x,b+y) + in map move coordlist end + val rotate = map (fn (x:int,y:int) => (y,~x)) + + val glider = [(0,0),(0,2),(1,1),(1,2),(2,1)] + val bail = [(0,0),(0,1),(1,0),(1,1)] + fun barberpole n = + let fun f i = if i=n then (n+n-1,n+n)::(n+n,n+n)::nil + else (i+i,i+i+1)::(i+i+2,i+i+1)::f(i+1) + in (0,0)::(1,0):: f 0 + end + + val genB = mkgen(glider at (2,2) @ bail at (2,12) + @ rotate (barberpole 4) at (5,20)) + + fun nthgen g 0 = g | nthgen g i = nthgen (mk_nextgen_fn neighbours g) (i-1) + + val gun = mkgen + [(2,20),(3,19),(3,21),(4,18),(4,22),(4,23),(4,32),(5,7),(5,8),(5,18), + (5,22),(5,23),(5,29),(5,30),(5,31),(5,32),(5,36),(6,7),(6,8),(6,18), + (6,22),(6,23),(6,28),(6,29),(6,30),(6,31),(6,36),(7,19),(7,21),(7,28), + (7,31),(7,40),(7,41),(8,20),(8,28),(8,29),(8,30),(8,31),(8,40),(8,41), + (9,29),(9,30),(9,31),(9,32)] + + fun show pr = (app (fn s => (pr s; pr "\n"))) o plot o alive + + fun doit () = show (fn _ => ()) (nthgen gun 25000) + + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop size + end + + fun testit strm = show (fn c => TextIO.output (strm, c)) (nthgen gun 50) + + end (* Life *) diff --git a/benchmark/tests/logic.sml b/benchmark/tests/logic.sml new file mode 100644 index 0000000..05c41a5 --- /dev/null +++ b/benchmark/tests/logic.sml @@ -0,0 +1,369 @@ +(* From the SML/NJ benchmark suite. *) + +(* term.sml *) + +structure Term = +struct + datatype term + = STR of string * term list + | INT of int + | CON of string + | REF of term option ref + + exception BadArg of string +end; + +(* trail.sml *) + +structure Trail = +struct + local + open Term + val global_trail = ref (nil : term option ref list) + val trail_counter = ref 0 + in + fun unwind_trail (0, tr) = tr + | unwind_trail (n, r::tr) = + ( r := NONE ; unwind_trail (n-1, tr) ) + | unwind_trail (_, nil) = + raise BadArg "unwind_trail" + + fun reset_trail () = ( global_trail := nil ) + + fun trail func = + let + val tc0 = !trail_counter + in + ( func () ; + global_trail := + unwind_trail (!trail_counter-tc0, !global_trail) ; + trail_counter := tc0 ) + end + + fun bind (r, t) = + ( r := SOME t ; + global_trail := r::(!global_trail) ; + trail_counter := !trail_counter+1 ) + end (* local *) +end; (* Trail *) + +(* unify.sml *) + +structure Unify = +struct + local + open Term Trail + fun same_ref (r, REF(r')) = (r = r') + | same_ref _ = false + + fun occurs_check r t = + let + fun oc (STR(_,ts)) = ocs ts + | oc (REF(r')) = + (case !r' of + SOME(s) => oc s + | _ => r <> r') + | oc (CON _) = true + | oc (INT _) = true + and ocs nil = true + | ocs (t::ts) = oc t andalso ocs ts + in + oc t + end + fun deref (t as (REF(x))) = + (case !x of + SOME(s) => deref s + | _ => t) + | deref t = t + fun unify' (REF(r), t) sc = unify_REF (r,t) sc + | unify' (s, REF(r)) sc = unify_REF (r,s) sc + | unify' (STR(f,ts), STR(g,ss)) sc = + if (f = g) + then unifys (ts,ss) sc + else () + | unify' (CON(f), CON(g)) sc = + if (f = g) then + sc () + else + () + | unify' (INT(f), INT(g)) sc = + if (f = g) then + sc () + else + () + | unify' (_, _) sc = () + and unifys (nil, nil) sc = sc () + | unifys (t::ts, s::ss) sc = + unify' (deref(t), deref(s)) + (fn () => unifys (ts, ss) sc) + | unifys _ sc = () + and unify_REF (r, t) sc = + if same_ref (r, t) + then sc () + else if occurs_check r t + then ( bind(r, t) ; sc () ) + else () + in + val deref = deref + fun unify (s, t) = unify' (deref(s), deref(t)) + end (* local *) +end; (* Unify *) + +(* data.sml *) + +structure Data = +struct + local + open Term Trail Unify + val cons_s = "cons" + val x_s = "x" + val nil_s = "nil" + val o_s = "o" + val s_s = "s" + val CON_o_s = CON(o_s) + val CON_nil_s = CON(nil_s) + val CON_x_s = CON(x_s) + in + fun exists sc = sc (REF(ref(NONE))) + +fun move_horiz (T_1, T_2) sc = +( +trail (fn () => +( +trail (fn () => +( +trail (fn () => +( +trail (fn () => +( +trail (fn () => +( +trail (fn () => +( +trail (fn () => +( +trail (fn () => +( +trail (fn () => +( +trail (fn () => +( +trail (fn () => +exists (fn T => +exists (fn TT => +unify (T_1, STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, T])])]), TT])) (fn () => +unify (T_2, STR(cons_s, [STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, T])])]), TT])) (fn () => +sc ()))))) +; +exists (fn P1 => +exists (fn P5 => +exists (fn TT => +unify (T_1, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, STR(cons_s, [P5, CON_nil_s])])])])]), TT])) (fn () => +unify (T_2, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, STR(cons_s, [P5, CON_nil_s])])])])]), TT])) (fn () => +sc ()))))) +)) +; +exists (fn P1 => +exists (fn P2 => +exists (fn TT => +unify (T_1, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [P2, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, CON_nil_s])])])])]), TT])) (fn () => +unify (T_2, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [P2, STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, CON_nil_s])])])])]), TT])) (fn () => +sc ()))))) +)) +; +exists (fn L1 => +exists (fn P4 => +exists (fn TT => +unify (T_1, STR(cons_s, [L1, STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, STR(cons_s, [P4, CON_nil_s])])])]), TT])])) (fn () => +unify (T_2, STR(cons_s, [L1, STR(cons_s, [STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, STR(cons_s, [P4, CON_nil_s])])])]), TT])])) (fn () => +sc ()))))) +)) +; +exists (fn L1 => +exists (fn P1 => +exists (fn TT => +unify (T_1, STR(cons_s, [L1, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, CON_nil_s])])])]), TT])])) (fn () => +unify (T_2, STR(cons_s, [L1, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, CON_nil_s])])])]), TT])])) (fn () => +sc ()))))) +)) +; +exists (fn L1 => +exists (fn L2 => +exists (fn TT => +unify (T_1, STR(cons_s, [L1, STR(cons_s, [L2, STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, CON_nil_s])])]), TT])])])) (fn () => +unify (T_2, STR(cons_s, [L1, STR(cons_s, [L2, STR(cons_s, [STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, CON_nil_s])])]), TT])])])) (fn () => +sc ()))))) +)) +; +exists (fn T => +exists (fn TT => +unify (T_1, STR(cons_s, [STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, T])])]), TT])) (fn () => +unify (T_2, STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, T])])]), TT])) (fn () => +sc ())))) +)) +; +exists (fn P1 => +exists (fn P5 => +exists (fn TT => +unify (T_1, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [P5, CON_nil_s])])])])]), TT])) (fn () => +unify (T_2, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, STR(cons_s, [P5, CON_nil_s])])])])]), TT])) (fn () => +sc ()))))) +)) +; +exists (fn P1 => +exists (fn P2 => +exists (fn TT => +unify (T_1, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [P2, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, CON_nil_s])])])])]), TT])) (fn () => +unify (T_2, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [P2, STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, CON_nil_s])])])])]), TT])) (fn () => +sc ()))))) +)) +; +exists (fn L1 => +exists (fn P4 => +exists (fn TT => +unify (T_1, STR(cons_s, [L1, STR(cons_s, [STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [P4, CON_nil_s])])])]), TT])])) (fn () => +unify (T_2, STR(cons_s, [L1, STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, STR(cons_s, [P4, CON_nil_s])])])]), TT])])) (fn () => +sc ()))))) +)) +; +exists (fn L1 => +exists (fn P1 => +exists (fn TT => +unify (T_1, STR(cons_s, [L1, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, CON_nil_s])])])]), TT])])) (fn () => +unify (T_2, STR(cons_s, [L1, STR(cons_s, [STR(cons_s, [P1, STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, CON_nil_s])])])]), TT])])) (fn () => +sc ()))))) +)) +; +exists (fn L1 => +exists (fn L2 => +exists (fn TT => +unify (T_1, STR(cons_s, [L1, STR(cons_s, [L2, STR(cons_s, [STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, CON_nil_s])])]), TT])])])) (fn () => +unify (T_2, STR(cons_s, [L1, STR(cons_s, [L2, STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_o_s, CON_nil_s])])]), TT])])])) (fn () => +sc ()))))) +) +(* | move_horiz _ _ = () *) + +and rotate (T_1, T_2) sc = +exists (fn P11 => +exists (fn P12 => +exists (fn P13 => +exists (fn P14 => +exists (fn P15 => +exists (fn P21 => +exists (fn P22 => +exists (fn P23 => +exists (fn P24 => +exists (fn P31 => +exists (fn P32 => +exists (fn P33 => +exists (fn P41 => +exists (fn P42 => +exists (fn P51 => +unify (T_1, STR(cons_s, [STR(cons_s, [P11, STR(cons_s, [P12, STR(cons_s, [P13, STR(cons_s, [P14, STR(cons_s, [P15, CON_nil_s])])])])]), STR(cons_s, [STR(cons_s, [P21, STR(cons_s, [P22, STR(cons_s, [P23, STR(cons_s, [P24, CON_nil_s])])])]), STR(cons_s, [STR(cons_s, [P31, STR(cons_s, [P32, STR(cons_s, [P33, CON_nil_s])])]), STR(cons_s, [STR(cons_s, [P41, STR(cons_s, [P42, CON_nil_s])]), STR(cons_s, [STR(cons_s, [P51, CON_nil_s]), CON_nil_s])])])])])) (fn () => +unify (T_2, STR(cons_s, [STR(cons_s, [P51, STR(cons_s, [P41, STR(cons_s, [P31, STR(cons_s, [P21, STR(cons_s, [P11, CON_nil_s])])])])]), STR(cons_s, [STR(cons_s, [P42, STR(cons_s, [P32, STR(cons_s, [P22, STR(cons_s, [P12, CON_nil_s])])])]), STR(cons_s, [STR(cons_s, [P33, STR(cons_s, [P23, STR(cons_s, [P13, CON_nil_s])])]), STR(cons_s, [STR(cons_s, [P24, STR(cons_s, [P14, CON_nil_s])]), STR(cons_s, [STR(cons_s, [P15, CON_nil_s]), CON_nil_s])])])])])) (fn () => +sc ()))))))))))))))))) +(* | rotate _ _ = () *) + +and move (T_1, T_2) sc = +( +trail (fn () => +( +trail (fn () => +exists (fn X => +exists (fn Y => +unify (T_1, X) (fn () => +unify (T_2, Y) (fn () => +move_horiz (X, Y) sc))))) +; +exists (fn X => +exists (fn X1 => +exists (fn Y => +exists (fn Y1 => +unify (T_1, X) (fn () => +unify (T_2, Y) (fn () => +rotate (X, X1) (fn () => +move_horiz (X1, Y1) (fn () => +rotate (Y, Y1) sc)))))))) +)) +; +exists (fn X => +exists (fn X1 => +exists (fn Y => +exists (fn Y1 => +unify (T_1, X) (fn () => +unify (T_2, Y) (fn () => +rotate (X1, X) (fn () => +move_horiz (X1, Y1) (fn () => +rotate (Y1, Y) sc)))))))) +) +(* | move _ _ = () *) + +and solitaire (T_1, T_2, T_3) sc = +( +trail (fn () => +exists (fn X => +unify (T_1, X) (fn () => +unify (T_2, STR(cons_s, [X, CON_nil_s])) (fn () => +unify (T_3, INT(0)) (fn () => +sc ()))))) +; +exists (fn N => +exists (fn X => +exists (fn Y => +exists (fn Z => +unify (T_1, X) (fn () => +unify (T_2, STR(cons_s, [X, Z])) (fn () => +unify (T_3, STR(s_s, [N])) (fn () => +move (X, Y) (fn () => +solitaire (Y, Z, N) sc)))))))) +) +(* | solitaire _ _ = () *) + +and solution1 (T_1) sc = +exists (fn X => +unify (T_1, X) (fn () => +solitaire (STR(cons_s, [STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, CON_nil_s])])])])]), STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, + CON_nil_s])])])]), STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, CON_nil_s])])]), STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, CON_nil_s])]), STR(cons_s, [STR(cons_s, [CON_x_s, CON_nil_s]), CON_nil_s])])])])]) +, X, STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [INT(0)])])])])])])])])])])])])])) sc)) +(* | solution1 _ _ = () *) + +and solution2 (T_1) sc = +exists (fn X => +unify (T_1, X) (fn () => +solitaire (STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, CON_nil_s])])])])]), STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, + CON_nil_s])])])]), STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_o_s, STR(cons_s, [CON_x_s, CON_nil_s])])]), STR(cons_s, [STR(cons_s, [CON_x_s, STR(cons_s, [CON_x_s, CON_nil_s])]), STR(cons_s, [STR(cons_s, [CON_x_s, CON_nil_s]), CON_nil_s])])])])]) +, X, STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [STR(s_s, [INT(0)])])])])])])])])])])])])])) sc)) +(* | solution2 _ _ = () *) + end (* local *) +end; (* Data *) +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; +(* main.sml *) + +structure Main : BMARK = + struct + val name = "Logic" + + exception Done + + fun testit strm = Data.exists(fn Z => Data.solution2 Z (fn () => raise Done)) + handle Done => TextIO.output(strm, "yes\n") + + fun doit () = Data.exists(fn Z => Data.solution2 Z (fn () => raise Done)) + handle Done => () + + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop size + end + + end; (* Main *) diff --git a/benchmark/tests/mandelbrot.sml b/benchmark/tests/mandelbrot.sml new file mode 100644 index 0000000..365f07c --- /dev/null +++ b/benchmark/tests/mandelbrot.sml @@ -0,0 +1,74 @@ +(* From the SML/NJ benchmark suite. *) + +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; +(* mandelbrot.sml *) + +structure Main : BMARK = + struct + val x_base = ~2.0 + val y_base = 1.25 + val side = 2.5 + + val sz = 32768 + val maxCount = 2048 + + val delta = side / (real sz) + + val sum_iterations = ref 0 + + fun loop1 i = if (i >= sz) + then () + else let + val c_im : real = y_base - (delta * real i) + fun loop2 j = if (j >= sz) + then () + else let + val c_re = x_base * (delta + real j) + fun loop3 (count, z_re : real, z_im : real) = if (count < maxCount) + then let + val z_re_sq = z_re * z_re + val z_im_sq = z_im * z_im + in + if ((z_re_sq + z_im_sq) > 4.0) + then count + else let + val z_re_im = (z_re * z_im) + in + loop3 (count+1, + (z_re_sq - z_im_sq) + c_re, + z_re_im + z_re_im + c_im) + end + end (* loop3 *) + else count + val count = loop3 (0, c_re, c_im) + in + sum_iterations := !sum_iterations + count; + loop2 (j+1) + end + in + loop2 0; + loop1 (i+1) + end + + fun doit () = (sum_iterations := 0; loop1 0) + + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop size + end + fun testit outstrm = ( + sum_iterations := 0; + loop1 0; + TextIO.output (outstrm, Int.toString(!sum_iterations) ^ " iterations\n")) + + end (* Mandelbrot *) diff --git a/benchmark/tests/matrix-multiply.sml b/benchmark/tests/matrix-multiply.sml new file mode 100644 index 0000000..7593e4a --- /dev/null +++ b/benchmark/tests/matrix-multiply.sml @@ -0,0 +1,59 @@ +(* Written by Stephen Weeks (sweeks@sweeks.com). *) +structure Array = Array2 + +fun 'a fold (n : int, b : 'a, f : int * 'a -> 'a) = + let + fun loop (i : int, b : 'a) : 'a = + if i = n + then b + else loop (i + 1, f (i, b)) + in loop (0, b) + end + +fun foreach (n : int, f : int -> unit) : unit = + fold (n, (), f o #1) + +fun mult (a1 : real Array.array, a2 : real Array.array) : real Array.array = + let + val r1 = Array.nRows a1 + val c1 = Array.nCols a1 + val r2 = Array.nRows a2 + val c2 = Array.nCols a2 + in if c1 <> r2 + then raise Fail "mult" + else + let val a = Array2.array (r1, c2, 0.0) + fun dot (r, c) = + fold (c1, 0.0, fn (i, sum) => + sum + Array.sub (a1, r, i) * Array.sub (a2, i, c)) + in foreach (r1, fn r => + foreach (c2, fn c => + Array.update (a, r, c, dot (r,c)))); + a + end + end + +structure Main = + struct + fun doit () = + let + val dim = 500 + val a = Array.tabulate Array.RowMajor (dim, dim, fn (r, c) => + Real.fromInt (r + c)) + in + if Real.== (41541750.0, Array2.sub (mult (a, a), 0, 0)) + then () + else raise Fail "bug" + end + + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit (); + loop (n-1)) + in loop size + end + end diff --git a/benchmark/tests/md5.sml b/benchmark/tests/md5.sml new file mode 100644 index 0000000..af965a8 --- /dev/null +++ b/benchmark/tests/md5.sml @@ -0,0 +1,278 @@ +(* Copyright (C) 2001 Daniel Wang. All rights reserved. + Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm. + *) +signature MD5 = + sig + type md5state +(* type slice = (Word8Vector.vector * int * int option) *) + val init : md5state + (* val updateSlice : (md5state * slice) -> md5state + *) + val update : (md5state * Word8Vector.vector) -> md5state + val final : md5state -> Word8Vector.vector + val toHexString : Word8Vector.vector -> string + end + +(* Quick and dirty transliteration of C code *) +structure MD5 :> MD5 = + struct + structure W32 = Word32 + structure W8V = + struct + open Word8Vector + fun extract (vec, s, l) = + let + val n = + case l of + NONE => length vec - s + | SOME i => i + in + tabulate (n, fn i => sub (vec, s + i)) + end + end + type word64 = {hi:W32.word,lo:W32.word} + type word128 = {A:W32.word, B:W32.word, C:W32.word, D:W32.word} + type md5state = {digest:word128, + mlen:word64, + buf:Word8Vector.vector} + + + + val w64_zero = ({hi=0w0,lo=0w0}:word64) + fun mul8add ({hi,lo},n) = let + val mul8lo = W32.<< (W32.fromInt (n),0w3) + val mul8hi = W32.>> (W32.fromInt (n),0w29) + val lo = W32.+ (lo,mul8lo) + val cout = if W32.< (lo,mul8lo) then 0w1 else 0w0 + val hi = W32.+ (mul8hi,W32.+ (hi,cout)) + in {hi=hi,lo=lo} + end + + fun packLittle wrds = let + fun loop [] = [] + | loop (w::ws) = let + val b0 = Word8.fromLarge (W32.toLarge w) + val b1 = Word8.fromLarge (W32.toLarge (W32.>> (w,0w8))) + val b2 = Word8.fromLarge (W32.toLarge (W32.>> (w,0w16))) + val b3 = Word8.fromLarge (W32.toLarge (W32.>> (w,0w24))) + in b0::b1::b2::b3:: (loop ws) + end + in W8V.fromList (loop wrds) + end + + val S11 = 0w7 + val S12 = 0w12 + val S13 = 0w17 + val S14 = 0w22 + val S21 = 0w5 + val S22 = 0w9 + val S23 = 0w14 + val S24 = 0w20 + val S31 = 0w4 + val S32 = 0w11 + val S33 = 0w16 + val S34 = 0w23 + val S41 = 0w6 + val S42 = 0w10 + val S43 = 0w15 + val S44 = 0w21 + + fun PADDING i = W8V.tabulate (i,(fn 0 => 0wx80 | _ => 0wx0)) + + fun F (x,y,z) = W32.orb (W32.andb (x,y), + W32.andb (W32.notb x,z)) + fun G (x,y,z) = W32.orb (W32.andb (x,z), + W32.andb (y,W32.notb z)) + fun H (x,y,z) = W32.xorb (x,W32.xorb (y,z)) + fun I (x,y,z) = W32.xorb (y,W32.orb (x,W32.notb z)) + fun ROTATE_LEFT (x,n) = + W32.orb (W32.<< (x,n), W32.>> (x,0w32 - n)) + + fun XX f (a,b,c,d,x,s,ac) = let + val a = W32.+ (a,W32.+ (W32.+ (f (b,c,d),x),ac)) + val a = ROTATE_LEFT (a,s) + in W32.+ (a,b) + end + + val FF = XX F + val GG = XX G + val HH = XX H + val II = XX I + + val empty_buf = W8V.tabulate (0,(fn x => raise (Fail "buf"))) + val init = {digest= {A=0wx67452301, + B=0wxefcdab89, + C=0wx98badcfe, + D=0wx10325476}, + mlen=w64_zero, + buf=empty_buf} : md5state + + fun update ({buf,digest,mlen}:md5state,input) = let + val inputLen = W8V.length input + val needBytes = 64 - W8V.length buf + fun loop (i,digest) = + if i + 63 < inputLen then + loop (i + 64,transform (digest,i,input)) + else (i,digest) + val (buf,(i,digest)) = + if inputLen >= needBytes then let + val buf = W8V.concat [buf,W8V.extract (input,0,SOME needBytes)] + val digest = transform (digest,0,buf) + in (empty_buf,loop (needBytes,digest)) + end + else (buf,(0,digest)) + val buf = W8V.concat [buf, W8V.extract (input,i,SOME (inputLen-i))] + val mlen = mul8add (mlen,inputLen) + in {buf=buf,digest=digest,mlen=mlen} + end + and final (state:md5state) = let + val {mlen= {lo,hi},buf,...} = state + val bits = packLittle [lo,hi] + val index = W8V.length buf + val padLen = if index < 56 then 56 - index else 120 - index + val state = update (state,PADDING padLen) + val {digest= {A,B,C,D},...} = update (state,bits) + in packLittle [A,B,C,D] + end + and transform ({A,B,C,D},i,buf) = let + val off = i div PackWord32Little.bytesPerElem + fun x (n) = Word32.fromLarge (PackWord32Little.subVec (buf,n + off)) + val (a,b,c,d) = (A,B,C,D) + (* fetch to avoid range checks *) + val x_00 = x (0) val x_01 = x (1) val x_02 = x (2) val x_03 = x (3) + val x_04 = x (4) val x_05 = x (5) val x_06 = x (6) val x_07 = x (7) + val x_08 = x (8) val x_09 = x (9) val x_10 = x (10) val x_11 = x (11) + val x_12 = x (12) val x_13 = x (13) val x_14 = x (14) val x_15 = x (15) + + val a = FF (a, b, c, d, x_00, S11, 0wxd76aa478) (* 1 *) + val d = FF (d, a, b, c, x_01, S12, 0wxe8c7b756) (* 2 *) + val c = FF (c, d, a, b, x_02, S13, 0wx242070db) (* 3 *) + val b = FF (b, c, d, a, x_03, S14, 0wxc1bdceee) (* 4 *) + val a = FF (a, b, c, d, x_04, S11, 0wxf57c0faf) (* 5 *) + val d = FF (d, a, b, c, x_05, S12, 0wx4787c62a) (* 6 *) + val c = FF (c, d, a, b, x_06, S13, 0wxa8304613) (* 7 *) + val b = FF (b, c, d, a, x_07, S14, 0wxfd469501) (* 8 *) + val a = FF (a, b, c, d, x_08, S11, 0wx698098d8) (* 9 *) + val d = FF (d, a, b, c, x_09, S12, 0wx8b44f7af) (* 10 *) + val c = FF (c, d, a, b, x_10, S13, 0wxffff5bb1) (* 11 *) + val b = FF (b, c, d, a, x_11, S14, 0wx895cd7be) (* 12 *) + val a = FF (a, b, c, d, x_12, S11, 0wx6b901122) (* 13 *) + val d = FF (d, a, b, c, x_13, S12, 0wxfd987193) (* 14 *) + val c = FF (c, d, a, b, x_14, S13, 0wxa679438e) (* 15 *) + val b = FF (b, c, d, a, x_15, S14, 0wx49b40821) (* 16 *) + + (* Round 2 *) + val a = GG (a, b, c, d, x_01, S21, 0wxf61e2562) (* 17 *) + val d = GG (d, a, b, c, x_06, S22, 0wxc040b340) (* 18 *) + val c = GG (c, d, a, b, x_11, S23, 0wx265e5a51) (* 19 *) + val b = GG (b, c, d, a, x_00, S24, 0wxe9b6c7aa) (* 20 *) + val a = GG (a, b, c, d, x_05, S21, 0wxd62f105d) (* 21 *) + val d = GG (d, a, b, c, x_10, S22, 0wx2441453) (* 22 *) + val c = GG (c, d, a, b, x_15, S23, 0wxd8a1e681) (* 23 *) + val b = GG (b, c, d, a, x_04, S24, 0wxe7d3fbc8) (* 24 *) + val a = GG (a, b, c, d, x_09, S21, 0wx21e1cde6) (* 25 *) + val d = GG (d, a, b, c, x_14, S22, 0wxc33707d6) (* 26 *) + val c = GG (c, d, a, b, x_03, S23, 0wxf4d50d87) (* 27 *) + val b = GG (b, c, d, a, x_08, S24, 0wx455a14ed) (* 28 *) + val a = GG (a, b, c, d, x_13, S21, 0wxa9e3e905) (* 29 *) + val d = GG (d, a, b, c, x_02, S22, 0wxfcefa3f8) (* 30 *) + val c = GG (c, d, a, b, x_07, S23, 0wx676f02d9) (* 31 *) + val b = GG (b, c, d, a, x_12, S24, 0wx8d2a4c8a) (* 32 *) + + (* Round 3 *) + val a = HH (a, b, c, d, x_05, S31, 0wxfffa3942) (* 33 *) + val d = HH (d, a, b, c, x_08, S32, 0wx8771f681) (* 34 *) + val c = HH (c, d, a, b, x_11, S33, 0wx6d9d6122) (* 35 *) + val b = HH (b, c, d, a, x_14, S34, 0wxfde5380c) (* 36 *) + val a = HH (a, b, c, d, x_01, S31, 0wxa4beea44) (* 37 *) + val d = HH (d, a, b, c, x_04, S32, 0wx4bdecfa9) (* 38 *) + val c = HH (c, d, a, b, x_07, S33, 0wxf6bb4b60) (* 39 *) + val b = HH (b, c, d, a, x_10, S34, 0wxbebfbc70) (* 40 *) + val a = HH (a, b, c, d, x_13, S31, 0wx289b7ec6) (* 41 *) + val d = HH (d, a, b, c, x_00, S32, 0wxeaa127fa) (* 42 *) + val c = HH (c, d, a, b, x_03, S33, 0wxd4ef3085) (* 43 *) + val b = HH (b, c, d, a, x_06, S34, 0wx4881d05) (* 44 *) + val a = HH (a, b, c, d, x_09, S31, 0wxd9d4d039) (* 45 *) + val d = HH (d, a, b, c, x_12, S32, 0wxe6db99e5) (* 46 *) + val c = HH (c, d, a, b, x_15, S33, 0wx1fa27cf8) (* 47 *) + val b = HH (b, c, d, a, x_02, S34, 0wxc4ac5665) (* 48 *) + + (* Round 4 *) + val a = II (a, b, c, d, x_00, S41, 0wxf4292244) (* 49 *) + val d = II (d, a, b, c, x_07, S42, 0wx432aff97) (* 50 *) + val c = II (c, d, a, b, x_14, S43, 0wxab9423a7) (* 51 *) + val b = II (b, c, d, a, x_05, S44, 0wxfc93a039) (* 52 *) + val a = II (a, b, c, d, x_12, S41, 0wx655b59c3) (* 53 *) + val d = II (d, a, b, c, x_03, S42, 0wx8f0ccc92) (* 54 *) + val c = II (c, d, a, b, x_10, S43, 0wxffeff47d) (* 55 *) + val b = II (b, c, d, a, x_01, S44, 0wx85845dd1) (* 56 *) + val a = II (a, b, c, d, x_08, S41, 0wx6fa87e4f) (* 57 *) + val d = II (d, a, b, c, x_15, S42, 0wxfe2ce6e0) (* 58 *) + val c = II (c, d, a, b, x_06, S43, 0wxa3014314) (* 59 *) + val b = II (b, c, d, a, x_13, S44, 0wx4e0811a1) (* 60 *) + val a = II (a, b, c, d, x_04, S41, 0wxf7537e82) (* 61 *) + val d = II (d, a, b, c, x_11, S42, 0wxbd3af235) (* 62 *) + val c = II (c, d, a, b, x_02, S43, 0wx2ad7d2bb) (* 63 *) + val b = II (b, c, d, a, x_09, S44, 0wxeb86d391) (* 64 *) + + val A = Word32.+ (A,a) + val B = Word32.+ (B,b) + val C = Word32.+ (C,c) + val D = Word32.+ (D,d) + in {A=A,B=B,C=C,D=D} + end + + val hxd = "0123456789abcdef" + fun toHexString v = let + fun byte2hex (b,acc) = + (String.sub (hxd,(Word8.toInt b) div 16)):: + (String.sub (hxd,(Word8.toInt b) mod 16))::acc + val digits = Word8Vector.foldr byte2hex [] v + in String.implode (digits) + end + end + +structure Test = + struct + val tests = + [("", "d41d8cd98f00b204e9800998ecf8427e"), + ("a", "0cc175b9c0f1b6a831c399e269772661"), + ("abc", "900150983cd24fb0d6963f7d28e17f72"), + ("message digest", "f96b697d7cb7938d525a2f31aaf161d0"), + ("abcdefghijklmnopqrstuvwxyz", "c3fcd3d76192e4007dfb496cca67e13b"), + ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789", + "d174ab98d277d9f5a5611c2c9f419d9f"), + ("12345678901234567890123456789012345678901234567890123456789012345678901234567890", + "57edf4a22be3c955ac49da2e2107b67a")] + + fun do_tests () = let + fun f (x,s) = let + val mstate = MD5.update (MD5.init,Byte.stringToBytes x) + val hash = MD5.final (mstate) + in print (" input: "^x^"\n"); + print ("expected: "^s^"\n"); + print ("produced: "^MD5.toHexString (hash)^"\n") + end + in List.app f tests + end + val BLOCK_LEN = 10000 + val BLOCK_COUNT = 100000 + fun time_test () = let + val block = Word8Vector.tabulate (BLOCK_LEN,Word8.fromInt) + fun loop (n,s) = + if n < BLOCK_COUNT then + loop (n+1,MD5.update (s,block)) + else s + in + loop (0,MD5.init) + end + end + +structure Main = + struct + fun doit n = + if n = 0 + then () + else (Test.time_test () + ; doit (n - 1)) + end diff --git a/benchmark/tests/merge.sml b/benchmark/tests/merge.sml new file mode 100644 index 0000000..0b746c2 --- /dev/null +++ b/benchmark/tests/merge.sml @@ -0,0 +1,31 @@ +(* Written by Stephen Weeks (sweeks@sweeks.com). *) +fun merge (l1: int list, l2) = + case (l1, l2) of + ([], _) => l2 + | (_, []) => l1 + | (x1 :: l1', x2 :: l2') => + if x1 <= x2 + then x1 :: merge (l1', l2) + else x2 :: merge (l1, l2') + +structure Main = + struct + fun doit size = + let + val len = 100000 + val l1 = List.tabulate (len, fn i => i * 2) + val l2 = List.tabulate (len, fn i => i * 2 + 1) + + fun test () = + if 0 = hd (merge (l1, l2)) + then () + else raise Fail "bug" + + fun loop n = + if n = 0 + then () + else (test (); loop (n - 1)) + in + loop size + end + end diff --git a/benchmark/tests/mlyacc.sml b/benchmark/tests/mlyacc.sml new file mode 100644 index 0000000..7c90524 --- /dev/null +++ b/benchmark/tests/mlyacc.sml @@ -0,0 +1,7292 @@ +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:46 george + * Version 109 + * + *) + +signature ORDSET = + sig + type set + type elem + exception Select_arb + val app : (elem -> unit) -> set -> unit + and card: set -> int + and closure: set * (elem -> set) -> set + and difference: set * set -> set + and elem_eq: (elem * elem -> bool) + and elem_gt : (elem * elem -> bool) + and empty: set + and exists: (elem * set) -> bool + and find : (elem * set) -> elem option + and fold: ((elem * 'b) -> 'b) -> set -> 'b -> 'b + and insert: (elem * set) -> set + and is_empty: set -> bool + and make_list: set -> elem list + and make_set: (elem list -> set) + and partition: (elem -> bool) -> (set -> set * set) + and remove: (elem * set) -> set + and revfold: ((elem * 'b) -> 'b) -> set -> 'b -> 'b + and select_arb: set -> elem + and set_eq: (set * set) -> bool + and set_gt: (set * set) -> bool + and singleton: (elem -> set) + and union: set * set -> set + end + +signature TABLE = + sig + type 'a table + type key + val size : 'a table -> int + val empty: 'a table + val exists: (key * 'a table) -> bool + val find : (key * 'a table) -> 'a option + val insert: ((key * 'a) * 'a table) -> 'a table + val make_table : (key * 'a ) list -> 'a table + val make_list : 'a table -> (key * 'a) list + val fold : ((key * 'a) * 'b -> 'b) -> 'a table -> 'b -> 'b + end + +signature HASH = + sig + type table + type elem + + val size : table -> int + val add : elem * table -> table + val find : elem * table -> int option + val exists : elem * table -> bool + val empty : table + end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:42 george + * Version 109 + * + *) + +(* base.sig: Base signature file for SML-Yacc. This file contains signatures + that must be loaded before any of the files produced by ML-Yacc are loaded +*) + +(* STREAM: signature for a lazy stream.*) + +signature STREAM = + sig type 'xa stream + val streamify : (unit -> 'a) -> 'a stream + val cons : 'a * 'a stream -> 'a stream + val get : 'a stream -> 'a * 'a stream + end + +(* LR_TABLE: signature for an LR Table. + + The list of actions and gotos passed to mkLrTable must be ordered by state + number. The values for state 0 are the first in the list, the values for + state 1 are next, etc. +*) + +signature LR_TABLE = + sig + datatype ('a,'b) pairlist = EMPTY | PAIR of 'a * 'b * ('a,'b) pairlist + datatype state = STATE of int + datatype term = T of int + datatype nonterm = NT of int + datatype action = SHIFT of state + | REDUCE of int + | ACCEPT + | ERROR + type table + + val numStates : table -> int + val numRules : table -> int + val describeActions : table -> state -> + (term,action) pairlist * action + val describeGoto : table -> state -> (nonterm,state) pairlist + val action : table -> state * term -> action + val goto : table -> state * nonterm -> state + val initialState : table -> state + exception Goto of state * nonterm + + val mkLrTable : {actions : ((term,action) pairlist * action) array, + gotos : (nonterm,state) pairlist array, + numStates : int, numRules : int, + initialState : state} -> table + end + +(* TOKEN: signature revealing the internal structure of a token. This signature + TOKEN distinct from the signature {parser name}_TOKENS produced by ML-Yacc. + The {parser name}_TOKENS structures contain some types and functions to + construct tokens from values and positions. + + The representation of token was very carefully chosen here to allow the + polymorphic parser to work without knowing the types of semantic values + or line numbers. + + This has had an impact on the TOKENS structure produced by SML-Yacc, which + is a structure parameter to lexer functors. We would like to have some + type 'a token which functions to construct tokens would create. A + constructor function for a integer token might be + + INT: int * 'a * 'a -> 'a token. + + This is not possible because we need to have tokens with the representation + given below for the polymorphic parser. + + Thus our constructur functions for tokens have the form: + + INT: int * 'a * 'a -> (svalue,'a) token + + This in turn has had an impact on the signature that lexers for SML-Yacc + must match and the types that a user must declare in the user declarations + section of lexers. +*) + +signature TOKEN = + sig + structure LrTable : LR_TABLE + datatype ('a,'b) token = TOKEN of LrTable.term * ('a * 'b * 'b) + val sameToken : ('a,'b) token * ('a,'b) token -> bool + end + +(* LR_PARSER: signature for a polymorphic LR parser *) + +signature LR_PARSER = + sig + structure Stream: STREAM + structure LrTable : LR_TABLE + structure Token : TOKEN + + sharing LrTable = Token.LrTable + + exception ParseError + + val parse : {table : LrTable.table, + lexer : ('b,'c) Token.token Stream.stream, + arg: 'arg, + saction : int * + 'c * + (LrTable.state * ('b * 'c * 'c)) list * + 'arg -> + LrTable.nonterm * + ('b * 'c * 'c) * + ((LrTable.state *('b * 'c * 'c)) list), + void : 'b, + ec : { is_keyword : LrTable.term -> bool, + noShift : LrTable.term -> bool, + preferred_change : (LrTable.term list * LrTable.term list) list, + errtermvalue : LrTable.term -> 'b, + showTerminal : LrTable.term -> string, + terms: LrTable.term list, + error : string * 'c * 'c -> unit + }, + lookahead : int (* max amount of lookahead used in *) + (* error correction *) + } -> 'b * + (('b,'c) Token.token Stream.stream) + end + +(* LEXER: a signature that most lexers produced for use with SML-Yacc's + output will match. The user is responsible for declaring type token, + type pos, and type svalue in the UserDeclarations section of a lexer. + + Note that type token is abstract in the lexer. This allows SML-Yacc to + create a TOKENS signature for use with lexers produced by ML-Lex that + treats the type token abstractly. Lexers that are functors parametrized by + a Tokens structure matching a TOKENS signature cannot examine the structure + of tokens. +*) + +signature LEXER = + sig + structure UserDeclarations : + sig + type ('a,'b) token + type pos + type svalue + end + val makeLexer : (int -> string) -> unit -> + (UserDeclarations.svalue,UserDeclarations.pos) UserDeclarations.token + end + +(* ARG_LEXER: the %arg option of ML-Lex allows users to produce lexers which + also take an argument before yielding a function from unit to a token +*) + +signature ARG_LEXER = + sig + structure UserDeclarations : + sig + type ('a,'b) token + type pos + type svalue + type arg + end + val makeLexer : (int -> string) -> UserDeclarations.arg -> unit -> + (UserDeclarations.svalue,UserDeclarations.pos) UserDeclarations.token + end + +(* PARSER_DATA: the signature of ParserData structures in {parser name}LrValsFun + produced by SML-Yacc. All such structures match this signature. + + The {parser name}LrValsFun produces a structure which contains all the values + except for the lexer needed to call the polymorphic parser mentioned + before. + +*) + +signature PARSER_DATA = + sig + (* the type of line numbers *) + + type pos + + (* the type of semantic values *) + + type svalue + + (* the type of the user-supplied argument to the parser *) + type arg + + (* the intended type of the result of the parser. This value is + produced by applying extract from the structure Actions to the + final semantic value resultiing from a parse. + *) + + type result + + structure LrTable : LR_TABLE + structure Token : TOKEN + sharing Token.LrTable = LrTable + + (* structure Actions contains the functions which mantain the + semantic values stack in the parser. Void is used to provide + a default value for the semantic stack. + *) + + structure Actions : + sig + val actions : int * pos * + (LrTable.state * (svalue * pos * pos)) list * arg-> + LrTable.nonterm * (svalue * pos * pos) * + ((LrTable.state *(svalue * pos * pos)) list) + val void : svalue + val extract : svalue -> result + end + + (* structure EC contains information used to improve error + recovery in an error-correcting parser *) + + structure EC : + sig + val is_keyword : LrTable.term -> bool + val noShift : LrTable.term -> bool + val preferred_change : (LrTable.term list * LrTable.term list) list + val errtermvalue : LrTable.term -> svalue + val showTerminal : LrTable.term -> string + val terms: LrTable.term list + end + + (* table is the LR table for the parser *) + + val table : LrTable.table + end + +(* signature PARSER is the signature that most user parsers created by + SML-Yacc will match. +*) + +signature PARSER = + sig + structure Token : TOKEN + structure Stream : STREAM + exception ParseError + + (* type pos is the type of line numbers *) + + type pos + + (* type result is the type of the result from the parser *) + + type result + + (* the type of the user-supplied argument to the parser *) + type arg + + (* type svalue is the type of semantic values for the semantic value + stack + *) + + type svalue + + (* val makeLexer is used to create a stream of tokens for the parser *) + + val makeLexer : (int -> string) -> + (svalue,pos) Token.token Stream.stream + + (* val parse takes a stream of tokens and a function to print + errors and returns a value of type result and a stream containing + the unused tokens + *) + + val parse : int * ((svalue,pos) Token.token Stream.stream) * + (string * pos * pos -> unit) * arg -> + result * (svalue,pos) Token.token Stream.stream + + val sameToken : (svalue,pos) Token.token * (svalue,pos) Token.token -> + bool + end + +(* signature ARG_PARSER is the signature that will be matched by parsers whose + lexer takes an additional argument. +*) + +signature ARG_PARSER = + sig + structure Token : TOKEN + structure Stream : STREAM + exception ParseError + + type arg + type lexarg + type pos + type result + type svalue + + val makeLexer : (int -> string) -> lexarg -> + (svalue,pos) Token.token Stream.stream + val parse : int * ((svalue,pos) Token.token Stream.stream) * + (string * pos * pos -> unit) * arg -> + result * (svalue,pos) Token.token Stream.stream + + val sameToken : (svalue,pos) Token.token * (svalue,pos) Token.token -> + bool + end + +(* ML-Yacc Parser Generator (c) 1989, 1991 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.2 1996/02/26 15:02:38 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:46 george + * Version 109 + * + *) + +signature HEADER = + sig + type pos (*= int 1998-5-14 STW: taken out because leads to nonstandard sharing constraint on line 3386 *) + val lineno : pos ref + val text : string list ref + + type inputSource + val newSource : string * TextIO.instream * TextIO.outstream -> inputSource + val error : inputSource -> pos -> string -> unit + val warn : inputSource -> pos -> string -> unit + val errorOccurred : inputSource -> unit -> bool + + datatype symbol = SYMBOL of string * pos + val symbolName : symbol -> string + val symbolPos : symbol -> pos + val symbolMake : string * int -> symbol + + type ty + val tyName : ty -> string + val tyMake : string -> ty + + (* associativities: each kind of associativity is assigned a unique + integer *) + + datatype prec = LEFT | RIGHT | NONASSOC + datatype control = NODEFAULT | VERBOSE | PARSER_NAME of symbol | + FUNCTOR of string | START_SYM of symbol | + NSHIFT of symbol list | POS of string | PURE | + PARSE_ARG of string * string + + datatype rule = RULE of {lhs : symbol, rhs : symbol list, + code : string, prec : symbol option} + + datatype declData = DECL of + {eop : symbol list, + keyword : symbol list, + nonterm : (symbol * ty option) list option, + prec : (prec * (symbol list)) list, + change: (symbol list * symbol list) list, + term : (symbol * ty option) list option, + control : control list, + value : (symbol * string) list} + + val join_decls : declData * declData * inputSource * pos -> declData + + type parseResult + val getResult : parseResult -> string * declData * rule list + end; + +signature PARSE_GEN_PARSER = + sig + structure Header : HEADER + val parse : string -> Header.parseResult * Header.inputSource + end; + +signature PARSE_GEN = + sig + val parseGen : string -> unit + end; + +signature GRAMMAR = + sig + + datatype term = T of int + datatype nonterm = NT of int + datatype symbol = TERM of term | NONTERM of nonterm + + (* grammar: + terminals should be numbered from 0 to terms-1, + nonterminals should be numbered from 0 to nonterms-1, + rules should be numbered between 0 and (length rules) - 1, + higher precedence binds tighter, + start nonterminal should not occur on the rhs of any rule + *) + + datatype grammar = GRAMMAR of + {rules: {lhs : nonterm, rhs : symbol list, + precedence : int option, rulenum : int } list, + terms: int, + nonterms: int, + start : nonterm, + eop : term list, + noshift : term list, + precedence : term -> int option, + termToString : term -> string, + nontermToString : nonterm -> string} + end + +(* signature for internal version of grammar *) + +signature INTGRAMMAR = + sig + structure Grammar : GRAMMAR + structure SymbolAssoc : TABLE + structure NontermAssoc : TABLE + + sharing type SymbolAssoc.key = Grammar.symbol + sharing type NontermAssoc.key = Grammar.nonterm + + datatype rule = RULE of + {lhs : Grammar.nonterm, + rhs : Grammar.symbol list, + + (* internal number of rule - convenient for producing LR graph *) + + num : int, + rulenum : int, + precedence : int option} + + val gtTerm : Grammar.term * Grammar.term -> bool + val eqTerm : Grammar.term * Grammar.term -> bool + + val gtNonterm : Grammar.nonterm * Grammar.nonterm -> bool + val eqNonterm : Grammar.nonterm * Grammar.nonterm -> bool + + val gtSymbol : Grammar.symbol * Grammar.symbol -> bool + val eqSymbol : Grammar.symbol * Grammar.symbol -> bool + + (* Debugging information will be generated only if DEBUG is true. *) + + val DEBUG : bool + + val prRule : (Grammar.symbol -> string) * (Grammar.nonterm -> string) * + (string -> 'b) -> rule -> unit + val prGrammar : (Grammar.symbol -> string)*(Grammar.nonterm -> string) * + (string -> unit) -> Grammar.grammar -> unit + end + +signature CORE = + sig + structure Grammar : GRAMMAR + structure IntGrammar : INTGRAMMAR + sharing Grammar = IntGrammar.Grammar + + datatype item = ITEM of + { rule : IntGrammar.rule, + dot : int, + +(* rhsAfter: The portion of the rhs of a rule that lies after the dot *) + + rhsAfter: Grammar.symbol list } + +(* eqItem and gtItem compare items *) + + val eqItem : item * item -> bool + val gtItem : item * item -> bool + +(* functions for maintaining ordered item lists *) + + val insert : item * item list -> item list + val union : item list * item list -> item list + +(* core: a set of items. It is represented by an ordered list of items. + The list is in ascending order The rule numbers and the positions of the + dots are used to order the items. *) + + datatype core = CORE of item list * int (* state # *) + +(* gtCore and eqCore compare the lists of items *) + + val gtCore : core * core -> bool + val eqCore : core * core -> bool + +(* functions for debugging *) + + val prItem : (Grammar.symbol -> string) * (Grammar.nonterm -> string) * + (string -> unit) -> item -> unit + val prCore : (Grammar.symbol -> string) * (Grammar.nonterm -> string) * + (string -> unit) -> core -> unit +end + +signature CORE_UTILS = + sig + + structure Grammar : GRAMMAR + structure IntGrammar : INTGRAMMAR + structure Core : CORE + + sharing Grammar = IntGrammar.Grammar = Core.Grammar + sharing IntGrammar = Core.IntGrammar + +(* mkFuncs: create functions for the set of productions derived from a + nonterminal, the cores that result from shift/gotos from a core, + and return a list of rules *) + + val mkFuncs : Grammar.grammar -> + { produces : Grammar.nonterm -> IntGrammar.rule list, + +(* shifts: take a core and compute all the cores that result from shifts/gotos + on symbols *) + + shifts : Core.core -> (Grammar.symbol*Core.item list) list, + rules: IntGrammar.rule list, + +(* epsProds: take a core compute epsilon productions for it *) + + epsProds : Core.core -> IntGrammar.rule list} + end + +signature LRGRAPH = + sig + structure Grammar : GRAMMAR + structure IntGrammar : INTGRAMMAR + structure Core : CORE + + sharing Grammar = IntGrammar.Grammar = Core.Grammar + sharing IntGrammar = Core.IntGrammar + + type graph + val edges : Core.core * graph -> {edge:Grammar.symbol,to:Core.core} list + val nodes : graph -> Core.core list + val shift : graph -> int * Grammar.symbol -> int (* int = state # *) + val core : graph -> int -> Core.core (* get core for a state *) + +(* mkGraph: compute the LR(0) sets of items *) + + val mkGraph : Grammar.grammar -> + {graph : graph, + produces : Grammar.nonterm -> IntGrammar.rule list, + rules : IntGrammar.rule list, + epsProds: Core.core -> IntGrammar.rule list} + + val prGraph: (Grammar.symbol -> string)*(Grammar.nonterm -> string) * + (string -> unit) -> graph -> unit + end + +signature LOOK = + sig + structure Grammar : GRAMMAR + structure IntGrammar : INTGRAMMAR + sharing Grammar = IntGrammar.Grammar + + val union : Grammar.term list * Grammar.term list -> Grammar.term list + val make_set : Grammar.term list -> Grammar.term list + + val mkFuncs : {rules : IntGrammar.rule list, nonterms : int, + produces : Grammar.nonterm -> IntGrammar.rule list} -> + {nullable: Grammar.nonterm -> bool, + first : Grammar.symbol list -> Grammar.term list} + + val prLook : (Grammar.term -> string) * (string -> unit) -> + Grammar.term list -> unit + end + +signature LALR_GRAPH = + sig + structure Grammar : GRAMMAR + structure IntGrammar : INTGRAMMAR + structure Core : CORE + structure Graph : LRGRAPH + + sharing Grammar = IntGrammar.Grammar = Core.Grammar = Graph.Grammar + sharing IntGrammar = Core.IntGrammar = Graph.IntGrammar + sharing Core = Graph.Core + + datatype lcore = LCORE of (Core.item * Grammar.term list) list * int + val addLookahead : {graph : Graph.graph, + first : Grammar.symbol list -> Grammar.term list, + eop : Grammar.term list, + nonterms : int, + nullable: Grammar.nonterm -> bool, + produces : Grammar.nonterm -> IntGrammar.rule list, + rules : IntGrammar.rule list, + epsProds : Core.core -> IntGrammar.rule list, + print : string -> unit, (* for debugging *) + termToString : Grammar.term -> string, + nontermToString : Grammar.nonterm -> string} -> + lcore list + val prLcore : (Grammar.symbol -> string) * (Grammar.nonterm -> string) * + (Grammar.term -> string) * (string -> unit) -> + lcore -> unit + end + +(* LR_ERRS: errors found while constructing an LR table *) + +signature LR_ERRS = + sig + structure LrTable : LR_TABLE + + (* RR = reduce/reduce, + SR = shift/reduce + NS: non-shiftable terminal found on the rhs of a rule + NOT_REDUCED n: rule number n was not reduced + START n : start symbol found on the rhs of rule n *) + + datatype err = RR of LrTable.term * LrTable.state * int * int + | SR of LrTable.term * LrTable.state * int + | NS of LrTable.term * int + | NOT_REDUCED of int + | START of int + + val summary : err list -> {rr : int, sr: int, + not_reduced : int, start : int,nonshift : int} + + val printSummary : (string -> unit) -> err list -> unit + + end + +(* PRINT_STRUCT: prints a structure which includes a value 'table' and a + structure Table whose signature matches LR_TABLE. The table in the printed + structure will contain the same information as the one passed to + printStruct, although the representation may be different. It returns + the number of entries left in the table after compaction.*) + +signature PRINT_STRUCT = + sig + structure LrTable : LR_TABLE + val makeStruct : + {table : LrTable.table, + name : string, + print: string -> unit, + verbose : bool + } -> int + end + +(* VERBOSE: signature for a structure which takes a table and creates a + verbose description of it *) + +signature VERBOSE = + sig + structure Errs : LR_ERRS + val printVerbose : + {table : Errs.LrTable.table, + entries : int, + termToString : Errs.LrTable.term -> string, + nontermToString : Errs.LrTable.nonterm -> string, + stateErrs : Errs.LrTable.state -> Errs.err list, + errs : Errs.err list, + print: string -> unit, + printCores : (string -> unit) -> Errs.LrTable.state -> unit, + printRule : (string -> unit) -> int -> unit} -> unit + end + +(* MAKE_LR_TABLE: signature for a structure which includes a structure + matching the signature LR_TABLE and a function which maps grammars + to tables *) + +signature MAKE_LR_TABLE = + sig + structure Grammar : GRAMMAR + structure Errs : LR_ERRS + structure LrTable : LR_TABLE + sharing Errs.LrTable = LrTable + + sharing type LrTable.term = Grammar.term + sharing type LrTable.nonterm = Grammar.nonterm + + (* boolean value determines whether default reductions will be used. + If it is true, reductions will be used. *) + + val mkTable : Grammar.grammar * bool -> + LrTable.table * + (LrTable.state -> Errs.err list) * (* errors in a state *) + ((string -> unit) -> LrTable.state -> unit) * + Errs.err list (* list of all errors *) + end; + +(* SHRINK_LR_TABLE: finds unique action entry rows in the action table + for the LR parser *) + +signature SHRINK_LR_TABLE = + sig + (* Takes an action table represented as a list of action rows. + It returns the number of unique rows left in the action table, + a list of integers which maps each original row to a unique + row, and a list of unique rows *) + structure LrTable : LR_TABLE + val shrinkActionList : LrTable.table * bool -> + (int * int list * + ((LrTable.term,LrTable.action) LrTable.pairlist * + LrTable.action) list) * int + end +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.2 1996/02/26 15:02:34 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:45 george + * Version 109 + * + *) + +functor HeaderFun () : HEADER = + struct + val DEBUG = true + + type pos = int + val lineno = ref 0 + val text = ref (nil: string list) + type inputSource = {name : string, + errStream : TextIO.outstream, + inStream : TextIO.instream, + errorOccurred : bool ref} + + val newSource = + fn (s : string,i : TextIO.instream ,errs : TextIO.outstream) => + {name=s,errStream=errs,inStream=i, + errorOccurred = ref false} + + val errorOccurred = fn (s : inputSource) =>fn () => !(#errorOccurred s) + + val pr = fn out : TextIO.outstream => fn s : string => TextIO.output(out,s) + + val error = fn {name,errStream, errorOccurred,...} : inputSource => + let val pr = pr errStream + in fn l : pos => fn msg : string => + (pr name; pr ", line "; pr (Int.toString l); pr ": Error: "; + pr msg; pr "\n"; errorOccurred := true) + end + + val warn = fn {name,errStream, errorOccurred,...} : inputSource => + let val pr = pr errStream + in fn l : pos => fn msg : string => + (pr name; pr ", line "; pr (Int.toString l); pr ": Warning: "; + pr msg; pr "\n") + end + + datatype prec = LEFT | RIGHT | NONASSOC + + datatype symbol = SYMBOL of string * pos + val symbolName = fn SYMBOL(s,_) => s + val symbolPos = fn SYMBOL(_,p) => p + val symbolMake = fn sp => SYMBOL sp + + type ty = string + val tyName = fn i => i + val tyMake = fn i => i + + datatype control = NODEFAULT | VERBOSE | PARSER_NAME of symbol | + FUNCTOR of string | START_SYM of symbol | + NSHIFT of symbol list | POS of string | PURE | + PARSE_ARG of string * string + + datatype declData = DECL of + {eop : symbol list, + keyword : symbol list, + nonterm : (symbol*ty option) list option, + prec : (prec * (symbol list)) list, + change: (symbol list * symbol list) list, + term : (symbol* ty option) list option, + control : control list, + value : (symbol * string) list} + + type rhsData = {rhs:symbol list,code:string, prec:symbol option} list + datatype rule = RULE of {lhs : symbol, rhs : symbol list, + code : string, prec : symbol option} + + type parseResult = string * declData * rule list + val getResult = fn p => p + + fun join_decls + (DECL {eop=e,control=c,keyword=k,nonterm=n,prec, + change=su,term=t,value=v}:declData, + DECL {eop=e',control=c',keyword=k',nonterm=n',prec=prec', + change=su',term=t',value=v'} : declData, + inputSource,pos) = + let val ignore = fn s => + (warn inputSource pos ("ignoring duplicate " ^ s ^ + " declaration")) + val join = fn (e,NONE,NONE) => NONE + | (e,NONE,a) => a + | (e,a,NONE) => a + | (e,a,b) => (ignore e; a) + fun mergeControl (nil,a) = [a] + | mergeControl (l as h::t,a) = + case (h,a) + of (PARSER_NAME _,PARSER_NAME n1) => (ignore "%name"; l) + | (FUNCTOR _,FUNCTOR _) => (ignore "%header"; l) + | (PARSE_ARG _,PARSE_ARG _) => (ignore "%arg"; l) + | (START_SYM _,START_SYM s) => (ignore "%start"; l) + | (POS _,POS _) => (ignore "%pos"; l) + | (NSHIFT a,NSHIFT b) => (NSHIFT (a@b)::t) + | _ => h :: mergeControl(t,a) + fun loop (nil,r) = r + | loop (h::t,r) = loop(t,mergeControl(r,h)) + in DECL {eop=e@e',control=loop(c',c),keyword=k'@k, + nonterm=join("%nonterm",n,n'), prec=prec@prec', + change=su@su', term=join("%term",t,t'),value=v@v'} : + declData + end +end; + +structure Header = HeaderFun(); + +signature Mlyacc_TOKENS = +sig +type ('a,'b) token +type svalue +val BOGUS_VALUE: 'a * 'a -> (svalue,'a) token +val UNKNOWN: (string) * 'a * 'a -> (svalue,'a) token +val VALUE: 'a * 'a -> (svalue,'a) token +val VERBOSE: 'a * 'a -> (svalue,'a) token +val TYVAR: (string) * 'a * 'a -> (svalue,'a) token +val TERM: 'a * 'a -> (svalue,'a) token +val START: 'a * 'a -> (svalue,'a) token +val SUBST: 'a * 'a -> (svalue,'a) token +val RPAREN: 'a * 'a -> (svalue,'a) token +val RBRACE: 'a * 'a -> (svalue,'a) token +val PROG: (string) * 'a * 'a -> (svalue,'a) token +val PREFER: 'a * 'a -> (svalue,'a) token +val PREC_TAG: 'a * 'a -> (svalue,'a) token +val PREC: (Header.prec) * 'a * 'a -> (svalue,'a) token +val PERCENT_ARG: 'a * 'a -> (svalue,'a) token +val PERCENT_POS: 'a * 'a -> (svalue,'a) token +val PERCENT_PURE: 'a * 'a -> (svalue,'a) token +val PERCENT_EOP: 'a * 'a -> (svalue,'a) token +val OF: 'a * 'a -> (svalue,'a) token +val NOSHIFT: 'a * 'a -> (svalue,'a) token +val NONTERM: 'a * 'a -> (svalue,'a) token +val NODEFAULT: 'a * 'a -> (svalue,'a) token +val NAME: 'a * 'a -> (svalue,'a) token +val LPAREN: 'a * 'a -> (svalue,'a) token +val LBRACE: 'a * 'a -> (svalue,'a) token +val KEYWORD: 'a * 'a -> (svalue,'a) token +val INT: (string) * 'a * 'a -> (svalue,'a) token +val PERCENT_HEADER: 'a * 'a -> (svalue,'a) token +val IDDOT: (string) * 'a * 'a -> (svalue,'a) token +val ID: (string*int) * 'a * 'a -> (svalue,'a) token +val HEADER: (string) * 'a * 'a -> (svalue,'a) token +val FOR: 'a * 'a -> (svalue,'a) token +val EOF: 'a * 'a -> (svalue,'a) token +val DELIMITER: 'a * 'a -> (svalue,'a) token +val COMMA: 'a * 'a -> (svalue,'a) token +val COLON: 'a * 'a -> (svalue,'a) token +val CHANGE: 'a * 'a -> (svalue,'a) token +val BAR: 'a * 'a -> (svalue,'a) token +val BLOCK: 'a * 'a -> (svalue,'a) token +val ASTERISK: 'a * 'a -> (svalue,'a) token +val ARROW: 'a * 'a -> (svalue,'a) token +end +signature Mlyacc_LRVALS= +sig +structure Tokens : Mlyacc_TOKENS +structure ParserData:PARSER_DATA +sharing type ParserData.Token.token = Tokens.token +sharing type ParserData.svalue = Tokens.svalue +end +functor MlyaccLrValsFun(structure Hdr : HEADER + where type prec = Header.prec + structure Token : TOKEN) = + +struct +structure ParserData= +struct +structure Header = +struct +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *) + +(* parser for the ML parser generator *) + +open Hdr + +end +structure LrTable = Token.LrTable +structure Token = Token +local open LrTable in +val table=let val actionRows = +"\ +\\001\000\001\000\074\000\000\000\ +\\001\000\005\000\024\000\008\000\023\000\014\000\022\000\016\000\021\000\ +\\019\000\020\000\020\000\019\000\021\000\018\000\022\000\017\000\ +\\024\000\016\000\025\000\015\000\026\000\014\000\027\000\013\000\ +\\028\000\012\000\030\000\011\000\034\000\010\000\035\000\009\000\ +\\036\000\008\000\038\000\007\000\039\000\006\000\000\000\ +\\001\000\006\000\061\000\000\000\ +\\001\000\006\000\072\000\000\000\ +\\001\000\006\000\084\000\000\000\ +\\001\000\006\000\096\000\000\000\ +\\001\000\007\000\083\000\032\000\082\000\000\000\ +\\001\000\009\000\000\000\000\000\ +\\001\000\010\000\059\000\000\000\ +\\001\000\011\000\003\000\000\000\ +\\001\000\012\000\025\000\000\000\ +\\001\000\012\000\027\000\000\000\ +\\001\000\012\000\028\000\000\000\ +\\001\000\012\000\031\000\000\000\ +\\001\000\012\000\042\000\013\000\041\000\000\000\ +\\001\000\012\000\042\000\013\000\041\000\017\000\040\000\031\000\039\000\ +\\037\000\038\000\000\000\ +\\001\000\012\000\046\000\000\000\ +\\001\000\012\000\051\000\000\000\ +\\001\000\012\000\069\000\015\000\068\000\000\000\ +\\001\000\012\000\069\000\015\000\068\000\032\000\067\000\000\000\ +\\001\000\012\000\075\000\000\000\ +\\001\000\012\000\078\000\000\000\ +\\001\000\012\000\099\000\000\000\ +\\001\000\031\000\035\000\000\000\ +\\001\000\031\000\048\000\000\000\ +\\001\000\031\000\055\000\000\000\ +\\001\000\031\000\098\000\000\000\ +\\001\000\031\000\102\000\000\000\ +\\104\000\012\000\051\000\000\000\ +\\105\000\000\000\ +\\106\000\000\000\ +\\107\000\004\000\056\000\000\000\ +\\108\000\004\000\056\000\000\000\ +\\109\000\000\000\ +\\110\000\000\000\ +\\111\000\000\000\ +\\112\000\000\000\ +\\113\000\000\000\ +\\114\000\000\000\ +\\115\000\000\000\ +\\116\000\000\000\ +\\117\000\000\000\ +\\118\000\000\000\ +\\119\000\001\000\064\000\002\000\063\000\012\000\042\000\013\000\041\000\000\000\ +\\120\000\000\000\ +\\121\000\000\000\ +\\122\000\000\000\ +\\123\000\001\000\064\000\002\000\063\000\012\000\042\000\013\000\041\000\000\000\ +\\124\000\000\000\ +\\125\000\000\000\ +\\126\000\004\000\073\000\000\000\ +\\127\000\000\000\ +\\128\000\000\000\ +\\129\000\004\000\058\000\000\000\ +\\130\000\000\000\ +\\131\000\001\000\064\000\002\000\063\000\012\000\042\000\013\000\041\000\000\000\ +\\132\000\023\000\089\000\000\000\ +\\133\000\001\000\064\000\002\000\063\000\012\000\042\000\013\000\041\000\000\000\ +\\134\000\023\000\057\000\000\000\ +\\135\000\004\000\092\000\000\000\ +\\136\000\000\000\ +\\137\000\000\000\ +\\138\000\000\000\ +\\139\000\012\000\033\000\000\000\ +\\140\000\000\000\ +\\141\000\000\000\ +\\142\000\000\000\ +\\143\000\000\000\ +\\144\000\000\000\ +\\145\000\000\000\ +\\146\000\000\000\ +\\147\000\000\000\ +\\148\000\012\000\042\000\013\000\041\000\000\000\ +\\149\000\001\000\064\000\002\000\063\000\012\000\042\000\013\000\041\000\000\000\ +\\150\000\001\000\064\000\002\000\063\000\012\000\042\000\013\000\041\000\000\000\ +\\151\000\001\000\064\000\002\000\063\000\012\000\042\000\013\000\041\000\000\000\ +\\152\000\000\000\ +\\153\000\000\000\ +\\154\000\000\000\ +\\155\000\000\000\ +\\156\000\000\000\ +\\157\000\029\000\094\000\000\000\ +\" +val actionRowNumbers = +"\009\000\030\000\001\000\029\000\ +\\010\000\044\000\011\000\012\000\ +\\013\000\063\000\063\000\023\000\ +\\015\000\046\000\063\000\063\000\ +\\011\000\045\000\016\000\063\000\ +\\024\000\017\000\063\000\025\000\ +\\031\000\058\000\034\000\053\000\ +\\039\000\008\000\037\000\063\000\ +\\033\000\002\000\047\000\071\000\ +\\066\000\069\000\019\000\014\000\ +\\076\000\035\000\040\000\032\000\ +\\042\000\036\000\041\000\028\000\ +\\061\000\003\000\050\000\038\000\ +\\000\000\048\000\020\000\015\000\ +\\013\000\021\000\062\000\015\000\ +\\070\000\015\000\015\000\006\000\ +\\004\000\068\000\079\000\078\000\ +\\077\000\060\000\063\000\063\000\ +\\063\000\056\000\057\000\052\000\ +\\054\000\043\000\072\000\073\000\ +\\067\000\018\000\015\000\059\000\ +\\081\000\049\000\051\000\015\000\ +\\005\000\075\000\063\000\026\000\ +\\022\000\055\000\015\000\081\000\ +\\064\000\080\000\074\000\027\000\ +\\065\000\007\000" +val gotoT = +"\ +\\001\000\101\000\000\000\ +\\006\000\002\000\000\000\ +\\005\000\003\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\002\000\024\000\000\000\ +\\000\000\ +\\013\000\028\000\014\000\027\000\000\000\ +\\003\000\030\000\000\000\ +\\003\000\032\000\000\000\ +\\000\000\ +\\007\000\035\000\017\000\034\000\000\000\ +\\000\000\ +\\003\000\041\000\000\000\ +\\003\000\042\000\000\000\ +\\002\000\043\000\000\000\ +\\000\000\ +\\000\000\ +\\003\000\045\000\000\000\ +\\000\000\ +\\010\000\048\000\011\000\047\000\000\000\ +\\003\000\052\000\015\000\051\000\016\000\050\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\003\000\058\000\000\000\ +\\000\000\ +\\000\000\ +\\007\000\060\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\004\000\064\000\008\000\063\000\000\000\ +\\007\000\068\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\010\000\069\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\007\000\035\000\017\000\074\000\000\000\ +\\013\000\075\000\014\000\027\000\000\000\ +\\000\000\ +\\000\000\ +\\007\000\035\000\017\000\077\000\000\000\ +\\000\000\ +\\007\000\035\000\017\000\078\000\000\000\ +\\007\000\035\000\017\000\079\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\\003\000\084\000\009\000\083\000\000\000\ +\\003\000\052\000\015\000\085\000\016\000\050\000\000\000\ +\\003\000\086\000\000\000\ +\\000\000\ +\\007\000\060\000\000\000\ +\\000\000\ +\\000\000\ +\\007\000\060\000\000\000\ +\\007\000\060\000\000\000\ +\\007\000\060\000\000\000\ +\\000\000\ +\\004\000\088\000\000\000\ +\\007\000\035\000\017\000\089\000\000\000\ +\\000\000\ +\\012\000\091\000\000\000\ +\\000\000\ +\\000\000\ +\\007\000\035\000\017\000\093\000\000\000\ +\\000\000\ +\\007\000\060\000\000\000\ +\\003\000\095\000\000\000\ +\\000\000\ +\\000\000\ +\\007\000\060\000\000\000\ +\\007\000\035\000\017\000\098\000\000\000\ +\\012\000\099\000\000\000\ +\\000\000\ +\\000\000\ +\\007\000\060\000\000\000\ +\\000\000\ +\\000\000\ +\\000\000\ +\" +val numstates = 102 +val numrules = 54 +val s = ref "" and index = ref 0 +val string_to_int = fn () => +let val i = !index +in index := i+2; Char.ord(String.sub(!s,i)) + Char.ord(String.sub(!s,i+1)) * 256 +end +val string_to_list = fn s' => + let val len = String.size s' + fun f () = + if !index < len then string_to_int() :: f() + else nil + in index := 0; s := s'; f () + end +val string_to_pairlist = fn (conv_key,conv_entry) => + let fun f () = + case string_to_int() + of 0 => EMPTY + | n => PAIR(conv_key (n-1),conv_entry (string_to_int()),f()) + in f + end +val string_to_pairlist_default = fn (conv_key,conv_entry) => + let val conv_row = string_to_pairlist(conv_key,conv_entry) + in fn () => + let val default = conv_entry(string_to_int()) + val row = conv_row() + in (row,default) + end + end +val string_to_table = fn (convert_row,s') => + let val len = String.size s' + fun f ()= + if !index < len then convert_row() :: f() + else nil + in (s := s'; index := 0; f ()) + end +local + val memo = Array.array(numstates+numrules,ERROR) + val _ =let fun g i=(Array.update(memo,i,REDUCE(i-numstates)); g(i+1)) + fun f i = + if i=numstates then g i + else (Array.update(memo,i,SHIFT (STATE i)); f (i+1)) + in f 0 handle Subscript => () + end +in +val entry_to_action = fn 0 => ACCEPT | 1 => ERROR | j => Array.sub(memo,(j-2)) +end +val gotoT=Array.fromList(string_to_table(string_to_pairlist(NT,STATE),gotoT)) +val actionRows=string_to_table(string_to_pairlist_default(T,entry_to_action),actionRows) +val actionRowNumbers = string_to_list actionRowNumbers +val actionT = let val actionRowLookUp= +let val a=Array.fromList(actionRows) in fn i=>Array.sub(a,i) end +in Array.fromList(map actionRowLookUp actionRowNumbers) +end +in LrTable.mkLrTable {actions=actionT,gotos=gotoT,numRules=numrules, +numStates=numstates,initialState=STATE 0} +end +end +local open Header in +type pos = int +type arg = Hdr.inputSource +structure MlyValue = +struct +datatype svalue = VOID | ntVOID of unit -> unit + | UNKNOWN of unit -> (string) | TYVAR of unit -> (string) + | PROG of unit -> (string) | PREC of unit -> (Header.prec) + | INT of unit -> (string) | IDDOT of unit -> (string) + | ID of unit -> (string*int) | HEADER of unit -> (string) + | TY of unit -> (string) + | CHANGE_DEC of unit -> ( ( Hdr.symbol list * Hdr.symbol list ) ) + | CHANGE_DECL of unit -> ( ( Hdr.symbol list * Hdr.symbol list ) list) + | SUBST_DEC of unit -> ( ( Hdr.symbol list * Hdr.symbol list ) ) + | SUBST_DECL of unit -> ( ( Hdr.symbol list * Hdr.symbol list ) list) + | G_RULE_PREC of unit -> (Hdr.symbol option) + | G_RULE_LIST of unit -> (Hdr.rule list) + | G_RULE of unit -> (Hdr.rule list) + | RHS_LIST of unit -> ({ rhs:Hdr.symbol list,code:string,prec:Hdr.symbol option } list) + | RECORD_LIST of unit -> (string) | QUAL_ID of unit -> (string) + | MPC_DECLS of unit -> (Hdr.declData) + | MPC_DECL of unit -> (Hdr.declData) | LABEL of unit -> (string) + | ID_LIST of unit -> (Hdr.symbol list) + | CONSTR_LIST of unit -> ( ( Hdr.symbol * Hdr.ty option ) list) + | BEGIN of unit -> (string*Hdr.declData* ( Hdr.rule list ) ) +end +type svalue = MlyValue.svalue +type result = string*Hdr.declData* ( Hdr.rule list ) +end +structure EC= +struct +open LrTable +val is_keyword = +fn _ => false +val preferred_change = +nil +val noShift = +fn (T 8) => true | _ => false +val showTerminal = +fn (T 0) => "ARROW" + | (T 1) => "ASTERISK" + | (T 2) => "BLOCK" + | (T 3) => "BAR" + | (T 4) => "CHANGE" + | (T 5) => "COLON" + | (T 6) => "COMMA" + | (T 7) => "DELIMITER" + | (T 8) => "EOF" + | (T 9) => "FOR" + | (T 10) => "HEADER" + | (T 11) => "ID" + | (T 12) => "IDDOT" + | (T 13) => "PERCENT_HEADER" + | (T 14) => "INT" + | (T 15) => "KEYWORD" + | (T 16) => "LBRACE" + | (T 17) => "LPAREN" + | (T 18) => "NAME" + | (T 19) => "NODEFAULT" + | (T 20) => "NONTERM" + | (T 21) => "NOSHIFT" + | (T 22) => "OF" + | (T 23) => "PERCENT_EOP" + | (T 24) => "PERCENT_PURE" + | (T 25) => "PERCENT_POS" + | (T 26) => "PERCENT_ARG" + | (T 27) => "PREC" + | (T 28) => "PREC_TAG" + | (T 29) => "PREFER" + | (T 30) => "PROG" + | (T 31) => "RBRACE" + | (T 32) => "RPAREN" + | (T 33) => "SUBST" + | (T 34) => "START" + | (T 35) => "TERM" + | (T 36) => "TYVAR" + | (T 37) => "VERBOSE" + | (T 38) => "VALUE" + | (T 39) => "UNKNOWN" + | (T 40) => "BOGUS_VALUE" + | _ => "bogus-term" +local open Header in +val errtermvalue= +fn _ => MlyValue.VOID +end +val terms = (T 0) :: (T 1) :: (T 2) :: (T 3) :: (T 4) :: (T 5) :: (T 6 +) :: (T 7) :: (T 8) :: (T 9) :: (T 13) :: (T 15) :: (T 16) :: (T 17) + :: (T 18) :: (T 19) :: (T 20) :: (T 21) :: (T 22) :: (T 23) :: (T 24) + :: (T 25) :: (T 26) :: (T 28) :: (T 29) :: (T 31) :: (T 32) :: (T 33) + :: (T 34) :: (T 35) :: (T 37) :: (T 38) :: (T 40) :: nil +end +structure Actions = +struct +exception mlyAction of int +local open Header +in +val actions = +fn (i392,defaultPos,stack, + (inputSource):arg) => +case (i392,stack) +of (0,(_,(MlyValue.G_RULE_LIST G_RULE_LIST1,_,G_RULE_LIST1right))::_:: +(_,(MlyValue.MPC_DECLS MPC_DECLS1,_,_))::(_,(MlyValue.HEADER HEADER1, +HEADER1left,_))::rest671) => let val result=MlyValue.BEGIN(fn _ => +let val HEADER as HEADER1=HEADER1 () +val MPC_DECLS as MPC_DECLS1=MPC_DECLS1 () +val G_RULE_LIST as G_RULE_LIST1=G_RULE_LIST1 () + in (HEADER,MPC_DECLS,rev G_RULE_LIST) end +) + in (LrTable.NT 0,(result,HEADER1left,G_RULE_LIST1right),rest671) end +| (1,(_,(MlyValue.MPC_DECL MPC_DECL1,MPC_DECLleft,MPC_DECL1right))::(_ +,(MlyValue.MPC_DECLS MPC_DECLS1,MPC_DECLS1left,_))::rest671) => let +val result=MlyValue.MPC_DECLS(fn _ => let val MPC_DECLS as MPC_DECLS1= +MPC_DECLS1 () +val MPC_DECL as MPC_DECL1=MPC_DECL1 () + in (join_decls(MPC_DECLS,MPC_DECL,inputSource,MPC_DECLleft)) end +) + in (LrTable.NT 5,(result,MPC_DECLS1left,MPC_DECL1right),rest671) end +| (2,rest671) => let val result=MlyValue.MPC_DECLS(fn _ => ( +DECL {prec=nil,nonterm=NONE,term=NONE,eop=nil,control=nil, + keyword=nil,change=nil, + value=nil} +)) + in (LrTable.NT 5,(result,defaultPos,defaultPos),rest671) end +| (3,(_,(MlyValue.CONSTR_LIST CONSTR_LIST1,_,CONSTR_LIST1right))::(_,( +_,TERM1left,_))::rest671) => let val result=MlyValue.MPC_DECL(fn _ => +let val CONSTR_LIST as CONSTR_LIST1=CONSTR_LIST1 () + in ( +DECL { prec=nil,nonterm=NONE, + term = SOME CONSTR_LIST, eop =nil,control=nil, + change=nil,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,TERM1left,CONSTR_LIST1right),rest671) end +| (4,(_,(MlyValue.CONSTR_LIST CONSTR_LIST1,_,CONSTR_LIST1right))::(_,( +_,NONTERM1left,_))::rest671) => let val result=MlyValue.MPC_DECL(fn _ + => let val CONSTR_LIST as CONSTR_LIST1=CONSTR_LIST1 () + in ( +DECL { prec=nil,control=nil,nonterm= SOME CONSTR_LIST, + term = NONE, eop=nil,change=nil,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,NONTERM1left,CONSTR_LIST1right),rest671) end +| (5,(_,(MlyValue.ID_LIST ID_LIST1,_,ID_LIST1right))::(_,( +MlyValue.PREC PREC1,PREC1left,_))::rest671) => let val result= +MlyValue.MPC_DECL(fn _ => let val PREC as PREC1=PREC1 () +val ID_LIST as ID_LIST1=ID_LIST1 () + in ( +DECL {prec= [(PREC,ID_LIST)],control=nil, + nonterm=NONE,term=NONE,eop=nil,change=nil, + keyword=nil,value=nil} +) end +) + in (LrTable.NT 4,(result,PREC1left,ID_LIST1right),rest671) end +| (6,(_,(MlyValue.ID ID1,_,ID1right))::(_,(_,START1left,_))::rest671) + => let val result=MlyValue.MPC_DECL(fn _ => let val ID as ID1=ID1 () + in ( +DECL {prec=nil,control=[START_SYM (symbolMake ID)],nonterm=NONE, + term = NONE, eop = nil,change=nil,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,START1left,ID1right),rest671) end +| (7,(_,(MlyValue.ID_LIST ID_LIST1,_,ID_LIST1right))::(_,(_, +PERCENT_EOP1left,_))::rest671) => let val result=MlyValue.MPC_DECL(fn +_ => let val ID_LIST as ID_LIST1=ID_LIST1 () + in ( +DECL {prec=nil,control=nil,nonterm=NONE,term=NONE, + eop=ID_LIST, change=nil,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,PERCENT_EOP1left,ID_LIST1right),rest671) end +| (8,(_,(MlyValue.ID_LIST ID_LIST1,_,ID_LIST1right))::(_,(_, +KEYWORD1left,_))::rest671) => let val result=MlyValue.MPC_DECL(fn _ + => let val ID_LIST as ID_LIST1=ID_LIST1 () + in ( +DECL {prec=nil,control=nil,nonterm=NONE,term=NONE,eop=nil, + change=nil,keyword=ID_LIST, + value=nil} +) end +) + in (LrTable.NT 4,(result,KEYWORD1left,ID_LIST1right),rest671) end +| (9,(_,(MlyValue.ID_LIST ID_LIST1,_,ID_LIST1right))::(_,(_, +PREFER1left,_))::rest671) => let val result=MlyValue.MPC_DECL(fn _ => +let val ID_LIST as ID_LIST1=ID_LIST1 () + in ( +DECL {prec=nil,control=nil,nonterm=NONE,term=NONE,eop=nil, + change=map (fn i=>([],[i])) ID_LIST,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,PREFER1left,ID_LIST1right),rest671) end +| (10,(_,(MlyValue.CHANGE_DECL CHANGE_DECL1,_,CHANGE_DECL1right))::(_, +(_,CHANGE1left,_))::rest671) => let val result=MlyValue.MPC_DECL(fn _ + => let val CHANGE_DECL as CHANGE_DECL1=CHANGE_DECL1 () + in ( +DECL {prec=nil,control=nil,nonterm=NONE,term=NONE,eop=nil, + change=CHANGE_DECL,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,CHANGE1left,CHANGE_DECL1right),rest671) end +| (11,(_,(MlyValue.SUBST_DECL SUBST_DECL1,_,SUBST_DECL1right))::(_,(_, +SUBST1left,_))::rest671) => let val result=MlyValue.MPC_DECL(fn _ => +let val SUBST_DECL as SUBST_DECL1=SUBST_DECL1 () + in ( +DECL {prec=nil,control=nil,nonterm=NONE,term=NONE,eop=nil, + change=SUBST_DECL,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,SUBST1left,SUBST_DECL1right),rest671) end +| (12,(_,(MlyValue.ID_LIST ID_LIST1,_,ID_LIST1right))::(_,(_, +NOSHIFT1left,_))::rest671) => let val result=MlyValue.MPC_DECL(fn _ + => let val ID_LIST as ID_LIST1=ID_LIST1 () + in ( +DECL {prec=nil,control=[NSHIFT ID_LIST],nonterm=NONE,term=NONE, + eop=nil,change=nil,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,NOSHIFT1left,ID_LIST1right),rest671) end +| (13,(_,(MlyValue.PROG PROG1,_,PROG1right))::(_,(_, +PERCENT_HEADER1left,_))::rest671) => let val result=MlyValue.MPC_DECL( +fn _ => let val PROG as PROG1=PROG1 () + in ( +DECL {prec=nil,control=[FUNCTOR PROG],nonterm=NONE,term=NONE, + eop=nil,change=nil,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,PERCENT_HEADER1left,PROG1right),rest671) end +| (14,(_,(MlyValue.ID ID1,_,ID1right))::(_,(_,NAME1left,_))::rest671) + => let val result=MlyValue.MPC_DECL(fn _ => let val ID as ID1=ID1 () + in ( +DECL {prec=nil,control=[PARSER_NAME (symbolMake ID)], + nonterm=NONE,term=NONE, + eop=nil,change=nil,keyword=nil, value=nil} +) end +) + in (LrTable.NT 4,(result,NAME1left,ID1right),rest671) end +| (15,(_,(MlyValue.TY TY1,_,TY1right))::_::(_,(MlyValue.PROG PROG1,_,_ +))::(_,(_,PERCENT_ARG1left,_))::rest671) => let val result= +MlyValue.MPC_DECL(fn _ => let val PROG as PROG1=PROG1 () +val TY as TY1=TY1 () + in ( +DECL {prec=nil,control=[PARSE_ARG(PROG,TY)],nonterm=NONE, + term=NONE,eop=nil,change=nil,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,PERCENT_ARG1left,TY1right),rest671) end +| (16,(_,(_,VERBOSE1left,VERBOSE1right))::rest671) => let val result= +MlyValue.MPC_DECL(fn _ => ( +DECL {prec=nil,control=[Hdr.VERBOSE], + nonterm=NONE,term=NONE,eop=nil, + change=nil,keyword=nil, + value=nil} +)) + in (LrTable.NT 4,(result,VERBOSE1left,VERBOSE1right),rest671) end +| (17,(_,(_,NODEFAULT1left,NODEFAULT1right))::rest671) => let val +result=MlyValue.MPC_DECL(fn _ => ( +DECL {prec=nil,control=[Hdr.NODEFAULT], + nonterm=NONE,term=NONE,eop=nil, + change=nil,keyword=nil, + value=nil} +)) + in (LrTable.NT 4,(result,NODEFAULT1left,NODEFAULT1right),rest671) end +| (18,(_,(_,PERCENT_PURE1left,PERCENT_PURE1right))::rest671) => let +val result=MlyValue.MPC_DECL(fn _ => ( +DECL {prec=nil,control=[Hdr.PURE], + nonterm=NONE,term=NONE,eop=nil, + change=nil,keyword=nil, + value=nil} +)) + in (LrTable.NT 4,(result,PERCENT_PURE1left,PERCENT_PURE1right), +rest671) end +| (19,(_,(MlyValue.TY TY1,_,TY1right))::(_,(_,PERCENT_POS1left,_)):: +rest671) => let val result=MlyValue.MPC_DECL(fn _ => let val TY as TY1 +=TY1 () + in ( +DECL {prec=nil,control=[Hdr.POS TY], + nonterm=NONE,term=NONE,eop=nil, + change=nil,keyword=nil, + value=nil} +) end +) + in (LrTable.NT 4,(result,PERCENT_POS1left,TY1right),rest671) end +| (20,(_,(MlyValue.PROG PROG1,_,PROG1right))::(_,(MlyValue.ID ID1,_,_) +)::(_,(_,VALUE1left,_))::rest671) => let val result=MlyValue.MPC_DECL( +fn _ => let val ID as ID1=ID1 () +val PROG as PROG1=PROG1 () + in ( +DECL {prec=nil,control=nil, + nonterm=NONE,term=NONE,eop=nil, + change=nil,keyword=nil, + value=[(symbolMake ID,PROG)]} +) end +) + in (LrTable.NT 4,(result,VALUE1left,PROG1right),rest671) end +| (21,(_,(MlyValue.CHANGE_DECL CHANGE_DECL1,_,CHANGE_DECL1right))::_:: +(_,(MlyValue.CHANGE_DEC CHANGE_DEC1,CHANGE_DEC1left,_))::rest671) => +let val result=MlyValue.CHANGE_DECL(fn _ => let val CHANGE_DEC as +CHANGE_DEC1=CHANGE_DEC1 () +val CHANGE_DECL as CHANGE_DECL1=CHANGE_DECL1 () + in (CHANGE_DEC :: CHANGE_DECL) end +) + in (LrTable.NT 14,(result,CHANGE_DEC1left,CHANGE_DECL1right),rest671) + end +| (22,(_,(MlyValue.CHANGE_DEC CHANGE_DEC1,CHANGE_DEC1left, +CHANGE_DEC1right))::rest671) => let val result=MlyValue.CHANGE_DECL( +fn _ => let val CHANGE_DEC as CHANGE_DEC1=CHANGE_DEC1 () + in ([CHANGE_DEC]) end +) + in (LrTable.NT 14,(result,CHANGE_DEC1left,CHANGE_DEC1right),rest671) + end +| (23,(_,(MlyValue.ID_LIST ID_LIST2,_,ID_LIST2right))::_::(_,( +MlyValue.ID_LIST ID_LIST1,ID_LIST1left,_))::rest671) => let val result +=MlyValue.CHANGE_DEC(fn _ => let val ID_LIST1=ID_LIST1 () +val ID_LIST2=ID_LIST2 () + in (ID_LIST1, ID_LIST2) end +) + in (LrTable.NT 15,(result,ID_LIST1left,ID_LIST2right),rest671) end +| (24,(_,(MlyValue.SUBST_DECL SUBST_DECL1,_,SUBST_DECL1right))::_::(_, +(MlyValue.SUBST_DEC SUBST_DEC1,SUBST_DEC1left,_))::rest671) => let +val result=MlyValue.SUBST_DECL(fn _ => let val SUBST_DEC as SUBST_DEC1 +=SUBST_DEC1 () +val SUBST_DECL as SUBST_DECL1=SUBST_DECL1 () + in (SUBST_DEC :: SUBST_DECL) end +) + in (LrTable.NT 12,(result,SUBST_DEC1left,SUBST_DECL1right),rest671) + end +| (25,(_,(MlyValue.SUBST_DEC SUBST_DEC1,SUBST_DEC1left,SUBST_DEC1right +))::rest671) => let val result=MlyValue.SUBST_DECL(fn _ => let val +SUBST_DEC as SUBST_DEC1=SUBST_DEC1 () + in ([SUBST_DEC]) end +) + in (LrTable.NT 12,(result,SUBST_DEC1left,SUBST_DEC1right),rest671) + end +| (26,(_,(MlyValue.ID ID2,_,ID2right))::_::(_,(MlyValue.ID ID1,ID1left +,_))::rest671) => let val result=MlyValue.SUBST_DEC(fn _ => let val +ID1=ID1 () +val ID2=ID2 () + in ([symbolMake ID2],[symbolMake ID1]) end +) + in (LrTable.NT 13,(result,ID1left,ID2right),rest671) end +| (27,(_,(MlyValue.TY TY1,_,TY1right))::_::(_,(MlyValue.ID ID1,_,_)):: +_::(_,(MlyValue.CONSTR_LIST CONSTR_LIST1,CONSTR_LIST1left,_))::rest671 +) => let val result=MlyValue.CONSTR_LIST(fn _ => let val CONSTR_LIST + as CONSTR_LIST1=CONSTR_LIST1 () +val ID as ID1=ID1 () +val TY as TY1=TY1 () + in ((symbolMake ID,SOME (tyMake TY))::CONSTR_LIST) end +) + in (LrTable.NT 1,(result,CONSTR_LIST1left,TY1right),rest671) end +| (28,(_,(MlyValue.ID ID1,_,ID1right))::_::(_,(MlyValue.CONSTR_LIST +CONSTR_LIST1,CONSTR_LIST1left,_))::rest671) => let val result= +MlyValue.CONSTR_LIST(fn _ => let val CONSTR_LIST as CONSTR_LIST1= +CONSTR_LIST1 () +val ID as ID1=ID1 () + in ((symbolMake ID,NONE)::CONSTR_LIST) end +) + in (LrTable.NT 1,(result,CONSTR_LIST1left,ID1right),rest671) end +| (29,(_,(MlyValue.TY TY1,_,TY1right))::_::(_,(MlyValue.ID ID1,ID1left +,_))::rest671) => let val result=MlyValue.CONSTR_LIST(fn _ => let val +ID as ID1=ID1 () +val TY as TY1=TY1 () + in ([(symbolMake ID,SOME (tyMake TY))]) end +) + in (LrTable.NT 1,(result,ID1left,TY1right),rest671) end +| (30,(_,(MlyValue.ID ID1,ID1left,ID1right))::rest671) => let val +result=MlyValue.CONSTR_LIST(fn _ => let val ID as ID1=ID1 () + in ([(symbolMake ID,NONE)]) end +) + in (LrTable.NT 1,(result,ID1left,ID1right),rest671) end +| (31,(_,(MlyValue.RHS_LIST RHS_LIST1,_,RHS_LIST1right))::_::(_,( +MlyValue.ID ID1,ID1left,_))::rest671) => let val result= +MlyValue.G_RULE(fn _ => let val ID as ID1=ID1 () +val RHS_LIST as RHS_LIST1=RHS_LIST1 () + in ( +map (fn {rhs,code,prec} => + Hdr.RULE {lhs=symbolMake ID,rhs=rhs, + code=code,prec=prec}) + RHS_LIST +) end +) + in (LrTable.NT 9,(result,ID1left,RHS_LIST1right),rest671) end +| (32,(_,(MlyValue.G_RULE G_RULE1,_,G_RULE1right))::(_,( +MlyValue.G_RULE_LIST G_RULE_LIST1,G_RULE_LIST1left,_))::rest671) => +let val result=MlyValue.G_RULE_LIST(fn _ => let val G_RULE_LIST as +G_RULE_LIST1=G_RULE_LIST1 () +val G_RULE as G_RULE1=G_RULE1 () + in (G_RULE@G_RULE_LIST) end +) + in (LrTable.NT 10,(result,G_RULE_LIST1left,G_RULE1right),rest671) end +| (33,(_,(MlyValue.G_RULE G_RULE1,G_RULE1left,G_RULE1right))::rest671) + => let val result=MlyValue.G_RULE_LIST(fn _ => let val G_RULE as +G_RULE1=G_RULE1 () + in (G_RULE) end +) + in (LrTable.NT 10,(result,G_RULE1left,G_RULE1right),rest671) end +| (34,(_,(MlyValue.ID_LIST ID_LIST1,_,ID_LIST1right))::(_,(MlyValue.ID + ID1,ID1left,_))::rest671) => let val result=MlyValue.ID_LIST(fn _ => +let val ID as ID1=ID1 () +val ID_LIST as ID_LIST1=ID_LIST1 () + in (symbolMake ID :: ID_LIST) end +) + in (LrTable.NT 2,(result,ID1left,ID_LIST1right),rest671) end +| (35,rest671) => let val result=MlyValue.ID_LIST(fn _ => (nil)) + in (LrTable.NT 2,(result,defaultPos,defaultPos),rest671) end +| (36,(_,(MlyValue.PROG PROG1,_,PROG1right))::(_,(MlyValue.G_RULE_PREC + G_RULE_PREC1,_,_))::(_,(MlyValue.ID_LIST ID_LIST1,ID_LIST1left,_)):: +rest671) => let val result=MlyValue.RHS_LIST(fn _ => let val ID_LIST + as ID_LIST1=ID_LIST1 () +val G_RULE_PREC as G_RULE_PREC1=G_RULE_PREC1 () +val PROG as PROG1=PROG1 () + in ([{rhs=ID_LIST,code=PROG,prec=G_RULE_PREC}]) end +) + in (LrTable.NT 8,(result,ID_LIST1left,PROG1right),rest671) end +| (37,(_,(MlyValue.PROG PROG1,_,PROG1right))::(_,(MlyValue.G_RULE_PREC + G_RULE_PREC1,_,_))::(_,(MlyValue.ID_LIST ID_LIST1,_,_))::_::(_,( +MlyValue.RHS_LIST RHS_LIST1,RHS_LIST1left,_))::rest671) => let val +result=MlyValue.RHS_LIST(fn _ => let val RHS_LIST as RHS_LIST1= +RHS_LIST1 () +val ID_LIST as ID_LIST1=ID_LIST1 () +val G_RULE_PREC as G_RULE_PREC1=G_RULE_PREC1 () +val PROG as PROG1=PROG1 () + in ({rhs=ID_LIST,code=PROG,prec=G_RULE_PREC}::RHS_LIST) end +) + in (LrTable.NT 8,(result,RHS_LIST1left,PROG1right),rest671) end +| (38,(_,(MlyValue.TYVAR TYVAR1,TYVAR1left,TYVAR1right))::rest671) => +let val result=MlyValue.TY(fn _ => let val TYVAR as TYVAR1=TYVAR1 () + in (TYVAR) end +) + in (LrTable.NT 16,(result,TYVAR1left,TYVAR1right),rest671) end +| (39,(_,(_,_,RBRACE1right))::(_,(MlyValue.RECORD_LIST RECORD_LIST1,_, +_))::(_,(_,LBRACE1left,_))::rest671) => let val result=MlyValue.TY(fn +_ => let val RECORD_LIST as RECORD_LIST1=RECORD_LIST1 () + in ("{ "^RECORD_LIST^" } ") end +) + in (LrTable.NT 16,(result,LBRACE1left,RBRACE1right),rest671) end +| (40,(_,(_,_,RBRACE1right))::(_,(_,LBRACE1left,_))::rest671) => let +val result=MlyValue.TY(fn _ => ("{}")) + in (LrTable.NT 16,(result,LBRACE1left,RBRACE1right),rest671) end +| (41,(_,(MlyValue.PROG PROG1,PROG1left,PROG1right))::rest671) => let +val result=MlyValue.TY(fn _ => let val PROG as PROG1=PROG1 () + in (" ( "^PROG^" ) ") end +) + in (LrTable.NT 16,(result,PROG1left,PROG1right),rest671) end +| (42,(_,(MlyValue.QUAL_ID QUAL_ID1,_,QUAL_ID1right))::(_,(MlyValue.TY + TY1,TY1left,_))::rest671) => let val result=MlyValue.TY(fn _ => let +val TY as TY1=TY1 () +val QUAL_ID as QUAL_ID1=QUAL_ID1 () + in (TY^" "^QUAL_ID) end +) + in (LrTable.NT 16,(result,TY1left,QUAL_ID1right),rest671) end +| (43,(_,(MlyValue.QUAL_ID QUAL_ID1,QUAL_ID1left,QUAL_ID1right)):: +rest671) => let val result=MlyValue.TY(fn _ => let val QUAL_ID as +QUAL_ID1=QUAL_ID1 () + in (QUAL_ID) end +) + in (LrTable.NT 16,(result,QUAL_ID1left,QUAL_ID1right),rest671) end +| (44,(_,(MlyValue.TY TY2,_,TY2right))::_::(_,(MlyValue.TY TY1,TY1left +,_))::rest671) => let val result=MlyValue.TY(fn _ => let val TY1=TY1 +() +val TY2=TY2 () + in (TY1^"*"^TY2) end +) + in (LrTable.NT 16,(result,TY1left,TY2right),rest671) end +| (45,(_,(MlyValue.TY TY2,_,TY2right))::_::(_,(MlyValue.TY TY1,TY1left +,_))::rest671) => let val result=MlyValue.TY(fn _ => let val TY1=TY1 +() +val TY2=TY2 () + in (TY1 ^ " -> " ^ TY2) end +) + in (LrTable.NT 16,(result,TY1left,TY2right),rest671) end +| (46,(_,(MlyValue.TY TY1,_,TY1right))::_::(_,(MlyValue.LABEL LABEL1,_ +,_))::_::(_,(MlyValue.RECORD_LIST RECORD_LIST1,RECORD_LIST1left,_)):: +rest671) => let val result=MlyValue.RECORD_LIST(fn _ => let val +RECORD_LIST as RECORD_LIST1=RECORD_LIST1 () +val LABEL as LABEL1=LABEL1 () +val TY as TY1=TY1 () + in (RECORD_LIST^","^LABEL^":"^TY) end +) + in (LrTable.NT 7,(result,RECORD_LIST1left,TY1right),rest671) end +| (47,(_,(MlyValue.TY TY1,_,TY1right))::_::(_,(MlyValue.LABEL LABEL1, +LABEL1left,_))::rest671) => let val result=MlyValue.RECORD_LIST(fn _ + => let val LABEL as LABEL1=LABEL1 () +val TY as TY1=TY1 () + in (LABEL^":"^TY) end +) + in (LrTable.NT 7,(result,LABEL1left,TY1right),rest671) end +| (48,(_,(MlyValue.ID ID1,ID1left,ID1right))::rest671) => let val +result=MlyValue.QUAL_ID(fn _ => let val ID as ID1=ID1 () + in ((fn (a,_) => a) ID) end +) + in (LrTable.NT 6,(result,ID1left,ID1right),rest671) end +| (49,(_,(MlyValue.QUAL_ID QUAL_ID1,_,QUAL_ID1right))::(_,( +MlyValue.IDDOT IDDOT1,IDDOT1left,_))::rest671) => let val result= +MlyValue.QUAL_ID(fn _ => let val IDDOT as IDDOT1=IDDOT1 () +val QUAL_ID as QUAL_ID1=QUAL_ID1 () + in (IDDOT^QUAL_ID) end +) + in (LrTable.NT 6,(result,IDDOT1left,QUAL_ID1right),rest671) end +| (50,(_,(MlyValue.ID ID1,ID1left,ID1right))::rest671) => let val +result=MlyValue.LABEL(fn _ => let val ID as ID1=ID1 () + in ((fn (a,_) => a) ID) end +) + in (LrTable.NT 3,(result,ID1left,ID1right),rest671) end +| (51,(_,(MlyValue.INT INT1,INT1left,INT1right))::rest671) => let val +result=MlyValue.LABEL(fn _ => let val INT as INT1=INT1 () + in (INT) end +) + in (LrTable.NT 3,(result,INT1left,INT1right),rest671) end +| (52,(_,(MlyValue.ID ID1,_,ID1right))::(_,(_,PREC_TAG1left,_)):: +rest671) => let val result=MlyValue.G_RULE_PREC(fn _ => let val ID as +ID1=ID1 () + in (SOME (symbolMake ID)) end +) + in (LrTable.NT 11,(result,PREC_TAG1left,ID1right),rest671) end +| (53,rest671) => let val result=MlyValue.G_RULE_PREC(fn _ => (NONE)) + in (LrTable.NT 11,(result,defaultPos,defaultPos),rest671) end +| _ => raise (mlyAction i392) +end +val void = MlyValue.VOID +val extract = fn a => (fn MlyValue.BEGIN x => x +| _ => let exception ParseInternal + in raise ParseInternal end) a () +end +end +structure Tokens : Mlyacc_TOKENS = +struct +type svalue = ParserData.svalue +type ('a,'b) token = ('a,'b) Token.token +fun ARROW (p1,p2) = Token.TOKEN (ParserData.LrTable.T 0,( +ParserData.MlyValue.VOID,p1,p2)) +fun ASTERISK (p1,p2) = Token.TOKEN (ParserData.LrTable.T 1,( +ParserData.MlyValue.VOID,p1,p2)) +fun BLOCK (p1,p2) = Token.TOKEN (ParserData.LrTable.T 2,( +ParserData.MlyValue.VOID,p1,p2)) +fun BAR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 3,( +ParserData.MlyValue.VOID,p1,p2)) +fun CHANGE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 4,( +ParserData.MlyValue.VOID,p1,p2)) +fun COLON (p1,p2) = Token.TOKEN (ParserData.LrTable.T 5,( +ParserData.MlyValue.VOID,p1,p2)) +fun COMMA (p1,p2) = Token.TOKEN (ParserData.LrTable.T 6,( +ParserData.MlyValue.VOID,p1,p2)) +fun DELIMITER (p1,p2) = Token.TOKEN (ParserData.LrTable.T 7,( +ParserData.MlyValue.VOID,p1,p2)) +fun EOF (p1,p2) = Token.TOKEN (ParserData.LrTable.T 8,( +ParserData.MlyValue.VOID,p1,p2)) +fun FOR (p1,p2) = Token.TOKEN (ParserData.LrTable.T 9,( +ParserData.MlyValue.VOID,p1,p2)) +fun HEADER (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 10,( +ParserData.MlyValue.HEADER (fn () => i),p1,p2)) +fun ID (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 11,( +ParserData.MlyValue.ID (fn () => i),p1,p2)) +fun IDDOT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 12,( +ParserData.MlyValue.IDDOT (fn () => i),p1,p2)) +fun PERCENT_HEADER (p1,p2) = Token.TOKEN (ParserData.LrTable.T 13,( +ParserData.MlyValue.VOID,p1,p2)) +fun INT (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 14,( +ParserData.MlyValue.INT (fn () => i),p1,p2)) +fun KEYWORD (p1,p2) = Token.TOKEN (ParserData.LrTable.T 15,( +ParserData.MlyValue.VOID,p1,p2)) +fun LBRACE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 16,( +ParserData.MlyValue.VOID,p1,p2)) +fun LPAREN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 17,( +ParserData.MlyValue.VOID,p1,p2)) +fun NAME (p1,p2) = Token.TOKEN (ParserData.LrTable.T 18,( +ParserData.MlyValue.VOID,p1,p2)) +fun NODEFAULT (p1,p2) = Token.TOKEN (ParserData.LrTable.T 19,( +ParserData.MlyValue.VOID,p1,p2)) +fun NONTERM (p1,p2) = Token.TOKEN (ParserData.LrTable.T 20,( +ParserData.MlyValue.VOID,p1,p2)) +fun NOSHIFT (p1,p2) = Token.TOKEN (ParserData.LrTable.T 21,( +ParserData.MlyValue.VOID,p1,p2)) +fun OF (p1,p2) = Token.TOKEN (ParserData.LrTable.T 22,( +ParserData.MlyValue.VOID,p1,p2)) +fun PERCENT_EOP (p1,p2) = Token.TOKEN (ParserData.LrTable.T 23,( +ParserData.MlyValue.VOID,p1,p2)) +fun PERCENT_PURE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 24,( +ParserData.MlyValue.VOID,p1,p2)) +fun PERCENT_POS (p1,p2) = Token.TOKEN (ParserData.LrTable.T 25,( +ParserData.MlyValue.VOID,p1,p2)) +fun PERCENT_ARG (p1,p2) = Token.TOKEN (ParserData.LrTable.T 26,( +ParserData.MlyValue.VOID,p1,p2)) +fun PREC (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 27,( +ParserData.MlyValue.PREC (fn () => i),p1,p2)) +fun PREC_TAG (p1,p2) = Token.TOKEN (ParserData.LrTable.T 28,( +ParserData.MlyValue.VOID,p1,p2)) +fun PREFER (p1,p2) = Token.TOKEN (ParserData.LrTable.T 29,( +ParserData.MlyValue.VOID,p1,p2)) +fun PROG (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 30,( +ParserData.MlyValue.PROG (fn () => i),p1,p2)) +fun RBRACE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 31,( +ParserData.MlyValue.VOID,p1,p2)) +fun RPAREN (p1,p2) = Token.TOKEN (ParserData.LrTable.T 32,( +ParserData.MlyValue.VOID,p1,p2)) +fun SUBST (p1,p2) = Token.TOKEN (ParserData.LrTable.T 33,( +ParserData.MlyValue.VOID,p1,p2)) +fun START (p1,p2) = Token.TOKEN (ParserData.LrTable.T 34,( +ParserData.MlyValue.VOID,p1,p2)) +fun TERM (p1,p2) = Token.TOKEN (ParserData.LrTable.T 35,( +ParserData.MlyValue.VOID,p1,p2)) +fun TYVAR (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 36,( +ParserData.MlyValue.TYVAR (fn () => i),p1,p2)) +fun VERBOSE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 37,( +ParserData.MlyValue.VOID,p1,p2)) +fun VALUE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 38,( +ParserData.MlyValue.VOID,p1,p2)) +fun UNKNOWN (i,p1,p2) = Token.TOKEN (ParserData.LrTable.T 39,( +ParserData.MlyValue.UNKNOWN (fn () => i),p1,p2)) +fun BOGUS_VALUE (p1,p2) = Token.TOKEN (ParserData.LrTable.T 40,( +ParserData.MlyValue.VOID,p1,p2)) +end +end +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:42 george + * Version 109 + * + *) + +structure LrTable : LR_TABLE = + struct + open Array List + infix 9 sub + datatype ('a,'b) pairlist = EMPTY + | PAIR of 'a * 'b * ('a,'b) pairlist + datatype term = T of int + datatype nonterm = NT of int + datatype state = STATE of int + datatype action = SHIFT of state + | REDUCE of int (* rulenum from grammar *) + | ACCEPT + | ERROR + exception Goto of state * nonterm + type table = {states: int, rules : int,initialState: state, + action: ((term,action) pairlist * action) array, + goto : (nonterm,state) pairlist array} + val numStates = fn ({states,...} : table) => states + val numRules = fn ({rules,...} : table) => rules + val describeActions = + fn ({action,...} : table) => + fn (STATE s) => action sub s + val describeGoto = + fn ({goto,...} : table) => + fn (STATE s) => goto sub s + fun findTerm (T term,row,default) = + let fun find (PAIR (T key,data,r)) = + if key < term then find r + else if key=term then data + else default + | find EMPTY = default + in find row + end + fun findNonterm (NT nt,row) = + let fun find (PAIR (NT key,data,r)) = + if key < nt then find r + else if key=nt then SOME data + else NONE + | find EMPTY = NONE + in find row + end + val action = fn ({action,...} : table) => + fn (STATE state,term) => + let val (row,default) = action sub state + in findTerm(term,row,default) + end + val goto = fn ({goto,...} : table) => + fn (a as (STATE state,nonterm)) => + case findNonterm(nonterm,goto sub state) + of SOME state => state + | NONE => raise (Goto a) + val initialState = fn ({initialState,...} : table) => initialState + val mkLrTable = fn {actions,gotos,initialState,numStates,numRules} => + ({action=actions,goto=gotos, + states=numStates, + rules=numRules, + initialState=initialState} : table) +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:43 george + * Version 109 + * + *) + +(* Stream: a structure implementing a lazy stream. The signature STREAM + is found in base.sig *) + +structure Stream :> STREAM = +struct + datatype 'a str = EVAL of 'a * 'a str ref | UNEVAL of (unit->'a) + + type 'a stream = 'a str ref + + fun get(ref(EVAL t)) = t + | get(s as ref(UNEVAL f)) = + let val t = (f(), ref(UNEVAL f)) in s := EVAL t; t end + + fun streamify f = ref(UNEVAL f) + fun cons(a,s) = ref(EVAL(a,s)) + +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.3 1996/10/03 03:36:58 jhr + * Qualified identifiers that are no-longer top-level (quot, rem, min, max). + * + * Revision 1.2 1996/02/26 15:02:29 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:42 george + * Version 109 + * + *) + +(* parser.sml: This is a parser driver for LR tables with an error-recovery + routine added to it. The routine used is described in detail in this + article: + + 'A Practical Method for LR and LL Syntactic Error Diagnosis and + Recovery', by M. Burke and G. Fisher, ACM Transactions on + Programming Langauges and Systems, Vol. 9, No. 2, April 1987, + pp. 164-197. + + This program is an implementation is the partial, deferred method discussed + in the article. The algorithm and data structures used in the program + are described below. + + This program assumes that all semantic actions are delayed. A semantic + action should produce a function from unit -> value instead of producing the + normal value. The parser returns the semantic value on the top of the + stack when accept is encountered. The user can deconstruct this value + and apply the unit -> value function in it to get the answer. + + It also assumes that the lexer is a lazy stream. + + Data Structures: + ---------------- + + * The parser: + + The state stack has the type + + (state * (semantic value * line # * line #)) list + + The parser keeps a queue of (state stack * lexer pair). A lexer pair + consists of a terminal * value pair and a lexer. This allows the + parser to reconstruct the states for terminals to the left of a + syntax error, and attempt to make error corrections there. + + The queue consists of a pair of lists (x,y). New additions to + the queue are cons'ed onto y. The first element of x is the top + of the queue. If x is nil, then y is reversed and used + in place of x. + + Algorithm: + ---------- + + * The steady-state parser: + + This parser keeps the length of the queue of state stacks at + a steady state by always removing an element from the front when + another element is placed on the end. + + It has these arguments: + + stack: current stack + queue: value of the queue + lexPair ((terminal,value),lex stream) + + When SHIFT is encountered, the state to shift to and the value are + are pushed onto the state stack. The state stack and lexPair are + placed on the queue. The front element of the queue is removed. + + When REDUCTION is encountered, the rule is applied to the current + stack to yield a triple (nonterm,value,new stack). A new + stack is formed by adding (goto(top state of stack,nonterm),value) + to the stack. + + When ACCEPT is encountered, the top value from the stack and the + lexer are returned. + + When an ERROR is encountered, fixError is called. FixError + takes the arguments to the parser, fixes the error if possible and + returns a new set of arguments. + + * The distance-parser: + + This parser includes an additional argument distance. It pushes + elements on the queue until it has parsed distance tokens, or an + ACCEPT or ERROR occurs. It returns a stack, lexer, the number of + tokens left unparsed, a queue, and an action option. +*) + +signature FIFO = + sig type 'a queue + val empty : 'a queue + exception Empty + val get : 'a queue -> 'a * 'a queue + val put : 'a * 'a queue -> 'a queue + end + +(* drt (12/15/89) -- the functor should be used in development work, but + it wastes space in the release version. + +functor ParserGen(structure LrTable : LR_TABLE + structure Stream : STREAM) : LR_PARSER = +*) + +structure LrParser :> LR_PARSER = + struct + structure LrTable = LrTable + structure Stream = Stream + + structure Token : TOKEN = + struct + structure LrTable = LrTable + datatype ('a,'b) token = TOKEN of LrTable.term * ('a * 'b * 'b) + val sameToken = fn (TOKEN(t,_),TOKEN(t',_)) => t=t' + end + + open LrTable + open Token + + val DEBUG1 = false + val DEBUG2 = false + exception ParseError + exception ParseImpossible of int + + structure Fifo :> FIFO = + struct + type 'a queue = ('a list * 'a list) + val empty = (nil,nil) + exception Empty + fun get(a::x, y) = (a, (x,y)) + | get(nil, nil) = raise Empty + | get(nil, y) = get(rev y, nil) + fun put(a,(x,y)) = (x,a::y) + end + + type ('a,'b) elem = (state * ('a * 'b * 'b)) + type ('a,'b) stack = ('a,'b) elem list + type ('a,'b) lexv = ('a,'b) token + type ('a,'b) lexpair = ('a,'b) lexv * (('a,'b) lexv Stream.stream) + type ('a,'b) distanceParse = + ('a,'b) lexpair * + ('a,'b) stack * + (('a,'b) stack * ('a,'b) lexpair) Fifo.queue * + int -> + ('a,'b) lexpair * + ('a,'b) stack * + (('a,'b) stack * ('a,'b) lexpair) Fifo.queue * + int * + action option + + type ('a,'b) ecRecord = + {is_keyword : term -> bool, + preferred_change : (term list * term list) list, + error : string * 'b * 'b -> unit, + errtermvalue : term -> 'a, + terms : term list, + showTerminal : term -> string, + noShift : term -> bool} + + local + val print = fn s => TextIO.output(TextIO.stdOut,s) + val println = fn s => (print s; print "\n") + val showState = fn (STATE s) => "STATE " ^ (Int.toString s) + in + fun printStack(stack: ('a,'b) stack, n: int) = + case stack + of (state,_) :: rest => + (print("\t" ^ Int.toString n ^ ": "); + println(showState state); + printStack(rest, n+1)) + | nil => () + + fun prAction showTerminal + (stack as (state,_) :: _, next as (TOKEN (term,_),_), action) = + (println "Parse: state stack:"; + printStack(stack, 0); + print(" state=" + ^ showState state + ^ " next=" + ^ showTerminal term + ^ " action=" + ); + case action + of SHIFT state => println ("SHIFT " ^ (showState state)) + | REDUCE i => println ("REDUCE " ^ (Int.toString i)) + | ERROR => println "ERROR" + | ACCEPT => println "ACCEPT") + | prAction _ (_,_,action) = () + end + + (* ssParse: parser which maintains the queue of (state * lexvalues) in a + steady-state. It takes a table, showTerminal function, saction + function, and fixError function. It parses until an ACCEPT is + encountered, or an exception is raised. When an error is encountered, + fixError is called with the arguments of parseStep (lexv,stack,and + queue). It returns the lexv, and a new stack and queue adjusted so + that the lexv can be parsed *) + + val ssParse = + fn (table,showTerminal,saction,fixError,arg) => + let val prAction = prAction showTerminal + val action = LrTable.action table + val goto = LrTable.goto table + fun parseStep(args as + (lexPair as (TOKEN (terminal, value as (_,leftPos,_)), + lexer + ), + stack as (state,_) :: _, + queue)) = + let val nextAction = action (state,terminal) + val _ = if DEBUG1 then prAction(stack,lexPair,nextAction) + else () + in case nextAction + of SHIFT s => + let val newStack = (s,value) :: stack + val newLexPair = Stream.get lexer + val (_,newQueue) =Fifo.get(Fifo.put((newStack,newLexPair), + queue)) + in parseStep(newLexPair,(s,value)::stack,newQueue) + end + | REDUCE i => + (case saction(i,leftPos,stack,arg) + of (nonterm,value,stack as (state,_) :: _) => + parseStep(lexPair,(goto(state,nonterm),value)::stack, + queue) + | _ => raise (ParseImpossible 197)) + | ERROR => parseStep(fixError args) + | ACCEPT => + (case stack + of (_,(topvalue,_,_)) :: _ => + let val (token,restLexer) = lexPair + in (topvalue,Stream.cons(token,restLexer)) + end + | _ => raise (ParseImpossible 202)) + end + | parseStep _ = raise (ParseImpossible 204) + in parseStep + end + + (* distanceParse: parse until n tokens are shifted, or accept or + error are encountered. Takes a table, showTerminal function, and + semantic action function. Returns a parser which takes a lexPair + (lex result * lexer), a state stack, a queue, and a distance + (must be > 0) to parse. The parser returns a new lex-value, a stack + with the nth token shifted on top, a queue, a distance, and action + option. *) + + val distanceParse = + fn (table,showTerminal,saction,arg) => + let val prAction = prAction showTerminal + val action = LrTable.action table + val goto = LrTable.goto table + fun parseStep(lexPair,stack,queue,0) = (lexPair,stack,queue,0,NONE) + | parseStep(lexPair as (TOKEN (terminal, value as (_,leftPos,_)), + lexer + ), + stack as (state,_) :: _, + queue,distance) = + let val nextAction = action(state,terminal) + val _ = if DEBUG1 then prAction(stack,lexPair,nextAction) + else () + in case nextAction + of SHIFT s => + let val newStack = (s,value) :: stack + val newLexPair = Stream.get lexer + in parseStep(newLexPair,(s,value)::stack, + Fifo.put((newStack,newLexPair),queue),distance-1) + end + | REDUCE i => + (case saction(i,leftPos,stack,arg) + of (nonterm,value,stack as (state,_) :: _) => + parseStep(lexPair,(goto(state,nonterm),value)::stack, + queue,distance) + | _ => raise (ParseImpossible 240)) + | ERROR => (lexPair,stack,queue,distance,SOME nextAction) + | ACCEPT => (lexPair,stack,queue,distance,SOME nextAction) + end + | parseStep _ = raise (ParseImpossible 242) + in parseStep : ('a,'b) distanceParse + end + +(* mkFixError: function to create fixError function which adjusts parser state + so that parse may continue in the presence of an error *) + +fun mkFixError({is_keyword,terms,errtermvalue, + preferred_change,noShift, + showTerminal,error,...} : ('a,'b) ecRecord, + distanceParse : ('a,'b) distanceParse, + minAdvance,maxAdvance) + + (lexv as (TOKEN (term,value as (_,leftPos,_)),_),stack,queue) = + let val _ = if DEBUG2 then + error("syntax error found at " ^ (showTerminal term), + leftPos,leftPos) + else () + + fun tokAt(t,p) = TOKEN(t,(errtermvalue t,p,p)) + + val minDelta = 3 + + (* pull all the state * lexv elements from the queue *) + + val stateList = + let fun f q = let val (elem,newQueue) = Fifo.get q + in elem :: (f newQueue) + end handle Fifo.Empty => nil + in f queue + end + + (* now number elements of stateList, giving distance from + error token *) + + val (_, numStateList) = + List.foldr (fn (a,(num,r)) => (num+1,(a,num)::r)) (0, []) stateList + + (* Represent the set of potential changes as a linked list. + + Values of datatype Change hold information about a potential change. + + oper = oper to be applied + pos = the # of the element in stateList that would be altered. + distance = the number of tokens beyond the error token which the + change allows us to parse. + new = new terminal * value pair at that point + orig = original terminal * value pair at the point being changed. + *) + + datatype ('a,'b) change = CHANGE of + {pos : int, distance : int, leftPos: 'b, rightPos: 'b, + new : ('a,'b) lexv list, orig : ('a,'b) lexv list} + + + val showTerms = concat o map (fn TOKEN(t,_) => " " ^ showTerminal t) + + val printChange = fn c => + let val CHANGE {distance,new,orig,pos,...} = c + in (print ("{distance= " ^ (Int.toString distance)); + print (",orig ="); print(showTerms orig); + print (",new ="); print(showTerms new); + print (",pos= " ^ (Int.toString pos)); + print "}\n") + end + + val printChangeList = app printChange + +(* parse: given a lexPair, a stack, and the distance from the error + token, return the distance past the error token that we are able to parse.*) + + fun parse (lexPair,stack,queuePos : int) = + case distanceParse(lexPair,stack,Fifo.empty,queuePos+maxAdvance+1) + of (_,_,_,distance,SOME ACCEPT) => + if maxAdvance-distance-1 >= 0 + then maxAdvance + else maxAdvance-distance-1 + | (_,_,_,distance,_) => maxAdvance - distance - 1 + +(* catList: concatenate results of scanning list *) + + fun catList l f = List.foldr (fn(a,r)=> f a @ r) [] l + + fun keywordsDelta new = if List.exists (fn(TOKEN(t,_))=>is_keyword t) new + then minDelta else 0 + + fun tryChange{lex,stack,pos,leftPos,rightPos,orig,new} = + let val lex' = List.foldr (fn (t',p)=>(t',Stream.cons p)) lex new + val distance = parse(lex',stack,pos+length new-length orig) + in if distance >= minAdvance + keywordsDelta new + then [CHANGE{pos=pos,leftPos=leftPos,rightPos=rightPos, + distance=distance,orig=orig,new=new}] + else [] + end + + +(* tryDelete: Try to delete n terminals. + Return single-element [success] or nil. + Do not delete unshiftable terminals. *) + + + fun tryDelete n ((stack,lexPair as (TOKEN(term,(_,l,r)),_)),qPos) = + let fun del(0,accum,left,right,lexPair) = + tryChange{lex=lexPair,stack=stack, + pos=qPos,leftPos=left,rightPos=right, + orig=rev accum, new=[]} + | del(n,accum,left,right,(tok as TOKEN(term,(_,_,r)),lexer)) = + if noShift term then [] + else del(n-1,tok::accum,left,r,Stream.get lexer) + in del(n,[],l,r,lexPair) + end + +(* tryInsert: try to insert tokens before the current terminal; + return a list of the successes *) + + fun tryInsert((stack,lexPair as (TOKEN(_,(_,l,_)),_)),queuePos) = + catList terms (fn t => + tryChange{lex=lexPair,stack=stack, + pos=queuePos,orig=[],new=[tokAt(t,l)], + leftPos=l,rightPos=l}) + +(* trySubst: try to substitute tokens for the current terminal; + return a list of the successes *) + + fun trySubst ((stack,lexPair as (orig as TOKEN (term,(_,l,r)),lexer)), + queuePos) = + if noShift term then [] + else + catList terms (fn t => + tryChange{lex=Stream.get lexer,stack=stack, + pos=queuePos, + leftPos=l,rightPos=r,orig=[orig], + new=[tokAt(t,r)]}) + + (* do_delete(toks,lexPair) tries to delete tokens "toks" from "lexPair". + If it succeeds, returns SOME(toks',l,r,lp), where + toks' is the actual tokens (with positions and values) deleted, + (l,r) are the (leftmost,rightmost) position of toks', + lp is what remains of the stream after deletion + *) + fun do_delete(nil,lp as (TOKEN(_,(_,l,_)),_)) = SOME(nil,l,l,lp) + | do_delete([t],(tok as TOKEN(t',(_,l,r)),lp')) = + if t=t' + then SOME([tok],l,r,Stream.get lp') + else NONE + | do_delete(t::rest,(tok as TOKEN(t',(_,l,r)),lp')) = + if t=t' + then case do_delete(rest,Stream.get lp') + of SOME(deleted,l',r',lp'') => + SOME(tok::deleted,l,r',lp'') + | NONE => NONE + else NONE + + fun tryPreferred((stack,lexPair),queuePos) = + catList preferred_change (fn (delete,insert) => + if List.exists noShift delete then [] (* should give warning at + parser-generation time *) + else case do_delete(delete,lexPair) + of SOME(deleted,l,r,lp) => + tryChange{lex=lp,stack=stack,pos=queuePos, + leftPos=l,rightPos=r,orig=deleted, + new=map (fn t=>(tokAt(t,r))) insert} + | NONE => []) + + val changes = catList numStateList tryPreferred @ + catList numStateList tryInsert @ + catList numStateList trySubst @ + catList numStateList (tryDelete 1) @ + catList numStateList (tryDelete 2) @ + catList numStateList (tryDelete 3) + + val findMaxDist = fn l => + foldr (fn (CHANGE {distance,...},high) => Int.max(distance,high)) 0 l + +(* maxDist: max distance past error taken that we could parse *) + + val maxDist = findMaxDist changes + +(* remove changes which did not parse maxDist tokens past the error token *) + + val changes = catList changes + (fn(c as CHANGE{distance,...}) => + if distance=maxDist then [c] else []) + + in case changes + of (l as change :: _) => + let fun print_msg (CHANGE {new,orig,leftPos,rightPos,...}) = + let val s = + case (orig,new) + of (_::_,[]) => "deleting " ^ (showTerms orig) + | ([],_::_) => "inserting " ^ (showTerms new) + | _ => "replacing " ^ (showTerms orig) ^ + " with " ^ (showTerms new) + in error ("syntax error: " ^ s,leftPos,rightPos) + end + + val _ = + (if length l > 1 andalso DEBUG2 then + (print "multiple fixes possible; could fix it by:\n"; + app print_msg l; + print "chosen correction:\n") + else (); + print_msg change) + + (* findNth: find nth queue entry from the error + entry. Returns the Nth queue entry and the portion of + the queue from the beginning to the nth-1 entry. The + error entry is at the end of the queue. + + Examples: + + queue = a b c d e + findNth 0 = (e,a b c d) + findNth 1 = (d,a b c) + *) + + val findNth = fn n => + let fun f (h::t,0) = (h,rev t) + | f (h::t,n) = f(t,n-1) + | f (nil,_) = let exception FindNth + in raise FindNth + end + in f (rev stateList,n) + end + + val CHANGE {pos,orig,new,...} = change + val (last,queueFront) = findNth pos + val (stack,lexPair) = last + + val lp1 = foldl(fn (_,(_,r)) => Stream.get r) lexPair orig + val lp2 = foldr(fn(t,r)=>(t,Stream.cons r)) lp1 new + + val restQueue = + Fifo.put((stack,lp2), + foldl Fifo.put Fifo.empty queueFront) + + val (lexPair,stack,queue,_,_) = + distanceParse(lp2,stack,restQueue,pos) + + in (lexPair,stack,queue) + end + | nil => (error("syntax error found at " ^ (showTerminal term), + leftPos,leftPos); raise ParseError) + end + + val parse = fn {arg,table,lexer,saction,void,lookahead, + ec=ec as {showTerminal,...} : ('a,'b) ecRecord} => + let val distance = 15 (* defer distance tokens *) + val minAdvance = 1 (* must parse at least 1 token past error *) + val maxAdvance = Int.max(lookahead,0)(* max distance for parse check *) + val lexPair = Stream.get lexer + val (TOKEN (_,(_,leftPos,_)),_) = lexPair + val startStack = [(initialState table,(void,leftPos,leftPos))] + val startQueue = Fifo.put((startStack,lexPair),Fifo.empty) + val distanceParse = distanceParse(table,showTerminal,saction,arg) + val fixError = mkFixError(ec,distanceParse,minAdvance,maxAdvance) + val ssParse = ssParse(table,showTerminal,saction,fixError,arg) + fun loop (lexPair,stack,queue,_,SOME ACCEPT) = + ssParse(lexPair,stack,queue) + | loop (lexPair,stack,queue,0,_) = ssParse(lexPair,stack,queue) + | loop (lexPair,stack,queue,distance,SOME ERROR) = + let val (lexPair,stack,queue) = fixError(lexPair,stack,queue) + in loop (distanceParse(lexPair,stack,queue,distance)) + end + | loop _ = let exception ParseInternal + in raise ParseInternal + end + in loop (distanceParse(lexPair,startStack,startQueue,distance)) + end + end; + +(* drt (12/15/89) -- needed only when the code above is functorized + +structure LrParser = ParserGen(structure LrTable=LrTable + structure Stream=Stream); +*) +functor LexMLYACC(structure Tokens : Mlyacc_TOKENS + structure Hdr : HEADER + where type prec = Header.prec + and type inputSource = Header.inputSource + and type pos = int) + : ARG_LEXER = + struct + structure UserDeclarations = + struct +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + + yacc.lex: Lexer specification + *) + +structure Tokens = Tokens +type svalue = Tokens.svalue +type pos = int +type ('a,'b) token = ('a,'b) Tokens.token +type lexresult = (svalue,pos) token + +type lexarg = Hdr.inputSource +type arg = lexarg + +open Tokens +val error = Hdr.error +val lineno = Hdr.lineno +val text = Hdr.text + +val pcount = ref 0 +val commentLevel = ref 0 +val actionstart = ref 0 + +val eof = fn i => (if (!pcount)>0 then + error i (!actionstart) + " eof encountered in action beginning here !" + else (); EOF(!lineno,!lineno)) + +val Add = fn s => (text := s::(!text)) + +local val dict = [("%prec",PREC_TAG),("%term",TERM), + ("%nonterm",NONTERM), ("%eop",PERCENT_EOP),("%start",START), + ("%prefer",PREFER),("%subst",SUBST),("%change",CHANGE), + ("%keyword",KEYWORD),("%name",NAME), + ("%verbose",VERBOSE), ("%nodefault",NODEFAULT), + ("%value",VALUE), ("%noshift",NOSHIFT), + ("%header",PERCENT_HEADER),("%pure",PERCENT_PURE), + ("%arg",PERCENT_ARG), + ("%pos",PERCENT_POS)] +in val lookup = + fn (s,left,right) => + let fun f ((a,d)::b) = if a=s then d(left,right) else f b + | f nil = UNKNOWN(s,left,right) + in f dict + end +end + +fun inc (ri as ref i) = (ri := i+1) +fun dec (ri as ref i) = (ri := i-1) + +end (* end of user routines *) +exception LexError (* raised if illegal leaf action tried *) +structure Internal = + struct + +datatype yyfinstate = N of int +type statedata = {fin : yyfinstate list, trans: string} +(* transition & final state table *) +val tab = let +val s0 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s1 = +"\015\015\015\015\015\015\015\015\015\015\021\015\015\015\015\015\ +\\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\ +\\015\015\015\015\015\019\015\015\017\015\015\015\015\015\015\015\ +\\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\ +\\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\ +\\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\ +\\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\ +\\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\015\ +\\015" +val s3 = +"\022\022\022\022\022\022\022\022\022\065\067\022\022\022\022\022\ +\\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\ +\\065\022\022\022\022\045\022\043\041\022\040\022\039\037\022\022\ +\\035\035\035\035\035\035\035\035\035\035\034\022\022\022\022\022\ +\\022\026\026\026\026\026\026\026\026\026\026\026\026\026\026\026\ +\\026\026\026\026\026\026\026\026\026\026\026\022\022\022\022\022\ +\\022\026\026\026\026\026\031\026\026\026\026\026\026\026\026\029\ +\\026\026\026\026\026\026\026\026\026\026\026\025\024\023\022\022\ +\\022" +val s5 = +"\068\068\068\068\068\068\068\068\068\068\021\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\072\068\068\068\068\068\070\069\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068" +val s7 = +"\073\073\073\073\073\073\073\073\073\075\021\073\073\073\073\073\ +\\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\ +\\075\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\ +\\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\ +\\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\ +\\073\073\073\073\073\073\073\073\073\073\073\073\074\073\073\073\ +\\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\ +\\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\073\ +\\073" +val s9 = +"\077\077\077\077\077\077\077\077\077\077\021\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\081\080\078\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077" +val s11 = +"\083\083\083\083\083\083\083\083\083\083\088\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\087\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\084\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083" +val s13 = +"\089\089\089\089\089\089\089\089\089\089\021\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\093\092\090\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089" +val s15 = +"\016\016\016\016\016\016\016\016\016\016\000\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\000\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016" +val s17 = +"\016\016\016\016\016\016\016\016\016\016\000\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\000\016\016\016\016\018\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\016\ +\\016" +val s19 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\020\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s26 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\028\000\ +\\027\027\027\027\027\027\027\027\027\027\000\000\000\000\000\000\ +\\000\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\000\000\000\000\027\ +\\000\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\000\000\000\000\000\ +\\000" +val s29 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\028\000\ +\\027\027\027\027\027\027\027\027\027\027\000\000\000\000\000\000\ +\\000\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\000\000\000\000\027\ +\\000\027\027\027\027\027\030\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\000\000\000\000\000\ +\\000" +val s31 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\028\000\ +\\027\027\027\027\027\027\027\027\027\027\000\000\000\000\000\000\ +\\000\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\000\000\000\000\027\ +\\000\027\027\027\027\027\027\027\027\027\027\027\027\027\027\032\ +\\027\027\027\027\027\027\027\027\027\027\027\000\000\000\000\000\ +\\000" +val s32 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\027\000\000\000\000\000\000\028\000\ +\\027\027\027\027\027\027\027\027\027\027\000\000\000\000\000\000\ +\\000\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\000\000\000\000\027\ +\\000\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\033\027\027\027\027\027\027\027\027\000\000\000\000\000\ +\\000" +val s35 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\036\036\036\036\036\036\036\036\036\036\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s37 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\038\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s41 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\042\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s43 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\044\000\000\000\000\000\000\000\000\ +\\044\044\044\044\044\044\044\044\044\044\000\000\000\000\000\000\ +\\000\044\044\044\044\044\044\044\044\044\044\044\044\044\044\044\ +\\044\044\044\044\044\044\044\044\044\044\044\000\000\000\000\044\ +\\000\044\044\044\044\044\044\044\044\044\044\044\044\044\044\044\ +\\044\044\044\044\044\044\044\044\044\044\044\000\000\000\000\000\ +\\000" +val s45 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\064\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\046\046\046\060\046\052\046\ +\\046\046\047\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s46 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\046\046\046\046\046\046\046\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s47 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\048\046\046\046\046\046\046\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s48 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\049\046\046\046\046\046\046\046\046\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s49 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\050\046\046\046\046\046\046\046\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s50 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\046\046\046\046\046\046\046\ +\\046\046\046\046\051\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s52 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\046\046\046\046\046\046\053\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s53 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\046\046\046\046\046\054\046\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s54 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\055\046\046\046\046\046\046\046\046\046\046\046\046\046\046\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s55 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\046\046\046\046\046\046\046\ +\\046\046\046\056\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s56 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\046\046\046\046\046\046\046\ +\\046\046\046\057\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s57 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\046\046\046\046\046\046\058\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s58 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\059\046\046\046\046\046\046\046\046\046\046\046\046\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s60 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\061\046\046\046\046\046\046\046\046\046\046\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s61 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\062\046\046\046\046\046\046\046\046\046\ +\\046\046\046\046\046\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s62 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\046\ +\\000\046\046\046\046\046\046\046\046\046\046\046\046\046\046\046\ +\\046\046\046\046\063\046\046\046\046\046\046\000\000\000\000\000\ +\\000" +val s65 = +"\000\000\000\000\000\000\000\000\000\066\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\066\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s68 = +"\068\068\068\068\068\068\068\068\068\068\000\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\000\068\068\068\068\068\000\000\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\068\ +\\068" +val s70 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\071\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s75 = +"\000\000\000\000\000\000\000\000\000\076\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\076\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s77 = +"\077\077\077\077\077\077\077\077\077\077\000\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\000\000\000\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\077\ +\\077" +val s78 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\079\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s81 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\082\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s83 = +"\083\083\083\083\083\083\083\083\083\083\000\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\000\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\000\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\083\ +\\083" +val s84 = +"\000\000\000\000\000\000\000\000\000\086\086\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\086\000\085\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s89 = +"\089\089\089\089\089\089\089\089\089\089\000\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\000\000\000\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\089\ +\\089" +val s90 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\091\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +val s93 = +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\094\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +in Vector.fromList +[{fin = [], trans = s0}, +{fin = [], trans = s1}, +{fin = [], trans = s1}, +{fin = [], trans = s3}, +{fin = [], trans = s3}, +{fin = [], trans = s5}, +{fin = [], trans = s5}, +{fin = [], trans = s7}, +{fin = [], trans = s7}, +{fin = [], trans = s9}, +{fin = [], trans = s9}, +{fin = [], trans = s11}, +{fin = [], trans = s11}, +{fin = [], trans = s13}, +{fin = [], trans = s13}, +{fin = [(N 11),(N 18)], trans = s15}, +{fin = [(N 11)], trans = s15}, +{fin = [(N 11),(N 18)], trans = s17}, +{fin = [(N 2),(N 11)], trans = s15}, +{fin = [(N 18)], trans = s19}, +{fin = [(N 14)], trans = s0}, +{fin = [(N 16)], trans = s0}, +{fin = [(N 94)], trans = s0}, +{fin = [(N 36),(N 94)], trans = s0}, +{fin = [(N 87),(N 94)], trans = s0}, +{fin = [(N 34),(N 94)], trans = s0}, +{fin = [(N 90),(N 94)], trans = s26}, +{fin = [(N 90)], trans = s26}, +{fin = [(N 77)], trans = s0}, +{fin = [(N 90),(N 94)], trans = s29}, +{fin = [(N 28),(N 90)], trans = s26}, +{fin = [(N 90),(N 94)], trans = s31}, +{fin = [(N 90)], trans = s32}, +{fin = [(N 32),(N 90)], trans = s26}, +{fin = [(N 85),(N 94)], trans = s0}, +{fin = [(N 80),(N 94)], trans = s35}, +{fin = [(N 80)], trans = s35}, +{fin = [(N 94)], trans = s37}, +{fin = [(N 43)], trans = s0}, +{fin = [(N 38),(N 94)], trans = s0}, +{fin = [(N 40),(N 94)], trans = s0}, +{fin = [(N 92),(N 94)], trans = s41}, +{fin = [(N 5)], trans = s0}, +{fin = [(N 73),(N 94)], trans = s43}, +{fin = [(N 73)], trans = s43}, +{fin = [(N 94)], trans = s45}, +{fin = [(N 70)], trans = s46}, +{fin = [(N 70)], trans = s47}, +{fin = [(N 70)], trans = s48}, +{fin = [(N 70)], trans = s49}, +{fin = [(N 70)], trans = s50}, +{fin = [(N 56),(N 70)], trans = s46}, +{fin = [(N 70)], trans = s52}, +{fin = [(N 70)], trans = s53}, +{fin = [(N 70)], trans = s54}, +{fin = [(N 70)], trans = s55}, +{fin = [(N 70)], trans = s56}, +{fin = [(N 70)], trans = s57}, +{fin = [(N 70)], trans = s58}, +{fin = [(N 66),(N 70)], trans = s46}, +{fin = [(N 70)], trans = s60}, +{fin = [(N 70)], trans = s61}, +{fin = [(N 70)], trans = s62}, +{fin = [(N 49),(N 70)], trans = s46}, +{fin = [(N 83)], trans = s0}, +{fin = [(N 25),(N 94)], trans = s65}, +{fin = [(N 25)], trans = s65}, +{fin = [(N 20)], trans = s0}, +{fin = [(N 103)], trans = s68}, +{fin = [(N 98)], trans = s0}, +{fin = [(N 96)], trans = s70}, +{fin = [(N 8)], trans = s0}, +{fin = [(N 100)], trans = s0}, +{fin = [(N 147)], trans = s0}, +{fin = [(N 145),(N 147)], trans = s0}, +{fin = [(N 143),(N 147)], trans = s75}, +{fin = [(N 143)], trans = s75}, +{fin = [(N 114)], trans = s77}, +{fin = [(N 105)], trans = s78}, +{fin = [(N 108)], trans = s0}, +{fin = [(N 105)], trans = s0}, +{fin = [(N 105)], trans = s81}, +{fin = [(N 111)], trans = s0}, +{fin = [(N 134)], trans = s83}, +{fin = [(N 129)], trans = s84}, +{fin = [(N 137)], trans = s0}, +{fin = [(N 140)], trans = s0}, +{fin = [(N 127)], trans = s0}, +{fin = [(N 131)], trans = s0}, +{fin = [(N 125)], trans = s89}, +{fin = [(N 116)], trans = s90}, +{fin = [(N 119)], trans = s0}, +{fin = [(N 116)], trans = s0}, +{fin = [(N 116)], trans = s93}, +{fin = [(N 122)], trans = s0}] +end +structure StartStates = + struct + datatype yystartstate = STARTSTATE of int + +(* start state definitions *) + +val A = STARTSTATE 3; +val CODE = STARTSTATE 5; +val COMMENT = STARTSTATE 9; +val EMPTYCOMMENT = STARTSTATE 13; +val F = STARTSTATE 7; +val INITIAL = STARTSTATE 1; +val STRING = STARTSTATE 11; + +end +type result = UserDeclarations.lexresult + exception LexerError (* raised if illegal leaf action tried *) +end + +fun makeLexer yyinput = +let + val yyb = ref "\n" (* buffer *) + val yybl = ref 1 (*buffer length *) + val yybufpos = ref 1 (* location of next character to use *) + val yygone = ref 1 (* position in file of beginning of buffer *) + val yydone = ref false (* eof found yet? *) + val yybegin = ref 1 (*Current 'start state' for lexer *) + + val YYBEGIN = fn (Internal.StartStates.STARTSTATE x) => + yybegin := x + +fun lex (yyarg as (inputSource)) = +let fun continue() : Internal.result = + let fun scan (s,AcceptingLeaves : Internal.yyfinstate list list,l,i0) = + let fun action (i,nil) = raise LexError + | action (i,nil::l) = action (i-1,l) + | action (i,(node::acts)::l) = + case node of + Internal.N yyk => + (let val yytext = substring(!yyb,i0,i-i0) + val yypos = i0+ !yygone + open UserDeclarations Internal.StartStates + in (yybufpos := i; case yyk of + + (* Application actions *) + + 100 => (Add yytext; YYBEGIN STRING; continue()) +| 103 => (Add yytext; continue()) +| 105 => (Add yytext; continue()) +| 108 => (Add yytext; dec commentLevel; + if !commentLevel=0 + then BOGUS_VALUE(!lineno,!lineno) + else continue() + ) +| 11 => (Add yytext; continue()) +| 111 => (Add yytext; inc commentLevel; continue()) +| 114 => (Add yytext; continue()) +| 116 => (continue()) +| 119 => (dec commentLevel; + if !commentLevel=0 then YYBEGIN A else (); + continue ()) +| 122 => (inc commentLevel; continue()) +| 125 => (continue()) +| 127 => (Add yytext; YYBEGIN CODE; continue()) +| 129 => (Add yytext; continue()) +| 131 => (Add yytext; error inputSource (!lineno) "unclosed string"; + inc lineno; YYBEGIN CODE; continue()) +| 134 => (Add yytext; continue()) +| 137 => (Add yytext; continue()) +| 14 => (YYBEGIN A; HEADER (concat (rev (!text)),!lineno,!lineno)) +| 140 => (Add yytext; + if substring(yytext,1,1)="\n" then inc lineno else (); + YYBEGIN F; continue()) +| 143 => (Add yytext; continue()) +| 145 => (Add yytext; YYBEGIN STRING; continue()) +| 147 => (Add yytext; error inputSource (!lineno) "unclosed string"; + YYBEGIN CODE; continue()) +| 16 => (Add yytext; inc lineno; continue()) +| 18 => (Add yytext; continue()) +| 2 => (Add yytext; YYBEGIN COMMENT; commentLevel := 1; + continue() before YYBEGIN INITIAL) +| 20 => (inc lineno; continue ()) +| 25 => (continue()) +| 28 => (OF(!lineno,!lineno)) +| 32 => (FOR(!lineno,!lineno)) +| 34 => (LBRACE(!lineno,!lineno)) +| 36 => (RBRACE(!lineno,!lineno)) +| 38 => (COMMA(!lineno,!lineno)) +| 40 => (ASTERISK(!lineno,!lineno)) +| 43 => (ARROW(!lineno,!lineno)) +| 49 => (PREC(Hdr.LEFT,!lineno,!lineno)) +| 5 => (YYBEGIN EMPTYCOMMENT; commentLevel := 1; continue()) +| 56 => (PREC(Hdr.RIGHT,!lineno,!lineno)) +| 66 => (PREC(Hdr.NONASSOC,!lineno,!lineno)) +| 70 => (lookup(yytext,!lineno,!lineno)) +| 73 => (TYVAR(yytext,!lineno,!lineno)) +| 77 => (IDDOT(yytext,!lineno,!lineno)) +| 8 => (Add yytext; YYBEGIN COMMENT; commentLevel := 1; + continue() before YYBEGIN CODE) +| 80 => (INT (yytext,!lineno,!lineno)) +| 83 => (DELIMITER(!lineno,!lineno)) +| 85 => (COLON(!lineno,!lineno)) +| 87 => (BAR(!lineno,!lineno)) +| 90 => (ID ((yytext,!lineno),!lineno,!lineno)) +| 92 => (pcount := 1; actionstart := (!lineno); + text := nil; YYBEGIN CODE; continue() before YYBEGIN A) +| 94 => (UNKNOWN(yytext,!lineno,!lineno)) +| 96 => (inc pcount; Add yytext; continue()) +| 98 => (dec pcount; + if !pcount = 0 then + PROG (concat (rev (!text)),!lineno,!lineno) + else (Add yytext; continue())) +| _ => raise Internal.LexerError + + ) end ) + + val {fin,trans} = Vector.sub(Internal.tab, s) + val NewAcceptingLeaves = fin::AcceptingLeaves + in if l = !yybl then + if trans = #trans(Vector.sub(Internal.tab,0)) + then action(l,NewAcceptingLeaves +) else let val newchars= if !yydone then "" else yyinput 1024 + in if (size newchars)=0 + then (yydone := true; + if (l=i0) then UserDeclarations.eof yyarg + else action(l,NewAcceptingLeaves)) + else (if i0=l then yyb := newchars + else yyb := substring(!yyb,i0,l-i0)^newchars; + yygone := !yygone+i0; + yybl := size (!yyb); + scan (s,AcceptingLeaves,l-i0,0)) + end + else let val NewChar = Char.ord(String.sub(!yyb,l)) + val NewState = if NewChar<128 then Char.ord(String.sub(trans,NewChar)) else Char.ord(String.sub(trans,128)) + in if NewState=0 then action(l,NewAcceptingLeaves) + else scan(NewState,NewAcceptingLeaves,l+1,i0) + end + end +(* + val start= if substring(!yyb,!yybufpos-1,1)="\n" +then !yybegin+1 else !yybegin +*) + in scan(!yybegin (* start *),nil,!yybufpos,!yybufpos) + end +in continue end + in lex + end +end +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:42 george + * Version 109 + * + *) + +(* functor Join creates a user parser by putting together a Lexer structure, + an LrValues structure, and a polymorphic parser structure. Note that + the Lexer and LrValues structure must share the type pos (i.e. the type + of line numbers), the type svalues for semantic values, and the type + of tokens. +*) + +functor Join(structure Lex : LEXER + structure ParserData: PARSER_DATA + structure LrParser : LR_PARSER + sharing ParserData.LrTable = LrParser.LrTable + sharing ParserData.Token = LrParser.Token + sharing type Lex.UserDeclarations.svalue = ParserData.svalue + sharing type Lex.UserDeclarations.pos = ParserData.pos + sharing type Lex.UserDeclarations.token = ParserData.Token.token) + : PARSER = +struct + structure Token = ParserData.Token + structure Stream = LrParser.Stream + + exception ParseError = LrParser.ParseError + + type arg = ParserData.arg + type pos = ParserData.pos + type result = ParserData.result + type svalue = ParserData.svalue + val makeLexer = LrParser.Stream.streamify o Lex.makeLexer + val parse = fn (lookahead,lexer,error,arg) => + (fn (a,b) => (ParserData.Actions.extract a,b)) + (LrParser.parse {table = ParserData.table, + lexer=lexer, + lookahead=lookahead, + saction = ParserData.Actions.actions, + arg=arg, + void= ParserData.Actions.void, + ec = {is_keyword = ParserData.EC.is_keyword, + noShift = ParserData.EC.noShift, + preferred_change = ParserData.EC.preferred_change, + errtermvalue = ParserData.EC.errtermvalue, + error=error, + showTerminal = ParserData.EC.showTerminal, + terms = ParserData.EC.terms}} + ) + val sameToken = Token.sameToken +end + +(* functor JoinWithArg creates a variant of the parser structure produced + above. In this case, the makeLexer take an additional argument before + yielding a value of type unit -> (svalue,pos) token + *) + +functor JoinWithArg(structure Lex : ARG_LEXER + structure ParserData: PARSER_DATA + structure LrParser : LR_PARSER + sharing ParserData.LrTable = LrParser.LrTable + sharing ParserData.Token = LrParser.Token + sharing type Lex.UserDeclarations.svalue = ParserData.svalue + sharing type Lex.UserDeclarations.pos = ParserData.pos + sharing type Lex.UserDeclarations.token = ParserData.Token.token) + : ARG_PARSER = +struct + structure Token = ParserData.Token + structure Stream = LrParser.Stream + + exception ParseError = LrParser.ParseError + + type arg = ParserData.arg + type lexarg = Lex.UserDeclarations.arg + type pos = ParserData.pos + type result = ParserData.result + type svalue = ParserData.svalue + + val makeLexer = fn s => fn arg => + LrParser.Stream.streamify (Lex.makeLexer s arg) + val parse = fn (lookahead,lexer,error,arg) => + (fn (a,b) => (ParserData.Actions.extract a,b)) + (LrParser.parse {table = ParserData.table, + lexer=lexer, + lookahead=lookahead, + saction = ParserData.Actions.actions, + arg=arg, + void= ParserData.Actions.void, + ec = {is_keyword = ParserData.EC.is_keyword, + noShift = ParserData.EC.noShift, + preferred_change = ParserData.EC.preferred_change, + errtermvalue = ParserData.EC.errtermvalue, + error=error, + showTerminal = ParserData.EC.showTerminal, + terms = ParserData.EC.terms}} + ) + val sameToken = Token.sameToken +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.2 1996/02/26 15:02:38 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:46 george + * Version 109 + * + *) + +functor ParseGenParserFun(S : sig + structure Parser : ARG_PARSER + structure Header : HEADER + sharing type Parser.pos = Header.pos + sharing type Parser.result = Header.parseResult + sharing type Parser.arg = Header.inputSource = + Parser.lexarg + end where type Header.pos = int + ) : PARSE_GEN_PARSER = + + struct + open S + structure Header = Header + val parse = fn file => + let + val in_str = TextIO.openIn file + val source = Header.newSource(file,in_str,TextIO.stdOut) + val error = fn (s : string,i:int,_) => + Header.error source i s + val stream = Parser.makeLexer (fn i => (TextIO.inputN(in_str,i))) + source + val (result,_) = (Header.lineno := 1; + Header.text := nil; + Parser.parse(15,stream,error,source)) + in (TextIO.closeIn in_str; (result,source)) + end + end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:47 george + * Version 109 + * + *) + +(* Implementation of ordered sets using ordered lists and red-black trees. The + code for red-black trees was originally written by Norris Boyd, which was + modified for use here. +*) + +(* ordered sets implemented using ordered lists. + + Upper bound running times for functions implemented here: + + app = O(n) + card = O(n) + closure = O(n^2) + difference = O(n+m), where n,m = the size of the two sets used here. + empty = O(1) + exists = O(n) + find = O(n) + fold = O(n) + insert = O(n) + is_empty = O(1) + make_list = O(1) + make_set = O(n^2) + partition = O(n) + remove = O(n) + revfold = O(n) + select_arb = O(1) + set_eq = O(n), where n = the cardinality of the smaller set + set_gt = O(n), ditto + singleton = O(1) + union = O(n+m) +*) + +functor ListOrdSet(B : sig type elem + val gt : elem * elem -> bool + val eq : elem * elem -> bool + end ) : ORDSET = + +struct + type elem = B.elem + val elem_gt = B.gt + val elem_eq = B.eq + + type set = elem list + exception Select_arb + val empty = nil + + val insert = fn (key,s) => + let fun f (l as (h::t)) = + if elem_gt(key,h) then h::(f t) + else if elem_eq(key,h) then key::t + else key::l + | f nil = [key] + in f s + end + + val select_arb = fn nil => raise Select_arb + | a::b => a + + val exists = fn (key,s) => + let fun f (h::t) = if elem_gt(key,h) then f t + else elem_eq(h,key) + | f nil = false + in f s + end + + val find = fn (key,s) => + let fun f (h::t) = if elem_gt(key,h) then f t + else if elem_eq(h,key) then SOME h + else NONE + | f nil = NONE + in f s + end + + fun revfold f lst init = List.foldl f init lst + fun fold f lst init = List.foldr f init lst + val app = List.app + +fun set_eq(h::t,h'::t') = + (case elem_eq(h,h') + of true => set_eq(t,t') + | a => a) + | set_eq(nil,nil) = true + | set_eq _ = false + +fun set_gt(h::t,h'::t') = + (case elem_gt(h,h') + of false => (case (elem_eq(h,h')) + of true => set_gt(t,t') + | a => a) + | a => a) + | set_gt(_::_,nil) = true + | set_gt _ = false + +fun union(a as (h::t),b as (h'::t')) = + if elem_gt(h',h) then h::union(t,b) + else if elem_eq(h,h') then h::union(t,t') + else h'::union(a,t') + | union(nil,s) = s + | union(s,nil) = s + +val make_list = fn s => s + +val is_empty = fn nil => true | _ => false + +val make_set = fn l => List.foldr insert [] l + +val partition = fn f => fn s => + fold (fn (e,(yes,no)) => + if (f e) then (e::yes,no) else (e::no,yes)) s (nil,nil) + +val remove = fn (e,s) => + let fun f (l as (h::t)) = if elem_gt(h,e) then l + else if elem_eq(h,e) then t + else h::(f t) + | f nil = nil + in f s + end + + (* difference: X-Y *) + + fun difference (nil,_) = nil + | difference (r,nil) = r + | difference (a as (h::t),b as (h'::t')) = + if elem_gt (h',h) then h::difference(t,b) + else if elem_eq(h',h) then difference(t,t') + else difference(a,t') + + fun singleton X = [X] + + fun card(S) = fold (fn (a,count) => count+1) S 0 + + local + fun closure'(from, f, result) = + if is_empty from then result + else + let val (more,result) = + fold (fn (a,(more',result')) => + let val more = f a + val new = difference(more,result) + in (union(more',new),union(result',new)) + end) from + (empty,result) + in closure'(more,f,result) + end + in + fun closure(start, f) = closure'(start, f, start) + end +end + +(* ordered set implemented using red-black trees: + + Upper bound running time of the functions below: + + app: O(n) + card: O(n) + closure: O(n^2 ln n) + difference: O(n ln n) + empty: O(1) + exists: O(ln n) + find: O(ln n) + fold: O(n) + insert: O(ln n) + is_empty: O(1) + make_list: O(n) + make_set: O(n ln n) + partition: O(n ln n) + remove: O(n ln n) + revfold: O(n) + select_arb: O(1) + set_eq: O(n) + set_gt: O(n) + singleton: O(1) + union: O(n ln n) +*) + +functor RbOrdSet (B : sig type elem + val eq : (elem*elem) -> bool + val gt : (elem*elem) -> bool + end + ) : ORDSET = +struct + + type elem = B.elem + val elem_gt = B.gt + val elem_eq = B.eq + + datatype Color = RED | BLACK + + abstype set = EMPTY | TREE of (B.elem * Color * set * set) + with exception Select_arb + val empty = EMPTY + + fun insert(key,t) = + let fun f EMPTY = TREE(key,RED,EMPTY,EMPTY) + | f (TREE(k,BLACK,l,r)) = + if elem_gt (key,k) + then case f r + of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) => + (case l + of TREE(lk,RED,ll,lr) => + TREE(k,RED,TREE(lk,BLACK,ll,lr), + TREE(rk,BLACK,rl,rr)) + | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll), + TREE(rk,RED,rlr,rr))) + | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) => + (case l + of TREE(lk,RED,ll,lr) => + TREE(k,RED,TREE(lk,BLACK,ll,lr), + TREE(rk,BLACK,rl,rr)) + | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr)) + | r => TREE(k,BLACK,l,r) + else if elem_gt(k,key) + then case f l + of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) => + (case r + of TREE(rk,RED,rl,rr) => + TREE(k,RED,TREE(lk,BLACK,ll,lr), + TREE(rk,BLACK,rl,rr)) + | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl), + TREE(k,RED,lrr,r))) + | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) => + (case r + of TREE(rk,RED,rl,rr) => + TREE(k,RED,TREE(lk,BLACK,ll,lr), + TREE(rk,BLACK,rl,rr)) + | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r))) + | l => TREE(k,BLACK,l,r) + else TREE(key,BLACK,l,r) + | f (TREE(k,RED,l,r)) = + if elem_gt(key,k) then TREE(k,RED,l, f r) + else if elem_gt(k,key) then TREE(k,RED, f l, r) + else TREE(key,RED,l,r) + in case f t + of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r) + | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r) + | t => t + end + + fun select_arb (TREE(k,_,l,r)) = k + | select_arb EMPTY = raise Select_arb + + fun exists(key,t) = + let fun look EMPTY = false + | look (TREE(k,_,l,r)) = + if elem_gt(k,key) then look l + else if elem_gt(key,k) then look r + else true + in look t + end + + fun find(key,t) = + let fun look EMPTY = NONE + | look (TREE(k,_,l,r)) = + if elem_gt(k,key) then look l + else if elem_gt(key,k) then look r + else SOME k + in look t + end + + fun revfold f t start = + let fun scan (EMPTY,value) = value + | scan (TREE(k,_,l,r),value) = scan(r,f(k,scan(l,value))) + in scan(t,start) + end + + fun fold f t start = + let fun scan(EMPTY,value) = value + | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value))) + in scan(t,start) + end + + fun app f t = + let fun scan EMPTY = () + | scan(TREE(k,_,l,r)) = (scan l; f k; scan r) + in scan t + end + +(* equal_tree : test if two trees are equal. Two trees are equal if + the set of leaves are equal *) + + fun set_eq (tree1 as (TREE _),tree2 as (TREE _)) = + let datatype pos = L | R | M + exception Done + fun getvalue(stack as ((a,position)::b)) = + (case a + of (TREE(k,_,l,r)) => + (case position + of L => getvalue ((l,L)::(a,M)::b) + | M => (k,case r of EMPTY => b | _ => (a,R)::b) + | R => getvalue ((r,L)::b) + ) + | EMPTY => getvalue b + ) + | getvalue(nil) = raise Done + fun f (nil,nil) = true + | f (s1 as (_ :: _),s2 as (_ :: _ )) = + let val (v1,news1) = getvalue s1 + and (v2,news2) = getvalue s2 + in (elem_eq(v1,v2)) andalso f(news1,news2) + end + | f _ = false + in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false + end + | set_eq (EMPTY,EMPTY) = true + | set_eq _ = false + + (* gt_tree : Test if tree1 is greater than tree 2 *) + + fun set_gt (tree1,tree2) = + let datatype pos = L | R | M + exception Done + fun getvalue(stack as ((a,position)::b)) = + (case a + of (TREE(k,_,l,r)) => + (case position + of L => getvalue ((l,L)::(a,M)::b) + | M => (k,case r of EMPTY => b | _ => (a,R)::b) + | R => getvalue ((r,L)::b) + ) + | EMPTY => getvalue b + ) + | getvalue(nil) = raise Done + fun f (nil,nil) = false + | f (s1 as (_ :: _),s2 as (_ :: _ )) = + let val (v1,news1) = getvalue s1 + and (v2,news2) = getvalue s2 + in (elem_gt(v1,v2)) orelse (elem_eq(v1,v2) andalso f(news1,news2)) + end + | f (_,nil) = true + | f (nil,_) = false + in f ((tree1,L)::nil,(tree2,L)::nil) handle Done => false + end + + fun is_empty S = (let val _ = select_arb S in false end + handle Select_arb => true) + + fun make_list S = fold (op ::) S nil + + fun make_set l = List.foldr insert empty l + + fun partition F S = fold (fn (a,(Yes,No)) => + if F(a) then (insert(a,Yes),No) + else (Yes,insert(a,No))) + S (empty,empty) + + fun remove(X, XSet) = + let val (YSet, _) = + partition (fn a => not (elem_eq (X, a))) XSet + in YSet + end + + fun difference(Xs, Ys) = + fold (fn (p as (a,Xs')) => + if exists(a,Ys) then Xs' else insert p) + Xs empty + + fun singleton X = insert(X,empty) + + fun card(S) = fold (fn (_,count) => count+1) S 0 + + fun union(Xs,Ys)= fold insert Ys Xs + + local + fun closure'(from, f, result) = + if is_empty from then result + else + let val (more,result) = + fold (fn (a,(more',result')) => + let val more = f a + val new = difference(more,result) + in (union(more',new),union(result',new)) + end) from + (empty,result) + in closure'(more,f,result) + end + in + fun closure(start, f) = closure'(start, f, start) + end + end +end +(* +signature TABLE = + sig + type 'a table + type key + val size : 'a table -> int + val empty: 'a table + val exists: (key * 'a table) -> bool + val find : (key * 'a table) -> 'a option + val insert: ((key * 'a) * 'a table) -> 'a table + val make_table : (key * 'a ) list -> 'a table + val make_list : 'a table -> (key * 'a) list + val fold : ((key * 'a) * 'b -> 'b) -> 'a table -> 'b -> 'b + end +*) +functor Table (B : sig type key + val gt : (key * key) -> bool + end + ) : TABLE = +struct + + datatype Color = RED | BLACK + type key = B.key + + abstype 'a table = EMPTY + | TREE of ((B.key * 'a ) * Color * 'a table * 'a table) + with + + val empty = EMPTY + + fun insert(elem as (key,data),t) = + let val key_gt = fn (a,_) => B.gt(key,a) + val key_lt = fn (a,_) => B.gt(a,key) + fun f EMPTY = TREE(elem,RED,EMPTY,EMPTY) + | f (TREE(k,BLACK,l,r)) = + if key_gt k + then case f r + of r as TREE(rk,RED, rl as TREE(rlk,RED,rll,rlr),rr) => + (case l + of TREE(lk,RED,ll,lr) => + TREE(k,RED,TREE(lk,BLACK,ll,lr), + TREE(rk,BLACK,rl,rr)) + | _ => TREE(rlk,BLACK,TREE(k,RED,l,rll), + TREE(rk,RED,rlr,rr))) + | r as TREE(rk,RED,rl, rr as TREE(rrk,RED,rrl,rrr)) => + (case l + of TREE(lk,RED,ll,lr) => + TREE(k,RED,TREE(lk,BLACK,ll,lr), + TREE(rk,BLACK,rl,rr)) + | _ => TREE(rk,BLACK,TREE(k,RED,l,rl),rr)) + | r => TREE(k,BLACK,l,r) + else if key_lt k + then case f l + of l as TREE(lk,RED,ll, lr as TREE(lrk,RED,lrl,lrr)) => + (case r + of TREE(rk,RED,rl,rr) => + TREE(k,RED,TREE(lk,BLACK,ll,lr), + TREE(rk,BLACK,rl,rr)) + | _ => TREE(lrk,BLACK,TREE(lk,RED,ll,lrl), + TREE(k,RED,lrr,r))) + | l as TREE(lk,RED, ll as TREE(llk,RED,lll,llr), lr) => + (case r + of TREE(rk,RED,rl,rr) => + TREE(k,RED,TREE(lk,BLACK,ll,lr), + TREE(rk,BLACK,rl,rr)) + | _ => TREE(lk,BLACK,ll,TREE(k,RED,lr,r))) + | l => TREE(k,BLACK,l,r) + else TREE(elem,BLACK,l,r) + | f (TREE(k,RED,l,r)) = + if key_gt k then TREE(k,RED,l, f r) + else if key_lt k then TREE(k,RED, f l, r) + else TREE(elem,RED,l,r) + in case f t + of TREE(k,RED, l as TREE(_,RED,_,_), r) => TREE(k,BLACK,l,r) + | TREE(k,RED, l, r as TREE(_,RED,_,_)) => TREE(k,BLACK,l,r) + | t => t + end + + fun exists(key,t) = + let fun look EMPTY = false + | look (TREE((k,_),_,l,r)) = + if B.gt(k,key) then look l + else if B.gt(key,k) then look r + else true + in look t + end + + fun find(key,t) = + let fun look EMPTY = NONE + | look (TREE((k,data),_,l,r)) = + if B.gt(k,key) then look l + else if B.gt(key,k) then look r + else SOME data + in look t + end + + fun fold f t start = + let fun scan(EMPTY,value) = value + | scan(TREE(k,_,l,r),value) = scan(l,f(k,scan(r,value))) + in scan(t,start) + end + + fun make_table l = List.foldr insert empty l + + fun size S = fold (fn (_,count) => count+1) S 0 + + fun make_list table = fold (op ::) table nil + + end +end; + +(* assumes that a functor Table with signature TABLE from table.sml is + in the environment *) +(* +signature HASH = + sig + type table + type elem + + val size : table -> int + val add : elem * table -> table + val find : elem * table -> int option + val exists : elem * table -> bool + val empty : table + end +*) +(* hash: creates a hash table of size n which assigns each distinct member + a unique integer between 0 and n-1 *) + +functor Hash(B : sig type elem + val gt : elem * elem -> bool + end) : HASH = +struct + type elem=B.elem + structure HashTable = Table(type key=B.elem + val gt = B.gt) + + type table = {count : int, table : int HashTable.table} + + val empty = {count=0,table=HashTable.empty} + val size = fn {count,table} => count + val add = fn (e,{count,table}) => + {count=count+1,table=HashTable.insert((e,count),table)} + val find = fn (e,{table,count}) => HashTable.find(e,table) + val exists = fn (e,{table,count}) => HashTable.exists(e,table) +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.2 1996/02/26 15:02:31 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:44 george + * Version 109 + * + *) + +functor mkCore(structure IntGrammar : INTGRAMMAR) : CORE = + struct + open IntGrammar + open Grammar + structure IntGrammar = IntGrammar + structure Grammar = Grammar + + datatype item = ITEM of + { rule : rule, + dot : int, + rhsAfter : symbol list + } + + val eqItem = fn (ITEM{rule=RULE{num=n,...},dot=d,...}, + ITEM{rule=RULE{num=m,...},dot=e,...}) => + n=m andalso d=e + + val gtItem = fn (ITEM{rule=RULE{num=n,...},dot=d,...}, + ITEM{rule=RULE{num=m,...},dot=e,...}) => + n>m orelse (n=m andalso d>e) + + structure ItemList = ListOrdSet + (struct + type elem = item + val eq = eqItem + val gt = gtItem + end) + + open ItemList + datatype core = CORE of item list * int + + val gtCore = fn (CORE (a,_),CORE (b,_)) => ItemList.set_gt(a,b) + val eqCore = fn (CORE (a,_),CORE (b,_)) => ItemList.set_eq(a,b) + + (* functions for printing and debugging *) + + val prItem = fn (symbolToString,nontermToString,print) => + let val printInt = print o (Int.toString : int -> string) + val prSymbol = print o symbolToString + val prNonterm = print o nontermToString + fun showRest nil = () + | showRest (h::t) = (prSymbol h; print " "; showRest t) + fun showRhs (l,0) = (print ". "; showRest l) + | showRhs (nil,_) = () + | showRhs (h::t,n) = (prSymbol h; + print " "; + showRhs(t,n-1)) + in fn (ITEM {rule=RULE {lhs,rhs,rulenum,num,...}, + dot,rhsAfter,...}) => + (prNonterm lhs; print " : "; showRhs(rhs,dot); + case rhsAfter + of nil => (print " (reduce by rule "; + printInt rulenum; + print ")") + | _ => (); + if DEBUG then + (print " (num "; printInt num; print ")") + else ()) + end + + val prCore = fn a as (_,_,print) => + let val prItem = prItem a + in fn (CORE (items,state)) => + (print "state "; + print (Int.toString state); + print ":\n\n"; + app (fn i => (print "\t"; + prItem i; print "\n")) items; + print "\n") + end +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:45 george + * Version 109 + * + *) + +functor mkCoreUtils(structure Core : CORE) : CORE_UTILS = + struct + open Array List + infix 9 sub + val DEBUG = true + structure Core = Core + structure IntGrammar = Core.IntGrammar + structure Grammar = IntGrammar.Grammar + + open Grammar IntGrammar Core + + structure Assoc = SymbolAssoc + + structure NtList = ListOrdSet + (struct + type elem = nonterm + val eq = eqNonterm + val gt = gtNonterm + end) + + val mkFuncs = fn (GRAMMAR {rules,terms,nonterms,...}) => + let val derives=array(nonterms,nil : rule list) + +(* sort rules by their lhs nonterminal by placing them in an array indexed + in their lhs nonterminal *) + + val _ = + let val f = fn {lhs=lhs as (NT n), rhs, precedence,rulenum} => + let val rule=RULE{lhs=lhs,rhs=rhs,precedence=precedence, + rulenum=rulenum,num=0} + in update(derives,n,rule::(derives sub n)) + end + in app f rules + end + +(* renumber rules so that rule numbers increase monotonically with + the number of their lhs nonterminal, and so that rules are numbered + sequentially. **Functions below assume that this number is true**, + i.e. productions for nonterm i are numbered from j to k, + productions for nonterm i+1 are numbered from k+1 to m, and + productions for nonterm 0 start at 0 *) + + val _ = + let val f = + fn (RULE{lhs,rhs,precedence,rulenum,num}, (l,i)) => + (RULE{lhs=lhs,rhs=rhs, precedence=precedence, + rulenum=rulenum, num=i}::l,i+1) + fun g(i,num) = + if i + if DEBUG andalso (n<0 orelse n>=nonterms) then + let exception Produces of int in raise (Produces n) end + else derives sub n + + val memoize = fn f => + let fun loop i = if i = nonterms then nil + else f (NT i) :: (loop (i+1)) + val data = Array.fromList(loop 0) + in fn (NT i) => data sub i + end + + (* compute nonterminals which must be added to a closure when a given + nonterminal is added, i.e all nonterminals C for each nonterminal A such + that A =*=> Cx *) + + val nontermClosure = + let val collectNonterms = fn n => + List.foldr (fn (r,l) => + case r + of RULE {rhs=NONTERM n :: _,...} => + NtList.insert(n,l) + | _ => l) NtList.empty (produces n) + val closureNonterm = fn n => + NtList.closure(NtList.singleton n, + collectNonterms) + in memoize closureNonterm + end + +(* ntShifts: Take the items produced by a nonterminal, and sort them + by their first symbol. For each first symbol, make sure the item + list associated with the symbol is sorted also. ** This function + assumes that the item list returned by produces is sorted ** + + Create a table of item lists keyed by symbols. Scan the list + of items produced by a nonterminal, and insert those with a first + symbol on to the beginning of the item list for that symbol, creating + a list if necessary. Since produces returns an item list that is + already in order, the list for each symbol will also end up in order. + *) + + fun sortItems nt = + let fun add_item (a as RULE{rhs=symbol::rest,...},r) = + let val item = ITEM{rule=a,dot=1,rhsAfter=rest} + in Assoc.insert((symbol,case Assoc.find (symbol,r) + of SOME l => item::l + | NONE => [item]),r) + end + | add_item (_,r) = r + in List.foldr add_item Assoc.empty (produces nt) + end + + val ntShifts = memoize sortItems + +(* getNonterms: get the nonterminals with a . before them in a core. + Returns a list of nonterminals in ascending order *) + + fun getNonterms l = + List.foldr (fn (ITEM {rhsAfter=NONTERM sym ::_, ...},r) => + NtList.insert(sym,r) + | (_,r) => r) [] l + +(* closureNonterms: compute the nonterminals that would have a . before them + in the closure of the core. Returns a list of nonterminals in ascending + order *) + fun closureNonterms a = + let val nonterms = getNonterms a + in List.foldr (fn (nt,r) => + NtList.union(nontermClosure nt,r)) + nonterms nonterms + end + +(* shifts: compute the core sets that result from shift/gotoing on + the closure of a kernal set. The items in core sets are sorted, of + course. + + (1) compute the core sets that result just from items added + through the closure operation. + (2) then add the shift/gotos on kernal items. + + We can do (1) the following way. Keep a table which for each shift/goto +symbol gives the list of items that result from shifting or gotoing on the +symbol. Compute the nonterminals that would have dots before them in the +closure of the kernal set. For each of these nonterminals, we already have an +item list in sorted order for each possible shift symbol. Scan the nonterminal +list from back to front. For each nonterminal, prepend the shift/goto list +for each shift symbol to the list already in the table. + + We end up with the list of items in correct order for each shift/goto +symbol. We have kept the item lists in order, scanned the nonterminals from +back to front (=> that the items end up in ascending order), and never had any +duplicate items (each item is derived from only one nonterminal). *) + + fun shifts (CORE (itemList,_)) = + let + +(* mergeShiftItems: add an item list for a shift/goto symbol to the table *) + +fun mergeShiftItems (args as ((k,l),r)) = + case Assoc.find(k,r) + of NONE => Assoc.insert args + | SOME old => Assoc.insert ((k,l@old),r) + +(* mergeItems: add all items derived from a nonterminal to the table. We've + kept these items sorted by their shift/goto symbol (the first symbol on + their rhs) *) + + fun mergeItems (n,r) = + Assoc.fold mergeShiftItems (ntShifts n) r + +(* nonterms: a list of nonterminals that are in a core after the + closure operation *) + + val nonterms = closureNonterms itemList + +(* now create a table which for each shift/goto symbol gives the sorted list + of closure items which would result from first taking all the closure items + and then sorting them by the shift/goto symbols *) + + val newsets = List.foldr mergeItems Assoc.empty nonterms + +(* finally prepare to insert the kernal items of a core *) + + fun insertItem ((k,i),r) = + case (Assoc.find(k,r)) + of NONE => Assoc.insert((k,[i]),r) + | SOME l => Assoc.insert((k,Core.insert(i,l)),r) + fun shiftCores(ITEM{rule,dot,rhsAfter=symbol::rest},r) = + insertItem((symbol, + ITEM{rule=rule,dot=dot+1,rhsAfter=rest}),r) + | shiftCores(_,r) = r + +(* insert the kernal items of a core *) + + val newsets = List.foldr shiftCores newsets itemList + in Assoc.make_list newsets + end + +(* nontermEpsProds: returns a list of epsilon productions produced by a + nonterminal sorted by rule number. ** Depends on produces returning + an ordered list **. It does not alter the order in which the rules + were returned by produces; it only removes non-epsilon productions *) + + val nontermEpsProds = + let val f = fn nt => + List.foldr + (fn (rule as RULE {rhs=nil,...},results) => rule :: results + | (_,results) => results) + [] (produces nt) + in memoize f + end + +(* epsProds: take a core and compute a list of epsilon productions for it + sorted by rule number. ** Depends on closureNonterms returning a list + of nonterminals sorted by nonterminal #, rule numbers increasing + monotonically with their lhs production #, and nontermEpsProds returning + an ordered item list for each production +*) + + fun epsProds (CORE (itemList,state)) = + let val prods = map nontermEpsProds (closureNonterms itemList) + in List.concat prods + end + + in {produces=produces,shifts=shifts,rules=rules,epsProds=epsProds} + end +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.2 1996/02/26 15:02:34 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:45 george + * Version 109 + * + *) + +functor mkGraph(structure IntGrammar : INTGRAMMAR + structure Core : CORE + structure CoreUtils : CORE_UTILS + sharing IntGrammar = Core.IntGrammar = CoreUtils.IntGrammar + sharing CoreUtils.Core = Core + ) : LRGRAPH = + struct + open Array List + infix 9 sub + structure Core = Core + structure Grammar = IntGrammar.Grammar + structure IntGrammar = IntGrammar + open Core Core.Grammar CoreUtils IntGrammar + + structure NodeSet = RbOrdSet + (struct + type elem = core + val eq = eqCore + val gt = gtCore + end) + + open NodeSet + exception Shift of int * symbol + + type graph = {edges: {edge:symbol,to:core} list array, + nodes: core list,nodeArray : core array} + val edges = fn (CORE (_,i),{edges,...}:graph) => edges sub i + val nodes = fn ({nodes,...} : graph) => nodes + val shift = fn ({edges,nodes,...} : graph) => fn a as (i,sym) => + let fun find nil = raise (Shift a) + | find ({edge,to=CORE (_,state)} :: r) = + if gtSymbol(sym,edge) then find r + else if eqSymbol(edge,sym) then state + else raise (Shift a) + in find (edges sub i) + end + + val core = fn ({nodeArray,...} : graph) => + fn i => nodeArray sub i + + val mkGraph = fn (g as (GRAMMAR {start,...})) => + let val {shifts,produces,rules,epsProds} = + CoreUtils.mkFuncs g + fun add_goto ((symbol,a),(nodes,edges,future,num)) = + case find(CORE (a,0),nodes) + of NONE => + let val core =CORE (a,num) + val edge = {edge=symbol,to=core} + in (insert(core,nodes),edge::edges, + core::future,num+1) + end + | (SOME c) => + let val edge={edge=symbol,to=c} + in (nodes,edge::edges,future,num) + end + fun f (nodes,node_list,edge_list,nil,nil,num) = + let val nodes=rev node_list + in {nodes=nodes, + edges=Array.fromList (rev edge_list), + nodeArray = Array.fromList nodes + } + end + | f (nodes,node_list,edge_list,nil,y,num) = + f (nodes,node_list,edge_list,rev y,nil,num) + | f (nodes,node_list,edge_list,h::t,y,num) = + let val (nodes,edges,future,num) = + List.foldr add_goto (nodes,[],y,num) (shifts h) + in f (nodes,h::node_list, + edges::edge_list,t,future,num) + end + in {graph= + let val makeItem = fn (r as (RULE {rhs,...})) => + ITEM{rule=r,dot=0,rhsAfter=rhs} + val initialItemList = map makeItem (produces start) + val orderedItemList = + List.foldr Core.insert [] initialItemList + val initial = CORE (orderedItemList,0) + in f(empty,nil,nil,[initial],nil,1) + end, + produces=produces, + rules=rules, + epsProds=epsProds} + end + val prGraph = fn a as (nontermToString,termToString,print) => fn g => + let val printCore = prCore a + val printSymbol = print o nontermToString + val nodes = nodes g + val printEdges = fn n => + List.app (fn {edge,to=CORE (_,state)} => + (print "\tshift on "; + printSymbol edge; + print " to "; + print (Int.toString state); + print "\n")) (edges (n,g)) + in List.app (fn c => (printCore c; print "\n"; printEdges c)) nodes + end +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:46 george + * Version 109 + * + *) + +functor mkLook (structure IntGrammar : INTGRAMMAR) : LOOK = + struct + open Array List + infix 9 sub + structure Grammar = IntGrammar.Grammar + structure IntGrammar = IntGrammar + open Grammar IntGrammar + + structure TermSet = ListOrdSet + (struct + type elem = term + val eq = eqTerm + val gt = gtTerm + end) + + val union = TermSet.union + val make_set = TermSet.make_set + + val prLook = fn (termToString,print) => + let val printTerm = print o termToString + fun f nil = print " " + | f (a :: b) = (printTerm a; print " "; f b) + in f + end + + structure NontermSet = ListOrdSet + (struct + type elem = nonterm + val eq = eqNonterm + val gt = gtNonterm + end) + + val mkFuncs = fn {rules : rule list, nonterms : int, + produces : nonterm -> rule list} => + + let + + (* nullable: create a function which tells if a nonterminal is nullable + or not. + + Method: Keep an array of booleans. The nth entry is true if + NT i is nullable. If is false if we don't know whether NT i + is nullable. + + Keep a list of rules whose remaining rhs we must prove to be + null. First, scan the list of rules and remove those rules + whose rhs contains a terminal. These rules are not nullable. + + Now iterate through the rules that were left: + (1) if there is no remaining rhs we have proved that + the rule is nullable, mark the nonterminal for the + rule as nullable + (2) if the first element of the remaining rhs is + nullable, place the rule back on the list with + the rest of the rhs + (3) if we don't know whether the nonterminal is nullable, + place it back on the list + (4) repeat until the list does not change. + + We have found all the possible nullable rules. + *) + + val nullable = + let fun ok_rhs nil = true + | ok_rhs ((TERM _)::_) = false + | ok_rhs ((NONTERM i)::r) = ok_rhs r + fun add_rule (RULE {lhs,rhs,...},r) = + if ok_rhs rhs then (lhs,map (fn (NONTERM (NT i)) => i) rhs)::r + else r + val items = List.foldr add_rule [] rules + val nullable = array(nonterms,false) + val f = fn ((NT i,nil),(l,_)) => (update(nullable,i,true); + (l,true)) + | (a as (lhs,(h::t)),(l,change)) => + case (nullable sub h) + of false => (a::l,change) + | true => ((lhs,t)::l,true) + fun prove(l,true) = prove(List.foldr f (nil,false) l) + | prove(_,false) = () + in (prove(items,true); fn (NT i) => nullable sub i) + end + + (* scanRhs : look at a list of symbols, scanning past nullable + nonterminals, applying addSymbol to the symbols scanned *) + + fun scanRhs addSymbol = + let fun f (nil,result) = result + | f ((sym as NONTERM nt) :: rest,result) = + if nullable nt then f (rest,addSymbol(sym,result)) + else addSymbol(sym,result) + | f ((sym as TERM _) :: _,result) = addSymbol(sym,result) + in f + end + + (* accumulate: look at the start of the right-hand-sides of rules, + looking past nullable nonterminals, applying addObj to the visible + symbols. *) + + fun accumulate(rules, empty, addObj) = + List.foldr (fn (RULE {rhs,...},r) =>(scanRhs addObj) (rhs,r)) empty rules + + val nontermMemo = fn f => + let val lookup = array(nonterms,nil) + fun g i = if i=nonterms then () + else (update(lookup,i,f (NT i)); g (i+1)) + in (g 0; fn (NT j) => lookup sub j) + end + + (* first1: the FIRST set of a nonterminal in the grammar. Only looks + at other terminals, but it is clever enough to move past nullable + nonterminals at the start of a production. *) + + fun first1 nt = accumulate(produces nt, TermSet.empty, + fn (TERM t, set) => TermSet.insert (t,set) + | (_, set) => set) + + val first1 = nontermMemo(first1) + + (* starters1: given a nonterminal "nt", return the set of nonterminals + which can start its productions. Looks past nullables, but doesn't + recurse *) + + fun starters1 nt = accumulate(produces nt, nil, + fn (NONTERM nt, set) => + NontermSet.insert(nt,set) + | (_, set) => set) + + val starters1 = nontermMemo(starters1) + + (* first: maps a nonterminal to its first-set. Get all the starters of + the nonterminal, get the first1 terminal set of each of these, + union the whole lot together *) + + fun first nt = + List.foldr (fn (a,r) => TermSet.union(r,first1 a)) + [] (NontermSet.closure (NontermSet.singleton nt, starters1)) + + val first = nontermMemo(first) + + (* prefix: all possible terminals starting a symbol list *) + + fun prefix symbols = + scanRhs (fn (TERM t,r) => TermSet.insert(t,r) + | (NONTERM nt,r) => TermSet.union(first nt,r)) + (symbols,nil) + + fun nullable_string ((TERM t) :: r) = false + | nullable_string ((NONTERM nt) :: r) = + (case (nullable nt) + of true => nullable_string r + | f => f) + | nullable_string nil = true + + in {nullable = nullable, first = prefix} + end +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.3 1996/10/03 03:37:12 jhr + * Qualified identifiers that are no-longer top-level (quot, rem, min, max). + * + * Revision 1.2 1996/02/26 15:02:35 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:45 george + * Version 109 + * + *) + +functor mkLalr ( structure IntGrammar : INTGRAMMAR + structure Core : CORE + structure Graph : LRGRAPH + structure Look: LOOK + sharing Graph.Core = Core + sharing Graph.IntGrammar = Core.IntGrammar = + Look.IntGrammar = IntGrammar) : LALR_GRAPH = + struct + open Array List + infix 9 sub + open IntGrammar.Grammar IntGrammar Core Graph Look + structure Graph = Graph + structure Core = Core + structure Grammar = IntGrammar.Grammar + structure IntGrammar = IntGrammar + + datatype tmpcore = TMPCORE of (item * term list ref) list * int + datatype lcore = LCORE of (item * term list) list * int + + + val prLcore = + fn a as (SymbolToString,nontermToString,termToString,print) => + let val printItem = prItem (SymbolToString,nontermToString,print) + val printLookahead = prLook(termToString,print) + in fn (LCORE (items,state)) => + (print "\n"; + print "state "; + print (Int.toString state); + print " :\n\n"; + List.app (fn (item,lookahead) => + (print "{"; + printItem item; + print ","; + printLookahead lookahead; + print "}\n")) items) + end + + exception Lalr of int + + structure ItemList = ListOrdSet + (struct + type elem = item * term list ref + val eq = fn ((a,_),(b,_)) => eqItem(a,b) + val gt = fn ((a,_),(b,_)) => gtItem(a,b) + end) + + structure NontermSet = ListOrdSet + (struct + type elem = nonterm + val gt = gtNonterm + val eq = eqNonterm + end) + +(* NTL: nonterms with lookahead *) + + structure NTL = RbOrdSet + (struct + type elem = nonterm * term list + val gt = fn ((i,_),(j,_)) => gtNonterm(i,j) + val eq = fn ((i,_),(j,_)) => eqNonterm(i,j) + end) + + val DEBUG = false + + val addLookahead = fn {graph,nullable,first,eop, + rules,produces,nonterms,epsProds, + print,termToString,nontermToString} => + let + + val eop = Look.make_set eop + + val symbolToString = fn (TERM t) => termToString t + | (NONTERM t) => nontermToString t + + val print = if DEBUG then print + else fn _ => () + + val prLook = if DEBUG then prLook (termToString,print) + else fn _ => () + + val prNonterm = print o nontermToString + + val prRule = if DEBUG + then prRule(symbolToString,nontermToString,print) + else fn _ => () + + val printInt = print o (Int.toString : int -> string) + + val printItem = prItem(symbolToString,nontermToString,print) + +(* look_pos: position in the rhs of a rule at which we should start placing + lookahead ref cells, i.e. the minimum place at which A -> x .B y, where + B is a nonterminal and y =*=> epsilon, or A -> x. is true. Positions are + given by the number of symbols before the place. The place before the first + symbol is 0, etc. *) + + val look_pos = + let val positions = array(length rules,0) + +(* rule_pos: calculate place in the rhs of a rule at which we should start + placing lookahead ref cells *) + + val rule_pos = fn (RULE {rhs,...}) => + case (rev rhs) + of nil => 0 + | (TERM t) :: r => length rhs + | (l as (NONTERM n) :: r) => + + (* f assumes that everything after n in the + rule has proven to be nullable so far. + Remember that the rhs has been reversed, + implying that this is true initially *) + + (* A -> .z t B y, where y is nullable *) + + let fun f (NONTERM b :: (r as (TERM _ :: _))) = + (length r) + + (* A -> .z B C y *) + + | f (NONTERM c :: (r as (NONTERM b :: _))) = + if nullable c then f r + else (length r) + + (* A -> .B y, where y is nullable *) + + | f (NONTERM b :: nil) = 0 + in f l + end + + val check_rule = fn (rule as RULE {num,...}) => + let val pos = rule_pos rule + in (print "look_pos: "; + prRule rule; + print " = "; + printInt pos; + print "\n"; + update(positions,num,rule_pos rule)) + end + in app check_rule rules; + fn RULE{num,...} => (positions sub num) + end + +(* rest_is_null: true for items of the form A -> x .B y, where y is nullable *) + + val rest_is_null = + fn (ITEM{rule,dot, rhsAfter=NONTERM _ :: _}) => + dot >= (look_pos rule) + | _ => false + +(* map core to a new core including only items of the form A -> x. or + A -> x. B y, where y =*=> epsilon. It also adds epsilon productions to the + core. Each item is given a ref cell to hold the lookahead nonterminals for + it.*) + + val map_core = + let val f = fn (item as ITEM {rhsAfter=nil,...},r) => + (item,ref nil) :: r + | (item,r) => + if (rest_is_null item) + then (item,ref nil)::r + else r + in fn (c as CORE (items,state)) => + let val epsItems = + map (fn rule=>(ITEM{rule=rule,dot=0,rhsAfter=nil}, + ref (nil : term list)) + ) (epsProds c) + in TMPCORE(ItemList.union(List.foldr f [] items,epsItems),state) + end + end + + val new_nodes = map map_core (nodes graph) + + exception Find + +(* findRef: state * item -> lookahead ref cell for item *) + + val findRef = + let val states = Array.fromList new_nodes + val dummy = ref nil + in fn (state,item) => + let val TMPCORE (l,_) = states sub state + in case ItemList.find((item,dummy),l) + of SOME (_,look_ref) => look_ref + | NONE => (print "find failed: state "; + printInt state; + print "\nitem =\n"; + printItem item; + print "\nactual items =\n"; + app (fn (i,_) => (printItem i; + print "\n")) l; + raise Find) + end + end + + +(* findRuleRefs: state -> rule -> lookahead refs for rule. *) + + val findRuleRefs = + let val shift = shift graph + in fn state => + (* handle epsilon productions *) + fn (rule as RULE {rhs=nil,...}) => + [findRef(state,ITEM{rule=rule,dot=0,rhsAfter=nil})] + | (rule as RULE {rhs=sym::rest,...}) => + let val pos = Int.max(look_pos rule,1) + fun scan'(state,nil,pos,result) = + findRef(state,ITEM{rule=rule, + dot=pos, + rhsAfter=nil}) :: result + | scan'(state,rhs as sym::rest,pos,result) = + scan'(shift(state,sym), rest, pos+1, + findRef(state,ITEM{rule=rule, + dot=pos, + rhsAfter=rhs})::result) + +(* find first item of the form A -> x .B y, where y =*=> epsilon and + x is not epsilon, or A -> x. use scan' to pick up all refs after this + point *) + + fun scan(state,nil,_) = + [findRef(state,ITEM{rule=rule,dot=pos,rhsAfter=nil})] + | scan(state,rhs,0) = scan'(state,rhs,pos,nil) + | scan(state,sym::rest,place) = + scan(shift(state,sym),rest,place-1) + + in scan(shift(state,sym),rest,pos-1) + end + + end + +(* function to compute for some nonterminal n the set of nonterminals A added + through the closure of nonterminal n such that n =c*=> .A x, where x is + nullable *) + + val nonterms_w_null = fn nt => + let val collect_nonterms = fn n => + List.foldr (fn (rule as RULE {rhs=rhs as NONTERM n :: _,...},r) => + (case + (rest_is_null(ITEM {dot=0,rhsAfter=rhs,rule=rule})) + of true => n :: r + | false => r) + | (_,r) => r) [] (produces n) + fun dfs(a as (n,r)) = + if (NontermSet.exists a) then r + else List.foldr dfs (NontermSet.insert(n,r)) + (collect_nonterms n) + in dfs(nt,NontermSet.empty) + end + + val nonterms_w_null = + let val data = array(nonterms,NontermSet.empty) + fun f n = if n=nonterms then () + else (update(data,n,nonterms_w_null (NT n)); + f (n+1)) + in (f 0; fn (NT nt) => data sub nt) + end + +(* look_info: for some nonterminal n the set of nonterms A added + through the closure of the nonterminal such that n =c+=> .Ax and the + lookahead accumlated for each nonterm A *) + + val look_info = fn nt => + let val collect_nonterms = fn n => + List.foldr (fn (RULE {rhs=NONTERM n :: t,...},r) => + (case NTL.find ((n,nil),r) + of SOME (key,data) => + NTL.insert((n,Look.union(data,first t)),r) + | NONE => NTL.insert ((n,first t),r)) + | (_,r) => r) + NTL.empty (produces n) + fun dfs(a as ((key1,data1),r)) = + case (NTL.find a) + of SOME (_,data2) => + NTL.insert((key1,Look.union(data1,data2)),r) + | NONE => NTL.fold dfs (collect_nonterms key1) + (NTL.insert a) + in dfs((nt,nil),NTL.empty) + end + + val look_info = + if not DEBUG then look_info + else fn nt => + (print "look_info of "; prNonterm nt; print "=\n"; + let val info = look_info nt + in (NTL.app (fn (nt,lookahead) => + (prNonterm nt; print ": "; prLook lookahead; + print "\n\n")) info; + info) + end) + +(* prop_look: propagate lookaheads for nonterms added in the closure of a + nonterm. Lookaheads must be propagated from each nonterminal m to + all nonterminals { n | m =c+=> nx, where x=*=>epsilon} *) + + val prop_look = fn ntl => + let val upd_lookhd = fn new_look => fn (nt,r) => + case NTL.find ((nt,new_look),r) + of SOME (_,old_look) => + NTL.insert((nt, Look.union(new_look,old_look)),r) + | NONE => raise (Lalr 241) + val upd_nonterm = fn ((nt,look),r) => + NontermSet.fold (upd_lookhd look) + (nonterms_w_null nt) r + in NTL.fold upd_nonterm ntl ntl + end + + val prop_look = + if not DEBUG then prop_look + else fn ntl => + (print "prop_look =\n"; + let val info = prop_look ntl + in (NTL.app (fn (nt,lookahead) => + (prNonterm nt; + print ": "; + prLook lookahead; + print "\n\n")) info; info) + end) + +(* now put the information from these functions together. Create a function + which takes a nonterminal n and returns a list of triplets of + (a nonterm added through closure, + the lookahead for the nonterm, + whether the nonterm should include the lookahead for the nonterminal + whose closure is being taken (i.e. first(y) for an item j of the + form A -> x .n y and lookahead(j) if y =*=> epsilon) +*) + + val closure_nonterms = + let val data = + array(nonterms,nil: (nonterm * term list * bool) list) + val do_nonterm = fn i => + let val nonterms_followed_by_null = + nonterms_w_null i + val nonterms_added_through_closure = + NTL.make_list (prop_look (look_info i)) + val result = + map (fn (nt,l) => + (nt,l,NontermSet.exists (nt,nonterms_followed_by_null)) + ) nonterms_added_through_closure + in if DEBUG then + (print "closure_nonterms = "; + prNonterm i; + print "\n"; + app (fn (nt,look,nullable) => + (prNonterm nt; + print ":"; + prLook look; + case nullable + of false => print "(false)\n" + | true => print "(true)\n")) result; + print "\n") + else (); + result + end + fun f i = + if i=nonterms then () + else (update(data,i,do_nonterm (NT i)); f (i+1)) + val _ = f 0 + in fn (NT i) => data sub i + end + +(* add_nonterm_lookahead: Add lookahead to all completion items for rules added + when the closure of a given nonterm in some state is taken. It returns + a list of lookahead refs to which the given nonterm's lookahead should + be propagated. For each rule, it must trace the shift/gotos in the LR(0) + graph to find all items of the form A-> x .B y where y =*=> epsilon or + A -> x. +*) + + val add_nonterm_lookahead = fn (nt,state) => + let val f = fn ((nt,lookahead,nullable),r) => + let val refs = map (findRuleRefs state) (produces nt) + val refs = List.concat refs + val _ = app (fn r => + r := (Look.union (!r,lookahead))) refs + in if nullable then refs @ r else r + end + in List.foldr f [] (closure_nonterms nt) + end + +(* scan_core: Scan a core for all items of the form A -> x .B y. Applies + add_nonterm_lookahead to each such B, and then merges first(y) into + the list of refs returned by add_nonterm_lookahead. It returns + a list of ref * ref list for all the items where y =*=> epsilon *) + + val scan_core = fn (CORE (l,state)) => + let fun f ((item as ITEM{rhsAfter= NONTERM b :: y, + dot,rule})::t,r) = + (case (add_nonterm_lookahead(b,state)) + of nil => r + | l => + let val first_y = first y + val newr = if dot >= (look_pos rule) + then (findRef(state,item),l)::r + else r + in (app (fn r => + r := Look.union(!r,first_y)) l; + f (t,newr)) + end) + | f (_ :: t,r) = f (t,r) + | f (nil,r) = r + in f (l,nil) + end + +(* add end-of-parse symbols to set of items consisting of all items + immediately derived from the start symbol *) + + val add_eop = fn (c as CORE (l,state),eop) => + let fun f (item as ITEM {rule,dot,...}) = + let val refs = findRuleRefs state rule + in + +(* first take care of kernal items. Add the end-of-parse symbols to + the lookahead sets for these items. Epsilon productions of the + start symbol do not need to be handled specially because they will + be in the kernal also *) + + app (fn r => r := Look.union(!r,eop)) refs; + +(* now take care of closure items. These are all nonterminals C which + have a derivation S =+=> .C x, where x is nullable *) + + if dot >= (look_pos rule) then + case item + of ITEM{rhsAfter=NONTERM b :: _,...} => + (case add_nonterm_lookahead(b,state) + of nil => () + | l => app (fn r => r := Look.union(!r,eop)) l) + | _ => () + else () + end + in app f l + end + + val iterate = fn l => + let fun f lookahead (nil,done) = done + | f lookahead (h::t,done) = + let val old = !h + in h := Look.union (old,lookahead); + if (length (!h)) <> (length old) + then f lookahead (t,false) + else f lookahead(t,done) + end + fun g ((from,to)::rest,done) = + let val new_done = f (!from) (to,done) + in g (rest,new_done) + end + | g (nil,done) = done + fun loop true = () + | loop false = loop (g (l,true)) + in loop false + end + + val lookahead = List.concat (map scan_core (nodes graph)) + +(* used to scan the item list of a TMPCORE and remove the items not + being reduced *) + + val create_lcore_list = + fn ((item as ITEM {rhsAfter=nil,...},ref l),r) => + (item,l) :: r + | (_,r) => r + + in add_eop(Graph.core graph 0,eop); + iterate lookahead; + map (fn (TMPCORE (l,state)) => + LCORE (List.foldr create_lcore_list [] l, state)) new_nodes + end +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.3 1996/05/31 14:05:01 dbm + * Rewrote definition of convert_to_pairlist to conform to value restriction. + * + * Revision 1.2 1996/02/26 15:02:36 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:46 george + * Version 109 + * + *) + +functor mkMakeLrTable (structure IntGrammar : INTGRAMMAR + structure LrTable : LR_TABLE + sharing type LrTable.term = IntGrammar.Grammar.term + sharing type LrTable.nonterm = IntGrammar.Grammar.nonterm + ) : MAKE_LR_TABLE = + struct + open Array List + infix 9 sub + structure Core = mkCore(structure IntGrammar = IntGrammar) + structure CoreUtils = mkCoreUtils(structure IntGrammar = IntGrammar + structure Core = Core) + structure Graph = mkGraph(structure IntGrammar = IntGrammar + structure Core = Core + structure CoreUtils = CoreUtils) + structure Look = mkLook(structure IntGrammar = IntGrammar) + structure Lalr = mkLalr(structure IntGrammar = IntGrammar + structure Core = Core + structure Graph = Graph + structure Look = Look) + structure LrTable = LrTable + structure IntGrammar = IntGrammar + structure Grammar = IntGrammar.Grammar + structure GotoList = ListOrdSet + (struct + type elem = Grammar.nonterm * LrTable.state + val eq = fn ((Grammar.NT a,_),(Grammar.NT b,_)) => a=b + val gt = fn ((Grammar.NT a,_),(Grammar.NT b,_)) => a>b + end) + structure Errs : LR_ERRS = + struct + structure LrTable = LrTable + datatype err = RR of LrTable.term * LrTable.state * int * int + | SR of LrTable.term * LrTable.state * int + | NOT_REDUCED of int + | NS of LrTable.term * int + | START of int + + val summary = fn l => + let val numRR = ref 0 + val numSR = ref 0 + val numSTART = ref 0 + val numNOT_REDUCED = ref 0 + val numNS = ref 0 + fun loop (h::t) = + (case h + of RR _ => numRR := !numRR+1 + | SR _ => numSR := !numSR+1 + | START _ => numSTART := !numSTART+1 + | NOT_REDUCED _ => numNOT_REDUCED := !numNOT_REDUCED+1 + | NS _ => numNS := !numNS+1; loop t) + | loop nil = {rr = !numRR, sr = !numSR, + start = !numSTART, + not_reduced = !numNOT_REDUCED, + nonshift = !numNS} + in loop l + end + + val printSummary = fn say => fn l => + let val {rr,sr,start, + not_reduced,nonshift} = summary l + val say_plural = fn (i,s) => + (say (Int.toString i); say " "; + case i + of 1 => (say s) + | _ => (say s; say "s")) + val say_error = fn (args as (i,s)) => + case i + of 0 => () + | i => (say_plural args; say "\n") + in say_error(rr,"reduce/reduce conflict"); + say_error(sr,"shift/reduce conflict"); + if nonshift<>0 then + (say "non-shiftable terminal used on the rhs of "; + say_plural(start,"rule"); say "\n") + else (); + if start<>0 then (say "start symbol used on the rhs of "; + say_plural(start,"rule"); say "\n") + else (); + if not_reduced<>0 then (say_plural(not_reduced,"rule"); + say " not reduced\n") + else () + end + end + + + open IntGrammar Grammar Errs LrTable Core + +(* rules for resolving conflicts: + + shift/reduce: + + If either the terminal or the rule has no + precedence, a shift/reduce conflict is reported. + A shift is chosen for the table. + + If both have precedences, the action with the + higher precedence is chosen. + + If the precedences are equal, neither the + shift nor the reduce is chosen. + + reduce/reduce: + + A reduce/reduce conflict is reported. The lowest + numbered rule is chosen for reduction. +*) + + +(* method for filling tables - first compute the reductions called for in a + state, then add the shifts for the state to this information. + +How to compute the reductions: + + A reduction initially is given as an item and a lookahead set calling +for reduction by that item. The first reduction is mapped to a list of +terminal * rule pairs. Each additional reduction is then merged into this +list and reduce/reduce conflicts are resolved according to the rule +given. + +Missed Errors: + + This method misses some reduce/reduce conflicts that exist because +some reductions are removed from the list before conflicting reductions +can be compared against them. All reduce/reduce conflicts, however, +can be generated given a list of the reduce/reduce conflicts generated +by this method. + + This can be done by taking the transitive closure of the relation given +by the list. If reduce/reduce (a,b) and reduce/reduce (b,c) are true, +then reduce/reduce (a,c) is true. The relation is symmetric and transitive. + +Adding shifts: + + Finally scan the list merging in shifts and resolving conflicts +according to the rule given. + +Missed Shift/Reduce Errors: + + Some errors may be missed by this method because some reductions were +removed as the result of reduce/reduce conflicts. For a shift/reduce +conflict of term a, reduction by rule n, shift/reduce conficts exist +for all rules y such that reduce/reduce (x,y) or reduce/reduce (y,x) +is true. +*) + + val mergeReduces = + let val merge = fn state => + let fun f (j as (pair1 as (T t1,action1)) :: r1, + k as (pair2 as (T t2,action2)) :: r2,result,errs) = + if t1 < t2 then f(r1,k,pair1::result,errs) + else if t1 > t2 then f(j,r2,pair2::result,errs) + else let val REDUCE num1 = action1 + val REDUCE num2 = action2 + val errs = RR(T t1,state,num1,num2) :: errs + val action = if num1 < num2 then pair1 else pair2 + in f(r1,r2,action::result,errs) + end + | f (nil,nil,result,errs) = (rev result,errs) + | f (pair1::r,nil,result,errs) = f(r,nil,pair1::result,errs) + | f (nil,pair2 :: r,result,errs) = f(nil,r,pair2::result,errs) + in f + end + in fn state => fn ((ITEM {rule=RULE {rulenum,...},...}, lookahead), + (reduces,errs)) => + let val action = REDUCE rulenum + val actions = map (fn a=>(a,action)) lookahead + in case reduces + of nil => (actions,errs) + | _ => merge state (reduces,actions,nil,errs) + end + end + + val computeActions = fn (rules,precedence,graph,defaultReductions) => + + let val rulePrec = + let val precData = array(length rules,NONE : int option) + in app (fn RULE {rulenum=r,precedence=p,...} => update(precData,r,p)) + rules; + fn i => precData sub i + end + + fun mergeShifts(state,shifts,nil) = (shifts,nil) + | mergeShifts(state,nil,reduces) = (reduces,nil) + | mergeShifts(state,shifts,reduces) = + let fun f(shifts as (pair1 as (T t1,_)) :: r1, + reduces as (pair2 as (T t2,action)) :: r2, + result,errs) = + if t1 < t2 then f(r1,reduces,pair1 :: result,errs) + else if t1 > t2 then f(shifts,r2,pair2 :: result,errs) + else let val REDUCE rulenum = action + val (term1,_) = pair1 + in case (precedence term1,rulePrec rulenum) + of (SOME i,SOME j) => + if i>j then f(r1,r2,pair1 :: result,errs) + else if j>i then f(r1,r2,pair2 :: result,errs) + else f(r1,r2,(T t1, ERROR)::result,errs) + | (_,_) => + f(r1,r2,pair1 :: result, + SR (term1,state,rulenum)::errs) + end + | f (nil,nil,result,errs) = (rev result,errs) + | f (nil,h::t,result,errs) = + f (nil,t,h::result,errs) + | f (h::t,nil,result,errs) = + f (t,nil,h::result,errs) + in f(shifts,reduces,nil,nil) + end + + fun mapCore ({edge=symbol,to=CORE (_,state)}::r,shifts,gotos) = + (case symbol + of (TERM t) => mapCore (r,(t,SHIFT(STATE state))::shifts,gotos) + | (NONTERM nt) => mapCore(r,shifts,(nt,STATE state)::gotos) + ) + | mapCore (nil,shifts,gotos) = (rev shifts,rev gotos) + + fun pruneError ((_,ERROR)::rest) = pruneError rest + | pruneError (a::rest) = a :: pruneError rest + | pruneError nil = nil + + in fn (Lalr.LCORE (reduceItems,state),c as CORE (shiftItems,state')) => + if DEBUG andalso (state <> state') then + let exception MkTable in raise MkTable end + else + let val (shifts,gotos) = mapCore (Graph.edges(c,graph),nil,nil) + val tableState = STATE state + in case reduceItems + of nil => ((shifts,ERROR),gotos,nil) + | h :: nil => + let val (ITEM {rule=RULE {rulenum,...},...}, l) = h + val (reduces,_) = mergeReduces tableState (h,(nil,nil)) + val (actions,errs) = mergeShifts(tableState, + shifts,reduces) + val actions' = pruneError actions + val (actions,default) = + let fun hasReduce (nil,actions) = + (rev actions,REDUCE rulenum) + | hasReduce ((a as (_,SHIFT _)) :: r,actions) = + hasReduce(r,a::actions) + | hasReduce (_ :: r,actions) = + hasReduce(r,actions) + fun loop (nil,actions) = (rev actions,ERROR) + | loop ((a as (_,SHIFT _)) :: r,actions) = + loop(r,a::actions) + | loop ((a as (_,REDUCE _)) :: r,actions) = + hasReduce(r,actions) + | loop (_ :: r,actions) = loop(r,actions) + in if defaultReductions + andalso length actions = length actions' + then loop(actions,nil) + else (actions',ERROR) + end + in ((actions,default), gotos,errs) + end + | l => + let val (reduces,errs1) = + List.foldr (mergeReduces tableState) (nil,nil) l + val (actions,errs2) = + mergeShifts(tableState,shifts,reduces) + in ((pruneError actions,ERROR),gotos,errs1@errs2) + end + end + end + + val mkTable = fn (grammar as GRAMMAR{rules,terms,nonterms,start, + precedence,termToString,noshift, + nontermToString,eop},defaultReductions) => + let val symbolToString = fn (TERM t) => termToString t + | (NONTERM nt) => nontermToString nt + val {rules,graph,produces,epsProds,...} = Graph.mkGraph grammar + val {nullable,first} = + Look.mkFuncs{rules=rules,produces=produces,nonterms=nonterms} + val lcores = Lalr.addLookahead + {graph=graph, + nullable=nullable, + produces=produces, + eop=eop, + nonterms=nonterms, + first=first, + rules=rules, + epsProds=epsProds, + print=(fn s=>TextIO.output(TextIO.stdOut,s)), + termToString = termToString, + nontermToString = nontermToString} + + fun zip (h::t,h'::t') = (h,h') :: zip(t,t') + | zip (nil,nil) = nil + | zip _ = let exception MkTable in raise MkTable end + + fun unzip l = + let fun f ((a,b,c)::r,j,k,l) = f(r,a::j,b::k,c::l) + | f (nil,j,k,l) = (rev j,rev k,rev l) + in f(l,nil,nil,nil) + end + + val (actions,gotos,errs) = + let val doState = + computeActions(rules,precedence,graph, + defaultReductions) + in unzip (map doState (zip(lcores,Graph.nodes graph))) + end + + (* add goto from state 0 to a new state. The new state + has accept actions for all of the end-of-parse symbols *) + + val (actions,gotos,errs) = + case gotos + of nil => (actions,gotos,errs) + | h :: t => + let val newStateActions = + (map (fn t => (t,ACCEPT)) (Look.make_set eop),ERROR) + val state0Goto = + GotoList.insert((start,STATE (length actions)),h) + in (actions @ [newStateActions], + state0Goto :: (t @ [nil]), + errs @ [nil]) + end + + val startErrs = + List.foldr (fn (RULE {rhs,rulenum,...},r) => + if (exists (fn NONTERM a => a=start + | _ => false) rhs) + then START rulenum :: r + else r) [] rules + + val nonshiftErrs = + List.foldr (fn (RULE {rhs,rulenum,...},r) => + (List.foldr (fn (nonshift,r) => + if (exists (fn TERM a => a=nonshift + | _ => false) rhs) + then NS(nonshift,rulenum) :: r + else r) r noshift) + ) [] rules + + val notReduced = + let val ruleReduced = array(length rules,false) + val test = fn REDUCE i => update(ruleReduced,i,true) + | _ => () + val _ = app (fn (actions,default) => + (app (fn (_,r) => test r) actions; + test default) + ) actions; + fun scan (i,r) = + if i >= 0 then + scan(i-1, if ruleReduced sub i then r + else NOT_REDUCED i :: r) + else r + in scan(Array.length ruleReduced-1,nil) + end handle Subscript => + (if DEBUG then + print "rules not numbered correctly!" + else (); nil) + + val numstates = length actions + + val allErrs = startErrs @ notReduced @ nonshiftErrs @ + (List.concat errs) + + fun convert_to_pairlist(nil : ('a * 'b) list): ('a,'b) pairlist = + EMPTY + | convert_to_pairlist ((a,b) :: r) = + PAIR(a,b,convert_to_pairlist r) + + in (mkLrTable {actions=Array.fromList(map (fn (a,b) => + (convert_to_pairlist a,b)) actions), + gotos=Array.fromList (map convert_to_pairlist gotos), + numRules=length rules,numStates=length actions, + initialState=STATE 0}, + let val errArray = Array.fromList errs + in fn (STATE state) => errArray sub state + end, + + fn print => + let val printCore = + prCore(symbolToString,nontermToString,print) + val core = Graph.core graph + in fn STATE state => + printCore (if state=(numstates-1) then + Core.CORE (nil,state) + else (core state)) + end, + allErrs) + end +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.2 1996/02/26 15:02:33 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:45 george + * Version 109 + * + *) + +structure Grammar : GRAMMAR = + struct + + (* define types term and nonterm using those in LrTable + datatype term = T of int + datatype nonterm = NT of int *) + + open LrTable + datatype symbol = TERM of term | NONTERM of nonterm + datatype grammar = GRAMMAR of + {rules: {lhs: nonterm, + rhs: symbol list, + precedence: int option, + rulenum: int} list, + noshift : term list, + eop : term list, + terms: int, + nonterms: int, + start : nonterm, + precedence : term -> int option, + termToString : term -> string, + nontermToString : nonterm -> string} +end; + +structure IntGrammar : INTGRAMMAR = + struct + structure Grammar = Grammar + open Grammar + + datatype rule = RULE of + {lhs: nonterm, + rhs: symbol list, + num: int,(* internal # assigned by coreutils *) + rulenum: int, + precedence: int option} + + val eqTerm = (op =) + val gtTerm = fn (T i,T j) => i>j + + val eqNonterm = (op =) + val gtNonterm = fn (NT i,NT j) => i>j + + val eqSymbol = (op =) + val gtSymbol = fn (TERM (T i),TERM (T j)) => i>j + | (NONTERM (NT i),NONTERM (NT j)) => i>j + | (TERM _,NONTERM _) => false + | (NONTERM _,TERM _) => true + + + structure SymbolAssoc = Table(type key = symbol + val gt = gtSymbol) + + structure NontermAssoc = Table(type key = nonterm + val gt = gtNonterm) + + val DEBUG = false + + val prRule = fn (a as symbolToString,nontermToString,print) => + let val printSymbol = print o symbolToString + fun printRhs (h::t) = (printSymbol h; print " "; + printRhs t) + | printRhs nil = () + in fn (RULE {lhs,rhs,num,rulenum,precedence,...}) => + ((print o nontermToString) lhs; print " : "; + printRhs rhs; + if DEBUG then (print " num = "; + print (Int.toString num); + print " rulenum = "; + print (Int.toString rulenum); + print " precedence = "; + case precedence + of NONE => print " none" + | (SOME i) => + print (Int.toString i); + ()) + else ()) + end + + val prGrammar = + fn (a as (symbolToString,nontermToString,print)) => + fn (GRAMMAR {rules,terms,nonterms,start,...}) => + let val printRule = + let val prRule = prRule a + in fn {lhs,rhs,precedence,rulenum} => + (prRule (RULE {lhs=lhs,rhs=rhs,num=0, + rulenum=rulenum, precedence=precedence}); + print "\n") + end + in print "grammar = \n"; + List.app printRule rules; + print "\n"; + print (" terms = " ^ (Int.toString terms) ^ + " nonterms = " ^ (Int.toString nonterms) ^ + " start = "); + (print o nontermToString) start; + () + end + end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.2 1996/02/26 15:02:39 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:47 george + * Version 109 + * + *) + +functor mkVerbose(structure Errs : LR_ERRS) : VERBOSE = +struct + structure Errs = Errs + open Errs Errs.LrTable + val mkPrintAction = fn print => + let val printInt = print o (Int.toString : int -> string) + in fn (SHIFT (STATE i)) => + (print "\tshift "; + printInt i; + print "\n") + | (REDUCE rulenum) => + (print "\treduce by rule "; + printInt rulenum; + print "\n") + | ACCEPT => print "\taccept\n" + | ERROR => print "\terror\n" + end + val mkPrintGoto = fn (printNonterm,print) => + let val printInt = print o (Int.toString : int -> string) + in fn (nonterm,STATE i) => + (print "\t"; + printNonterm nonterm; + print "\tgoto "; + printInt i; + print "\n") + end + + val mkPrintTermAction = fn (printTerm,print) => + let val printAction = mkPrintAction print + in fn (term,action) => + (print "\t"; + printTerm term; + printAction action) + end + val mkPrintGoto = fn (printNonterm,print) => + fn (nonterm,STATE i) => + let val printInt = print o (Int.toString : int -> string) + in (print "\t"; + printNonterm nonterm; + print "\tgoto "; + printInt i; + print "\n") + end + val mkPrintError = fn (printTerm,printRule,print) => + let val printInt = print o (Int.toString : int -> string) + val printState = fn STATE s => (print " state "; printInt s) + in fn (RR (term,state,r1,r2)) => + (print "error: "; + printState state; + print ": reduce/reduce conflict between rule "; + printInt r1; + print " and rule "; + printInt r2; + print " on "; + printTerm term; + print "\n") + | (SR (term,state,r1)) => + (print "error: "; + printState state; + print ": shift/reduce conflict "; + print "(shift "; + printTerm term; + print ", reduce by rule "; + printInt r1; + print ")\n") + | NOT_REDUCED i => + (print "warning: rule <"; + printRule i; + print "> will never be reduced\n") + | START i => + (print "warning: start symbol appears on the rhs of "; + print "<"; + printRule i; + print ">\n") + | NS (term,i) => + (print "warning: non-shiftable terminal "; + printTerm term; + print "appears on the rhs of "; + print "<"; + printRule i; + print ">\n") + end + structure PairList : sig + val app : ('a * 'b -> unit) -> ('a,'b) pairlist -> unit + val length : ('a,'b) pairlist -> int + end + = + struct + val app = fn f => + let fun g EMPTY = () + | g (PAIR(a,b,r)) = (f(a,b); g r) + in g + end + val length = fn l => + let fun g(EMPTY,len) = len + | g(PAIR(_,_,r),len) = g(r,len+1) + in g(l,0) + end + end + val printVerbose = + fn {termToString,nontermToString,table,stateErrs,entries:int, + print,printRule,errs,printCores} => + let + val printTerm = print o termToString + val printNonterm = print o nontermToString + + val printCore = printCores print + val printTermAction = mkPrintTermAction(printTerm,print) + val printAction = mkPrintAction print + val printGoto = mkPrintGoto(printNonterm,print) + val printError = mkPrintError(printTerm,printRule print,print) + + val gotos = LrTable.describeGoto table + val actions = LrTable.describeActions table + val states = numStates table + + val gotoTableSize = ref 0 + val actionTableSize = ref 0 + + val _ = if length errs > 0 + then (printSummary print errs; + print "\n"; + app printError errs) + else () + fun loop i = + if i=states then () + else let val s = STATE i + in (app printError (stateErrs s); + print "\n"; + printCore s; + let val (actionList,default) = actions s + val gotoList = gotos s + in (PairList.app printTermAction actionList; + print "\n"; + PairList.app printGoto gotoList; + print "\n"; + print "\t."; + printAction default; + print "\n"; + gotoTableSize:=(!gotoTableSize)+ + PairList.length gotoList; + actionTableSize := (!actionTableSize) + + PairList.length actionList + 1 + ) + end; + loop (i+1)) + end + in loop 0; + print (Int.toString entries ^ " of " ^ + Int.toString (!actionTableSize)^ + " action table entries left after compaction\n"); + print (Int.toString (!gotoTableSize)^ " goto table entries\n") + end +end; + + +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.2 1996/02/26 15:02:37 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:46 george + * Version 109 + * + *) + +functor mkPrintStruct(structure LrTable : LR_TABLE + structure ShrinkLrTable : SHRINK_LR_TABLE + sharing LrTable = ShrinkLrTable.LrTable):PRINT_STRUCT = + struct + open Array List + infix 9 sub + structure LrTable = LrTable + open ShrinkLrTable LrTable + + + (* lineLength = approximately the largest number of characters to allow + on a line when printing out an encode string *) + + val lineLength = 72 + + (* maxLength = length of a table entry. All table entries are encoded + using two 16-bit integers, one for the terminal number and the other + for the entry. Each integer is printed as two characters (low byte, + high byte), using the ML ascii escape sequence. We need 4 + characters for each escape sequence and 16 characters for each entry + *) + + val maxLength = 16 + + (* number of entries we can fit on a row *) + + val numEntries = lineLength div maxLength + + (* convert integer between 0 and 255 to the three character ascii + decimal escape sequence for it *) + + val chr = + let val lookup = Array.array(256,"\000") + val intToString = fn i => + if i>=100 then "\\" ^ (Int.toString i) + else if i>=10 then "\\0" ^ (Int.toString i) + else "\\00" ^ (Int.toString i) + fun loop n = if n=256 then () + else (Array.update(lookup,n,intToString n); loop (n+1)) + in loop 0; fn i => lookup sub i + end + + val makeStruct = fn {table,name,print,verbose} => + let + val states = numStates table + val rules = numRules table + fun printPairList (prEntry : 'a * 'b -> unit) l = + let fun f (EMPTY,_) = () + | f (PAIR(a,b,r),count) = + if count >= numEntries then + (print "\\\n\\"; prEntry(a,b); f(r,1)) + else (prEntry(a,b); f(r,(count+1))) + in f(l,0) + end + val printList : ('a -> unit) -> 'a list -> unit = + fn prEntry => fn l => + let fun f (nil,_) = () + | f (a :: r,count) = + if count >= numEntries then + (print "\\\n\\"; prEntry a; f(r,1)) + else (prEntry a; f(r,count+1)) + in f(l,0) + end + val prEnd = fn _ => print "\\000\\000\\\n\\" + fun printPairRow prEntry = + let val printEntries = printPairList prEntry + in fn l => (printEntries l; prEnd()) + end + fun printPairRowWithDefault (prEntry,prDefault) = + let val f = printPairRow prEntry + in fn (l,default) => (prDefault default; f l) + end + fun printTable (printRow,count) = + (print "\"\\\n\\"; + let fun f i = if i=count then () + else (printRow i; f (i+1)) + in f 0 + end; + print"\"\n") + val printChar = print o chr + + (* print an integer between 0 and 2^16-1 as a 2-byte character, + with the low byte first *) + + val printInt = fn i => (printChar (i mod 256); + printChar (i div 256)) + + (* encode actions as integers: + + ACCEPT => 0 + ERROR => 1 + SHIFT i => 2 + i + REDUCE rulenum => numstates+2+rulenum + *) + + val printAction = + fn (REDUCE rulenum) => printInt (rulenum+states+2) + | (SHIFT (STATE i)) => printInt (i+2) + | ACCEPT => printInt 0 + | ERROR => printInt 1 + + val printTermAction = fn (T t,action) => + (printInt (t+1); printAction action) + + val printGoto = fn (NT n,STATE s) => (printInt (n+1); printInt s) + + val ((rowCount,rowNumbers,actionRows),entries)= + shrinkActionList(table,verbose) + val getActionRow = let val a = Array.fromList actionRows + in fn i => a sub i + end + val printGotoRow : int -> unit = + let val f = printPairRow printGoto + val g = describeGoto table + in fn i => f (g (STATE i)) + end + val printActionRow = + let val f = printPairRowWithDefault(printTermAction,printAction) + in fn i => f (getActionRow i) + end + in print "val "; + print name; + print "="; + print "let val actionRows =\n"; + printTable(printActionRow,rowCount); + print "val actionRowNumbers =\n\""; + printList (fn i => printInt i) rowNumbers; + print "\"\n"; + print "val gotoT =\n"; + printTable(printGotoRow,states); + print "val numstates = "; + print (Int.toString states); + print "\nval numrules = "; + print (Int.toString rules); + print "\n\ +\val s = ref \"\" and index = ref 0\n\ +\val string_to_int = fn () => \n\ +\let val i = !index\n\ +\in index := i+2; Char.ord(String.sub(!s,i)) + Char.ord(String.sub(!s,i+1)) * 256\n\ +\end\n\ +\val string_to_list = fn s' =>\n\ +\ let val len = String.size s'\n\ +\ fun f () =\n\ +\ if !index < len then string_to_int() :: f()\n\ +\ else nil\n\ +\ in index := 0; s := s'; f ()\n\ +\ end\n\ +\val string_to_pairlist = fn (conv_key,conv_entry) =>\n\ +\ let fun f () =\n\ +\ case string_to_int()\n\ +\ of 0 => EMPTY\n\ +\ | n => PAIR(conv_key (n-1),conv_entry (string_to_int()),f())\n\ +\ in f\n\ +\ end\n\ +\val string_to_pairlist_default = fn (conv_key,conv_entry) =>\n\ +\ let val conv_row = string_to_pairlist(conv_key,conv_entry)\n\ +\ in fn () =>\n\ +\ let val default = conv_entry(string_to_int())\n\ +\ val row = conv_row()\n\ +\ in (row,default)\n\ +\ end\n\ +\ end\n\ +\val string_to_table = fn (convert_row,s') =>\n\ +\ let val len = String.size s'\n\ +\ fun f ()=\n\ +\ if !index < len then convert_row() :: f()\n\ +\ else nil\n\ +\ in (s := s'; index := 0; f ())\n\ +\ end\n\ +\local\n\ +\ val memo = Array.array(numstates+numrules,ERROR)\n\ +\ val _ =let fun g i=(Array.update(memo,i,REDUCE(i-numstates)); g(i+1))\n\ +\ fun f i =\n\ +\ if i=numstates then g i\n\ +\ else (Array.update(memo,i,SHIFT (STATE i)); f (i+1))\n\ +\ in f 0 handle Subscript => ()\n\ +\ end\n\ +\in\n\ +\val entry_to_action = fn 0 => ACCEPT | 1 => ERROR | j => Array.sub(memo,(j-2))\n\ +\end\n\ +\val gotoT=Array.fromList(string_to_table(string_to_pairlist(NT,STATE),gotoT))\n\ +\val actionRows=string_to_table(string_to_pairlist_default(T,entry_to_action),actionRows)\n\ +\val actionRowNumbers = string_to_list actionRowNumbers\n\ +\val actionT = let val actionRowLookUp=\n\ +\let val a=Array.fromList(actionRows) in fn i=>Array.sub(a,i) end\n\ +\in Array.fromList(map actionRowLookUp actionRowNumbers)\n\ +\end\n\ +\in LrTable.mkLrTable {actions=actionT,gotos=gotoT,numRules=numrules,\n\ +\numStates=numstates,initialState=STATE "; +print (Int.toString ((fn (STATE i) => i) (initialState table))); +print "}\nend\n"; + entries + end +end; +(* ML-Yacc Parser Generator (c) 1991 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.2 1996/05/30 17:52:58 dbm + * Lifted a let to a local in definition of createEquivalences to conform with + * value restriction. + * + * Revision 1.1.1.1 1996/01/31 16:01:46 george + * Version 109 + * + *) + +signature SORT_ARG = + sig + type entry + val gt : entry * entry -> bool + end +signature SORT = + sig + type entry + val sort : entry list -> entry list + end +signature EQUIV_ARG = + sig + type entry + val gt : entry * entry -> bool + val eq : entry * entry -> bool + end +signature EQUIV = + sig + type entry + + (* equivalences: take a list of entries and divides them into + equivalence classes numbered 0 to n-1. + + It returns a triple consisting of: + + * the number of equivalence classes + * a list which maps each original entry to an equivalence + class. The nth entry in this list gives the equivalence + class for the nth entry in the original entry list. + * a list which maps equivalence classes to some representative + element. The nth entry in this list is an element from the + nth equivalence class + *) + + val equivalences : entry list -> (int * int list * entry list) + end + +(* An O(n lg n) merge sort routine *) + +functor MergeSortFun(A : SORT_ARG) : SORT = + struct + type entry = A.entry + + (* sort: an O(n lg n) merge sort routine. We create a list of lists + and then merge these lists in passes until only one list is left.*) + + fun sort nil = nil + | sort l = + let (* merge: merge two lists *) + + fun merge (l as a::at,r as b::bt) = + if A.gt(a,b) + then b :: merge(l,bt) + else a :: merge(at,r) + | merge (l,nil) = l + | merge (nil,r) = r + + (* scan: merge pairs of lists on a list of lists. + Reduces the number of lists by about 1/2 *) + + fun scan (a :: b :: rest) = merge(a,b) :: scan rest + | scan l = l + + (* loop: calls scan on a list of lists until only + one list is left. It terminates only if the list of + lists is nonempty. (The pattern match for sort + ensures this.) *) + + fun loop (a :: nil) = a + | loop l = loop (scan l) + + in loop (map (fn a => [a]) l) + end + end + +(* an O(n lg n) routine for placing items in equivalence classes *) + +functor EquivFun(A : EQUIV_ARG) : EQUIV = + struct + open Array List + infix 9 sub + + (* Our algorithm for finding equivalence class is simple. The basic + idea is to sort the entries and place duplicates entries in the same + equivalence class. + + Let the original entry list be E. We map E to a list of a pairs + consisting of the entry and its position in E, where the positions + are numbered 0 to n-1. Call this list of pairs EP. + + We then sort EP on the original entries. The second elements in the + pairs now specify a permutation that will return us to EP. + + We then scan the sorted list to create a list R of representative + entries, a list P of integers which permutes the sorted list back to + the original list and a list SE of integers which gives the + equivalence class for the nth entry in the sorted list . + + We then return the length of R, R, and the list that results from + permuting SE by P. + *) + + type entry = A.entry + + val gt = fn ((a,_),(b,_)) => A.gt(a,b) + + structure Sort = MergeSortFun(type entry = A.entry * int + val gt = gt) + val assignIndex = + fn l => + let fun loop (index,nil) = nil + | loop (index,h :: t) = (h,index) :: loop(index+1,t) + in loop (0,l) + end + + local fun loop ((e,_) :: t, prev, class, R , SE) = + if A.eq(e,prev) + then loop(t,e,class,R, class :: SE) + else loop(t,e,class+1,e :: R, (class + 1) :: SE) + | loop (nil,_,_,R,SE) = (rev R, rev SE) + in val createEquivalences = + fn nil => (nil,nil) + | (e,_) :: t => loop(t, e, 0, [e],[0]) + end + + val inversePermute = fn permutation => + fn nil => nil + | l as h :: _ => + let val result = array(length l,h) + fun loop (elem :: r, dest :: s) = + (update(result,dest,elem); loop(r,s)) + | loop _ = () + fun listofarray i = + if i < Array.length result then + (result sub i) :: listofarray (i+1) + else nil + in loop (l,permutation); listofarray 0 + end + + fun makePermutation x = map (fn (_,b) => b) x + + val equivalences = fn l => + let val EP = assignIndex l + val sorted = Sort.sort EP + val P = makePermutation sorted + val (R, SE) = createEquivalences sorted + in (length R, inversePermute P SE, R) + end +end + +functor ShrinkLrTableFun(structure LrTable : LR_TABLE) : SHRINK_LR_TABLE = + struct + structure LrTable = LrTable + open LrTable + val gtAction = fn (a,b) => + case a + of SHIFT (STATE s) => + (case b of SHIFT (STATE s') => s>s' | _ => true) + | REDUCE i => (case b of SHIFT _ => false | REDUCE i' => i>i' + | _ => true) + | ACCEPT => (case b of ERROR => true | _ => false) + | ERROR => false + structure ActionEntryList = + struct + type entry = (term,action) pairlist * action + val rec eqlist = + fn (EMPTY,EMPTY) => true + | (PAIR (T t,d,r),PAIR(T t',d',r')) => + t=t' andalso d=d' andalso eqlist(r,r') + | _ => false + val rec gtlist = + fn (PAIR _,EMPTY) => true + | (PAIR(T t,d,r),PAIR(T t',d',r')) => + t>t' orelse (t=t' andalso + (gtAction(d,d') orelse + (d=d' andalso gtlist(r,r')))) + | _ => false + val eq = fn ((l,a),(l',a')) => a=a' andalso eqlist(l,l') + val gt = fn ((l,a),(l',a')) => gtAction(a,a') + orelse (a=a' andalso gtlist(l,l')) + end +(* structure GotoEntryList = + struct + type entry = (nonterm,state) pairlist + val rec eq = + fn (EMPTY,EMPTY) => true + | (PAIR (t,d,r),PAIR(t',d',r')) => + t=t' andalso d=d' andalso eq(r,r') + | _ => false + val rec gt = + fn (PAIR _,EMPTY) => true + | (PAIR(NT t,STATE d,r),PAIR(NT t',STATE d',r')) => + t>t' orelse (t=t' andalso + (d>d' orelse (d=d' andalso gt(r,r')))) + | _ => false + end *) + structure EquivActionList = EquivFun(ActionEntryList) + val states = fn max => + let fun f i=if i int = + fn l => + let fun g(EMPTY,len) = len + | g(PAIR(_,_,r),len) = g(r,len+1) + in g(l,0) + end + val size : (('a,'b) pairlist * 'c) list -> int = + fn l => + let val c = ref 0 + in (app (fn (row,_) => c := !c + length row) l; !c) + end + val shrinkActionList = + fn (table,verbose) => + case EquivActionList.equivalences + (map (describeActions table) (states (numStates table))) + of result as (_,_,l) => (result,if verbose then size l else 0) +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:44 george + * Version 109 + * + *) + +signature ABSYN = + sig + datatype exp = EVAR of string + | EAPP of exp * exp + | ETUPLE of exp list + | EINT of int + | FN of pat * exp + | LET of decl list * exp + | UNIT + | SEQ of exp * exp + | CODE of string + and pat = PVAR of string + | PAPP of string * pat + | PTUPLE of pat list + | PLIST of pat list + | PINT of int + | WILD + | AS of pat * pat + and decl = VB of pat * exp + and rule = RULE of pat * exp + val printRule : ((string -> unit) * (string -> unit)) -> rule -> unit + end +(* ML-Yacc Parser Generator (c) 1989, 1990 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.3 1996/05/30 18:05:09 dbm + * Made changes to generate code that conforms to the value restriction by + * lifting lets to locals in the code generated to define errtermvalue and action. + * + * Revision 1.2 1996/02/26 15:02:40 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.1.1.1 1996/01/31 16:01:48 george + * Version 109 + * + *) + +functor ParseGenFun(structure ParseGenParser : PARSE_GEN_PARSER where type Header.pos = int + structure MakeTable : MAKE_LR_TABLE + structure Verbose : VERBOSE + structure PrintStruct : PRINT_STRUCT + + sharing MakeTable.LrTable = PrintStruct.LrTable + sharing MakeTable.Errs = Verbose.Errs + + structure Absyn : ABSYN + ) : PARSE_GEN = + struct + open Array List + infix 9 sub + structure Grammar = MakeTable.Grammar + structure Header = ParseGenParser.Header + + open Header Grammar + + (* approx. maximum length of a line *) + + val lineLength = 70 + + (* record type describing names of structures in the program being + generated *) + + datatype names = NAMES + of {miscStruct : string, (* Misc{n} struct name *) + tableStruct : string, (* LR table structure *) + tokenStruct : string, (* Tokens{n} struct name *) + actionsStruct : string, (* Actions structure *) + valueStruct: string, (* semantic value structure *) + ecStruct : string, (* error correction structure *) + arg: string, (* user argument for parser *) + tokenSig : string, (* TOKENS{n} signature *) + miscSig :string, (* Signature for Misc structure *) + dataStruct:string, (* name of structure in Misc *) + (* which holds parser data *) + dataSig:string (* signature for this structure *) + + } + + val DEBUG = true + exception Semantic + + (* common functions and values used in printing out program *) + + datatype values = VALS + of {say : string -> unit, + saydot : string -> unit, + sayln : string -> unit, + pureActions: bool, + pos_type : string, + arg_type : string, + ntvoid : string, + termvoid : string, + start : Grammar.nonterm, + hasType : Grammar.symbol -> bool, + + (* actual (user) name of terminal *) + + termToString : Grammar.term -> string, + symbolToString : Grammar.symbol -> string, + + (* type symbol comes from the HDR structure, + and is now abstract *) + + term : (Header.symbol * ty option) list, + nonterm : (Header.symbol * ty option) list, + terms : Grammar.term list} + + structure SymbolHash = Hash(type elem = string + val gt = (op >) : string*string -> bool) + + structure TermTable = Table(type key = Grammar.term + val gt = fn (T i,T j) => i > j) + + structure SymbolTable = Table( + type key = Grammar.symbol + val gt = fn (TERM(T i),TERM(T j)) => i>j + | (NONTERM(NT i),NONTERM(NT j)) => i>j + | (NONTERM _,TERM _) => true + | (TERM _,NONTERM _) => false) + + (* printTypes: function to print the following types in the LrValues + structure and a structure containing the datatype svalue: + + type svalue -- it holds semantic values on the parse + stack + type pos -- the type of line numbers + type result -- the type of the value that results + from the parse + + The type svalue is set equal to the datatype svalue declared + in the structure named by valueStruct. The datatype svalue + is declared inside the structure named by valueStruct to deal + with the scope of constructors. + *) + + val printTypes = fn (VALS {say,sayln,term,nonterm,symbolToString,pos_type, + arg_type, + termvoid,ntvoid,saydot,hasType,start, + pureActions,...}, + NAMES {valueStruct,...},symbolType) => + let val prConstr = fn (symbol,SOME s) => + say (" | " ^ (symbolName symbol) ^ " of " ^ + (if pureActions then "" else "unit -> ") ^ + " (" ^ tyName s ^ ")" + ) + | _ => () + in sayln "local open Header in"; + sayln ("type pos = " ^ pos_type); + sayln ("type arg = " ^ arg_type); + sayln ("structure " ^ valueStruct ^ " = "); + sayln "struct"; + say ("datatype svalue = " ^ termvoid ^ " | " ^ ntvoid ^ " of" ^ + (if pureActions then "" else " unit -> ") ^ " unit"); + app prConstr term; + app prConstr nonterm; + sayln "\nend"; + sayln ("type svalue = " ^ valueStruct ^ ".svalue"); + say "type result = "; + case symbolType (NONTERM start) + of NONE => sayln "unit" + | SOME t => (say (tyName t); sayln ""); + sayln "end" + end + + (* function to print Tokens{n} structure *) + + val printTokenStruct = + fn (VALS {say, sayln, termToString, hasType,termvoid,terms, + pureActions,...}, + NAMES {miscStruct,tableStruct,valueStruct, + tokenStruct,tokenSig,dataStruct,...}) => + (sayln ("structure " ^ tokenStruct ^ " : " ^ tokenSig ^ " ="); + sayln "struct"; + sayln ("type svalue = " ^ dataStruct ^ ".svalue"); + sayln "type ('a,'b) token = ('a,'b) Token.token"; + let val f = fn term as T i => + (say "fun "; say (termToString term); + say " ("; + if (hasType (TERM term)) then say "i," else (); + say "p1,p2) = Token.TOKEN ("; + say (dataStruct ^ "." ^ tableStruct ^ ".T "); + say (Int.toString i); + say ",("; + say (dataStruct ^ "." ^ valueStruct ^ "."); + if (hasType (TERM term)) then + (say (termToString term); + if pureActions then say " i" + else say " (fn () => i)") + else say termvoid; + say ","; + sayln "p1,p2))") + in app f terms + end; + sayln "end") + + (* function to print signatures out - takes print function which + does not need to insert line breaks *) + + val printSigs = fn (VALS {term,...}, + NAMES {tokenSig,tokenStruct,miscSig, + dataStruct, dataSig, ...}, + say) => + say ("signature " ^ tokenSig ^ " =\nsig\n\ + \type ('a,'b) token\ntype svalue\n" ^ + (List.foldr (fn ((s,ty),r) => String.concat [ + "val ", symbolName s, + (case ty + of NONE => ": " + | SOME l => ": (" ^ (tyName l) ^ ") * "), + " 'a * 'a -> (svalue,'a) token\n", r]) "" term) ^ + "end\nsignature " ^ miscSig ^ + "=\nsig\nstructure Tokens : " ^ tokenSig ^ + "\nstructure " ^ dataStruct ^ ":" ^ dataSig ^ + "\nsharing type " ^ dataStruct ^ + ".Token.token = Tokens.token\nsharing type " ^ + dataStruct ^ ".svalue = Tokens.svalue\nend\n") + + (* function to print structure for error correction *) + + val printEC = fn (keyword : term list, + preferred_change : (term list * term list) list, + noshift : term list, + value : (term * string) list, + VALS {termToString, say,sayln,terms,saydot,hasType, + termvoid,pureActions,...}, + NAMES {ecStruct,tableStruct,valueStruct,...}) => + let + + val sayterm = fn (T i) => (say "(T "; say (Int.toString i); say ")") + + val printBoolCase = fn ( l : term list) => + (say "fn "; + app (fn t => (sayterm t; say " => true"; say " | ")) l; + sayln "_ => false") + + val printTermList = fn (l : term list) => + (app (fn t => (sayterm t; say " :: ")) l; sayln "nil") + + fun printChange () = + (sayln "val preferred_change = "; + app (fn (d,i) => + (say"("; printTermList d; say ","; printTermList i; + sayln ")::" + ) + ) preferred_change; + sayln "nil") + + val printErrValues = fn (l : (term * string) list) => + (sayln "local open Header in"; + sayln "val errtermvalue="; + say "fn "; + app (fn (t,s) => + (sayterm t; say " => "; + saydot valueStruct; say (termToString t); + say "("; + if pureActions then () else say "fn () => "; + say "("; say s; say "))"; + sayln " | " + ) + ) l; + say "_ => "; + say (valueStruct ^ "."); + sayln termvoid; sayln "end") + + + val printNames = fn () => + let val f = fn term => + (sayterm term; say " => "; say "\""; + say (termToString term); sayln "\""; say " | ") + in (sayln "val showTerminal ="; + say "fn "; + app f terms; + sayln "_ => \"bogus-term\"") + end + + val ecTerms = + List.foldr (fn (t,r) => + if hasType (TERM t) orelse exists (fn (a,_)=>a=t) value + then r + else t::r) + [] terms + + in say "structure "; + say ecStruct; + sayln "="; + sayln "struct"; + say "open "; + sayln tableStruct; + sayln "val is_keyword ="; + printBoolCase keyword; + printChange(); + sayln "val noShift = "; + printBoolCase noshift; + printNames (); + printErrValues value; + say "val terms = "; + printTermList ecTerms; + sayln "end" + end + +val printAction = fn (rules, + VALS {hasType,say,sayln,termvoid,ntvoid, + symbolToString,saydot,start,pureActions,...}, + NAMES {actionsStruct,valueStruct,tableStruct,arg,...}) => +let val printAbsynRule = Absyn.printRule(say,sayln) + val is_nonterm = fn (NONTERM i) => true | _ => false + val numberRhs = fn r => + List.foldl (fn (e,(r,table)) => + let val num = case SymbolTable.find(e,table) + of SOME i => i + | NONE => 1 + in ((e,num,hasType e orelse is_nonterm e)::r, + SymbolTable.insert((e,num+1),table)) + end) (nil,SymbolTable.empty) r + + val saySym = symbolToString + + val printCase = fn (i:int, r as {lhs=lhs as (NT lhsNum),prec, + rhs,code,rulenum}) => + + (* mkToken: Build an argument *) + + let open Absyn + val mkToken = fn (sym,num : int,typed) => + let val symString = symbolToString sym + val symNum = symString ^ (Int.toString num) + in PTUPLE[WILD, + PTUPLE[if not (hasType sym) then + (if is_nonterm sym then + PAPP(valueStruct^"."^ntvoid, + PVAR symNum) + else WILD) + else + PAPP(valueStruct^"."^symString, + if num=1 andalso pureActions + then AS(PVAR symNum,PVAR symString) + else PVAR symNum), + if num=1 then AS(PVAR (symString^"left"), + PVAR(symNum^"left")) + else PVAR(symNum^"left"), + if num=1 then AS(PVAR(symString^"right"), + PVAR(symNum^"right")) + else PVAR(symNum^"right")]] + end + + val numberedRhs = #1 (numberRhs rhs) + + (* construct case pattern *) + + val pat = PTUPLE[PINT i,PLIST(map mkToken numberedRhs @ + [PVAR "rest671"])] + + (* remove terminals in argument list w/o types *) + + val argsWithTypes = + List.foldr (fn ((_,_,false),r) => r + | (s as (_,_,true),r) => s::r) nil numberedRhs + + (* construct case body *) + + val defaultPos = EVAR "defaultPos" + val resultexp = EVAR "result" + val resultpat = PVAR "result" + val code = CODE code + val rest = EVAR "rest671" + + val body = + LET([VB(resultpat, + EAPP(EVAR(valueStruct^"."^ + (if hasType (NONTERM lhs) + then saySym(NONTERM lhs) + else ntvoid)), + if pureActions then code + else if argsWithTypes=nil then FN(WILD,code) + else + FN(WILD, + let val body = + LET(map (fn (sym,num:int,_) => + let val symString = symbolToString sym + val symNum = symString ^ Int.toString num + in VB(if num=1 then + AS(PVAR symString,PVAR symNum) + else PVAR symNum, + EAPP(EVAR symNum,UNIT)) + end) (rev argsWithTypes), + code) + in if hasType (NONTERM lhs) then + body else SEQ(body,UNIT) + end)))], + ETUPLE[EAPP(EVAR(tableStruct^".NT"),EINT(lhsNum)), + case rhs + of nil => ETUPLE[resultexp,defaultPos,defaultPos] + | r =>let val (rsym,rnum,_) = hd(numberedRhs) + val (lsym,lnum,_) = hd(rev numberedRhs) + in ETUPLE[resultexp, + EVAR (symbolToString lsym ^ + Int.toString lnum ^ "left"), + EVAR (symbolToString rsym ^ + Int.toString rnum ^ "right")] + end, + rest]) + in printAbsynRule (RULE(pat,body)) + end + + val prRules = fn () => + (sayln "fn (i392,defaultPos,stack,"; + say " ("; say arg; sayln "):arg) =>"; + sayln "case (i392,stack)"; + say "of "; + app (fn (rule as {rulenum,...}) => + (printCase(rulenum,rule); say "| ")) rules; + sayln "_ => raise (mlyAction i392)") + + in say "structure "; + say actionsStruct; + sayln " ="; + sayln "struct "; + sayln "exception mlyAction of int"; + sayln "local open Header in"; + sayln "val actions = "; + prRules(); + sayln "end"; + say "val void = "; + saydot valueStruct; + sayln termvoid; + say "val extract = "; + say "fn a => (fn "; + saydot valueStruct; + if hasType (NONTERM start) + then say (symbolToString (NONTERM start)) + else say "ntVOID"; + sayln " x => x"; + sayln "| _ => let exception ParseInternal"; + say "\tin raise ParseInternal end) a "; + sayln (if pureActions then "" else "()"); + sayln "end" + end + + val make_parser = fn ((header, + DECL {eop,change,keyword,nonterm,prec, + term, control,value} : declData, + rules : rule list),spec,error : pos -> string -> unit, + wasError : unit -> bool) => + let + val verbose = List.exists (fn VERBOSE=>true | _ => false) control + val defaultReductions = not (List.exists (fn NODEFAULT=>true | _ => false) control) + val pos_type = + let fun f nil = NONE + | f ((POS s)::r) = SOME s + | f (_::r) = f r + in f control + end + val start = + let fun f nil = NONE + | f ((START_SYM s)::r) = SOME s + | f (_::r) = f r + in f control + end + val name = + let fun f nil = NONE + | f ((PARSER_NAME s)::r) = SOME s + | f (_::r) = f r + in f control + end + val header_decl = + let fun f nil = NONE + | f ((FUNCTOR s)::r) = SOME s + | f (_::r) = f r + in f control + end + val arg_decl = + let fun f nil = ("()","unit") + | f ((PARSE_ARG s)::r) = s + | f (_::r) = f r + in f control + end + + val noshift = + let fun f nil = nil + | f ((NSHIFT s)::r) = s + | f (_::r) = f r + in f control + end + + val pureActions = + let fun f nil = false + | f ((PURE)::r) = true + | f (_::r) = f r + in f control + end + + val term = + case term + of NONE => (error 1 "missing %term definition"; nil) + | SOME l => l + + val nonterm = + case nonterm + of NONE => (error 1 "missing %nonterm definition"; nil) + | SOME l => l + + val pos_type = + case pos_type + of NONE => (error 1 "missing %pos definition"; "") + | SOME l => l + + + val termHash = + List.foldr (fn ((symbol,_),table) => + let val name = symbolName symbol + in if SymbolHash.exists(name,table) then + (error (symbolPos symbol) + ("duplicate definition of " ^ name ^ " in %term"); + table) + else SymbolHash.add(name,table) + end) SymbolHash.empty term + + val isTerm = fn name => SymbolHash.exists(name,termHash) + + val symbolHash = + List.foldr (fn ((symbol,_),table) => + let val name = symbolName symbol + in if SymbolHash.exists(name,table) then + (error (symbolPos symbol) + (if isTerm name then + name ^ " is defined as a terminal and a nonterminal" + else + "duplicate definition of " ^ name ^ " in %nonterm"); + table) + else SymbolHash.add(name,table) + end) termHash nonterm + + fun makeUniqueId s = + if SymbolHash.exists(s,symbolHash) then makeUniqueId (s ^ "'") + else s + + val _ = if wasError() then raise Semantic else () + + val numTerms = SymbolHash.size termHash + val numNonterms = SymbolHash.size symbolHash - numTerms + + val symError = fn sym => fn err => fn symbol => + error (symbolPos symbol) + (symbolName symbol^" in "^err^" is not defined as a " ^ sym) + + val termNum : string -> Header.symbol -> term = + let val termError = symError "terminal" + in fn stmt => + let val stmtError = termError stmt + in fn symbol => + case SymbolHash.find(symbolName symbol,symbolHash) + of NONE => (stmtError symbol; T ~1) + | SOME i => T (if i Header.symbol -> nonterm = + let val nontermError = symError "nonterminal" + in fn stmt => + let val stmtError = nontermError stmt + in fn symbol => + case SymbolHash.find(symbolName symbol,symbolHash) + of NONE => (stmtError symbol; NT ~1) + | SOME i => if i>=numTerms then NT (i-numTerms) + else (stmtError symbol;NT ~1) + end + end + + val symbolNum : string -> Header.symbol -> Grammar.symbol = + let val symbolError = symError "symbol" + in fn stmt => + let val stmtError = symbolError stmt + in fn symbol => + case SymbolHash.find(symbolName symbol,symbolHash) + of NONE => (stmtError symbol; NONTERM (NT ~1)) + | SOME i => if i>=numTerms then NONTERM(NT (i-numTerms)) + else TERM(T i) + end + end + +(* map all symbols in the following values to terminals and check that + the symbols are defined as terminals: + + eop : symbol list + keyword: symbol list + prec: (lexvalue * (symbol list)) list + change: (symbol list * symbol list) list +*) + + val eop = map (termNum "%eop") eop + val keyword = map (termNum "%keyword") keyword + val prec = map (fn (a,l) => + (a,case a + of LEFT => map (termNum "%left") l + | RIGHT => map (termNum "%right") l + | NONASSOC => map (termNum "%nonassoc") l + )) prec + val change = + let val mapTerm = termNum "%prefer, %subst, or %change" + in map (fn (a,b) => (map mapTerm a, map mapTerm b)) change + end + val noshift = map (termNum "%noshift") noshift + val value = + let val mapTerm = termNum "%value" + in map (fn (a,b) => (mapTerm a,b)) value + end + val (rules,_) = + let val symbolNum = symbolNum "rule" + val nontermNum = nontermNum "rule" + val termNum = termNum "%prec tag" + in List.foldr + (fn (RULE {lhs,rhs,code,prec},(l,n)) => + ( {lhs=nontermNum lhs,rhs=map symbolNum rhs, + code=code,prec=case prec + of NONE => NONE + | SOME t => SOME (termNum t), + rulenum=n}::l,n-1)) + (nil,length rules-1) rules + end + + val _ = if wasError() then raise Semantic else () + + (* termToString: map terminals back to strings *) + + val termToString = + let val data = array(numTerms,"") + val unmap = fn (symbol,_) => + let val name = symbolName symbol + in update(data, + case SymbolHash.find(name,symbolHash) + of SOME i => i,name) + end + val _ = app unmap term + in fn T i => + if DEBUG andalso (i<0 orelse i>=numTerms) + then "bogus-num" ^ (Int.toString i) + else data sub i + end + + val nontermToString = + let val data = array(numNonterms,"") + val unmap = fn (symbol,_) => + let val name = symbolName symbol + in update(data, + case SymbolHash.find(name,symbolHash) + of SOME i => i-numTerms,name) + end + val _ = app unmap nonterm + in fn NT i => + if DEBUG andalso (i<0 orelse i>=numNonterms) + then "bogus-num" ^ (Int.toString i) + else data sub i + end + +(* create functions mapping terminals to precedence numbers and rules to + precedence numbers. + + Precedence statements are listed in order of ascending (tighter binding) + precedence in the specification. We receive a list composed of pairs + containing the kind of precedence (left,right, or assoc) and a list of + terminals associated with that precedence. The list has the same order as + the corresponding declarations did in the specification. + + Internally, a tighter binding has a higher precedence number. We give + precedences using multiples of 3: + + p+2 = right associative (force shift of symbol) + p+1 = precedence for rule + p = left associative (force reduction of rule) + + Nonassociative terminals are given also given a precedence of p+1. The +table generator detects when the associativity of a nonassociative terminal +is being used to resolve a shift/reduce conflict by checking if the +precedences of the rule and the terminal are equal. + + A rule is given the precedence of its rightmost terminal *) + + val termPrec = + let val precData = array(numTerms, NONE : int option) + val addPrec = fn termPrec => fn term as (T i) => + case precData sub i + of SOME _ => + error 1 ("multiple precedences specified for terminal " ^ + (termToString term)) + | NONE => update(precData,i,termPrec) + val termPrec = fn ((LEFT,_) ,i) => i + | ((RIGHT,_),i) => i+2 + | ((NONASSOC,l),i) => i+1 + val _ = List.foldl (fn (args as ((_,l),i)) => + (app (addPrec (SOME (termPrec args))) l; i+3)) + 0 prec + in fn (T i) => + if DEBUG andalso (i < 0 orelse i >= numTerms) then + NONE + else precData sub i + end + + val elimAssoc = fn i => (i - (i mod 3) + 1) + val rulePrec = + let fun findRightTerm (nil,r) = r + | findRightTerm (TERM t :: tail,r) = + findRightTerm(tail,SOME t) + | findRightTerm (_ :: tail,r) = findRightTerm(tail,r) + in fn rhs => + case findRightTerm(rhs,NONE) + of NONE => NONE + | SOME term => + case termPrec term + of SOME i => SOME (elimAssoc i) + | a => a + end + + val grammarRules = + let val conv = fn {lhs,rhs,code,prec,rulenum} => + {lhs=lhs,rhs =rhs,precedence= + case prec + of SOME t => (case termPrec t + of SOME i => SOME(elimAssoc i) + | a => a) + | _ => rulePrec rhs, + rulenum=rulenum} + in map conv rules + end + + (* get start symbol *) + + val start = + case start + of NONE => #lhs (hd grammarRules) + | SOME name => + nontermNum "%start" name + + val symbolType = + let val data = array(numTerms+numNonterms,NONE : ty option) + val unmap = fn (symbol,ty) => + update(data, + case SymbolHash.find(symbolName symbol,symbolHash) + of SOME i => i,ty) + val _ = (app unmap term; app unmap nonterm) + in fn NONTERM(NT i) => + if DEBUG andalso (i<0 orelse i>=numNonterms) + then NONE + else data sub (i+numTerms) + | TERM (T i) => + if DEBUG andalso (i<0 orelse i>=numTerms) + then NONE + else data sub i + end + + val symbolToString = + fn NONTERM i => nontermToString i + | TERM i => termToString i + + val grammar = GRAMMAR {rules=grammarRules, + terms=numTerms,nonterms=numNonterms, + eop = eop, start=start,noshift=noshift, + termToString = termToString, + nontermToString = nontermToString, + precedence = termPrec} + + val name' = case name + of NONE => "" + | SOME s => symbolName s + + val names = NAMES {miscStruct=name' ^ "LrValsFun", + valueStruct="MlyValue", + tableStruct="LrTable", + tokenStruct="Tokens", + actionsStruct="Actions", + ecStruct="EC", + arg= #1 arg_decl, + tokenSig = name' ^ "_TOKENS", + miscSig = name' ^ "_LRVALS", + dataStruct = "ParserData", + dataSig = "PARSER_DATA"} + + val (table,stateErrs,corePrint,errs) = + MakeTable.mkTable(grammar,defaultReductions) + + val entries = ref 0 (* save number of action table entries here *) + + in let val result = TextIO.openOut (spec ^ ".sml") + val sigs = TextIO.openOut (spec ^ ".sig") + val pos = ref 0 + val pr = fn s => TextIO.output(result,s) + val say = fn s => let val l = String.size s + val newPos = (!pos) + l + in if newPos > lineLength + then (pr "\n"; pos := l) + else (pos := newPos); + pr s + end + val saydot = fn s => (say (s ^ ".")) + val sayln = fn t => (pr t; pr "\n"; pos := 0) + val termvoid = makeUniqueId "VOID" + val ntvoid = makeUniqueId "ntVOID" + val hasType = fn s => case symbolType s + of NONE => false + | _ => true + val terms = let fun f n = if n=numTerms then nil + else (T n) :: f(n+1) + in f 0 + end + val values = VALS {say=say,sayln=sayln,saydot=saydot, + termvoid=termvoid, ntvoid = ntvoid, + hasType=hasType, pos_type = pos_type, + arg_type = #2 arg_decl, + start=start,pureActions=pureActions, + termToString=termToString, + symbolToString=symbolToString,term=term, + nonterm=nonterm,terms=terms} + + val (NAMES {miscStruct,tableStruct,dataStruct,tokenSig,tokenStruct,dataSig,...}) = names + in case header_decl + of NONE => (say "functor "; say miscStruct; + sayln "(structure Token : TOKEN)"; + say " : sig structure "; + say dataStruct; + say " : "; sayln dataSig; + say " structure "; + say tokenStruct; say " : "; sayln tokenSig; + sayln " end") + | SOME s => say s; + sayln " = "; + sayln "struct"; + sayln ("structure " ^ dataStruct ^ "="); + sayln "struct"; + sayln "structure Header = "; + sayln "struct"; + sayln header; + sayln "end"; + sayln "structure LrTable = Token.LrTable"; + sayln "structure Token = Token"; + sayln "local open LrTable in "; + entries := PrintStruct.makeStruct{table=table,print=pr, + name = "table", + verbose=verbose}; + sayln "end"; + printTypes(values,names,symbolType); + printEC (keyword,change,noshift,value,values,names); + printAction(rules,values,names); + sayln "end"; + printTokenStruct(values,names); + sayln "end"; + printSigs(values,names,fn s => TextIO.output(sigs,s)); + TextIO.closeOut sigs; + TextIO.closeOut result; + MakeTable.Errs.printSummary + (fn s => () (* commented out by sweeks so it runs silently + TextIO.output(TextIO.stdOut,s) *)) errs + end; + if verbose then + let val f = TextIO.openOut (spec ^ ".desc") + val say = fn s=> TextIO.output(f,s) + val printRule = + let val rules = Array.fromList grammarRules + in fn say => + let val prRule = fn {lhs,rhs,precedence,rulenum} => + ((say o nontermToString) lhs; say " : "; + app (fn s => (say (symbolToString s); say " ")) rhs) + in fn i => prRule (rules sub i) + end + end + in Verbose.printVerbose + {termToString=termToString,nontermToString=nontermToString, + table=table, stateErrs=stateErrs,errs = errs,entries = !entries, + print=say, printCores=corePrint,printRule=printRule}; + TextIO.closeOut f + end + else () + end + + val parseGen = fn spec => + let val (result,inputSource) = ParseGenParser.parse spec + in make_parser(getResult result,spec,Header.error inputSource, + errorOccurred inputSource) + end +end; +(* ML-Yacc Parser Generator (c) 1991 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.3 1996/02/26 15:02:30 george + * print no longer overloaded. + * use of makestring has been removed and replaced with Int.toString .. + * use of IO replaced with TextIO + * + * Revision 1.2 1996/02/15 01:51:38 jhr + * Replaced character predicates (isalpha, isnum) with functions from Char. + * + * Revision 1.1.1.1 1996/01/31 16:01:44 george + * Version 109 + * + *) + +structure Absyn : ABSYN = + struct + datatype exp + = CODE of string + | EAPP of exp * exp + | EINT of int + | ETUPLE of exp list + | EVAR of string + | FN of pat * exp + | LET of decl list * exp + | SEQ of exp * exp + | UNIT + and pat + = PVAR of string + | PAPP of string * pat + | PINT of int + | PLIST of pat list + | PTUPLE of pat list + | WILD + | AS of pat * pat + and decl = VB of pat * exp + and rule = RULE of pat * exp + + fun idchar #"'" = true + | idchar #"_" = true + | idchar c = Char.isAlpha c orelse Char.isDigit c + + fun code_to_ids s = let + fun g(nil,r) = r + | g(a as (h::t),r) = if Char.isAlpha h then f(t,[h],r) else g(t,r) + and f(nil,accum,r)= implode(rev accum)::r + | f(a as (h::t),accum,r) = + if idchar h then f(t,h::accum,r) else g(a,implode (rev accum) :: r) + in g(explode s,nil) + end + + val simplifyRule : rule -> rule = fn (RULE(p,e)) => + let val used : (string -> bool) = + let fun f(CODE s) = code_to_ids s + | f(EAPP(a,b)) = f a @ f b + | f(ETUPLE l) = List.concat (map f l) + | f(EVAR s) = [s] + | f(FN(_,e)) = f e + | f(LET(dl,e)) = + (List.concat (map (fn VB(_,e) => f e) dl)) @ f e + | f(SEQ(a,b)) = f a @ f b + | f _ = nil + val identifiers = f e + in fn s => List.exists (fn a=>a=s) identifiers + end + val simplifyPat : pat -> pat = + let fun f a = + case a + of (PVAR s) => if used s then a else WILD + | (PAPP(s,pat)) => + (case f pat + of WILD => WILD + | pat' => PAPP(s,pat')) + | (PLIST l) => + let val l' = map f l + in if List.exists(fn WILD=>false | _ => true) l' + then PLIST l' + else WILD + end + | (PTUPLE l) => + let val l' = map f l + in if List.exists(fn WILD=>false | _ => true) l' + then PTUPLE l' + else WILD + end + | (AS(a,b)) => + let val a'=f a + val b'=f b + in case(a',b') + of (WILD,_) => b' + | (_,WILD) => a' + | _ => AS(a',b') + end + | _ => a + in f + end + val simplifyExp : exp -> exp = + let fun f(EAPP(a,b)) = EAPP(f a,f b) + | f(ETUPLE l) = ETUPLE(map f l) + | f(FN(p,e)) = FN(simplifyPat p,f e) + | f(LET(dl,e)) = + LET(map (fn VB(p,e) => + VB(simplifyPat p,f e)) dl, + f e) + | f(SEQ(a,b)) = SEQ(f a,f b) + | f a = a + in f + end + in RULE(simplifyPat p,simplifyExp e) + end + + fun printRule (say : string -> unit, sayln:string -> unit) = let + val lp = ["("] + val rp = [")"] + val sp = [" "] + val sm = [";"] + val cm = [","] + val cr = ["\n"] + val unit = ["()"] + fun printExp c = + let fun f (CODE c) = ["(",c,")"] + | f (EAPP(EVAR a,UNIT)) = [a," ","()"] + | f (EAPP(EVAR a,EINT i)) = [a," ",Int.toString i] + | f (EAPP(EVAR a,EVAR b)) = [a," ",b] + | f (EAPP(EVAR a,b)) = List.concat[[a],lp,f b,rp] + | f (EAPP(a,b)) = List.concat [lp,f a,rp,lp,f b,rp] + | f (EINT i) = [Int.toString i] + | f (ETUPLE (a::r)) = + let fun scan nil = [rp] + | scan (h :: t) = cm :: f h :: scan t + in List.concat (lp :: f a :: scan r) + end + | f (ETUPLE _) = [""] + | f (EVAR s) = [s] + | f (FN (p,b)) = List.concat[["fn "],printPat p,[" => "],f b] + | f (LET (nil,body)) = f body + | f (LET (dl,body)) = + let fun scan nil = [[" in "],f body,[" end"],cr] + | scan (h :: t) = printDecl h :: scan t + in List.concat(["let "] :: scan dl) + end + | f (SEQ (a,b)) = List.concat [lp,f a,sm,f b,rp] + | f (UNIT) = unit + in f c + end + and printDecl (VB (pat,exp)) = + List.concat[["val "],printPat pat,["="],printExp exp,cr] + and printPat c = + let fun f (AS(PVAR a,PVAR b)) = [a," as ",b] + | f (AS(a,b)) = List.concat [lp,f a,[") as ("],f b,rp] + | f (PAPP(a,WILD)) = [a," ","_"] + | f (PAPP(a,PINT i)) = [a," ",Int.toString i] + | f (PAPP(a,PVAR b)) = [a," ",b] + | f (PAPP(a,b)) = List.concat [lp,[a],sp,f b,rp] + | f (PINT i) = [Int.toString i] + | f (PLIST nil) = [""] + | f (PLIST l) = + let fun scan (h :: nil) = [f h] + | scan (h :: t) = f h :: ["::"] :: scan t + in List.concat (scan l) + end + | f (PTUPLE (a::r)) = + let fun scan nil = [rp] + | scan (h :: t) = cm :: f h :: scan t + in List.concat (lp :: f a :: scan r) + end + | f (PTUPLE nil) = [""] + | f (PVAR a) = [a] + | f WILD = ["_"] + in f c + end + fun oursay "\n" = sayln "" + | oursay a = say a + in fn a => + let val RULE(p,e) = simplifyRule a + in app oursay (printPat p); + say " => "; + app oursay (printExp e) + end + end +end; +(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi + * + * $Log$ + * Revision 1.1.1.1 1996/01/31 16:01:45 george + * Version 109 + * + *) +local + +(* create parser *) + + structure LrVals = MlyaccLrValsFun(structure Token = LrParser.Token + structure Hdr = Header) + structure Lex = LexMLYACC(structure Tokens = LrVals.Tokens + structure Hdr = Header) + structure Parser = JoinWithArg(structure Lex=Lex + structure ParserData = LrVals.ParserData + structure LrParser= LrParser) + structure ParseGenParser = + ParseGenParserFun(structure Parser = Parser + structure Header = Header) + +(* create structure for computing LALR table from a grammar *) + + structure MakeLrTable = mkMakeLrTable(structure IntGrammar =IntGrammar + structure LrTable = LrTable) + +(* create structures for printing LALR tables: + + Verbose prints a verbose description of an lalr table + PrintStruct prints an ML structure representing that is an lalr table *) + + structure Verbose = mkVerbose(structure Errs = MakeLrTable.Errs) + structure PrintStruct = + mkPrintStruct(structure LrTable = MakeLrTable.LrTable + structure ShrinkLrTable = + ShrinkLrTableFun(structure LrTable=LrTable)) +in + +(* returns function which takes a file name, invokes the parser on the file, + does semantic checks, creates table, and prints it *) + + structure ParseGen = ParseGenFun(structure ParseGenParser = ParseGenParser + structure MakeTable = MakeLrTable + structure Verbose = Verbose + structure PrintStruct = PrintStruct + structure Absyn = Absyn) +end + +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; +(* main.sml + *) + +structure Main : BMARK = + struct + val s = OS.FileSys.getDir() + fun doit size = + let + fun loop n = + if n = 0 + then () + else (ParseGen.parseGen(s^"/DATA/ml.grm"); + loop(n - 1)) + in loop size + end + fun testit _ = ParseGen.parseGen(s^"/DATA/ml.grm") + end diff --git a/benchmark/tests/model-elimination.sml b/benchmark/tests/model-elimination.sml new file mode 100644 index 0000000..373bf85 --- /dev/null +++ b/benchmark/tests/model-elimination.sml @@ -0,0 +1,8801 @@ +(* Benchmark from Joe Hurd on 2002-09-24. + * + * He writes: + * + * FYI: this benchmark attacks a bunch of non-trivial problems using the + * model elimination first-order proof procedure. I've spent a fairly + * long time optimizing this at a "high-level" (meaning data-structures + * and algorithms optimizations, as well as exploiting domain knowledge, + * but no tricks that speed things up for a particular ML + * implementation). + *) +exception Empty + +(*#line 0.0 "$HOME/dev/sml/basic/src/PP.sig"*) +(* PP -- pretty-printing -- from the SML/NJ library *) + +signature PP = + sig + type ppstream + type ppconsumer = { consumer : string -> unit, + linewidth : int, + flush : unit -> unit } + + datatype break_style = + CONSISTENT + | INCONSISTENT + + val mk_ppstream : ppconsumer -> ppstream + val dest_ppstream : ppstream -> ppconsumer + val add_break : ppstream -> int * int -> unit + val add_newline : ppstream -> unit + val add_string : ppstream -> string -> unit + val begin_block : ppstream -> break_style -> int -> unit + val end_block : ppstream -> unit + val clear_ppstream : ppstream -> unit + val flush_ppstream : ppstream -> unit + val with_pp : ppconsumer -> (ppstream -> unit) -> unit + val pp_to_string : int -> (ppstream -> 'a -> unit) -> 'a -> string + end + +(* + This structure provides tools for creating customized Oppen-style + pretty-printers, based on the type ppstream. A ppstream is an + output stream that contains prettyprinting commands. The commands + are placed in the stream by various function calls listed below. + + There following primitives add commands to the stream: + begin_block, end_block, add_string, add_break, and add_newline. + All calls to add_string, add_break, and add_newline must happen + between a pair of calls to begin_block and end_block must be + properly nested dynamically. All calls to begin_block and + end_block must be properly nested (dynamically). + + [ppconsumer] is the type of sinks for pretty-printing. A value of + type ppconsumer is a record + { consumer : string -> unit, + linewidth : int, + flush : unit -> unit } + of a string consumer, a specified linewidth, and a flush function + which is called whenever flush_ppstream is called. + + A prettyprinter can be called outright to print a value. In + addition, a prettyprinter for a base type or nullary datatype ty + can be installed in the top-level system. Then the installed + prettyprinter will be invoked automatically whenever a value of + type ty is to be printed. + + [break_style] is the type of line break styles for blocks: + + [CONSISTENT] specifies that if any line break occurs inside the + block, then all indicated line breaks occur. + + [INCONSISTENT] specifies that breaks will be inserted to only to + avoid overfull lines. + + [mk_ppstream {consumer, linewidth, flush}] creates a new ppstream + which invokes the consumer to output text, putting at most + linewidth characters on each line. + + [dest_ppstream ppstrm] extracts the linewidth, flush function, and + consumer from a ppstream. + + [add_break ppstrm (size, offset)] notifies the pretty-printer that + a line break is possible at this point. + * When the current block style is CONSISTENT: + ** if the entire block fits on the remainder of the line, then + output size spaces; else + ** increase the current indentation by the block offset; + further indent every item of the block by offset, and add + one newline at every add_break in the block. + * When the current block style is INCONSISTENT: + ** if the next component of the block fits on the remainder of + the line, then output size spaces; else + ** issue a newline and indent to the current indentation level + plus the block offset plus the offset. + + [add_newline ppstrm] issues a newline. + + [add_string ppstrm str] outputs the string str to the ppstream. + + [begin_block ppstrm style blockoffset] begins a new block and + level of indentation, with the given style and block offset. + + [end_block ppstrm] closes the current block. + + [clear_ppstream ppstrm] restarts the stream, without affecting the + underlying consumer. + + [flush_ppstream ppstrm] executes any remaining commands in the + ppstream (that is, flushes currently accumulated output to the + consumer associated with ppstrm); executes the flush function + associated with the consumer; and calls clear_ppstream. + + [with_pp consumer f] makes a new ppstream from the consumer and + applies f (which can be thought of as a producer) to that + ppstream, then flushed the ppstream and returns the value of f. + + [pp_to_string linewidth printit x] constructs a new ppstream + ppstrm whose consumer accumulates the output in a string s. Then + evaluates (printit ppstrm x) and finally returns the string s. + + + Example 1: A simple prettyprinter for Booleans: + + load "PP"; + fun ppbool pps d = + let open PP + in + begin_block pps INCONSISTENT 6; + add_string pps (if d then "right" else "wrong"); + end_block pps + end; + + Now one may define a ppstream to print to, and exercise it: + + val ppstrm = PP.mk_ppstream {consumer = + fn s => TextIO.output(TextIO.stdOut, s), + linewidth = 72, + flush = + fn () => TextIO.flushOut TextIO.stdOut}; + + fun ppb b = (ppbool ppstrm b; PP.flush_ppstream ppstrm); + + - ppb false; + wrong> val it = () : unit + + The prettyprinter may also be installed in the toplevel system; + then it will be used to print all expressions of type bool + subsequently computed: + + - installPP ppbool; + > val it = () : unit + - 1=0; + > val it = wrong : bool + - 1=1; + > val it = right : bool + + See library Meta for a description of installPP. + + + Example 2: Prettyprinting simple expressions (examples/pretty/ppexpr.sml): + + datatype expr = + Cst of int + | Neg of expr + | Plus of expr * expr + + fun ppexpr pps e0 = + let open PP + fun ppe (Cst i) = add_string pps (Int.toString i) + | ppe (Neg e) = (add_string pps "~"; ppe e) + | ppe (Plus(e1, e2)) = (begin_block pps CONSISTENT 0; + add_string pps "("; + ppe e1; + add_string pps " + "; + add_break pps (0, 1); + ppe e2; + add_string pps ")"; + end_block pps) + in + begin_block pps INCONSISTENT 0; + ppe e0; + end_block pps + end + + val _ = installPP ppexpr; + + (* Some example values: *) + + val e1 = Cst 1; + val e2 = Cst 2; + val e3 = Plus(e1, Neg e2); + val e4 = Plus(Neg e3, e3); + val e5 = Plus(Neg e4, e4); + val e6 = Plus(e5, e5); + val e7 = Plus(e6, e6); + val e8 = + Plus(e3, Plus(e3, Plus(e3, Plus(e3, Plus(e3, Plus(e3, e7)))))); +*) +(*#line 0.0 "$HOME/dev/sml/basic/src/PP.sml"*) +(* PP -- Oppen-style prettyprinters. + * + * Modified for Milton ML from SML/NJ Library version 0.2 + * + * COPYRIGHT (c) 1992 by AT&T Bell Laboratories. + * See file mosml/copyrght/copyrght.att for details. + *) + +(* the functions and data for actually doing printing. *) + +structure PP :> PP = +struct + +open Array +infix 9 sub + +(* the queue library, formerly in unit Ppqueue *) + +datatype Qend = Qback | Qfront + +exception QUEUE_FULL +exception QUEUE_EMPTY +exception REQUESTED_QUEUE_SIZE_TOO_SMALL + +local + fun ++ i n = (i + 1) mod n + fun -- i n = (i - 1) mod n +in + +abstype 'a queue = QUEUE of {elems: 'a array, (* the contents *) + front: int ref, + back: int ref, + size: int} (* fixed size of element array *) +with + + fun is_empty (QUEUE{front=ref ~1, back=ref ~1,...}) = true + | is_empty _ = false + + fun mk_queue n init_val = + if (n < 2) + then raise REQUESTED_QUEUE_SIZE_TOO_SMALL + else QUEUE{elems=array(n, init_val), front=ref ~1, back=ref ~1, size=n} + + fun clear_queue (QUEUE{front,back,...}) = (front := ~1; back := ~1) + + fun queue_at Qfront (QUEUE{elems,front,...}) = elems sub !front + | queue_at Qback (QUEUE{elems,back,...}) = elems sub !back + + fun en_queue Qfront item (Q as QUEUE{elems,front,back,size}) = + if (is_empty Q) + then (front := 0; back := 0; + update(elems,0,item)) + else let val i = --(!front) size + in if (i = !back) + then raise QUEUE_FULL + else (update(elems,i,item); front := i) + end + | en_queue Qback item (Q as QUEUE{elems,front,back,size}) = + if (is_empty Q) + then (front := 0; back := 0; + update(elems,0,item)) + else let val i = ++(!back) size + in if (i = !front) + then raise QUEUE_FULL + else (update(elems,i,item); back := i) + end + + fun de_queue Qfront (Q as QUEUE{front,back,size,...}) = + if (!front = !back) (* unitary queue *) + then clear_queue Q + else front := ++(!front) size + | de_queue Qback (Q as QUEUE{front,back,size,...}) = + if (!front = !back) + then clear_queue Q + else back := --(!back) size + +end (* abstype queue *) +end (* local *) + + +val magic: 'a -> 'a = fn x => x + +(* exception PP_FAIL of string *) + +datatype break_style = CONSISTENT | INCONSISTENT + +datatype break_info + = FITS + | PACK_ONTO_LINE of int + | ONE_PER_LINE of int + +(* Some global values *) +val INFINITY = 999999 + +abstype indent_stack = Istack of break_info list ref +with + fun mk_indent_stack() = Istack (ref([]:break_info list)) + fun clear_indent_stack (Istack stk) = (stk := ([]:break_info list)) + fun top (Istack stk) = + case !stk + of nil => raise Fail "PP-error: top: badly formed block" + | x::_ => x + fun push (x,(Istack stk)) = stk := x::(!stk) + fun pop (Istack stk) = + case !stk + of nil => raise Fail "PP-error: pop: badly formed block" + | _::rest => stk := rest +end + +(* The delim_stack is used to compute the size of blocks. It is + a stack of indices into the token buffer. The indices only point to + BBs, Es, and BRs. We push BBs and Es onto the stack until a BR + is encountered. Then we compute sizes and pop. When we encounter + a BR in the middle of a block, we compute the Distance_to_next_break + of the previous BR in the block, if there was one. + + We need to be able to delete from the bottom of the delim_stack, so + we use a queue, treated with a stack discipline, i.e., we only add + items at the head of the queue, but can delete from the front or + back of the queue. +*) +abstype delim_stack = Dstack of int queue +with + fun new_delim_stack i = Dstack(mk_queue i ~1) + fun reset_delim_stack (Dstack q) = clear_queue q + + fun pop_delim_stack (Dstack d) = de_queue Qfront d + fun pop_bottom_delim_stack (Dstack d) = de_queue Qback d + + fun push_delim_stack(i,Dstack d) = en_queue Qfront i d + fun top_delim_stack (Dstack d) = queue_at Qfront d + fun bottom_delim_stack (Dstack d) = queue_at Qback d + fun delim_stack_is_empty (Dstack d) = is_empty d +end + + +type block_info = { Block_size : int ref, + Block_offset : int, + How_to_indent : break_style } + + +(* Distance_to_next_break includes Number_of_blanks. Break_offset is + a local offset for the break. BB represents a sequence of contiguous + Begins. E represents a sequence of contiguous Ends. +*) +datatype pp_token + = S of {String : string, Length : int} + | BB of {Pblocks : block_info list ref, (* Processed *) + Ublocks : block_info list ref} (* Unprocessed *) + | E of {Pend : int ref, Uend : int ref} + | BR of {Distance_to_next_break : int ref, + Number_of_blanks : int, + Break_offset : int} + + +(* The initial values in the token buffer *) +val initial_token_value = S{String = "", Length = 0} + +(* type ppstream = General.ppstream; *) +datatype ppstream_ = + PPS of + {consumer : string -> unit, + linewidth : int, + flush : unit -> unit, + the_token_buffer : pp_token array, + the_delim_stack : delim_stack, + the_indent_stack : indent_stack, + ++ : int ref -> unit, (* increment circular buffer index *) + space_left : int ref, (* remaining columns on page *) + left_index : int ref, (* insertion index *) + right_index : int ref, (* output index *) + left_sum : int ref, (* size of strings and spaces inserted *) + right_sum : int ref} (* size of strings and spaces printed *) + +type ppstream = ppstream_ + +type ppconsumer = {consumer : string -> unit, + linewidth : int, + flush : unit -> unit} + +fun mk_ppstream {consumer,linewidth,flush} = + if (linewidth<5) + then raise Fail "PP-error: linewidth too_small" + else let val buf_size = 3*linewidth + in magic( + PPS{consumer = consumer, + linewidth = linewidth, + flush = flush, + the_token_buffer = array(buf_size, initial_token_value), + the_delim_stack = new_delim_stack buf_size, + the_indent_stack = mk_indent_stack (), + ++ = fn i => i := ((!i + 1) mod buf_size), + space_left = ref linewidth, + left_index = ref 0, right_index = ref 0, + left_sum = ref 0, right_sum = ref 0} + ) : ppstream + end + +fun dest_ppstream(pps : ppstream) = + let val PPS{consumer,linewidth,flush, ...} = magic pps + in {consumer=consumer,linewidth=linewidth,flush=flush} end + +local + val space = " " + fun mk_space (0,s) = String.concat s + | mk_space (n,s) = mk_space((n-1), (space::s)) + val space_table = Vector.tabulate(100, fn i => mk_space(i,[])) + fun nspaces n = Vector.sub(space_table, n) + handle General.Subscript => + if n < 0 + then "" + else let val n2 = n div 2 + val n2_spaces = nspaces n2 + val extra = if (n = (2*n2)) then "" else space + in String.concat [n2_spaces, n2_spaces, extra] + end +in + fun cr_indent (ofn, i) = ofn ("\n"^(nspaces i)) + fun indent (ofn,i) = ofn (nspaces i) +end + + +(* Print a the first member of a contiguous sequence of Begins. If there + are "processed" Begins, then take the first off the list. If there are + no processed Begins, take the last member off the "unprocessed" list. + This works because the unprocessed list is treated as a stack, the + processed list as a FIFO queue. How can an item on the unprocessed list + be printable? Because of what goes on in add_string. See there for details. +*) + +fun print_BB (_,{Pblocks = ref [], Ublocks = ref []}) = + raise Fail "PP-error: print_BB" + | print_BB (PPS{the_indent_stack,linewidth,space_left=ref sp_left,...}, + {Pblocks as ref({How_to_indent=CONSISTENT,Block_size, + Block_offset}::rst), + Ublocks=ref[]}) = + (push ((if (!Block_size > sp_left) + then ONE_PER_LINE (linewidth - (sp_left - Block_offset)) + else FITS), + the_indent_stack); + Pblocks := rst) + | print_BB(PPS{the_indent_stack,linewidth,space_left=ref sp_left,...}, + {Pblocks as ref({Block_size,Block_offset,...}::rst),Ublocks=ref[]}) = + (push ((if (!Block_size > sp_left) + then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset)) + else FITS), + the_indent_stack); + Pblocks := rst) + | print_BB (PPS{the_indent_stack, linewidth, space_left=ref sp_left,...}, + {Ublocks,...}) = + let fun pr_end_Ublock [{How_to_indent=CONSISTENT,Block_size,Block_offset}] l = + (push ((if (!Block_size > sp_left) + then ONE_PER_LINE (linewidth - (sp_left - Block_offset)) + else FITS), + the_indent_stack); + List.rev l) + | pr_end_Ublock [{Block_size,Block_offset,...}] l = + (push ((if (!Block_size > sp_left) + then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset)) + else FITS), + the_indent_stack); + List.rev l) + | pr_end_Ublock (a::rst) l = pr_end_Ublock rst (a::l) + | pr_end_Ublock _ _ = + raise Fail "PP-error: print_BB: internal error" + in Ublocks := pr_end_Ublock(!Ublocks) [] + end + + +(* Uend should always be 0 when print_E is called. *) +fun print_E (_,{Pend = ref 0, Uend = ref 0}) = + raise Fail "PP-error: print_E" + | print_E (istack,{Pend, ...}) = + let fun pop_n_times 0 = () + | pop_n_times n = (pop istack; pop_n_times(n-1)) + in pop_n_times(!Pend); Pend := 0 + end + + +(* "cursor" is how many spaces across the page we are. *) + +fun print_token(PPS{consumer,space_left,...}, S{String,Length}) = + (consumer String; + space_left := (!space_left) - Length) + | print_token(ppstrm,BB b) = print_BB(ppstrm,b) + | print_token(PPS{the_indent_stack,...},E e) = + print_E (the_indent_stack,e) + | print_token (PPS{the_indent_stack,space_left,consumer,linewidth,...}, + BR{Distance_to_next_break,Number_of_blanks,Break_offset}) = + (case (top the_indent_stack) + of FITS => + (space_left := (!space_left) - Number_of_blanks; + indent (consumer,Number_of_blanks)) + | (ONE_PER_LINE cursor) => + let val new_cursor = cursor + Break_offset + in space_left := linewidth - new_cursor; + cr_indent (consumer,new_cursor) + end + | (PACK_ONTO_LINE cursor) => + if (!Distance_to_next_break > (!space_left)) + then let val new_cursor = cursor + Break_offset + in space_left := linewidth - new_cursor; + cr_indent(consumer,new_cursor) + end + else (space_left := !space_left - Number_of_blanks; + indent (consumer,Number_of_blanks))) + + +fun clear_ppstream(pps : ppstream) = + let val PPS{the_token_buffer, the_delim_stack, + the_indent_stack,left_sum, right_sum, + left_index, right_index,space_left,linewidth,...} + = magic pps + val buf_size = 3*linewidth + fun set i = + if (i = buf_size) + then () + else (update(the_token_buffer,i,initial_token_value); + set (i+1)) + in set 0; + clear_indent_stack the_indent_stack; + reset_delim_stack the_delim_stack; + left_sum := 0; right_sum := 0; + left_index := 0; right_index := 0; + space_left := linewidth + end + + +(* Move insertion head to right unless adding a BB and already at a BB, + or unless adding an E and already at an E. +*) +fun BB_inc_right_index(PPS{the_token_buffer, right_index, ++,...})= + case (the_token_buffer sub (!right_index)) + of (BB _) => () + | _ => ++right_index + +fun E_inc_right_index(PPS{the_token_buffer,right_index, ++,...})= + case (the_token_buffer sub (!right_index)) + of (E _) => () + | _ => ++right_index + + +fun pointers_coincide(PPS{left_index,right_index,the_token_buffer,...}) = + (!left_index = !right_index) andalso + (case (the_token_buffer sub (!left_index)) + of (BB {Pblocks = ref [], Ublocks = ref []}) => true + | (BB _) => false + | (E {Pend = ref 0, Uend = ref 0}) => true + | (E _) => false + | _ => true) + +fun advance_left (ppstrm as PPS{consumer,left_index,left_sum, + the_token_buffer,++,...}, + instr) = + let val NEG = ~1 + val POS = 0 + fun inc_left_sum (BR{Number_of_blanks, ...}) = + left_sum := (!left_sum) + Number_of_blanks + | inc_left_sum (S{Length, ...}) = left_sum := (!left_sum) + Length + | inc_left_sum _ = () + + fun last_size [{Block_size, ...}:block_info] = !Block_size + | last_size (_::rst) = last_size rst + | last_size _ = raise Fail "PP-error: last_size: internal error" + fun token_size (S{Length, ...}) = Length + | token_size (BB b) = + (case b + of {Pblocks = ref [], Ublocks = ref []} => + raise Fail "PP-error: BB_size" + | {Pblocks as ref(_::_),Ublocks=ref[]} => POS + | {Ublocks, ...} => last_size (!Ublocks)) + | token_size (E{Pend = ref 0, Uend = ref 0}) = + raise Fail "PP-error: token_size.E" + | token_size (E{Pend = ref 0, ...}) = NEG + | token_size (E _) = POS + | token_size (BR {Distance_to_next_break, ...}) = !Distance_to_next_break + fun loop (instr) = + if (token_size instr < 0) (* synchronization point; cannot advance *) + then () + else (print_token(ppstrm,instr); + inc_left_sum instr; + if (pointers_coincide ppstrm) + then () + else (* increment left index *) + + (* When this is evaluated, we know that the left_index has not yet + caught up to the right_index. If we are at a BB or an E, we can + increment left_index if there is no work to be done, i.e., all Begins + or Ends have been dealt with. Also, we should do some housekeeping and + clear the buffer at left_index, otherwise we can get errors when + left_index catches up to right_index and we reset the indices to 0. + (We might find ourselves adding a BB to an "old" BB, with the result + that the index is not pushed onto the delim_stack. This can lead to + mangled output.) + *) + (case (the_token_buffer sub (!left_index)) + of (BB {Pblocks = ref [], Ublocks = ref []}) => + (update(the_token_buffer,!left_index, + initial_token_value); + ++left_index) + | (BB _) => () + | (E {Pend = ref 0, Uend = ref 0}) => + (update(the_token_buffer,!left_index, + initial_token_value); + ++left_index) + | (E _) => () + | _ => ++left_index; + loop (the_token_buffer sub (!left_index)))) + in loop instr + end + + +fun begin_block (pps : ppstream) style offset = + let val ppstrm = magic pps : ppstream_ + val PPS{the_token_buffer, the_delim_stack,left_index, + left_sum, right_index, right_sum,...} + = ppstrm + in + (if (delim_stack_is_empty the_delim_stack) + then (left_index := 0; + left_sum := 1; + right_index := 0; + right_sum := 1) + else BB_inc_right_index ppstrm; + case (the_token_buffer sub (!right_index)) + of (BB {Ublocks, ...}) => + Ublocks := {Block_size = ref (~(!right_sum)), + Block_offset = offset, + How_to_indent = style}::(!Ublocks) + | _ => (update(the_token_buffer, !right_index, + BB{Pblocks = ref [], + Ublocks = ref [{Block_size = ref (~(!right_sum)), + Block_offset = offset, + How_to_indent = style}]}); + push_delim_stack (!right_index, the_delim_stack))) + end + +fun end_block(pps : ppstream) = + let val ppstrm = magic pps : ppstream_ + val PPS{the_token_buffer,the_delim_stack,right_index,...} + = ppstrm + in + if (delim_stack_is_empty the_delim_stack) + then print_token(ppstrm,(E{Pend = ref 1, Uend = ref 0})) + else (E_inc_right_index ppstrm; + case (the_token_buffer sub (!right_index)) + of (E{Uend, ...}) => Uend := !Uend + 1 + | _ => (update(the_token_buffer,!right_index, + E{Uend = ref 1, Pend = ref 0}); + push_delim_stack (!right_index, the_delim_stack))) + end + +local + fun check_delim_stack(PPS{the_token_buffer,the_delim_stack,right_sum,...}) = + let fun check k = + if (delim_stack_is_empty the_delim_stack) + then () + else case(the_token_buffer sub (top_delim_stack the_delim_stack)) + of (BB{Ublocks as ref ((b as {Block_size, ...})::rst), + Pblocks}) => + if (k>0) + then (Block_size := !right_sum + !Block_size; + Pblocks := b :: (!Pblocks); + Ublocks := rst; + if (List.length rst = 0) + then pop_delim_stack the_delim_stack + else (); + check(k-1)) + else () + | (E{Pend,Uend}) => + (Pend := (!Pend) + (!Uend); + Uend := 0; + pop_delim_stack the_delim_stack; + check(k + !Pend)) + | (BR{Distance_to_next_break, ...}) => + (Distance_to_next_break := + !right_sum + !Distance_to_next_break; + pop_delim_stack the_delim_stack; + if (k>0) + then check k + else ()) + | _ => raise Fail "PP-error: check_delim_stack.catchall" + in check 0 + end +in + + fun add_break (pps : ppstream) (n, break_offset) = + let val ppstrm = magic pps : ppstream_ + val PPS{the_token_buffer,the_delim_stack,left_index, + right_index,left_sum,right_sum, ++, ...} + = ppstrm + in + (if (delim_stack_is_empty the_delim_stack) + then (left_index := 0; right_index := 0; + left_sum := 1; right_sum := 1) + else ++right_index; + update(the_token_buffer, !right_index, + BR{Distance_to_next_break = ref (~(!right_sum)), + Number_of_blanks = n, + Break_offset = break_offset}); + check_delim_stack ppstrm; + right_sum := (!right_sum) + n; + push_delim_stack (!right_index,the_delim_stack)) + end + + fun flush_ppstream0(pps : ppstream) = + let val ppstrm = magic pps : ppstream_ + val PPS{the_delim_stack,the_token_buffer, flush, left_index,...} + = ppstrm + in + (if (delim_stack_is_empty the_delim_stack) + then () + else (check_delim_stack ppstrm; + advance_left(ppstrm, the_token_buffer sub (!left_index))); + flush()) + end + +end (* local *) + + +fun flush_ppstream ppstrm = + (flush_ppstream0 ppstrm; + clear_ppstream ppstrm) + +fun add_string (pps : ppstream) s = + let val ppstrm = magic pps : ppstream_ + val PPS{the_token_buffer,the_delim_stack,consumer, + right_index,right_sum,left_sum, + left_index,space_left,++,...} + = ppstrm + fun fnl [{Block_size, ...}:block_info] = Block_size := INFINITY + | fnl (_::rst) = fnl rst + | fnl _ = raise Fail "PP-error: fnl: internal error" + + fun set(dstack,BB{Ublocks as ref[{Block_size,...}:block_info],...}) = + (pop_bottom_delim_stack dstack; + Block_size := INFINITY) + | set (_,BB {Ublocks = ref(_::rst), ...}) = fnl rst + | set (dstack, E{Pend,Uend}) = + (Pend := (!Pend) + (!Uend); + Uend := 0; + pop_bottom_delim_stack dstack) + | set (dstack,BR{Distance_to_next_break,...}) = + (pop_bottom_delim_stack dstack; + Distance_to_next_break := INFINITY) + | set _ = raise (Fail "PP-error: add_string.set") + + fun check_stream () = + if ((!right_sum - !left_sum) > !space_left) + then if (delim_stack_is_empty the_delim_stack) + then () + else let val i = bottom_delim_stack the_delim_stack + in if (!left_index = i) + then set (the_delim_stack, the_token_buffer sub i) + else (); + advance_left(ppstrm, + the_token_buffer sub (!left_index)); + if (pointers_coincide ppstrm) + then () + else check_stream () + end + else () + + val slen = String.size s + val S_token = S{String = s, Length = slen} + + in if (delim_stack_is_empty the_delim_stack) + then print_token(ppstrm,S_token) + else (++right_index; + update(the_token_buffer, !right_index, S_token); + right_sum := (!right_sum)+slen; + check_stream ()) + end + + +(* Derived form. The +2 is for peace of mind *) +fun add_newline (pps : ppstream) = + let val PPS{linewidth, ...} = magic pps + in add_break pps (linewidth+2,0) end + +(* Derived form. Builds a ppstream, sends pretty printing commands called in + f to the ppstream, then flushes ppstream. +*) + +fun with_pp ppconsumer ppfn = + let val ppstrm = mk_ppstream ppconsumer + in ppfn ppstrm; + flush_ppstream0 ppstrm + end + handle Fail msg => + (TextIO.print (">>>> Pretty-printer failure: " ^ msg ^ "\n")) + +fun pp_to_string linewidth ppfn ob = + let val l = ref ([]:string list) + fun attach s = l := (s::(!l)) + in with_pp {consumer = attach, linewidth=linewidth, flush = fn()=>()} + (fn ppstrm => ppfn ppstrm ob); + String.concat(List.rev(!l)) + end +end +(*#line 0.0 "$HOME/dev/sml/basic/src/Binarymap.sig"*) +(* Binarymap -- applicative maps as balanced ordered binary trees *) +(* From SML/NJ lib 0.2, copyright 1993 by AT&T Bell Laboratories *) +(* Original implementation due to Stephen Adams, Southampton, UK *) + +signature Binarymap = +sig + +type ('key, 'a) dict + +exception NotFound + +val mkDict : ('key * 'key -> order) -> ('key, 'a) dict +val insert : ('key, 'a) dict * 'key * 'a -> ('key, 'a) dict +val find : ('key, 'a) dict * 'key -> 'a +val peek : ('key, 'a) dict * 'key -> 'a option +val remove : ('key, 'a) dict * 'key -> ('key, 'a) dict * 'a +val numItems : ('key, 'a) dict -> int +val listItems : ('key, 'a) dict -> ('key * 'a) list +val app : ('key * 'a -> unit) -> ('key,'a) dict -> unit +val revapp : ('key * 'a -> unit) -> ('key,'a) dict -> unit +val foldr : ('key * 'a * 'b -> 'b)-> 'b -> ('key,'a) dict -> 'b +val foldl : ('key * 'a * 'b -> 'b) -> 'b -> ('key,'a) dict -> 'b +val map : ('key * 'a -> 'b) -> ('key,'a) dict -> ('key, 'b) dict +val transform : ('a -> 'b) -> ('key,'a) dict -> ('key, 'b) dict + +end + +(* + [('key, 'a) dict] is the type of applicative maps from domain type + 'key to range type 'a, or equivalently, applicative dictionaries + with keys of type 'key and values of type 'a. They are implemented + as ordered balanced binary trees. + + [mkDict ordr] returns a new, empty map whose keys have ordering + ordr. + + [insert(m, i, v)] extends (or modifies) map m to map i to v. + + [find (m, k)] returns v if m maps k to v; otherwise raises NotFound. + + [peek(m, k)] returns SOME v if m maps k to v; otherwise returns NONE. + + [remove(m, k)] removes k from the domain of m and returns the + modified map and the element v corresponding to k. Raises NotFound + if k is not in the domain of m. + + [numItems m] returns the number of entries in m (that is, the size + of the domain of m). + + [listItems m] returns a list of the entries (k, v) of keys k and + the corresponding values v in m, in order of increasing key values. + + [app f m] applies function f to the entries (k, v) in m, in + increasing order of k (according to the ordering ordr used to + create the map or dictionary). + + [revapp f m] applies function f to the entries (k, v) in m, in + decreasing order of k. + + [foldl f e m] applies the folding function f to the entries (k, v) + in m, in increasing order of k. + + [foldr f e m] applies the folding function f to the entries (k, v) + in m, in decreasing order of k. + + [map f m] returns a new map whose entries have form (k, f(k,v)), + where (k, v) is an entry in m. + + [transform f m] returns a new map whose entries have form (k, f v), + where (k, v) is an entry in m. +*) +(*#line 0.0 "$HOME/dev/sml/basic/src/Binarymap.sml"*) +(* Binarymap -- modified for Milton ML + * from SML/NJ library v. 0.2 file binary-dict.sml. + * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. + * See file mosml/copyrght/copyrght.att for details. + * + * This code was adapted from Stephen Adams' binary tree implementation + * of applicative integer sets. + * + * Copyright 1992 Stephen Adams. + * + * This software may be used freely provided that: + * 1. This copyright notice is attached to any copy, derived work, + * or work including all or part of this software. + * 2. Any derived work must contain a prominent notice stating that + * it has been altered from the original. + * + * + * Name(s): Stephen Adams. + * Department, Institution: Electronics & Computer Science, + * University of Southampton + * Address: Electronics & Computer Science + * University of Southampton + * Southampton SO9 5NH + * Great Britian + * E-mail: sra@ecs.soton.ac.uk + * + * Comments: + * + * 1. The implementation is based on Binary search trees of Bounded + * Balance, similar to Nievergelt & Reingold, SIAM J. Computing + * 2(1), March 1973. The main advantage of these trees is that + * they keep the size of the tree in the node, giving a constant + * time size operation. + * + * 2. The bounded balance criterion is simpler than N&R's alpha. + * Simply, one subtree must not have more than `weight' times as + * many elements as the opposite subtree. Rebalancing is + * guaranteed to reinstate the criterion for weight>2.23, but + * the occasional incorrect behaviour for weight=2 is not + * detrimental to performance. + * + *) + +structure Binarymap :> Binarymap = +struct + +exception NotFound + +fun wt (i : int) = 3 * i + +datatype ('key, 'a) dict = + DICT of ('key * 'key -> order) * ('key, 'a) tree +and ('key, 'a) tree = + E + | T of {key : 'key, + value : 'a, + cnt : int, + left : ('key, 'a) tree, + right : ('key, 'a) tree} + +fun treeSize E = 0 + | treeSize (T{cnt,...}) = cnt + +fun numItems (DICT(_, t)) = treeSize t + +local + fun N(k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} + | N(k,v,E,r as T n) = T{key=k,value=v,cnt=1+(#cnt n),left=E,right=r} + | N(k,v,l as T n,E) = T{key=k,value=v,cnt=1+(#cnt n),left=l,right=E} + | N(k,v,l as T n,r as T n') = + T{key=k,value=v,cnt=1+(#cnt n)+(#cnt n'),left=l,right=r} + + fun single_L (a,av,x,T{key=b,value=bv,left=y,right=z,...}) = + N(b,bv,N(a,av,x,y),z) + | single_L _ = raise Match + fun single_R (b,bv,T{key=a,value=av,left=x,right=y,...},z) = + N(a,av,x,N(b,bv,y,z)) + | single_R _ = raise Match + fun double_L (a,av,w,T{key=c,value=cv, + left=T{key=b,value=bv,left=x,right=y,...}, + right=z,...}) = + N(b,bv,N(a,av,w,x),N(c,cv,y,z)) + | double_L _ = raise Match + fun double_R (c,cv,T{key=a,value=av,left=w, + right=T{key=b,value=bv,left=x,right=y,...},...},z) = + N(b,bv,N(a,av,w,x),N(c,cv,y,z)) + | double_R _ = raise Match + + fun T' (k,v,E,E) = T{key=k,value=v,cnt=1,left=E,right=E} + | T' (k,v,E,r as T{right=E,left=E,...}) = + T{key=k,value=v,cnt=2,left=E,right=r} + | T' (k,v,l as T{right=E,left=E,...},E) = + T{key=k,value=v,cnt=2,left=l,right=E} + + | T' (p as (_,_,E,T{left=T _,right=E,...})) = double_L p + | T' (p as (_,_,T{left=E,right=T _,...},E)) = double_R p + + (* these cases almost never happen with small weight*) + | T' (p as (_,_,E,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...})) = + if ln < rn then single_L p else double_L p + | T' (p as (_,_,T{left=T{cnt=ln,...},right=T{cnt=rn,...},...},E)) = + if ln > rn then single_R p else double_R p + + | T' (p as (_,_,E,T{left=E,...})) = single_L p + | T' (p as (_,_,T{right=E,...},E)) = single_R p + + | T' (p as (k,v,l as T{cnt=ln,left=ll,right=lr,...}, + r as T{cnt=rn,left=rl,right=rr,...})) = + if rn >= wt ln then (*right is too big*) + let val rln = treeSize rl + val rrn = treeSize rr + in + if rln < rrn then single_L p else double_L p + end + + else if ln >= wt rn then (*left is too big*) + let val lln = treeSize ll + val lrn = treeSize lr + in + if lrn < lln then single_R p else double_R p + end + + else T{key=k,value=v,cnt=ln+rn+1,left=l,right=r} + + local + fun min (T{left=E,key,value,...}) = (key,value) + | min (T{left,...}) = min left + | min _ = raise Match + + fun delmin (T{left=E,right,...}) = right + | delmin (T{key,value,left,right,...}) = + T'(key,value,delmin left,right) + | delmin _ = raise Match + in + fun delete' (E,r) = r + | delete' (l,E) = l + | delete' (l,r) = let val (mink,minv) = min r + in T'(mink,minv,l,delmin r) end + end +in + fun mkDict cmpKey = DICT(cmpKey, E) + + fun insert (DICT (cmpKey, t),x,v) = + let fun ins E = T{key=x,value=v,cnt=1,left=E,right=E} + | ins (T(set as {key,left,right,value,...})) = + case cmpKey (key,x) of + GREATER => T'(key,value,ins left,right) + | LESS => T'(key,value,left,ins right) + | _ => + T{key=x,value=v,left=left,right=right,cnt= #cnt set} + in DICT(cmpKey, ins t) end + + fun find (DICT(cmpKey, t), x) = + let fun mem E = raise NotFound + | mem (T(n as {key,left,right,...})) = + case cmpKey (x,key) of + GREATER => mem right + | LESS => mem left + | _ => #value n + in mem t end + + fun peek arg = (SOME(find arg)) handle NotFound => NONE + + fun remove (DICT(cmpKey, t), x) = + let fun rm E = raise NotFound + | rm (set as T{key,left,right,value,...}) = + (case cmpKey (key,x) of + GREATER => let val (left', v) = rm left + in (T'(key, value, left', right), v) end + | LESS => let val (right', v) = rm right + in (T'(key, value, left, right'), v) end + | _ => (delete'(left,right),value)) + val (newtree, valrm) = rm t + in (DICT(cmpKey, newtree), valrm) end + + fun listItems (DICT(_, d)) = + let fun d2l E res = res + | d2l (T{key,value,left,right,...}) res = + d2l left ((key,value) :: d2l right res) + in d2l d [] end + + fun revapp f (DICT(_, d)) = let + fun a E = () + | a (T{key,value,left,right,...}) = (a right; f(key,value); a left) + in a d end + + fun app f (DICT(_, d)) = let + fun a E = () + | a (T{key,value,left,right,...}) = (a left; f(key,value); a right) + in a d end + + fun foldr f init (DICT(_, d)) = let + fun a E v = v + | a (T{key,value,left,right,...}) v = a left (f(key,value,a right v)) + in a d init end + + fun foldl f init (DICT(_, d)) = let + fun a E v = v + | a (T{key,value,left,right,...}) v = a right (f(key,value,a left v)) + in a d init end + + fun map f (DICT(cmpKey, d)) = let + fun a E = E + | a (T{key,value,left,right,cnt}) = let + val left' = a left + val value' = f(key,value) + in + T{cnt=cnt, key=key,value=value',left = left', right = a right} + end + in DICT(cmpKey, a d) end + + fun transform f (DICT(cmpKey, d)) = + let fun a E = E + | a (T{key,value,left,right,cnt}) = + let val left' = a left + in + T{cnt=cnt, key=key, value=f value, left = left', + right = a right} + end + in DICT(cmpKey, a d) end +end + +end +(*#line 0.0 "$HOME/dev/sml/basic/src/Susp.sig"*) +(* Susp -- support for lazy evaluation *) + +signature Susp = +sig + +type 'a susp + +val delay : (unit -> 'a) -> 'a susp +val force : 'a susp -> 'a + +end + +(* + ['a susp] is the type of lazily evaluated expressions with result + type 'a. + + [delay (fn () => e)] creates a suspension for the expression e. + The first time the suspension is forced, the expression e will be + evaluated, and the result stored in the suspension. All subsequent + forcing of the suspension will just return this result, so e is + evaluated at most once. If the suspension is never forced, then e + is never evaluated. + + [force su] forces the suspension su and returns the result of the + expression e stored in the suspension. +*) +(*#line 0.0 "$HOME/dev/sml/basic/src/Susp.sml"*) +(* Susp -- support for lazy evaluation 1995-05-22 *) + +structure Susp :> Susp = +struct + +datatype 'a thunk = VAL of 'a | THUNK of unit -> 'a; + +type 'a susp = 'a thunk ref; + +fun delay (f : unit -> 'a) = ref (THUNK f); + +fun force (su : 'a susp) : 'a = + case !su of + VAL v => v + | THUNK f => let val v = f () in su := VAL v; v end + +end +(*#line 0.0 "$HOME/dev/sml/basic/src/Milton.sig"*) +(* ========================================================================= *) +(* MLton SPECIFIC FUNCTIONS *) +(* Created by Joe Hurd, September 2002 *) +(* ========================================================================= *) + +signature Milton = +sig + +(* The ML implementation *) +val ml : string + +(* Pointer equality using the run-time system *) + +(* Quotations a la Mosml *) +datatype 'a frag = QUOTE of string | ANTIQUOTE of 'a + +(* Timing function applications a la Mosml.time *) +val time : ('a -> 'b) -> 'a -> 'b + +(* Bring certain declarations to the top-level *) +type ppstream = PP.ppstream + +(* Dummy versions of Mosml declarations to stop MLton barfing *) +val quotation : bool ref +val load : string -> unit +val installPP : (ppstream -> 'a -> unit) -> unit + +end +(*#line 0.0 "$HOME/dev/sml/basic/src/Milton.sml"*) +(* ========================================================================= *) +(* MLton SPECIFIC FUNCTIONS *) +(* Created by Joe Hurd, September 2002 *) +(* ========================================================================= *) + +structure Milton :> Milton = +struct + +(* ------------------------------------------------------------------------- *) +(* The ML implementation. *) +(* ------------------------------------------------------------------------- *) + +val ml = "MLton"; + +(* ------------------------------------------------------------------------- *) +(* Pointer equality using the run-time system. *) +(* ------------------------------------------------------------------------- *) + +(* ------------------------------------------------------------------------- *) +(* Quotations a la Mosml. *) +(* ------------------------------------------------------------------------- *) + +datatype 'a frag = QUOTE of string | ANTIQUOTE of 'a; + +(* ------------------------------------------------------------------------- *) +(* Timing function applications a la Mosml.time. *) +(* ------------------------------------------------------------------------- *) + +fun time f x = + let + fun p t = + let + val s = Time.fmt 3 t + in + case size (List.last (String.fields (fn x => x = #".") s)) of 3 => s + | 2 => s ^ "0" + | 1 => s ^ "00" + | _ => raise Fail "Milton.time" + end + val c = Timer.startCPUTimer () + val r = Timer.startRealTimer () + fun pt () = + let + val {usr, sys, ...} = Timer.checkCPUTimer c + val real = Timer.checkRealTimer r + in + print + ("User: " ^ p usr ^ " System: " ^ p sys ^ " Real: " ^ p real ^ "\n") + end + val y = f x handle e => (pt (); raise e) + val () = pt () + in + y + end; + +(* ------------------------------------------------------------------------- *) +(* Bring certain declarations to the top-level. *) +(* ------------------------------------------------------------------------- *) + +type ppstream = PP.ppstream; + +(* ------------------------------------------------------------------------- *) +(* Dummy versions of Mosml declarations to stop MLton barfing. *) +(* ------------------------------------------------------------------------- *) + +val quotation = ref false; +val load = fn (_ : string) => (); +val installPP = fn (_ : ppstream -> 'a -> unit) => (); + +end +open Milton; +(*#line 0.0 "basic/Useful.sig"*) +(* ========================================================================= *) +(* ML UTILITY FUNCTIONS *) +(* Created by Joe Hurd, April 2001 *) +(* ========================================================================= *) + +signature Useful = +sig + +(* Exceptions, profiling and tracing *) +exception ERR_EXN of {origin_function : string, message : string} +exception BUG_EXN of {origin_function : string, message : string} +val ERR : string -> string -> exn +val BUG : string -> string -> exn +val assert : bool -> exn -> unit +val try : ('a -> 'b) -> 'a -> 'b +val total : ('a -> 'b) -> 'a -> 'b option +val can : ('a -> 'b) -> 'a -> bool +val partial : exn -> ('a -> 'b option) -> 'a -> 'b +val timed : ('a -> 'b) -> 'a -> real * 'b +val tracing : int ref +val traces : {module : string, alignment : int -> int} list ref +val trace : {module : string, message : string, level : int} -> unit + +(* Combinators *) +val C : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c +val I : 'a -> 'a +val K : 'a -> 'b -> 'a +val N : int -> ('a -> 'a) -> 'a -> 'a +val S : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c +val W : ('a -> 'a -> 'b) -> 'a -> 'b +val oo : ('a -> 'b) * ('c -> 'd -> 'a) -> 'c -> 'd -> 'b +val ## : ('a -> 'b) * ('c -> 'd) -> 'a * 'c -> 'b * 'd + +(* Booleans *) +val bool_to_string : bool -> string +val non : ('a -> bool) -> 'a -> bool + +(* Pairs *) +val D : 'a -> 'a * 'a +val Df : ('a -> 'b) -> 'a * 'a -> 'b * 'b +val fst : 'a * 'b -> 'a +val snd : 'a * 'b -> 'b +val pair : 'a -> 'b -> 'a * 'b +val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c +val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c +val equal : ''a -> ''a -> bool + +(* State transformers *) +val unit : 'a -> 's -> 'a * 's +val bind : ('s -> 'a * 's) -> ('a -> 's -> 'b * 's) -> 's -> 'b * 's +val mmap : ('a -> 'b) -> ('s -> 'a * 's) -> 's -> 'b * 's +val join : ('s -> ('s -> 'a * 's) * 's) -> 's -> 'a * 's +val mwhile : ('a -> bool) -> ('a -> 's -> 'a * 's) -> 'a -> 's -> 'a * 's + +(* Lists: note we count elements from 0 *) +val cons : 'a -> 'a list -> 'a list +val append : 'a list -> 'a list -> 'a list +val wrap : 'a -> 'a list +val unwrap : 'a list -> 'a +val first : ('a -> 'b option) -> 'a list -> 'b option +val index : ('a -> bool) -> 'a list -> int option +val maps : ('a -> 's -> 'b * 's) -> 'a list -> 's -> 'b list * 's +val partial_maps : ('a -> 's -> 'b option * 's) -> 'a list -> 's -> 'b list * 's +val enumerate : int -> 'a list -> (int * 'a) list +val cartwith : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +val zipwith : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list +val zip : 'a list -> 'b list -> ('a * 'b) list +val unzip : ('a * 'b) list -> 'a list * 'b list +val split : 'a list -> int -> 'a list * 'a list (* Subscript *) +val update_nth : ('a -> 'a) -> int -> 'a list -> 'a list (* Subscript *) + +(* Lists-as-sets *) +val mem : ''a -> ''a list -> bool +val insert : ''a -> ''a list -> ''a list +val delete : ''a -> ''a list -> ''a list +val union : ''a list -> ''a list -> ''a list +val intersect : ''a list -> ''a list -> ''a list +val subtract : ''a list -> ''a list -> ''a list +val setify : ''a list -> ''a list +val subset : ''a list -> ''a list -> bool +val distinct : ''a list -> bool + +(* Comparisons *) +val lex_compare : ('a * 'a -> order) -> ('a * 'a) list -> order + +(* Sorting and searching *) +val min : ('a -> 'a -> bool) -> 'a list -> 'a +val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list +val sort : ('a -> 'a -> bool) -> 'a list -> 'a list + +(* Integers *) +val int_to_string : int -> string +val string_to_int : string -> int (* Overflow, Option *) +val int_to_bits : int -> bool list +val bits_to_int : bool list -> int (* Overflow *) +val interval : int -> int -> int list +val divides : int -> int -> bool +val primes : int -> int list + +(* Strings *) +val variant : string -> string list -> string +val variant_num : string -> string list -> string +val dest_prefix : string -> string -> string +val is_prefix : string -> string -> bool +val mk_prefix : string -> string -> string + +(* Reals *) +val real_to_string : real -> string; + +(* Pretty-printing *) +type 'a pp = ppstream -> 'a -> unit +val LINE_LENGTH : int ref +val unit_pp : 'a pp -> 'a -> unit pp +val pp_unit_pp : unit pp pp +val pp_map : ('a -> 'b) -> 'b pp -> 'a pp +val pp_bracket : string * string -> 'a pp -> 'a pp +val pp_sequence : string -> 'a pp -> 'a list pp +val pp_unop : string -> 'a pp -> 'a pp +val pp_binop : string -> 'a pp -> 'b pp -> ('a * 'b) pp +val pp_nothing : 'a pp +val pp_string : string pp +val pp_unit : unit pp +val pp_bool : bool pp +val pp_int : int pp +val pp_real : real pp +val pp_order : order pp +val pp_list : 'a pp -> 'a list pp +val pp_pair : 'a pp -> 'b pp -> ('a * 'b) pp +val pp_triple : 'a pp -> 'b pp -> 'c pp -> ('a * 'b * 'c) pp +val pp_record : (string * unit pp) list -> unit pp +val pp_option : 'a pp -> 'a option pp + +(* Sum datatype *) +datatype ('a, 'b) sum = INL of 'a | INR of 'b +val is_inl : ('a, 'b) sum -> bool +val is_inr : ('a, 'b) sum -> bool + +(* Maplets *) +datatype ('a, 'b) maplet = |-> of 'a * 'b +val pp_maplet : 'a pp -> 'b pp -> ('a, 'b) maplet pp + +(* Trees *) +datatype ('a, 'b) tree = BRANCH of 'a * ('a, 'b) tree list | LEAF of 'b +val tree_size : ('a, 'b) tree -> int +val tree_foldr : ('a -> 'c list -> 'c) -> ('b -> 'c) -> ('a, 'b) tree -> 'c +val tree_foldl : + ('a -> 'c -> 'c) -> ('b -> 'c -> 'd) -> 'c -> ('a, 'b) tree -> 'd list +val tree_partial_foldl : + ('a -> 'c -> 'c option) -> ('b -> 'c -> 'd option) -> 'c -> ('a, 'b) tree -> + 'd list + +(* Useful imperative features *) +val lazify_thunk : (unit -> 'a) -> unit -> 'a +val new_int : unit -> int +val new_ints : int -> int list +val with_flag : 'r ref * ('r -> 'r) -> ('a -> 'b) -> 'a -> 'b + +(* Information about the environment *) +val host : string +val date : unit -> string + +end +(*#line 0.0 "basic/Useful.sml"*) +(* ========================================================================= *) +(* ML UTILITY FUNCTIONS *) +(* Created by Joe Hurd, April 2001 *) +(* ========================================================================= *) + +structure Useful :> Useful = +struct + +infixr 0 oo ## |->; + +(* ------------------------------------------------------------------------- *) +(* Exceptions, profiling and tracing. *) +(* ------------------------------------------------------------------------- *) + +exception ERR_EXN of {origin_function : string, message : string}; +exception BUG_EXN of {origin_function : string, message : string}; + +fun ERR f s = ERR_EXN {origin_function = f, message = s}; +fun BUG f s = BUG_EXN {origin_function = f, message = s}; + +fun ERR_to_string (ERR_EXN {origin_function, message}) = + "\nERR in function " ^ origin_function ^ ":\n" ^ message ^ "\n" + | ERR_to_string _ = raise BUG "ERR_to_string" "not a ERR_EXN"; + +fun BUG_to_string (BUG_EXN {origin_function, message}) = + "\nBUG in function " ^ origin_function ^ ":\n" ^ message ^ "\n" + | BUG_to_string _ = raise BUG "BUG_to_string" "not a BUG_EXN"; + +fun assert b e = if b then () else raise e; + +fun try f a = f a + handle h as ERR_EXN _ => (print (ERR_to_string h); raise h) + | b as BUG_EXN _ => (print (BUG_to_string b); raise b) + | e => (print "\ntry: strange exception raised\n"; raise e); + +fun total f x = SOME (f x) handle ERR_EXN _ => NONE; + +fun can f = Option.isSome o total f; + +fun partial (e as ERR_EXN _) f x = (case f x of SOME y => y | NONE => raise e) + | partial _ _ _ = raise BUG "partial" "must take a ERR_EXN"; + +fun timed f a = + let + val tmr = Timer.startCPUTimer () + val res = f a + val {usr, sys, ...} = Timer.checkCPUTimer tmr + in + (Time.toReal usr + Time.toReal sys, res) + end; + +val tracing = ref 1; + +val traces : {module : string, alignment : int -> int} list ref = ref []; + +local + val MAX = 10; + val trace_printer = print; + fun query m l = + let val t = List.find (fn {module, ...} => module = m) (!traces) + in case t of NONE => MAX | SOME {alignment, ...} => alignment l + end; +in + fun trace {module = m, message = s, level = l} = + if 0 < !tracing andalso (MAX <= !tracing orelse query m l <= !tracing) + then trace_printer s + else (); +end; + +(* ------------------------------------------------------------------------- *) +(* Combinators *) +(* ------------------------------------------------------------------------- *) + +fun C f x y = f y x; +fun I x = x; +fun K x y = x; +fun N 0 _ x = x | N n f x = N (n - 1) f (f x); +fun S f g x = f x (g x); +fun W f x = f x x; +fun f oo g = fn x => f o (g x); + +(* ------------------------------------------------------------------------- *) +(* Booleans *) +(* ------------------------------------------------------------------------- *) + +fun bool_to_string true = "true" + | bool_to_string false = "false"; + +fun non f = not o f; + +(* ------------------------------------------------------------------------- *) +(* Pairs *) +(* ------------------------------------------------------------------------- *) + +fun op## (f, g) (x, y) = (f x, g y); +fun D x = (x, x); +fun Df f = f ## f; +fun fst (x,_) = x; +fun snd (_,y) = y; +fun pair x y = (x, y) +(* Note: val add_fst = pair and add_snd = C pair; *) +fun curry f x y = f (x, y); +fun uncurry f (x, y) = f x y; +fun equal x y = (x = y); + +(* ------------------------------------------------------------------------- *) +(* State transformers. *) +(* ------------------------------------------------------------------------- *) + +val unit : 'a -> 's -> 'a * 's = pair; + +fun bind f (g : 'a -> 's -> 'b * 's) = uncurry g o f; + +fun mmap f (m : 's -> 'a * 's) = bind m (unit o f); + +fun join (f : 's -> ('s -> 'a * 's) * 's) = bind f I; + +fun mwhile c b = let fun f a = if c a then bind (b a) f else unit a in f end; + +(* ------------------------------------------------------------------------- *) +(* Lists. *) +(* ------------------------------------------------------------------------- *) + +fun cons x y = x :: y; +fun append xs ys = xs @ ys; +fun wrap a = [a]; +fun unwrap [a] = a | unwrap _ = raise ERR "unwrap" "not a singleton"; + +fun first f [] = NONE + | first f (x :: xs) = (case f x of NONE => first f xs | s => s); + +fun index p = + let + fun idx _ [] = NONE + | idx n (x :: xs) = if p x then SOME n else idx (n + 1) xs + in + idx 0 + end; + +(* This is the pure version +fun maps (_ : 'a -> 's -> 'b * 's) [] = unit [] + | maps f (x :: xs) = + bind (f x) (fn y => bind (maps f xs) (fn ys => unit (y :: ys))); +*) + +(* This is an optimized version *) +fun maps f = + let fun g (x, (ys, s)) = let val (y, s) = f x s in (y :: ys, s) end + in fn l => fn (s : 's) => (rev ## I) (foldl g ([], s) l) + end; + +(* This is the pure version +fun partial_maps (_ : 'a -> 's -> 'b option * 's) [] = unit [] + | partial_maps f (x :: xs) = + bind (f x) + (fn yo => bind (partial_maps f xs) + (fn ys => unit (case yo of NONE => ys | SOME y => y :: ys))); +*) + +(* This is an optimized version *) +fun partial_maps f = + let + fun g (x, (ys, s)) = + let val (yo, s) = f x s + in (case yo of NONE => ys | SOME y => y :: ys, s) + end + in + fn l => fn (s : 's) => (rev ## I) (foldl g ([], s) l) + end; + +fun enumerate n = fst o C (maps (fn x => fn m => ((m, x), m + 1))) n; + +fun zipwith f = + let + fun z l [] [] = l + | z l (x :: xs) (y :: ys) = z (f x y :: l) xs ys + | z _ _ _ = raise ERR "zipwith" "lists different lengths"; + in + fn xs => fn ys => rev (z [] xs ys) + end; + +fun zip xs ys = zipwith pair xs ys; + +fun unzip ab = + foldl (fn ((x, y), (xs, ys)) => (x :: xs, y :: ys)) ([], []) (rev ab); + +fun cartwith f = + let + fun aux _ res _ [] = res + | aux xs_copy res [] (y :: yt) = aux xs_copy res xs_copy yt + | aux xs_copy res (x :: xt) (ys as y :: _) = + aux xs_copy (f x y :: res) xt ys + in + fn xs => fn ys => + let val xs' = rev xs in aux xs' [] xs' (rev ys) end + end; + +local + fun aux res l 0 = (rev res, l) + | aux _ [] _ = raise Subscript + | aux res (h :: t) n = aux (h :: res) t (n - 1); +in + fun split l n = aux [] l n; +end; + +fun update_nth f n l = + let + val (a, b) = split l n + in + case b of [] => raise Subscript + | h :: t => a @ (f h :: t) + end; + +(* ------------------------------------------------------------------------- *) +(* Lists-as-sets. *) +(* ------------------------------------------------------------------------- *) + +fun mem x = List.exists (equal x); + +fun insert x s = if mem x s then s else x :: s; +fun delete x s = List.filter (not o equal x) s; + +(* Removes duplicates *) +fun setify s = foldl (fn (v, x) => if mem v x then x else v :: x) [] s; + +(* For all three set operations: if s has duplicates, so may the result. *) +fun union s t = foldl (fn (v, x) => if mem v x then x else v :: x) s t; +fun intersect s t = foldl (fn (v, x) => if mem v t then v :: x else x) [] s; +fun subtract s t = foldl (fn (v, x) => if mem v t then x else v :: x) [] s; + +fun subset s t = List.all (fn x => mem x t) s; + +fun distinct [] = true + | distinct (x :: rest) = not (mem x rest) andalso distinct rest; + +(* ------------------------------------------------------------------------- *) +(* Comparisons. *) +(* ------------------------------------------------------------------------- *) + +fun lex_compare f = + let + fun lex [] = EQUAL + | lex (x :: l) = case f x of EQUAL => lex l | y => y + in + lex + end; + +(* ------------------------------------------------------------------------- *) +(* Finding the minimal element of a list, wrt some order. *) +(* ------------------------------------------------------------------------- *) + +fun min f = + let + fun min_acc best [] = best + | min_acc best (h :: t) = min_acc (if f best h then best else h) t + in + fn [] => raise ERR "min" "empty list" + | h :: t => min_acc h t + end; + +(* ------------------------------------------------------------------------- *) +(* Merge (for the following merge-sort, but generally useful too). *) +(* ------------------------------------------------------------------------- *) + +fun merge f = + let + fun mrg res [] ys = foldl (op ::) ys res + | mrg res xs [] = foldl (op ::) xs res + | mrg res (xs as x :: xt) (ys as y :: yt) = + if f x y then mrg (x :: res) xt ys else mrg (y :: res) xs yt + in + mrg [] + end; + +(* ------------------------------------------------------------------------- *) +(* Order function here should be <= for a stable sort... *) +(* ...and I think < gives a reverse stable sort (but don't quote me). *) +(* ------------------------------------------------------------------------- *) + +fun sort f = + let + fun srt [] = [] + | srt (l as [x]) = l + | srt l = + let + val halfway = length l div 2 + in + merge f (srt (List.take (l, halfway))) (srt (List.drop (l, halfway))) + end + in + srt + end; + +(* ------------------------------------------------------------------------- *) +(* Integers. *) +(* ------------------------------------------------------------------------- *) + +val int_to_string = Int.toString; +val string_to_int = Option.valOf o Int.fromString; + +fun int_to_bits 0 = [] + | int_to_bits n = (n mod 2 <> 0) :: (int_to_bits (n div 2)); + +fun bits_to_int [] = 0 + | bits_to_int (h :: t) = (if h then curry op+ 1 else I) (2 * bits_to_int t); + +fun interval m 0 = [] + | interval m len = m :: interval (m + 1) (len - 1); + +fun divides a b = if a = 0 then b = 0 else b mod (Int.abs a) = 0; + +local + fun both f g n = f n andalso g n; + fun next f = let fun nx x = if f x then x else nx (x + 1) in nx end; + + fun looking res 0 _ _ = rev res + | looking res n f x = + let + val p = next f x + val res' = p :: res + val f' = both f (not o divides p) + in + looking res' (n - 1) f' (p + 1) + end +in + fun primes n = looking [] n (K true) 2 +end; + +(* ------------------------------------------------------------------------- *) +(* Strings. *) +(* ------------------------------------------------------------------------- *) + +fun variant x vars = if mem x vars then variant (x ^ "'") vars else x; + +fun variant_num x vars = + let + fun xn n = x ^ int_to_string n + fun v n = let val x' = xn n in if mem x' vars then v (n + 1) else x' end + in + if mem x vars then v 1 else x + end; + +fun dest_prefix p = + let + fun check s = assert (String.isPrefix p s) (ERR "dest_prefix" "") + val size_p = size p + in + fn s => (check s; String.extract (s, size_p, NONE)) + end; + +fun is_prefix p = can (dest_prefix p); + +fun mk_prefix p s = p ^ s; + +(* ------------------------------------------------------------------------- *) +(* Reals. *) +(* ------------------------------------------------------------------------- *) + +val real_to_string = Real.toString; + +(* ------------------------------------------------------------------------- *) +(* Pretty-printing. *) +(* ------------------------------------------------------------------------- *) + +type 'a pp = ppstream -> 'a -> unit; + +val LINE_LENGTH = ref 75; + +fun unit_pp pp_a a pp () = pp_a pp a; + +fun pp_unit_pp pp upp = upp pp (); + +fun pp_map f pp_a (ppstrm : ppstream) x : unit = pp_a ppstrm (f x); + +fun pp_bracket (l, r) pp_a pp a = + (PP.begin_block pp PP.INCONSISTENT (size l); PP.add_string pp l; pp_a pp a; + PP.add_string pp r; PP.end_block pp); + +fun pp_sequence sep pp_a = + let + fun pp_elt pp x = (PP.add_string pp sep; PP.add_break pp (1, 0); pp_a pp x) + fun pp_seq pp [] = () + | pp_seq pp (h :: t) = (pp_a pp h; app (pp_elt pp) t) + in + fn pp => fn l => + (PP.begin_block pp PP.INCONSISTENT 0; pp_seq pp l; PP.end_block pp) + end; + +fun pp_unop s pp_a pp a = + (PP.begin_block pp PP.CONSISTENT 0; + PP.add_string pp s; + PP.add_break pp (1, 0); + pp_a pp a; + PP.end_block pp); + +fun pp_binop s pp_a pp_b pp (a, b) = + (PP.begin_block pp PP.CONSISTENT 0; + pp_a pp a; + PP.add_string pp s; + PP.add_break pp (1, 0); + pp_b pp b; + PP.end_block pp); + +fun pp_nothing pp _ = (PP.begin_block pp PP.CONSISTENT 0; PP.end_block pp); + +fun pp_string pp s = + (PP.begin_block pp PP.CONSISTENT 0; PP.add_string pp s; PP.end_block pp); + +val pp_unit = fn z => (pp_map (K "()") pp_string) z; + +val pp_bool = pp_map bool_to_string pp_string; + +val pp_int = pp_map int_to_string pp_string; + +val pp_real = pp_map real_to_string pp_string; + +val pp_order = + pp_map (fn LESS => "LESS" | EQUAL => "EQUAL" | GREATER => "GREATER") + pp_string; + +fun pp_list pp_a = pp_bracket ("[", "]") (pp_sequence "," pp_a); + +fun pp_pair pp_a pp_b = pp_bracket ("(", ")") (pp_binop "," pp_a pp_b); + +fun pp_triple pp_a pp_b pp_c = + pp_bracket ("(", ")") + (pp_map (fn (a, b, c) => (a, (b, c))) + (pp_binop "," pp_a (pp_binop "," pp_b pp_c))); + +local + val pp_l = fn z => (pp_sequence "," (pp_binop " =" pp_string pp_unit_pp)) z; +in + fun pp_record l = pp_bracket ("{", "}") (unit_pp pp_l l); +end; + +fun pp_option pp_a pp NONE = pp_string pp "NONE" + | pp_option pp_a pp (SOME a) = pp_unop "SOME" pp_a pp a; + +(* ------------------------------------------------------------------------- *) +(* Sums. *) +(* ------------------------------------------------------------------------- *) + +datatype ('a, 'b) sum = INL of 'a | INR of 'b + +fun is_inl (INL _) = true | is_inl (INR _) = false; + +fun is_inr (INR _) = true | is_inr (INL _) = false; + +(* ------------------------------------------------------------------------- *) +(* Maplets. *) +(* ------------------------------------------------------------------------- *) + +datatype ('a, 'b) maplet = |-> of 'a * 'b; + +fun pp_maplet pp_a pp_b = + pp_map (fn a |-> b => (a, b)) (pp_binop " |->" pp_a pp_b); + +(* ------------------------------------------------------------------------- *) +(* Trees. *) +(* ------------------------------------------------------------------------- *) + +datatype ('a, 'b) tree = BRANCH of 'a * ('a, 'b) tree list | LEAF of 'b; + +fun tree_size (LEAF _) = 1 + | tree_size (BRANCH (_, t)) = foldl (op+ o (tree_size ## I)) 1 t; + +fun tree_foldr f_b f_l (LEAF l) = f_l l + | tree_foldr f_b f_l (BRANCH (p, s)) = f_b p (map (tree_foldr f_b f_l) s); + +fun tree_foldl f_b f_l = + let + fun fold state (LEAF l, res) = f_l l state :: res + | fold state (BRANCH (p, ts), res) = foldl (fold (f_b p state)) res ts + in + fn state => fn t => fold state (t, []) + end; + +fun tree_partial_foldl f_b f_l = + let + fun fold state (LEAF l, res) = + (case f_l l state of NONE => res | SOME x => x :: res) + | fold state (BRANCH (p, ts), res) = + (case f_b p state of NONE => res | SOME s => foldl (fold s) res ts) + in + fn state => fn t => fold state (t, []) + end; + +(* ------------------------------------------------------------------------- *) +(* Useful imperative features. *) +(* ------------------------------------------------------------------------- *) + +fun lazify_thunk f = let val s = Susp.delay f in fn () => Susp.force s end; + +local + val generator = ref 0 +in + fun new_int () = let val n = !generator val () = generator := n + 1 in n end; + + fun new_ints 0 = [] + | new_ints k = + let val n = !generator val () = generator := n + k in interval n k end; +end; + +fun with_flag (r, update) f x = + let + val old = !r + val () = r := update old + val y = f x handle e => (r := old; raise e) + val () = r := old + in + y + end; + +(* ------------------------------------------------------------------------- *) +(* Information about the environment. *) +(* ------------------------------------------------------------------------- *) + +val host = Option.getOpt (OS.Process.getEnv "HOSTNAME", "unknown"); + +val date = Date.fmt "%H:%M:%S %d/%m/%Y" o Date.fromTimeLocal o Time.now; + +end +(*#line 0.0 "basic/Queue.sig"*) +(* ========================================================================= *) +(* A QUEUE DATATYPE FOR ML *) +(* Created by Joe Hurd, October 2001 *) +(* ========================================================================= *) + +signature Queue = +sig + +type 'a queue + +val empty : 'a queue +val add : 'a -> 'a queue -> 'a queue +val is_empty : 'a queue -> bool +val hd : 'a queue -> 'a (* raises Empty *) +val tl : 'a queue -> 'a queue (* raises Empty *) +val length : 'a queue -> int +val from_list : 'a list -> 'a queue +val to_list : 'a queue -> 'a list +val pp_queue : 'a Useful.pp -> 'a queue Useful.pp + +end +(*#line 0.0 "basic/Queue.sml"*) +(* ========================================================================= *) +(* A QUEUE DATATYPE FOR ML *) +(* Created by Joe Hurd, October 2001 *) +(* ========================================================================= *) + +structure Queue :> Queue = +struct + +type 'a queue = 'a list * 'a list; + +val empty : 'a queue = ([], []); + +fun norm ([], ys as _ :: _) = (rev ys, []) + | norm q = q; + +fun add z (xs, ys) = norm (xs, z :: ys); + +fun is_empty ([], _) = true + | is_empty (_ :: _, _) = false; + +fun hd ([], _) = raise Empty + | hd (x :: _, _) = x; + +fun tl ([], _) = raise Empty + | tl (_ :: xs, ys) = norm (xs, ys); + +val length = fn (xs, ys) => length xs + length ys; + +fun from_list l = (rev l, []); + +fun to_list (xs, ys) = xs @ rev ys; + +local + open Useful; +in + fun pp_queue pp_a = + pp_map to_list (pp_bracket ("Q[", "]") (pp_sequence "," pp_a)); +end; + +end +(*#line 0.0 "basic/Heap.sig"*) +(* ========================================================================= *) +(* A HEAP DATATYPE FOR ML *) +(* Created by Joe Hurd, October 2001 *) +(* Taken from Purely Functional Data Structures, by Chris Okasaki. *) +(* ========================================================================= *) + +signature Heap = +sig + +type 'a heap + +val empty : ('a * 'a -> order) -> 'a heap +val add : 'a -> 'a heap -> 'a heap +val is_empty : 'a heap -> bool +val top : 'a heap -> 'a (* raises Empty *) +val remove : 'a heap -> 'a * 'a heap (* raises Empty *) +val size : 'a heap -> int +val app : ('a -> unit) -> 'a heap -> unit +val to_list : 'a heap -> 'a list +val pp_heap : 'a Useful.pp -> 'a heap Useful.pp + +end +(*#line 0.0 "basic/Heap.sml"*) +(* ========================================================================= *) +(* A HEAP DATATYPE FOR ML *) +(* Created by Joe Hurd, October 2001 *) +(* Taken from Purely Functional Data Structures, by Chris Okasaki. *) +(* ========================================================================= *) + +(* +*) +structure Heap :> Heap = +struct + +datatype 'a node = E | T of int * 'a * 'a node * 'a node; + +datatype 'a heap = Heap of ('a * 'a -> order) * int * 'a node; + +fun rank E = 0 + | rank (T (r, _, _, _)) = r; + +fun makeT (x, a, b) = + if rank a >= rank b then T (rank b + 1, x, a, b) else T (rank a + 1, x, b, a); + +fun merge f = + let + fun mrg (h, E) = h + | mrg (E, h) = h + | mrg (h1 as T (_, x, a1, b1), h2 as T (_, y, a2, b2)) = + (case f (x, y) of GREATER => makeT (y, a2, mrg (h1, b2)) + | _ => makeT (x, a1, mrg (b1, h2))) + in + mrg + end; + +fun empty f = Heap (f, 0, E); + +fun add x (Heap (f, n, a)) = Heap (f, n + 1, merge f (T (1, x, E, E), a)); + +fun is_empty (Heap (_, _, E)) = true + | is_empty (Heap (_, _, T _)) = false; + +fun top (Heap (_, _, E)) = raise Empty + | top (Heap (_, _, T (_, x, _, _))) = x; + +fun remove (Heap (_, _, E)) = raise Empty + | remove (Heap (f, n, T (_, x, a, b))) = (x, Heap (f, n - 1, merge f (a, b))); + +fun size (Heap (_, n, _)) = n; + +fun app f = + let + fun ap [] = () + | ap (E :: rest) = ap rest + | ap (T (_, d, a, b) :: rest) = (f d; ap (a :: b :: rest)) + in + fn Heap (_, _, a) => ap [a] + end; + +local + fun to_lst res h = + if is_empty h then rev res + else let val (x, h) = remove h in to_lst (x :: res) h end; +in + fun to_list h = to_lst [] h; +end; + +local + open Useful; +in + fun pp_heap pp_a = + pp_map to_list (pp_bracket ("H[", "]") (pp_sequence "," pp_a)); +end; + +end +(*#line 0.0 "basic/Multiset.sig"*) +(* ========================================================================= *) +(* A MULTISET DATATYPE FOR ML *) +(* Created by Joe Hurd, July 2002 *) +(* ========================================================================= *) + +signature Multiset = +sig + +type 'a mset + +val empty : ('a * 'a -> order) -> 'a mset +val insert : 'a * int -> 'a mset -> 'a mset +val count : 'a mset -> 'a -> int +val union : 'a mset -> 'a mset -> 'a mset +val compl : 'a mset -> 'a mset +val subtract : 'a mset -> 'a mset -> 'a mset +val subset : 'a mset -> 'a mset -> bool +val compare : 'a mset * 'a mset -> order option +val app : ('a * int -> unit) -> 'a mset -> unit +val to_list : 'a mset -> ('a * int) list +val pp_mset : 'a Useful.pp -> 'a mset Useful.pp + +end +(*#line 0.0 "basic/Multiset.sml"*) +(* ========================================================================= *) +(* A MULTISET DATATYPE FOR ML *) +(* Created by Joe Hurd, July 2002 *) +(* ========================================================================= *) + +(* +List.app load ["Binarymap", "Useful"]; +*) + +(* +*) +structure Multiset :> Multiset = +struct + +structure M = Binarymap; + +fun Mpurge m k = let val (m, _) = M.remove (m, k) in m end; + +fun Mall p = + let + exception Cut + fun f (x, y, ()) = if p (x, y) then () else raise Cut + in + fn a => (M.foldl f () a; true) handle Cut => false + end; + +type 'a mset = ('a, int) M.dict; + +fun empty ord : 'a mset = M.mkDict ord; + +fun insert (_, 0) a = a + | insert (x, n) a = + (case M.peek (a, x) of NONE => M.insert (a, x, n) + | SOME n' => + let val n'' = n + n' + in if n'' = 0 then Mpurge a x else M.insert (a, x, n'') + end); + +fun count m x = case M.peek (m, x) of SOME n => n | NONE => 0; + +local fun un a b = M.foldl (fn (x : 'a, n : int, d) => insert (x, n) d) a b; +in fun union a b = if M.numItems a < M.numItems b then un b a else un a b; +end; + +fun compl a : 'a mset = M.transform ~ a; + +fun subtract a b = union a (compl b); + +local + fun sign a = (Mall (fn (_, n) => 0 <= n) a, Mall (fn (_, n) => n <= 0) a); +in + fun compare (a, b) = + (case sign (subtract a b) of (true, true) => SOME EQUAL + | (true, false) => SOME GREATER + | (false, true) => SOME LESS + | (false, false) => NONE); +end; + +fun subset a b = + (case compare (a, b) of SOME LESS => true + | SOME EQUAL => true + | _ => false); + +fun app f (a : 'a mset) = M.app f a; + +fun to_list (a : 'a mset) = M.listItems a; + +local + open Useful; +in + fun pp_mset pp_a = + pp_map (map Useful.|-> o to_list) + (pp_bracket ("M[", "]") (pp_sequence "," (Useful.pp_maplet pp_a pp_int))); +end; + +end +(*#line 0.0 "basic/Stream.sig"*) +(* ========================================================================= *) +(* A POSSIBLY-INFINITE STREAM DATATYPE FOR ML *) +(* Created by Joe Hurd, April 2001 *) +(* ========================================================================= *) + +signature Stream = +sig + +datatype 'a stream = NIL | CONS of 'a * (unit -> 'a stream) +type 'a Sthk = unit -> 'a stream + +(* If you're wondering how to create an infinite stream: *) +(* val stream4 = let fun s4 () = CONS 4 s4 in s4 () end; *) + +val cons : 'a -> (unit -> 'a stream) -> 'a stream +val null : 'a stream -> bool +val hd : 'a stream -> 'a (* raises Empty *) +val tl : 'a stream -> 'a stream (* raises Empty *) +val dest : 'a stream -> 'a * 'a stream (* raises Empty *) +val repeat : 'a -> 'a stream +val count : int -> int stream +val fold : ('a -> (unit -> 'b) -> 'b) -> 'b -> 'a stream -> 'b +val map : ('a -> 'b) -> 'a stream -> 'b stream +val map_thk : ('a Sthk -> 'a Sthk) -> 'a Sthk -> 'a Sthk +val partial_map : ('a -> 'b option) -> 'a stream -> 'b stream +val maps : ('a -> 'c -> 'b * 'c) -> 'c -> 'a stream -> 'b stream +val partial_maps : ('a -> 'c -> 'b option * 'c) -> 'c -> 'a stream -> 'b stream +val filter : ('a -> bool) -> 'a stream -> 'a stream +val flatten : 'a stream stream -> 'a stream +val zipwith : ('a -> 'b -> 'c) -> 'a stream -> 'b stream -> 'c stream +val zip : 'a stream -> 'b stream -> ('a * 'b) stream +val take : int -> 'a stream -> 'a stream (* raises Subscript *) +val drop : int -> 'a stream -> 'a stream (* raises Subscript *) +val to_list : 'a stream -> 'a list +val from_list : 'a list -> 'a stream +val from_textfile : string -> string stream (* lines of the file *) + +end +(*#line 0.0 "basic/Stream.sml"*) +(* ========================================================================= *) +(* A POSSIBLY-INFINITE STREAM DATATYPE FOR ML *) +(* Created by Joe Hurd, April 2001 *) +(* ========================================================================= *) + +structure Stream :> Stream = +struct + +open Useful; + +infixr 0 oo ##; + +(* ------------------------------------------------------------------------- *) +(* The datatype declaration encapsulates all the primitive operations. *) +(* ------------------------------------------------------------------------- *) + +datatype 'a stream = NIL | CONS of 'a * (unit -> 'a stream); + +type 'a Sthk = unit -> 'a stream; + +(* ------------------------------------------------------------------------- *) +(* Useful functions. *) +(* ------------------------------------------------------------------------- *) + +val cons = fn z => curry CONS z; + +fun null NIL = true | null (CONS _) = false; + +fun hd NIL = raise Empty | hd (CONS (h, _)) = h; + +fun tl NIL = raise Empty | tl (CONS (_, t)) = t (); + +fun dest s = (hd s, tl s); + +fun repeat x = let fun rep () = CONS (x, rep) in rep () end; + +fun count n = CONS (n, fn () => count (n + 1)); + +fun fold b c = + let fun f NIL = c | f (CONS (x, xs)) = b x (fn () => f (xs ())) in f end; + +fun map f = + let + fun m NIL = NIL + | m (CONS (h, t)) = CONS (f h, fn () => m (t ())) + in + m + end; + +fun map_thk f = + let + fun mt NIL = NIL + | mt (CONS (h, t)) = CONS (h, mt' t) + and mt' t = f (fn () => mt (t ())) + in + mt' + end; + +fun partial_map f = + let + fun mp NIL = NIL + | mp (CONS (h, t)) = + case f h of NONE => mp (t ()) + | SOME h' => CONS (h', fn () => mp (t ())) + in + mp + end; + +fun maps f = + let + fun mm _ NIL = NIL + | mm s (CONS (x, xs)) = + let val (y, s') = f x s + in CONS (y, fn () => mm s' (xs ())) + end + in + mm + end; + +fun partial_maps f = + let + fun mm _ NIL = NIL + | mm s (CONS (x, xs)) = + let + val (yo, s') = f x s + val t = mm s' o xs + in + case yo of NONE => t () | SOME y => CONS (y, t) + end + in + mm + end; + +fun filter f = partial_map (fn x => if f x then SOME x else NONE); + +fun flatten NIL = NIL + | flatten (CONS (NIL, ss)) = flatten (ss ()) + | flatten (CONS (CONS (x, xs), ss)) = + CONS (x, fn () => flatten (CONS (xs (), ss))); + +fun zipwith f = + let + fun z NIL _ = NIL + | z _ NIL = NIL + | z (CONS (x, xs)) (CONS (y, ys)) = + CONS (f x y, fn () => z (xs ()) (ys ())) + in + z + end; + +fun zip s t = zipwith pair s t; + +fun take 0 s = NIL + | take n NIL = raise Subscript + | take 1 (CONS (x, _)) = CONS (x, K NIL) + | take n (CONS (x, xs)) = CONS (x, fn () => take (n - 1) (xs ())); + +fun drop n s = N n tl s handle Empty => raise Subscript; + +local + fun to_lst res NIL = res + | to_lst res (CONS (x, xs)) = to_lst (x :: res) (xs ()); +in + val to_list = fn z => (rev o to_lst []) z +end; + +fun from_list [] = NIL + | from_list (x :: xs) = CONS (x, fn () => from_list xs); + +fun from_textfile filename = + let + open TextIO + val fh = openIn filename + fun res () = + case inputLine fh of NONE => (closeIn fh; NIL) + | SOME s => CONS (s, lazify_thunk res) + in + res () + end; + +end +(*#line 0.0 "basic/Parser.sig"*) +(* ========================================================================= *) +(* PARSER COMBINATORS *) +(* Created by Joe Hurd, April 2001 *) +(* ========================================================================= *) + +signature Parser = +sig + +(* Recommended fixities + infixr 9 >>++; + infixr 8 ++; + infixr 7 >>; + infixr 6 ||; +*) + +type 'a pp = 'a Useful.pp +type 'a stream = 'a Stream.stream + +(* Generic *) +exception Noparse +val ++ : ('a -> 'b * 'a) * ('a -> 'c * 'a) -> 'a -> ('b * 'c) * 'a +val >> : ('a -> 'b * 'a) * ('b -> 'c) -> 'a -> 'c * 'a +val >>++ : ('a -> 'b * 'a) * ('b -> 'a -> 'c * 'a) -> 'a -> 'c * 'a +val || : ('a -> 'b * 'a) * ('a -> 'b * 'a) -> 'a -> 'b * 'a +val many : ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val atleastone : ('a -> 'b * 'a) -> 'a -> 'b list * 'a +val nothing : 'a -> unit * 'a +val optional : ('a -> 'b * 'a) -> 'a -> 'b option * 'a + +(* Stream-based *) +type ('a, 'b) parser = 'a stream -> 'b * 'a stream +val maybe : ('a -> 'b option) -> ('a, 'b) parser +val finished : ('a, unit) parser +val some : ('a -> bool) -> ('a, 'a) parser +val any : ('a, 'a) parser +val exact : ''a -> (''a, ''a) parser + +(* Parsing and pretty-printing for infix operators *) +type infixities = {tok : string, prec : int, left_assoc : bool} list +type 'a con = string * 'a * 'a -> 'a +type 'a des = 'a -> (string * 'a * 'a) option +type 'a iparser = (string, 'a) parser +type 'a iprinter = ('a * bool) pp +val optoks : infixities -> string list +val parse_left_infix : string list -> 'a con -> 'a iparser -> 'a iparser +val parse_right_infix : string list -> 'a con -> 'a iparser -> 'a iparser +val parse_infixes : infixities -> 'a con -> 'a iparser -> 'a iparser +val pp_left_infix : string list -> 'a des -> 'a iprinter -> 'a iprinter +val pp_right_infix : string list -> 'a des -> 'a iprinter -> 'a iprinter +val pp_infixes : infixities -> 'a des -> 'a iprinter -> 'a iprinter + +(* Lexing *) +val space : char -> bool +val digit : char -> bool +val lower : char -> bool +val upper : char -> bool +val alpha : char -> bool +val alphanum : char -> bool (* alpha + digit + _ + ' *) +val symbol : char -> bool (* <>=-*+/\?@|!$%&~#^: *) +val punct : char -> bool (* ()[]{}.,; *) + +(* Quotations *) +type 'a quotation = 'a frag list +val quotation_parser : (string -> 'a) -> 'b pp -> 'b quotation -> 'a + +end +(*#line 0.0 "basic/Parser.sml"*) +(* ========================================================================= *) +(* PARSER COMBINATORS *) +(* Created by Joe Hurd, April 2001 *) +(* ========================================================================= *) + +(* +app load ["Useful", "Stream"]; +*) + +(* +*) +structure Parser :> Parser = +struct + +open Useful; + +structure S = Stream; + +infixr 9 >>++; +infixr 8 ++; +infixr 7 >>; +infixr 6 ||; +infix ##; + +type 'a stream = 'a Stream.stream; +val omap = Option.map; + +(* ------------------------------------------------------------------------- *) +(* Generic. *) +(* ------------------------------------------------------------------------- *) + +exception Noparse; + +fun op ++ (parser1, parser2) input = + let + val (result1, rest1) = parser1 input + val (result2, rest2) = parser2 rest1 + in + ((result1, result2), rest2) + end; + +fun op >> (parser, treatment) input = + let + val (result, rest) = parser input + in + (treatment result, rest) + end; + +fun op >>++ (parser, treatment) input = + let + val (result, rest) = parser input + in + treatment result rest + end; + +fun op || (parser1, parser2) input = parser1 input +handle Noparse => parser2 input; + +fun many parser input = + let + val (result, next) = parser input + val (results, rest) = many parser next + in + ((result :: results), rest) + end + handle Noparse => ([], input); + +fun atleastone p = (p ++ many p) >> op::; + +fun nothing input = ((), input); + +fun optional p = (p >> SOME) || (nothing >> K NONE); + +(* ------------------------------------------------------------------------- *) +(* Stream-based. *) +(* ------------------------------------------------------------------------- *) + +type ('a, 'b) parser = 'a stream -> 'b * 'a stream + +fun maybe p S.NIL = raise Noparse + | maybe p (S.CONS (h, t)) = + case p h of SOME r => (r, t ()) | NONE => raise Noparse; + +fun finished S.NIL = ((), S.NIL) + | finished (S.CONS _) = raise Noparse; + +val finished: ('a, unit) parser = finished + +fun some p = maybe (fn x => if p x then SOME x else NONE); + +fun any input = some (K true) input; + +fun exact tok = some (fn item => item = tok); + +(* ------------------------------------------------------------------------- *) +(* Parsing and pretty-printing for infix operators. *) +(* ------------------------------------------------------------------------- *) + +type infixities = {tok : string, prec : int, left_assoc : bool} list; +type 'a con = string * 'a * 'a -> 'a; +type 'a des = 'a -> (string * 'a * 'a) option; +type 'a iparser = (string, 'a) parser; +type 'a iprinter = ('a * bool) pp; + +local + val sort_ops : infixities -> infixities = + let + fun order {prec, tok = _, left_assoc = _} + {prec = prec', tok = _, left_assoc = _} = + prec < prec' + in sort order + end; + fun unflatten ({tok, prec, left_assoc}, ([], _)) = + ([(left_assoc, [tok])], prec) + | unflatten ({tok, prec, left_assoc}, ((a, l) :: dealt, p)) = + if p = prec then + (assert (left_assoc = a) (BUG "infix parser/printer" "mixed assocs"); + ((a, tok :: l) :: dealt, p)) + else + ((left_assoc, [tok]) :: (a, l) :: dealt, prec); +in + val layerops = fst o foldl unflatten ([], 0) o sort_ops; +end; + +local + fun chop (#" " :: chs) = (curry op+ 1 ## I) (chop chs) | chop chs = (0, chs); + fun nspaces n = N n (curry op^ " ") ""; + fun spacify tok = + let + val chs = explode tok + val (r, chs) = chop (rev chs) + val (l, chs) = chop (rev chs) + in + ((l, r), implode chs) + end; + fun lrspaces (l, r) = + (if l = 0 then K () else C PP.add_string (nspaces l), + if r = 0 then K () else C PP.add_break (r, 0)); +in + val op_spaces = (lrspaces ## I) o spacify; + val op_clean = snd o spacify; +end; + +val optoks : infixities -> string list = map (fn {tok, ...} => op_clean tok); + +fun parse_gen_infix update sof toks parse inp = + let + val (e, rest) = parse inp + val continue = + case rest of S.NIL => NONE + | S.CONS (h, t) => if mem h toks then SOME (h, t) else NONE + in + case continue of NONE => (sof e, rest) + | SOME (h, t) => parse_gen_infix update (update sof h e) toks parse (t ()) + end; + +fun parse_left_infix toks con = + parse_gen_infix (fn f => fn t => fn a => fn b => con (t, f a, b)) I toks; + +fun parse_right_infix toks con = + parse_gen_infix (fn f => fn t => fn a => fn b => f (con (t, a, b))) I toks; + +fun parse_infixes ops = + let + val layeredops = map (I ## map op_clean) (layerops ops) + fun iparser (a, t) = (if a then parse_left_infix else parse_right_infix) t + val iparsers = map iparser layeredops + in + fn con => fn subparser => foldl (fn (p, sp) => p con sp) subparser iparsers + end; + +fun pp_gen_infix left toks : 'a des -> 'a iprinter -> 'a iprinter = + let + val spc = map op_spaces toks + in + fn dest => fn pp_sub => + let + fun dest' tm = + case dest tm of NONE => NONE + | SOME (t, a, b) => omap (pair (a, b)) (List.find (equal t o snd) spc) + open PP + fun pp_go pp (tmr as (tm, r)) = + case dest' tm of NONE => pp_sub pp tmr + | SOME ((a, b), ((lspc, rspc), tok)) + => ((if left then pp_go else pp_sub) pp (a, true); + lspc pp; add_string pp tok; rspc pp; + (if left then pp_sub else pp_go) pp (b, r)) + in + fn pp => fn tmr as (tm, _) => + case dest' tm of NONE => pp_sub pp tmr + | SOME _ => (begin_block pp INCONSISTENT 0; pp_go pp tmr; end_block pp) + end + end; + +fun pp_left_infix toks = pp_gen_infix true toks; + +fun pp_right_infix toks = pp_gen_infix false toks; + +fun pp_infixes ops = + let + val layeredops = layerops ops + val toks = List.concat (map (map op_clean o snd) layeredops) + fun iprinter (a, t) = (if a then pp_left_infix else pp_right_infix) t + val iprinters = map iprinter layeredops + in + fn dest => fn pp_sub => + let + fun printer sub = foldl (fn (ip, p) => ip dest p) sub iprinters + fun is_op t = case dest t of SOME (x, _, _) => mem x toks | _ => false + open PP + fun subpr pp (tmr as (tm, _)) = + if is_op tm then + (begin_block pp INCONSISTENT 1; add_string pp "("; + printer subpr pp (tm, false); add_string pp ")"; end_block pp) + else pp_sub pp tmr + in + fn pp => fn tmr => + (begin_block pp INCONSISTENT 0; printer subpr pp tmr; end_block pp) + end + end; + +(* ------------------------------------------------------------------------- *) +(* Lexing. *) +(* ------------------------------------------------------------------------- *) + +val space = Char.isSpace; +val digit = Char.isDigit; +val lower = Char.isLower; +val upper = Char.isUpper; +val alpha = Char.isAlpha; +val alphanum = fn c => alpha c orelse digit c orelse c = #"'" orelse c = #"_"; +val symbol = Char.contains "<>=-*+/\\?@|!$%&~#^:"; +val punct = Char.contains "()[]{}.,;"; + +(* ------------------------------------------------------------------------- *) +(* Quotations. *) +(* ------------------------------------------------------------------------- *) + +type 'a quotation = 'a frag list; + +fun quotation_parser parser pp_a = + let val f = PP.pp_to_string (!LINE_LENGTH) pp_a + in parser o foldl (fn (QUOTE q, s) => s ^ q | (ANTIQUOTE a, s) => s ^ f a) "" + end; + +end +(*#line 0.0 "fol/Term1.sig"*) +(* ========================================================================= *) +(* BASIC FIRST-ORDER LOGIC MANIPULATIONS *) +(* Created by Joe Hurd, September 2001 *) +(* Partly ported from the CAML-Light code accompanying John Harrison's book *) +(* ========================================================================= *) + +signature Term1 = +sig + +type 'a pp = 'a Useful.pp +type ('a, 'b) maplet = ('a, 'b) Useful.maplet +type 'a quotation = 'a Parser.quotation +type infixities = Parser.infixities + +(* Datatypes for terms and formulas *) +datatype term = + Var of string +| Fn of string * term list + +datatype formula = + True +| False +| Atom of term +| Not of formula +| And of formula * formula +| Or of formula * formula +| Imp of formula * formula +| Iff of formula * formula +| Forall of string * formula +| Exists of string * formula + +(* Contructors and destructors *) +val dest_var : term -> string +val is_var : term -> bool + +val dest_fn : term -> string * term list +val is_fn : term -> bool +val fn_name : term -> string +val fn_args : term -> term list +val fn_arity : term -> int +val fn_function : term -> string * int + +val mk_const : string -> term +val dest_const : term -> string +val is_const : term -> bool + +val mk_binop : string -> term * term -> term +val dest_binop : string -> term -> term * term +val is_binop : string -> term -> bool + +val dest_atom : formula -> term +val is_atom : formula -> bool + +val list_mk_conj : formula list -> formula +val strip_conj : formula -> formula list +val flatten_conj : formula -> formula list + +val list_mk_disj : formula list -> formula +val strip_disj : formula -> formula list +val flatten_disj : formula -> formula list + +val list_mk_forall : string list * formula -> formula +val strip_forall : formula -> string list * formula + +val list_mk_exists : string list * formula -> formula +val strip_exists : formula -> string list * formula + +(* New variables *) +val new_var : unit -> term +val new_vars : int -> term list + +(* Sizes of terms and formulas *) +val term_size : term -> int +val formula_size : formula -> int + +(* Total comparison functions for terms and formulas *) +val term_compare : term * term -> order +val formula_compare : formula * formula -> order + +(* Operations on literals *) +val mk_literal : bool * formula -> formula +val dest_literal : formula -> bool * formula +val is_literal : formula -> bool +val literal_atom : formula -> formula + +(* Operations on formula negations *) +val negative : formula -> bool +val positive : formula -> bool +val negate : formula -> formula + +(* Functions and relations in a formula *) +val functions : formula -> (string * int) list +val function_names : formula -> string list +val relations : formula -> (string * int) list +val relation_names : formula -> string list + +(* The equality relation has a special status *) +val eq_rel : string * int +val mk_eq : term * term -> formula +val dest_eq : formula -> term * term +val is_eq : formula -> bool +val lhs : formula -> term +val rhs : formula -> term +val eq_occurs : formula -> bool +val relations_no_eq : formula -> (string * int) list + +(* Free variables *) +val FVT : term -> string list +val FV : formula -> string list +val FVL : formula list -> string list +val specialize : formula -> formula +val generalize : formula -> formula + +(* Subterms *) +val subterm : int list -> term -> term +val rewrite : (int list, term) maplet -> term -> term +val literal_subterm : int list -> formula -> term +val literal_rewrite : (int list, term) maplet -> formula -> formula + +(* The Knuth-Bendix ordering *) +type Weight = string * int -> int +type Prec = (string * int) * (string * int) -> order +val kb_weight : Weight -> term -> int * string Multiset.mset +val kb_compare : Weight -> Prec -> term * term -> order option + +(* A datatype to antiquote both terms and formulas *) +datatype thing = Term of term | Formula of formula; + +(* Operators parsed and printed infix *) +val infixes : infixities ref + +(* Deciding whether a string denotes a variable or constant *) +val var_string : (string -> bool) ref + +(* Parsing *) +val string_to_term' : infixities -> string -> term (* purely functional *) +val string_to_formula' : infixities -> string -> formula +val parse_term' : infixities -> thing quotation -> term +val parse_formula' : infixities -> thing quotation -> formula +val string_to_term : string -> term (* using !infixes *) +val string_to_formula : string -> formula +val parse_term : thing quotation -> term +val parse_formula : thing quotation -> formula + +(* Pretty-printing *) +val pp_term' : infixities -> term pp (* purely functional *) +val pp_formula' : infixities -> formula pp +val term_to_string' : infixities -> int -> term -> string +val formula_to_string' : infixities -> int -> formula -> string +val pp_term : term pp (* using !infixes *) +val pp_formula : formula pp (* and !LINE_LENGTH *) +val term_to_string : term -> string +val formula_to_string : formula -> string + +end +(*#line 0.0 "fol/Term1.sml"*) +(* ========================================================================= *) +(* BASIC FIRST-ORDER LOGIC MANIPULATIONS *) +(* Created by Joe Hurd, September 2001 *) +(* Partly ported from the CAML-Light code accompanying John Harrison's book *) +(* ========================================================================= *) + +(* +app load ["Useful", "Stream", "Parser", "Mosml", "Binarymap"]; +*) + +(* +*) +structure Term1 :> Term1 = +struct + +open Parser Useful; + +infixr 8 ++; +infixr 7 >>; +infixr 6 ||; +infixr |-> ::> @> oo ##; + +(* ------------------------------------------------------------------------- *) +(* Datatypes for storing first-order terms and formulas. *) +(* ------------------------------------------------------------------------- *) + +datatype term = + Var of string +| Fn of string * term list; + +datatype formula = + True +| False +| Atom of term +| Not of formula +| And of formula * formula +| Or of formula * formula +| Imp of formula * formula +| Iff of formula * formula +| Forall of string * formula +| Exists of string * formula; + +(* ------------------------------------------------------------------------- *) +(* Constructors and destructors. *) +(* ------------------------------------------------------------------------- *) + +(* Variables *) + +fun dest_var (Var v) = v + | dest_var (Fn _) = raise ERR "dest_var" ""; + +val is_var = can dest_var; + +(* Functions *) + +fun dest_fn (Fn f) = f + | dest_fn (Var _) = raise ERR "dest_fn" ""; + +val is_fn = can dest_fn; + +val fn_name = fst o dest_fn; + +val fn_args = snd o dest_fn; + +val fn_arity = length o fn_args; + +fun fn_function tm = (fn_name tm, fn_arity tm); + +(* Constants *) + +fun mk_const c = (Fn (c, [])); + +fun dest_const (Fn (c, [])) = c + | dest_const _ = raise ERR "dest_const" ""; + +val is_const = can dest_const; + +(* Binary functions *) + +fun mk_binop f (a, b) = Fn (f, [a, b]); + +fun dest_binop f (Fn (x, [a, b])) = + if x = f then (a, b) else raise ERR "dest_binop" "wrong binop" + | dest_binop _ _ = raise ERR "dest_binop" "not a binop"; + +fun is_binop f = can (dest_binop f); + +(* Atoms *) + +fun dest_atom (Atom a) = a + | dest_atom _ = raise ERR "dest_atom" ""; + +val is_atom = can dest_atom; + +(* Conjunctions *) + +fun list_mk_conj l = (case rev l of [] => True | h :: t => foldl And h t); + +local + fun conj cs (And (a, b)) = conj (a :: cs) b + | conj cs fm = rev (fm :: cs); +in + fun strip_conj True = [] + | strip_conj fm = conj [] fm; +end; + +val flatten_conj = + let + fun flat acc [] = acc + | flat acc (And (p, q) :: fms) = flat acc (q :: p :: fms) + | flat acc (True :: fms) = flat acc fms + | flat acc (fm :: fms) = flat (fm :: acc) fms + in + fn fm => flat [] [fm] + end; + +(* Disjunctions *) + +fun list_mk_disj l = (case rev l of [] => False | h :: t => foldl Or h t); + +local + fun disj cs (Or (a, b)) = disj (a :: cs) b + | disj cs fm = rev (fm :: cs); +in + fun strip_disj False = [] + | strip_disj fm = disj [] fm; +end; + +val flatten_disj = + let + fun flat acc [] = acc + | flat acc (Or (p, q) :: fms) = flat acc (q :: p :: fms) + | flat acc (False :: fms) = flat acc fms + | flat acc (fm :: fms) = flat (fm :: acc) fms + in + fn fm => flat [] [fm] + end; + +(* Universal quantifiers *) + +fun list_mk_forall ([], body) = body + | list_mk_forall (v :: vs, body) = Forall (v, list_mk_forall (vs, body)); + +local + fun dest vs (Forall (v, b)) = dest (v :: vs) b + | dest vs tm = (rev vs, tm); +in + val strip_forall = dest []; +end; + +(* Existential quantifiers *) + +fun list_mk_exists ([], body) = body + | list_mk_exists (v :: vs, body) = Exists (v, list_mk_exists (vs, body)); + +local + fun dest vs (Exists (v, b)) = dest (v :: vs) b + | dest vs tm = (rev vs, tm); +in + val strip_exists = dest []; +end; + +(* ------------------------------------------------------------------------- *) +(* A datatype to antiquote both terms and formulas. *) +(* ------------------------------------------------------------------------- *) + +datatype thing = Term of term | Formula of formula; + +(* ------------------------------------------------------------------------- *) +(* Built-in infix operators and reserved symbols. *) +(* ------------------------------------------------------------------------- *) + +val infixes : infixities ref = ref + [(* ML style *) + {tok = " / ", prec = 7, left_assoc = true}, + {tok = " div ", prec = 7, left_assoc = true}, + {tok = " mod ", prec = 7, left_assoc = true}, + {tok = " * ", prec = 7, left_assoc = true}, + {tok = " + ", prec = 6, left_assoc = true}, + {tok = " - ", prec = 6, left_assoc = true}, + {tok = " ^ ", prec = 6, left_assoc = true}, + {tok = " @ ", prec = 5, left_assoc = false}, + {tok = " :: ", prec = 5, left_assoc = false}, + {tok = " = ", prec = 4, left_assoc = true}, (* may be interpreted *) + {tok = " == ", prec = 4, left_assoc = true}, (* won't be interpreted *) + {tok = " <> ", prec = 4, left_assoc = true}, + {tok = " <= ", prec = 4, left_assoc = true}, + {tok = " < ", prec = 4, left_assoc = true}, + {tok = " >= ", prec = 4, left_assoc = true}, + {tok = " > ", prec = 4, left_assoc = true}, + {tok = " o ", prec = 8, left_assoc = true}, (* ML prec = 3 *) + (* HOL style *) + {tok = " % ", prec = 9, left_assoc = true}, (* function application *) + {tok = " -> ", prec = 2, left_assoc = false}, (* HOL ty prec = 50 *) + {tok = " : ", prec = 1, left_assoc = false}, (* not in HOL grammars *) + {tok = ", ", prec = 0, left_assoc = false}, (* HOL tm prec = 50 *) + (* Convenient alternative symbols *) + {tok = " ** ", prec = 7, left_assoc = true}, + {tok = " ++ ", prec = 6, left_assoc = true}, + {tok = " -- ", prec = 6, left_assoc = true}]; + +val connectives = + [{tok = " /\\ ", prec = ~1, left_assoc = false}, + {tok = " \\/ ", prec = ~2, left_assoc = false}, + {tok = " ==> ", prec = ~3, left_assoc = false}, + {tok = " <=> ", prec = ~4, left_assoc = false}]; + +val reserved = ["!", "?", "(", ")", ".", "~"]; + +(* ------------------------------------------------------------------------- *) +(* Deciding whether a string denotes a variable or constant. *) +(* ------------------------------------------------------------------------- *) + +val var_string = + ref (C mem [#"_",#"v",#"w",#"x",#"y",#"z"] o Char.toLower o hd o explode); + +(* ------------------------------------------------------------------------- *) +(* Pretty-printing. *) +(* ------------------------------------------------------------------------- *) + +(* Purely functional pretty-printing *) + +val pp_vname = + pp_map (fn s => if !var_string s then s else "var->" ^ s ^ "<-var") pp_string; + +val pp_cname = + pp_map (fn s => if !var_string s then "const->" ^ s ^ "<-const" else s) + pp_string; + +val pp_fname = + pp_map (fn s => if !var_string s then "fn->" ^ s ^ "<-fn" else s) pp_string; + +fun pp_term' ops = + let + val ops = ops @ connectives + val iprinter = pp_infixes ops + val itoks = optoks ops + fun pp_uninfix pp_s pp s = + if mem s itoks then PP.add_string pp ("(" ^ s ^ ")") else pp_s pp s + fun idest (Fn (f, [a, b])) = SOME (f, a, b) | idest _ = NONE + fun is_op t = case idest t of SOME (f, _, _) => mem f itoks | NONE => false + fun is_q (Fn ("!", _)) = true | is_q (Fn ("?", _)) = true | is_q _ = false + fun negs (Fn ("~", [a])) = (curry op+ 1 ## I) (negs a) | negs tm = (0, tm) + fun binds s (tm as Fn (n, [Var v, b])) = + if s = n then (cons v ## I) (binds s b) else ([], tm) + | binds _ tm = ([], tm) + open PP + fun basic pp (Var v) = pp_vname pp v + | basic pp (Fn (c, [])) = pp_uninfix pp_cname pp c + | basic pp (Fn (f, a)) = + (pp_uninfix pp_fname pp f; + app (fn x => (add_break pp (1, 0); argument pp x)) a) + and argument pp tm = + if is_var tm orelse is_const tm then basic pp tm else pp_btm pp tm + and quant pp (tm, r) = + let + fun pr pp (Fn (q, [Var v, tm])) = + let + val (vs, body) = binds q tm + in + add_string pp q; + pp_vname pp v; + app (fn a => (add_break pp (1, 0); pp_vname pp a)) vs; + add_string pp "."; + add_break pp (1, 0); + if is_q body then pr pp body else pp_tm pp (body, false) + end + | pr pp tm = raise BUG "pp_term" "not a quantifier" + fun pp_q pp t = (begin_block pp INCONSISTENT 2; pr pp t; end_block pp) + in + (if is_q tm then (if r then pp_bracket ("(", ")") else I) pp_q + else basic) pp tm + end + and molecule pp (tm, r) = + let + val (n, x) = negs tm + in + begin_block pp INCONSISTENT n; + N n (fn () => add_string pp "~") (); + if is_op x then pp_btm pp x else quant pp (x, r); + end_block pp + end + and pp_btm pp tm = pp_bracket ("(", ")") pp_tm pp (tm, false) + and pp_tm pp tmr = iprinter idest molecule pp tmr + in + pp_map (C pair false) pp_tm + end; + +local + fun demote True = Fn ("T", [] ) + | demote False = Fn ("F", [] ) + | demote (Not a) = Fn ("~", [demote a] ) + | demote (And (a, b)) = Fn ("/\\", [demote a, demote b]) + | demote (Or (a, b)) = Fn ("\\/", [demote a, demote b]) + | demote (Imp (a, b)) = Fn ("==>", [demote a, demote b]) + | demote (Iff (a, b)) = Fn ("<=>", [demote a, demote b]) + | demote (Forall (v, b)) = Fn ("!", [Var v, demote b]) + | demote (Exists (v, b)) = Fn ("?", [Var v, demote b]) + | demote (Atom t) = t; +in + fun pp_formula' ops = pp_map demote (pp_term' ops); +end; + +fun term_to_string' ops len tm = PP.pp_to_string len (pp_term' ops) tm; +fun formula_to_string' ops len fm = PP.pp_to_string len (pp_formula' ops) fm; + +(* Pretty-printing things is needed for parsing thing quotations *) + +fun pp_thing ops pp (Term tm) = pp_term' ops pp tm + | pp_thing ops pp (Formula fm) = pp_formula' ops pp fm; + +fun pp_bracketed_thing ops pp th = + (PP.begin_block pp PP.INCONSISTENT 1; PP.add_string pp "("; + pp_thing ops pp th; PP.add_string pp ")"; PP.end_block pp); + +(* Pretty-printing using !infixes and !LINE_LENGTH *) + +fun pp_term pp tm = pp_term' (!infixes) pp tm; +fun pp_formula pp fm = pp_formula' (!infixes) pp fm; +fun term_to_string tm = term_to_string' (!infixes) (!LINE_LENGTH) tm; +fun formula_to_string fm = formula_to_string' (!infixes) (!LINE_LENGTH) fm; + +(* ------------------------------------------------------------------------- *) +(* Parsing. *) +(* ------------------------------------------------------------------------- *) + +(* Lexing *) + +val lexer = + (fn ((_, (toks, _)), _) => toks) o + (many (some space) ++ + (many + ((((atleastone (some alphanum) || + (some (fn c => symbol c andalso c <> #"~") ++ many (some symbol)) >> + op ::) >> implode + || some (fn c => c = #"~" orelse punct c) >> str) ++ + many (some space)) >> fst)) ++ + finished); + +val lex_str = lexer o Stream.from_list o explode; + +(* Purely functional parsing *) + +val vname_parser = + some (fn tok => not (mem tok reserved) andalso !var_string tok); + +fun term_parser ops = + let + val ops = ops @ connectives + val iparser = parse_infixes ops + val itoks = optoks ops + val avoid = itoks @ reserved + fun fname tok = not (mem tok avoid) andalso not (!var_string tok) + fun uninfix tok = mem tok itoks + val uninfix_parser = (exact "(" ++ some uninfix ++ exact ")") >> (fst o snd) + val fname_parser = some fname || uninfix_parser + fun bind s (v, t) = Fn (s, [Var v, t]) + fun basic inp = + ((exact "(" ++ tm_parser ++ exact ")") >> (fn (_, (t, _)) => t) || + (exact "!" ++ atleastone vname_parser ++ exact "." ++ tm_parser) >> + (fn (_, (vs, (_, body))) => foldr (bind "!") body vs) || + (exact "?" ++ atleastone vname_parser ++ exact "." ++ tm_parser) >> + (fn (_, (vs, (_, body))) => foldr (bind "?") body vs) || + fname_parser >> (fn f => Fn (f, [])) || + vname_parser >> Var) inp + and molecule inp = + ((many (exact "~") ++ ((fname_parser ++ many basic) >> Fn || basic)) >> + (fn (l, t) => N (length l) (fn x => Fn ("~", [x])) t)) inp + and tm_parser inp = iparser (fn (f, a, b) => Fn (f, [a, b])) molecule inp + in + tm_parser + end; + +local + fun promote (Fn ("T", [] )) = True + | promote (Fn ("F", [] )) = False + | promote (Fn ("~", [a] )) = Not (promote a) + | promote (Fn ("/\\", [a, b] )) = And (promote a, promote b) + | promote (Fn ("\\/", [a, b] )) = Or (promote a, promote b) + | promote (Fn ("==>", [a, b] )) = Imp (promote a, promote b) + | promote (Fn ("<=>", [a, b] )) = Iff (promote a, promote b) + | promote (Fn ("!", [Var v, b])) = Forall (v, promote b) + | promote (Fn ("?", [Var v, b])) = Exists (v, promote b) + | promote tm = Atom tm; +in + fun formula_parser ops = term_parser ops >> promote; +end; + +fun string_to_term' ops = + fst o ((term_parser ops ++ finished) >> fst) o Stream.from_list o lex_str; + +fun string_to_formula' ops = + fst o ((formula_parser ops ++ finished) >> fst) o Stream.from_list o lex_str; + +fun parse_term' ops = + quotation_parser (string_to_term' ops) (pp_bracketed_thing ops); + +fun parse_formula' ops = + quotation_parser (string_to_formula' ops) (pp_bracketed_thing ops); + +(* Parsing using !infixes *) + +fun string_to_term s = string_to_term' (!infixes) s; +fun string_to_formula s = string_to_formula' (!infixes) s; +fun parse_term q = parse_term' (!infixes) q; +fun parse_formula q = parse_formula' (!infixes) q; + +(* ------------------------------------------------------------------------- *) +(* New variables. *) +(* ------------------------------------------------------------------------- *) + +local + val prefix = "_"; + val num_var = Var o mk_prefix prefix o int_to_string; +in + val new_var = num_var o new_int; + val new_vars = map num_var o new_ints; +end; + +(* ------------------------------------------------------------------------- *) +(* Sizes of terms and formulas. *) +(* ------------------------------------------------------------------------- *) + +local + fun szt n [] = n + | szt n (Var _ :: tms) = szt (n + 1) tms + | szt n (Fn (_, args) :: tms) = szt (n + 1) (args @ tms); + + fun sz n [] = n + | sz n (True :: fms) = sz (n + 1) fms + | sz n (False :: fms) = sz (n + 1) fms + | sz n (Atom t :: fms) = sz (szt (n + 1) [t]) fms + | sz n (Not p :: fms) = sz (n + 1) (p :: fms) + | sz n (And (p, q) :: fms) = sz (n + 1) (p :: q :: fms) + | sz n (Or (p, q) :: fms) = sz (n + 1) (p :: q :: fms) + | sz n (Imp (p, q) :: fms) = sz (n + 1) (p :: q :: fms) + | sz n (Iff (p, q) :: fms) = sz (n + 1) (p :: q :: fms) + | sz n (Forall (_, p) :: fms) = sz (n + 1) (p :: fms) + | sz n (Exists (_, p) :: fms) = sz (n + 1) (p :: fms); +in + val term_size = szt 0 o wrap; + val formula_size = sz 0 o wrap; +end; + +(* ------------------------------------------------------------------------- *) +(* Total comparison functions for terms and formulas. *) +(* ------------------------------------------------------------------------- *) + +local + fun lex EQUAL f x = f x | lex x _ _ = x; + + fun cmt [] = EQUAL + | cmt ((Var _, Fn _) :: _) = LESS + | cmt ((Fn _, Var _) :: _) = GREATER + | cmt ((Var v, Var w) :: l) = lex (String.compare (v, w)) cmt l + | cmt ((Fn (f, a), Fn (g, b)) :: l) = + (case lex (String.compare (f, g)) (Int.compare o Df length) (a, b) of EQUAL + => cmt (zip a b @ l) + | x => x); + + fun cm [] = EQUAL + | cm ((True, True ) :: l) = cm l + | cm ((True, _ ) :: _) = LESS + | cm ((_, True ) :: _) = GREATER + | cm ((False, False ) :: l) = cm l + | cm ((False, _ ) :: _) = LESS + | cm ((_, False ) :: _) = GREATER + | cm ((Atom t, Atom u ) :: l) = lex (cmt [(t, u)]) cm l + | cm ((Atom _, _ ) :: _) = LESS + | cm ((_, Atom _ ) :: _) = GREATER + | cm ((Not p, Not q ) :: l) = cm ((p, q) :: l) + | cm ((Not _ , _ ) :: _) = LESS + | cm ((_, Not _ ) :: _) = GREATER + | cm ((And (p1, q1), And (p2, q2) ) :: l) = cm ((p1, p2) :: (q1, q2) :: l) + | cm ((And _, _ ) :: _) = LESS + | cm ((_, And _ ) :: _) = GREATER + | cm ((Or (p1, q1), Or (p2, q2) ) :: l) = cm ((p1, p2) :: (q1, q2) :: l) + | cm ((Or _, _ ) :: _) = LESS + | cm ((_, Or _ ) :: _) = GREATER + | cm ((Imp (p1, q1), Imp (p2, q2) ) :: l) = cm ((p1, p2) :: (q1, q2) :: l) + | cm ((Imp _, _ ) :: _) = LESS + | cm ((_, Imp _ ) :: _) = GREATER + | cm ((Iff (p1, q1), Iff (p2, q2) ) :: l) = cm ((p1, p2) :: (q1, q2) :: l) + | cm ((Iff _, _ ) :: _) = LESS + | cm ((_, Iff _ ) :: _) = GREATER + | cm ((Forall (v, p), Forall (w, q)) :: l) = + lex (String.compare (v, w)) (cm o cons (p, q)) l + | cm ((Forall _, Exists _ ) :: _) = LESS + | cm ((Exists _, Forall _ ) :: _) = GREATER + | cm ((Exists (v, p), Exists (w, q)) :: l) = + lex (String.compare (v, w)) (cm o cons (p, q)) l; +in + val term_compare = cmt o wrap; + val formula_compare = cm o wrap; +end; + +(* ------------------------------------------------------------------------- *) +(* Basic operations on literals. *) +(* ------------------------------------------------------------------------- *) + +fun mk_literal (true, a) = a + | mk_literal (false, a) = Not a; + +fun dest_literal (a as Atom _) = (true, a) + | dest_literal (Not (a as Atom _)) = (false, a) + | dest_literal _ = raise ERR "dest_literal" ""; + +val is_literal = can dest_literal; + +val literal_atom = snd o dest_literal; + +(* ------------------------------------------------------------------------- *) +(* Dealing with formula negations. *) +(* ------------------------------------------------------------------------- *) + +fun negative (Not p) = true + | negative _ = false; + +val positive = non negative; + +fun negate (Not p) = p + | negate p = Not p; + +(* ------------------------------------------------------------------------- *) +(* Functions and relations in a formula. *) +(* ------------------------------------------------------------------------- *) + +local + fun fnc fs [] = fs + | fnc fs (Var _ :: tms) = fnc fs tms + | fnc fs (Fn (n, a) :: tms) = fnc (insert (n, length a) fs) (a @ tms); + + fun func fs [] = fs + | func fs (True :: fms) = func fs fms + | func fs (False :: fms) = func fs fms + | func fs (Atom (Var _) :: fms) = func fs fms + | func fs (Atom (Fn (_, tms)) :: fms) = func (fnc fs tms) fms + | func fs (Not p :: fms) = func fs (p :: fms) + | func fs (And (p, q) :: fms) = func fs (p :: q :: fms) + | func fs (Or (p, q) :: fms) = func fs (p :: q :: fms) + | func fs (Imp (p, q) :: fms) = func fs (p :: q :: fms) + | func fs (Iff (p, q) :: fms) = func fs (p :: q :: fms) + | func fs (Forall (_, p) :: fms) = func fs (p :: fms) + | func fs (Exists (_, p) :: fms) = func fs (p :: fms); +in + val functions = func [] o wrap; +end; + +val function_names = map fst o functions; + +local + fun rel rs [] = rs + | rel rs (True :: fms) = rel rs fms + | rel rs (False :: fms) = rel rs fms + | rel rs (Atom (Var _) :: fms) = rel rs fms + | rel rs (Atom (f as Fn _) :: fms) = rel (insert (fn_function f) rs) fms + | rel rs (Not p :: fms) = rel rs (p :: fms) + | rel rs (And (p, q) :: fms) = rel rs (p :: q :: fms) + | rel rs (Or (p, q) :: fms) = rel rs (p :: q :: fms) + | rel rs (Imp (p, q) :: fms) = rel rs (p :: q :: fms) + | rel rs (Iff (p, q) :: fms) = rel rs (p :: q :: fms) + | rel rs (Forall (_, p) :: fms) = rel rs (p :: fms) + | rel rs (Exists (_, p) :: fms) = rel rs (p :: fms); +in + val relations = rel [] o wrap; +end; + +val relation_names = map fst o relations; + +(* ------------------------------------------------------------------------- *) +(* The equality relation has a special status. *) +(* ------------------------------------------------------------------------- *) + +val eq_rel = ("=", 2); + +fun mk_eq (a, b) = Atom (Fn ("=", [a, b])); + +fun dest_eq (Atom (Fn ("=", [a, b]))) = (a, b) + | dest_eq _ = raise ERR "dest_eq" ""; + +val is_eq = can dest_eq; + +val lhs = fst o dest_eq; + +val rhs = snd o dest_eq; + +val eq_occurs = mem eq_rel o relations; + +val relations_no_eq = List.filter (non (equal eq_rel)) o relations; + +(* ------------------------------------------------------------------------- *) +(* Free variables in terms and formulas. *) +(* ------------------------------------------------------------------------- *) + +local + fun fvt av = + let + val seen = + if null av then mem else (fn v => fn vs => mem v av orelse mem v vs) + fun f vs [] = vs + | f vs (Var v :: tms) = f (if seen v vs then vs else v :: vs) tms + | f vs (Fn (_, args) :: tms) = f vs (args @ tms) + in + f + end; + + fun fv vs [] = vs + | fv vs ((_ , True ) :: fms) = fv vs fms + | fv vs ((_ , False ) :: fms) = fv vs fms + | fv vs ((av, Atom t ) :: fms) = fv (fvt av vs [t]) fms + | fv vs ((av, Not p ) :: fms) = fv vs ((av, p) :: fms) + | fv vs ((av, And (p, q) ) :: fms) = fv vs ((av, p) :: (av, q) :: fms) + | fv vs ((av, Or (p, q) ) :: fms) = fv vs ((av, p) :: (av, q) :: fms) + | fv vs ((av, Imp (p, q) ) :: fms) = fv vs ((av, p) :: (av, q) :: fms) + | fv vs ((av, Iff (p, q) ) :: fms) = fv vs ((av, p) :: (av, q) :: fms) + | fv vs ((av, Forall (x, p)) :: fms) = fv vs ((insert x av, p) :: fms) + | fv vs ((av, Exists (x, p)) :: fms) = fv vs ((insert x av, p) :: fms); +in + fun FVT tm = rev (fvt [] [] [tm]); + fun FV fm = rev (fv [] [([], fm)]); + fun FVL fms = rev (fv [] (map (pair []) fms)); +end; + +val specialize = snd o strip_forall; + +fun generalize fm = list_mk_forall (FV fm, fm); + +(* ------------------------------------------------------------------------- *) +(* Subterms. *) +(* ------------------------------------------------------------------------- *) + +fun subterm [] tm = tm + | subterm (_ :: _) (Var _) = raise ERR "subterm" "Var" + | subterm (h :: t) (Fn (_, args)) = + subterm t (List.nth (args, h)) + handle Subscript => raise ERR "subterm" "bad path"; + +local + fun update _ _ [] = raise ERR "rewrite" "bad path" + | update f n (h :: t) = if n = 0 then f h :: t else h :: update f (n - 1) t; +in + fun rewrite ([] |-> res) _ = res + | rewrite _ (Var _) = raise ERR "rewrite" "Var" + | rewrite ((h :: t) |-> res) (Fn (f, args)) = + Fn (f, update (rewrite (t |-> res)) h args); +end; + +local + fun atom_rewrite r = Atom o rewrite r o dest_atom; +in + fun literal_subterm p = subterm p o dest_atom o literal_atom; + fun literal_rewrite r = mk_literal o (I ## atom_rewrite r) o dest_literal; +end; + +(* ------------------------------------------------------------------------- *) +(* The Knuth-Bendix ordering. *) +(* ------------------------------------------------------------------------- *) + +type Weight = string * int -> int; +type Prec = (string * int) * (string * int) -> order; + +val no_vars = Multiset.empty String.compare; +fun one_var v = Multiset.insert (v, 1) no_vars; + +fun kb_weight w = + let + fun weight (Var v) = (0, one_var v) + | weight (Fn (f, a)) = foldl wght (w (f, length a), no_vars) a + and wght (t, (n, v)) = (curry op+ n ## Multiset.union v) (weight t) + in + weight + end; + +(* The Knuth-Bendix ordering is partial when terms contain variables *) + +fun kb_compare w p = + let + fun kbo [] = SOME EQUAL + | kbo (tu :: rest) = + if op= tu then SOME EQUAL + else + let val ((wt, vt), (wu, vu)) = Df (kb_weight w) tu + in kbo1 (Int.compare (wt, wu)) (Multiset.compare (vt, vu)) tu rest + end + and kbo1 _ NONE _ _ = NONE + | kbo1 LESS (SOME LESS) _ _ = SOME LESS + | kbo1 GREATER (SOME LESS) _ _ = NONE + | kbo1 EQUAL (SOME LESS) _ _ = SOME LESS + | kbo1 LESS (SOME GREATER) _ _ = NONE + | kbo1 GREATER (SOME GREATER) _ _ = SOME GREATER + | kbo1 EQUAL (SOME GREATER) _ _ = SOME GREATER + | kbo1 LESS (SOME EQUAL) _ _ = SOME LESS + | kbo1 GREATER (SOME EQUAL) _ _ = SOME GREATER + | kbo1 EQUAL (SOME EQUAL) (t, u) rest = kbo2 t u rest + and kbo2 (Fn (f, a)) (Fn (g, b)) rest = + (case p ((f, length a), (g, length b)) of LESS => SOME LESS + | GREATER => SOME GREATER + | EQUAL => kbo (zip a b @ rest)) + | kbo2 _ _ _ = raise BUG "kbo" "variable" + in + kbo o wrap + end; + +end +(*#line 0.0 "fol/Subst1.sig"*) +(* ========================================================================= *) +(* SUBSTITUTIONS ON FIRST-ORDER TERMS AND FORMULAS *) +(* Created by Joe Hurd, June 2002 *) +(* ========================================================================= *) + +signature Subst1 = +sig + +type 'a pp = 'a Useful.pp +type ('a, 'b) maplet = ('a, 'b) Useful.maplet +type term = Term1.term +type formula = Term1.formula + +type subst + +val |<>| : subst +val ::> : (string, term) maplet * subst -> subst +val @> : subst * subst -> subst +val null : subst -> bool +val term_subst : subst -> term -> term +val formula_subst : subst -> formula -> formula +val find_redex : string -> subst -> term option +val norm : subst -> subst (* Removes identity substitutions *) +val restrict : string list -> subst -> subst +val refine : subst -> subst -> subst +val is_renaming : subst -> bool +val to_maplets : subst -> (string, term) maplet list +val from_maplets : (string, term) maplet list -> subst +val foldl : ((string, term) maplet -> 'a -> 'a) -> 'a -> subst -> 'a +val foldr : ((string, term) maplet -> 'a -> 'a) -> 'a -> subst -> 'a +val pp_subst : subst pp + +end + +(*#line 0.0 "fol/Subst1.sml"*) +(* ========================================================================= *) +(* SUBSTITUTIONS ON FIRST-ORDER TERMS AND FORMULAS *) +(* Created by Joe Hurd, June 2002 *) +(* ========================================================================= *) + +(* +app load ["Binarymap", "Useful", "Term1"]; +*) + +(* +*) +structure Subst1 :> Subst1 = +struct + +open Useful Term1; + +infixr 8 ++; +infixr 7 >>; +infixr 6 ||; +infixr |-> ::> @> oo ##; + +structure M = Binarymap; + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +fun Mpurge (d, k) = fst (M.remove (d, k)) handle NotFound => d; + +(* ------------------------------------------------------------------------- *) +(* The underlying representation. *) +(* ------------------------------------------------------------------------- *) + +datatype subst = Subst of (string, term) M.dict; + +(* ------------------------------------------------------------------------- *) +(* Operations. *) +(* ------------------------------------------------------------------------- *) + +val |<>| = Subst (M.mkDict String.compare); + +fun (a |-> b) ::> (Subst d) = Subst (M.insert (d, a, b)); + +fun (Subst sub1) @> (Subst sub2) = + Subst (M.foldl (fn (a, b, d) => M.insert (d, a, b)) sub2 sub1); + +fun null (Subst s) = M.numItems s = 0; + +fun find_redex r (Subst d) = M.peek (d, r); + +fun purge v (Subst d) = Subst (Mpurge (d, v)); + +local + exception Unchanged; + + fun always f x = f x handle Unchanged => x; + + fun pair_unchanged f (x, y) = + let + val (c, x) = (true, f x) handle Unchanged => (false, x) + val (c, y) = (true, f y) handle Unchanged => (c, y) + in + if c then (x, y) else raise Unchanged + end; + + fun list_unchanged f = + let + fun g (x, (b, l)) = (true, f x :: l) handle Unchanged => (b, x :: l) + fun h (true, l) = rev l | h (false, _) = raise Unchanged + in + h o foldl g (false, []) + end; + + fun find_unchanged v r = + case find_redex v r of SOME t => t | NONE => raise Unchanged; + + fun tm_subst r = + let + fun f (Var v) = find_unchanged v r + | f (Fn (n, a)) = Fn (n, list_unchanged f a) + in + f + end; + + fun fm_subst r = + let + fun f False = raise Unchanged + | f True = raise Unchanged + | f (Atom tm ) = Atom (tm_subst r tm) + | f (Not p ) = Not (f p) + | f (And pq ) = And (pair_unchanged f pq) + | f (Or pq ) = Or (pair_unchanged f pq) + | f (Imp pq ) = Imp (pair_unchanged f pq) + | f (Iff pq ) = Iff (pair_unchanged f pq) + | f (Forall vp) = fm_substq r Forall vp + | f (Exists vp) = fm_substq r Exists vp + in + if null r then I else always f + end + and fm_substq r Q (v, p) = + let val v' = variant v (FV (fm_subst (purge v r) p)) + in Q (v', fm_subst ((v |-> Var v') ::> r) p) + end; +in + fun term_subst env tm = if null env then tm else always (tm_subst env) tm; + fun formula_subst env fm = fm_subst env fm; +end; + +fun norm (sub as Subst dict) = + let + fun check (a, b, (c, d)) = + if Var a = b then (true, fst (M.remove (d, a))) else (c, d) + val (removed, dict') = M.foldl check (false, dict) dict + in + if removed then Subst dict' else sub + end; + +fun to_maplets (Subst s) = map (op|->) (M.listItems s); + +fun from_maplets ms = foldl (op ::>) |<>| (rev ms); + +fun restrict vs = + from_maplets o List.filter (fn (a |-> _) => mem a vs) o to_maplets; + +(* Note: this just doesn't work with cyclic substitutions! *) +fun refine (Subst sub1) sub2 = + let + fun f ((a, b), s) = + let val b' = term_subst sub2 b + in if Var a = b' then s else (a |-> b') ::> s + end + in + foldl f sub2 (M.listItems sub1) + end; + +local + exception QF + fun rs (v, Var w, l) = if mem w l then raise QF else w :: l + | rs (_, Fn _, _) = raise QF +in + fun is_renaming (Subst sub) = (M.foldl rs [] sub; true) handle QF => false; +end; + +fun foldl f b (Subst sub) = M.foldl (fn (s, t, a) => f (s |-> t) a) b sub; + +fun foldr f b (Subst sub) = M.foldr (fn (s, t, a) => f (s |-> t) a) b sub; + +val pp_subst = + pp_map to_maplets + (fn pp => + (fn [] => pp_string pp "|<>|" + | l => pp_list (pp_maplet pp_string pp_term) pp l)); + +end +(*#line 0.0 "fol/Kernel1.sig"*) +(* ========================================================================= *) +(* A LCF-STYLE LOGICAL KERNEL FOR FIRST-ORDER CLAUSES *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +signature Kernel1 = +sig + +type term = Term1.term +type formula = Term1.formula +type subst = Subst1.subst + +(* An ABSTRACT type for theorems *) +eqtype thm +datatype inference = Axiom | Refl | Assume | Inst | Factor | Resolve | Equality + +(* Destruction of theorems is fine *) +val dest_thm : thm -> formula list * (inference * thm list) + +(* But creation is only allowed by the primitive rules of inference *) +val AXIOM : formula list -> thm +val REFL : term -> thm +val ASSUME : formula -> thm +val INST : subst -> thm -> thm +val FACTOR : thm -> thm +val RESOLVE : formula -> thm -> thm -> thm +val EQUALITY : formula -> int list -> term -> bool -> thm -> thm + +end +(*#line 0.0 "fol/Kernel1.sml"*) +(* ========================================================================= *) +(* A LCF-STYLE LOGICAL KERNEL FOR FIRST-ORDER CLAUSES *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +structure Kernel1 :> Kernel1 = +struct + +open Useful Term1; + +infixr |-> ::> oo; + +type subst = Subst1.subst; +val formula_subst = Subst1.formula_subst; + +(* ------------------------------------------------------------------------- *) +(* An ABSTRACT type for theorems. *) +(* ------------------------------------------------------------------------- *) + +datatype inference = Axiom | Refl | Assume | Inst | Factor | Resolve | Equality; + +datatype thm = Thm of formula list * (inference * thm list); + +(* ------------------------------------------------------------------------- *) +(* Destruction of theorems is fine. *) +(* ------------------------------------------------------------------------- *) + +fun dest_thm (Thm th) = th; + +val clause = fst o dest_thm; + +(* ------------------------------------------------------------------------- *) +(* But creation is only allowed by the primitive rules of inference. *) +(* ------------------------------------------------------------------------- *) + +fun AXIOM cl = + if List.all is_literal cl then Thm (cl, (Axiom, [])) + else raise ERR "AXIOM" "argument not a list of literals"; + +fun REFL tm = Thm ([mk_eq (tm, tm)], (Refl, [])); + +fun ASSUME fm = + if is_literal fm then Thm ([fm, negate fm], (Assume, [])) + else raise ERR "ASSUME" "argument not a literal"; + +fun INST env (th as Thm (cl, pr)) = + let + val cl' = map (formula_subst env) cl + in + if cl' = cl then th else + case pr of (Inst, [th']) + => if cl' = clause th' then th' else Thm (cl', (Inst, [th'])) + | _ => Thm (cl', (Inst, [th])) + end; + +fun FACTOR th = + let val cl = rev (setify (clause th)) + in if cl = clause th then th else Thm (cl, (Factor, [th])) + end; + +fun RESOLVE fm th1 th2 = + let + val cl1 = clause th1 + val cl1' = List.filter (not o equal fm) cl1 + val cl2 = clause th2 + val cl2' = List.filter (not o equal (negate fm)) cl2 + val () = + assert (cl1 <> cl1' orelse cl2 <> cl2') + (ERR "RESOLVE" "resolvant does not feature in either clause") + in + Thm (cl1' @ cl2', (Resolve, [th1, th2])) + end; + +fun EQUALITY fm p res lr th = + let + val eq_lit = + let + val red = literal_subterm p fm + in + Not (mk_eq (if lr then (red, res) else (res, red))) + end + val other_lits = + let + val l = clause th + in + case index (equal fm) l of NONE + => raise ERR "EQUALITY" "literal does not occur in clause" + | SOME n => update_nth (literal_rewrite (p |-> res)) n l + end + in + Thm (eq_lit :: other_lits, (Equality, [th])) + end; + +end +(*#line 0.0 "fol/Match1.sig"*) +(* ========================================================================= *) +(* MATCHING AND UNIFICATION *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +signature Match1 = +sig + +type term = Term1.term +type formula = Term1.formula +type subst = Subst1.subst + +(* Matching *) +val matchl : subst -> (term * term) list -> subst +val match : term -> term -> subst +val matchl_literals : subst -> (formula * formula) list -> subst +val match_literals : formula -> formula -> subst + +(* Unification *) +val unifyl : subst -> (term * term) list -> subst +val unify : subst -> term -> term -> subst +val unify_and_apply : term -> term -> term +val unifyl_literals : subst -> (formula * formula) list -> subst +val unify_literals : subst -> formula -> formula -> subst + +end +(*#line 0.0 "fol/Match1.sml"*) +(* ========================================================================= *) +(* MATCHING AND UNIFICATION *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +(* +app load ["Useful", "Mosml", "Term1"]; +*) + +(* +*) +structure Match1 :> Match1 = +struct + +open Useful Term1; + +infixr |-> ::>; + +type subst = Subst1.subst; +val |<>| = Subst1.|<>|; +val op ::> = Subst1.::>; +val term_subst = Subst1.term_subst; +val formula_subst = Subst1.formula_subst; + +(* ------------------------------------------------------------------------- *) +(* Matching. *) +(* ------------------------------------------------------------------------- *) + +fun raw_match env x tm = + (case Subst1.find_redex x env of NONE => (x |-> tm) ::> env + | SOME tm' => + if tm = tm' then env + else raise ERR "match" "one var trying to match two different terms"); + +fun matchl env [] = env + | matchl env ((Var x, tm) :: rest) = matchl (raw_match env x tm) rest + | matchl env ((Fn (f, args), Fn (f', args')) :: rest) = + if f = f' andalso length args = length args' then + matchl env (zip args args' @ rest) + else raise ERR "match" "can't match two different functions" + | matchl _ _ = raise ERR "match" "different structure"; + +fun match tm tm' = Subst1.norm (matchl |<>| [(tm, tm')]); + +local + fun conv (Atom t, Atom t') = SOME (t, t') + | conv (Not p, Not q) = conv (p, q) + | conv (True, True) = NONE + | conv (False, False) = NONE + | conv _ = raise ERR "match_literals" "incompatible"; +in + fun matchl_literals sub = matchl sub o List.mapPartial conv; +end; + +fun match_literals lit lit' = Subst1.norm (matchl_literals |<>| [(lit, lit')]); + +(* ------------------------------------------------------------------------- *) +(* Unification. *) +(* ------------------------------------------------------------------------- *) + +local + fun occurs v tm = mem v (FVT tm); + + fun solve env [] = env + | solve env ((tm1, tm2) :: rest) = + solve' env (term_subst env tm1) (term_subst env tm2) rest + and solve' env (Var x) tm rest = + if Var x = tm then solve env rest + else if occurs x tm then raise ERR "unify" "occurs check" + else + (case Subst1.find_redex x env of NONE + => solve (Subst1.refine env ((x |-> tm) ::> |<>|)) rest + | SOME tm' => solve' env tm' tm rest) + | solve' env tm (tm' as Var _) rest = solve' env tm' tm rest + | solve' env (Fn (f, args)) (Fn (f', args')) rest = + if f = f' andalso length args = length args' then + solve env (zip args args' @ rest) + else raise ERR "unify" "different structure"; +in + val unifyl = solve; +end; + +fun unify env tm tm' = unifyl env [(tm, tm')]; + +fun unify_and_apply tm tm' = term_subst (unify |<>| tm tm') tm; + +local + fun conv (Atom t, Atom t') = SOME (t, t') + | conv (Not p, Not q) = conv (p, q) + | conv (True, True) = NONE + | conv (False, False) = NONE + | conv _ = raise ERR "unify_literals" "incompatible"; +in + fun unifyl_literals env = unifyl env o List.mapPartial conv; +end; + +fun unify_literals env lit lit' = unifyl_literals env [(lit, lit')]; + +end +(*#line 0.0 "fol/TermNet1.sig"*) +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF TERMS *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +signature TermNet1 = +sig + +type 'a pp = 'a Useful.pp +type ('a, 'b) maplet = ('a, 'b) Useful.maplet +type term = Term1.term + +type 'a term_map + +val empty : 'a term_map +val insert : (term, 'a) maplet -> 'a term_map -> 'a term_map +val match : 'a term_map -> term -> 'a list +val matched : 'a term_map -> term -> 'a list +val unify : 'a term_map -> term -> 'a list +val size : 'a term_map -> int +val from_maplets : (term, 'a) maplet list -> 'a term_map +val to_list : 'a term_map -> 'a list +val pp_term_map : 'a pp -> 'a term_map pp + +end +(*#line 0.0 "fol/TermNet1.sml"*) +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF TERMS *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +(* +app load ["Useful", "Mosml", "Term1"]; +*) + +(* +*) +structure TermNet1 :> TermNet1 = +struct + +open Useful Term1; + +infixr |-> ::> oo; + +val flatten = List.concat; + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +local + fun fifo_order (m, _) (n, _) = m <= n; +in + fun restore_fifo_order l = map snd (sort fifo_order l); +end; + +fun partition_find f l = + let + fun pf _ [] = (NONE, l) + | pf dealt (x :: xs) = + if f x then (SOME x, List.revAppend (dealt, xs)) else pf (x :: dealt) xs + in + pf [] l + end; + +(* ------------------------------------------------------------------------- *) +(* Term discrimination trees are optimized for match queries. *) +(* ------------------------------------------------------------------------- *) + +datatype pattern = VAR | FN of string * int; + +type 'a map = (pattern, 'a) tree; + +datatype 'a term_map = MAP of int * (int * 'a) map list; + +val empty = MAP (0, []); + +fun size (MAP (i, _)) = i; + +fun to_list (MAP (_, n)) = + restore_fifo_order (flatten (map (tree_foldr (K flatten) wrap) n)); + +fun pp_term_map pp_a = pp_map to_list (pp_list pp_a); + +local + fun find_pat x (BRANCH (p, _)) = p = x + | find_pat _ (LEAF _) = raise BUG "find_pat" "misplaced LEAF"; + + fun add a [] l = LEAF a :: l + | add a (tm :: rest) l = + let + val (pat, rest) = + case tm of Var _ => (VAR, rest) + | Fn (f, args) => (FN (f, length args), args @ rest) + val (this, others) = partition_find (find_pat pat) l + val next = + case this of NONE => [] + | SOME (BRANCH (_, l)) => l + | SOME (LEAF _) => raise BUG "add" "misplaced LEAF" + in + BRANCH (pat, add a rest next) :: others + end; +in + fun insert (tm |-> a) (MAP (i, n)) = MAP (i + 1, add (i, a) [tm] n) + handle ERR_EXN _ => raise BUG "insert" "should never fail"; +end; + +fun from_maplets l = foldl (uncurry insert) empty l; + +local + fun mat VAR (_ :: rest) = SOME rest + | mat (FN (f, n)) (Fn (g, args) :: rest) = + if f = g andalso n = length args then SOME (args @ rest) else NONE + | mat (FN _) (Var _ :: _) = NONE + | mat _ [] = raise BUG "match" "ran out of subterms"; + + fun final a [] = SOME a + | final _ (_ :: _) = raise BUG "match" "too many subterms"; +in + fun match (MAP (_, n)) tm = + restore_fifo_order (flatten (map (tree_partial_foldl mat final [tm]) n)) + handle ERR_EXN _ => raise BUG "match" "should never fail"; +end; + +local + fun more VAR = 0 | more (FN (f, n)) = n; + fun mat pat (0, Var _ :: rest) = SOME (more pat, rest) + | mat VAR (0, Fn _ :: _) = NONE + | mat (FN (f, n)) (0, Fn (g, args) :: rest) = + if f = g andalso n = length args then SOME (0, args @ rest) else NONE + | mat _ (0, []) = raise BUG "matched" "ran out of subterms" + | mat pat (n, rest) = SOME (more pat + n - 1, rest); + + fun final a (0, []) = SOME a + | final _ (0, _ :: _) = raise BUG "matched" "too many subterms" + | final _ (n, _) = raise BUG "matched" "still skipping"; +in + fun matched (MAP (_, n)) tm = + restore_fifo_order (flatten (map (tree_partial_foldl mat final (0,[tm])) n)) + handle ERR_EXN _ => raise BUG "matched" "should never fail"; +end; + +local + fun more VAR = 0 | more (FN (f, n)) = n; + fun mat pat (0, Var _ :: rest) = SOME (more pat, rest) + | mat VAR (0, Fn _ :: rest) = SOME (0, rest) + | mat (FN (f, n)) (0, Fn (g, args) :: rest) = + if f = g andalso n = length args then SOME (0, args @ rest) else NONE + | mat _ (0, []) = raise BUG "unify" "ran out of subterms" + | mat pat (n, rest) = SOME (more pat + n - 1, rest); + + fun final a (0, []) = SOME a + | final _ (0, _ :: _) = raise BUG "unify" "too many subterms" + | final _ (n, _) = raise BUG "unify" "still skipping"; +in + fun unify (MAP (_, n)) tm = + restore_fifo_order (flatten (map (tree_partial_foldl mat final (0,[tm])) n)) + handle ERR_EXN _ => raise BUG "unify" "should never fail"; +end; + +(* ------------------------------------------------------------------------- *) +(* We can overlay the above type with a simple list type. *) +(* ------------------------------------------------------------------------- *) +(* +type 'a simple = int * int * term list * 'a list; + +type 'a term_map = ('a simple, 'a term_map) sum; + +fun check (0, _, t, a) = + INR (from_maplets (foldl (fn (x, xs) => op|-> x :: xs) [] (zip t a))) + | check p = INL p; + +val empty : 'a term_map = INR empty; + +fun new n = check (n, 0, [], []); + +val insert = fn m => + (fn INL (n, s, ts, xs) => + (case m of t |-> x => check (n - 1, s + 1, t :: ts, x :: xs)) + | INR d => INR (insert m d)); + +val match = fn INL (_, _, _, xs) => K (rev xs) | INR d => match d; + +val matched = fn INL (_, _, _, xs) => K (rev xs) | INR d => matched d; + +val unify = fn INL (_, _, _, xs) => K (rev xs) | INR d => unify d; + +val size = fn INL (_, s, _, _) => s | INR d => size d; + +val from_maplets = INR o from_maplets; + +val to_list = fn INL (_, _, _, xs) => rev xs | INR d => to_list d; + +val pp_term_map = + fn pp_a => fn pp => + (fn INL (_, _, _, xs) => pp_list pp_a pp xs | INR d => pp_term_map pp_a pp d); +*) + +end +(*#line 0.0 "fol/LiteralNet1.sig"*) +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF LITERALS *) +(* Created by Joe Hurd, June 2002 *) +(* ========================================================================= *) + +signature LiteralNet1 = +sig + +type 'a pp = 'a Useful.pp +type formula = Term1.formula +type ('a, 'b) maplet = ('a, 'b) Term1.maplet + +type 'a literal_map + +val empty : 'a literal_map +val insert : (formula, 'a) maplet -> 'a literal_map -> 'a literal_map +val match : 'a literal_map -> formula -> 'a list +val matched : 'a literal_map -> formula -> 'a list +val unify : 'a literal_map -> formula -> 'a list +val size : 'a literal_map -> int +val size_profile : 'a literal_map -> {t : int, f : int, p : int, n : int} +val from_maplets : (formula, 'a) maplet list -> 'a literal_map +val to_list : 'a literal_map -> 'a list +val pp_literal_map : 'a pp -> 'a literal_map pp + +end +(*#line 0.0 "fol/LiteralNet1.sml"*) +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF LITERALS *) +(* Created by Joe Hurd, June 2002 *) +(* ========================================================================= *) + +(* +app load ["Useful", "Mosml", "Term1"]; +*) + +(* +*) +structure LiteralNet1 :> LiteralNet1 = +struct + +open Useful Term1; + +infixr |-> ::> oo; + +structure T = TermNet1; + +(* ------------------------------------------------------------------------- *) +(* Literal nets. *) +(* ------------------------------------------------------------------------- *) + +type 'a literal_map = + ('a T.term_map * 'a T.term_map) * ((int * 'a list) * (int * 'a list)); + +val empty = ((T.empty, T.empty), ((0, []), (0, []))); + +fun insert (Atom a |-> b) ((p, n), tf) = ((T.insert (a |-> b) p, n), tf) + | insert (Not (Atom a) |-> b) ((p, n), tf) = ((p, T.insert (a |-> b) n), tf) + | insert (True |-> b) (pn, ((n, l), f)) = (pn, ((n + 1, b :: l), f)) + | insert (False |-> b) (pn, (t, (n, l))) = (pn, (t, (n + 1, b :: l))) + | insert (f |-> _) _ = raise BUG "insert" ("not a lit: "^formula_to_string f); + +fun from_maplets l = foldl (uncurry insert) empty l; + +fun to_list ((pos, neg), ((_, t), (_, f))) = + rev t @ rev f @ T.to_list pos @ T.to_list neg; + +fun pp_literal_map pp_a = pp_map to_list (pp_list pp_a); + +local + fun pos ((pos, _ ), _ ) = T.size pos; + fun neg ((_, neg), _ ) = T.size neg; + fun truth (_, ((n, _), _ )) = n; + fun falsity (_, (_, (n, _))) = n; +in + fun size l = truth l + falsity l + pos l + neg l; + fun size_profile l = {t = truth l, f = falsity l, p = pos l, n = neg l}; +end; + +fun match ((pos, _), _) (Atom a) = T.match pos a + | match ((_, neg), _) (Not (Atom a)) = T.match neg a + | match (_, ((_, t), _)) True = rev t + | match (_, (_, (_, f))) False = rev f + | match _ _ = raise BUG "match" "not a literal"; + +fun matched ((pos, _), _) (Atom a) = T.matched pos a + | matched ((_, neg), _) (Not (Atom a)) = T.matched neg a + | matched (_, ((_, t), _)) True = rev t + | matched (_, (_, (_, f))) False = rev f + | matched _ _ = raise BUG "matched" "not a literal"; + +fun unify ((pos, _), _) (Atom a) = T.unify pos a + | unify ((_, neg), _) (Not (Atom a)) = T.unify neg a + | unify (_, ((_, t), _)) True = rev t + | unify (_, (_, (_, f))) False = rev f + | unify _ _ = raise BUG "unify" "not a literal"; + +end +(*#line 0.0 "fol/Subsume1.sig"*) +(* ========================================================================= *) +(* A TYPE FOR SUBSUMPTION CHECKING *) +(* Created by Joe Hurd, April 2002 *) +(* ========================================================================= *) + +signature Subsume1 = +sig + +type 'a pp = 'a Useful.pp +type ('a, 'b) maplet = ('a, 'b) Useful.maplet +type formula = Term1.formula +type subst = Subst1.subst + +type 'a subsume + +val empty : 'a subsume +val add : (formula list, 'a) maplet -> 'a subsume -> 'a subsume +val subsumed : 'a subsume -> formula list -> (subst * 'a) list +val strictly_subsumed : 'a subsume -> formula list -> (subst * 'a) list +val info : 'a subsume -> string +val pp_subsum : 'a subsume pp + +end +(*#line 0.0 "fol/Subsume1.sml"*) +(* ========================================================================= *) +(* A TYPE FOR SUBSUMPTION CHECKING *) +(* Created by Joe Hurd, April 2002 *) +(* ========================================================================= *) + +(* +app load ["Thm1", "Match1"]; +*) + +(* +*) +structure Subsume1 :> Subsume1 = +struct + +infix |-> ::>; + +open Useful Term1 Match1; + +structure N = LiteralNet1; + +val ofilter = Option.filter; +type subst = Subst1.subst; +val |<>| = Subst1.|<>|; +val op ::> = Subst1.::>; +val term_subst = Subst1.term_subst; +val formula_subst = Subst1.formula_subst; + +(* ------------------------------------------------------------------------- *) +(* Chatting. *) +(* ------------------------------------------------------------------------- *) + +val () = traces := {module = "Subsume1", alignment = K 1} :: !traces; + +fun chat l m = trace {module = "Subsume1", message = m, level = l}; + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +val frozen_prefix = "FROZEN__"; + +fun mk_frozen v = Fn (frozen_prefix ^ v, []); + +local + val chk = String.isPrefix frozen_prefix; + val dest = + let val l = size frozen_prefix in fn s => String.extract (s, l, NONE) end; +in + fun dest_frozen (Fn (s, [])) = + (assert (chk s) (ERR "dest_frozen" "not a frozen var"); dest s) + | dest_frozen _ = raise ERR "dest_frozen" "bad structure"; +end; + +val is_frozen = can dest_frozen; + +fun freeze_vars fms = + let + val vars = FV (list_mk_disj fms) + val sub = foldl (fn (v, s) => (v |-> mk_frozen v) ::> s) |<>| vars + in + map (formula_subst sub) fms + end; + +local + fun f (v |-> a) = (v |-> (if is_frozen a then Var (dest_frozen a) else a)); +in + val defrost_vars = Subst1.from_maplets o map f o Subst1.to_maplets; +end; + +val lit_size = formula_size o literal_atom; + +val sort_literals_by_size = + map snd o sort (fn (m, _) => fn (n, _) => m <= n) o + map (fn lit => (lit_size lit, lit)); + +(* ------------------------------------------------------------------------- *) +(* The core engine for subsumption checking. *) +(* ------------------------------------------------------------------------- *) + +type 'a sinfo = {sub : subst, hd : formula, tl : formula list, fin : 'a}; + +type 'a subs = 'a sinfo N.literal_map; + +fun add_lits (i as {hd, ...}) (net : 'a subs) = N.insert (hd |-> i) net; + +local + fun subsum strict lits = + let + val accept = + (if strict then ofilter (non Subst1.is_renaming) else SOME) o + defrost_vars + val impossible = + let val lit_net = N.from_maplets (map (fn l => (l |-> ())) lits) + in List.exists (null o N.matched lit_net) + end + fun extend sub lits fin net = + if impossible lits then net + else + case sort_literals_by_size lits of [] => raise BUG "extend" "null" + | hd :: tl => add_lits {sub = sub, hd = hd, tl = tl, fin = fin} net + fun examine lit ({sub, hd, tl, fin}, s as (net, res)) = + case total (matchl_literals sub) [(hd, lit)] of NONE => s + | SOME sub => + if null tl then + case accept sub of SOME sub => (net, (sub, fin) :: res) | NONE => s + else (extend sub (map (formula_subst sub) tl) fin net, res) + fun narrow1 net (lit, s) = foldl (examine lit) s (N.match net lit) + fun narrow (net, res) = + if N.size net = 0 then res + else narrow (foldl (narrow1 net) (N.empty, res) lits) + in + narrow + end; +in + fun subsumes strict net lits = + subsum strict (freeze_vars lits) (net, []) + handle ERR_EXN _ => raise BUG "subsumes" "shouldn't fail"; +end; + +(* ------------------------------------------------------------------------- *) +(* The user interface. *) +(* ------------------------------------------------------------------------- *) + +type 'a subsume = ('a, 'a subs) sum; + +val empty : 'a subsume = INR N.empty; + +fun add _ (s as INL _) = s + | add (fms |-> fin) (INR net) = + case sort_literals_by_size fms of [] => INL fin + | h :: t => INR (add_lits {sub = |<>|, hd = h, tl = t, fin = fin} net); + +fun subsumed (INL fin) _ = [(|<>|, fin)] + | subsumed (INR _) [] = [] + | subsumed (INR net) lits = subsumes false net lits; + +fun strictly_subsumed _ [] = [] + | strictly_subsumed (INL fin) _ = [(|<>|, fin)] + | strictly_subsumed (INR net) lits = subsumes true net lits; + +fun info ((INL _) : 'a subsume) = "*" + | info (INR net) = int_to_string (N.size net); + +val pp_subsum = fn z => pp_map info pp_string z; + +(* Quick testing +quotation := true; +installPP pp_formula; +installPP pp_term; +installPP pp_subst; +installPP pp_thm; +freeze_vars (map parse [`x + y <= 0`, `x = __x()`]); +val s = add_subsumer (AXIOM (map parse [`p(x,3)`, `p(2,y)`])) empty_subsum; +subsumed s (map parse [`p(2,3)`]); +*) + +end +(*#line 0.0 "fol/Tptp1.sig"*) +(* ========================================================================= *) +(* INTERFACE TO TPTP PROBLEM FILES *) +(* Created by Joe Hurd, December 2001 *) +(* ========================================================================= *) + +signature Tptp1 = +sig + +type term = Term1.term +type formula = Term1.formula + +(* Maintaining different relation and function names in TPTP problems *) +val renaming : {tptp : string, fol : string, arity : int} list ref + +(* Parsing: pass in a filename *) +val parse_cnf : string -> formula + +end +(*#line 0.0 "fol/Tptp1.sml"*) +(* ========================================================================= *) +(* INTERFACE TO TPTP PROBLEM FILES *) +(* Created by Joe Hurd, December 2001 *) +(* ========================================================================= *) + +(* +app load ["Stream", "Useful", "Parser", "Term1"]; +*) + +(* +*) +structure Tptp1 :> Tptp1 = +struct + +open Parser Useful Term1; + +infixr 9 >>++; +infixr 8 ++; +infixr 7 >>; +infixr 6 ||; +infix |->; + +structure S = Stream; + +(* ------------------------------------------------------------------------- *) +(* Abbreviating relation and function names in TPTP problems. *) +(* ------------------------------------------------------------------------- *) + +type rename = {tptp : string, fol : string, arity : int}; + +val renaming : rename list ref = ref [{tptp = "equal", fol = "=", arity = 2}]; + +(* ------------------------------------------------------------------------- *) +(* Parsing: pass in a filename. *) +(* ------------------------------------------------------------------------- *) + +val comment = equal #"%" o hd o explode; + +val input_lines = S.filter (non comment) o S.from_textfile; + +val input_chars = S.flatten o S.map (S.from_list o explode); + +datatype tok_type = Lower | Upper | Symbol | Punct; + +val lexer = + (many (some space) ++ + (((some lower || some digit) ++ many (some alphanum) >> + (fn (a, b) => (Lower, implode (a :: b)))) || + (some upper ++ many (some alphanum) >> + (fn (a, b) => (Upper, implode (a :: b)))) || + (atleastone (some symbol) >> (fn l => (Symbol, implode l))) || + (some punct >> (fn c => (Punct, str c))))) >> snd; + +val lex = many lexer ++ (many (some space) ++ finished) >> fst; + +val input_toks = S.from_list o fst o lex; + +fun Var' "T" = Var "T'" + | Var' "F" = Var "F'" + | Var' v = Var (if !var_string v then v else "v_" ^ v); + +local + fun verify (f, a) = + (if !var_string f then (if null a then "c_" else "f_") ^ f else f, a); + fun mapped (f, a) (m : rename list) = + let + fun g {tptp, arity, fol = _} = tptp = f andalso arity = length a + in case List.find g m of SOME {fol, ...} => (fol, a) | NONE => verify (f, a) + end; +in + fun Fn' A = Fn (mapped A (!renaming)); +end; + +fun term_parser input = + ((some (equal Upper o fst) >> (Var' o snd)) || + ((some (equal Lower o fst) >> snd) ++ + (optional + (exact (Punct, "(") ++ term_parser ++ + many ((exact (Punct, ",") ++ term_parser) >> snd) ++ + exact (Punct, ")")) >> + (fn SOME (_, (t, (ts, _))) => t :: ts | NONE => [])) >> + Fn')) input; + +val literal_parser = + ((exact (Symbol, "++") >> K true || exact (Symbol, "--") >> K false) ++ + term_parser) >> + (fn (s, t) => mk_literal (s, Atom (case t of Var v => Fn (v, []) | _ => t))); + +val clause_parser = + (exact (Lower, "input_clause") ++ exact (Punct, "(") ++ any ++ + exact (Punct, ",") ++ any ++ exact (Punct, ",") ++ exact (Punct, "[") ++ + literal_parser ++ many ((exact (Punct, ",") ++ literal_parser) >> snd) ++ + exact (Punct, "]") ++ exact (Punct, ")") ++ exact (Punct, ".")) >> + (fn (_, (_, (name, (_, (typ, (_, (_, (l, (ls, _))))))))) => + (snd name, snd typ, l :: ls)); + +val cnf_parser = fst o ((many clause_parser ++ finished) >> fst); + +local + fun cycle _ _ ([], _) = raise BUG "cycle" "" + | cycle f v (h :: t, avoid) = + let val h' = f h avoid in (h', (t @ [h], h' :: avoid)) end; +in + fun generalize_clause fm = + let + open Subst1 + val vars = FV fm + val nvars = length vars + val var_fn = if nvars <= 15 then variant else variant_num + val news = + if nvars = 6 then ["x", "y", "z", "x'", "y'", "z'"] + else fst (maps (cycle var_fn) vars (["x", "y", "z", "v", "w"], [])) + val sub = from_maplets (zipwith (fn v => fn x => v |-> Var x) vars news) + in + generalize (formula_subst sub fm) + end; +end; + +val input_cnf = + (fn (a, b) => Imp (a, Imp (b, False))) o + Df (list_mk_conj o map (generalize_clause o list_mk_disj o #3)) o + List.partition (not o equal "conjecture" o #2) o cnf_parser; + +val parse_cnf = input_cnf o input_toks o input_chars o input_lines; + +end +(*#line 0.0 "fol/Thm1.sig"*) +(* ========================================================================= *) +(* INTERFACE TO THE LCF-STYLE LOGICAL KERNEL, PLUS SOME DERIVED RULES *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +signature Thm1 = +sig + +type 'a pp = 'a Useful.pp + +include Kernel1 + +(* Annotated primitive inferences *) +datatype inference' = + Axiom' of formula list +| Refl' of term +| Assume' of formula +| Inst' of subst * thm +| Factor' of thm +| Resolve' of formula * thm * thm +| Equality' of formula * int list * term * bool * thm + +val primitive_inference : inference' -> thm + +(* User-friendly destructors *) +val clause : thm -> formula list +val inference : thm -> inference' +val proof : thm -> (thm * inference') list + +(* Pretty-printing of theorems and inferences *) +val pp_thm : thm pp +val pp_inference : inference pp +val pp_inference' : inference' pp +val pp_proof : (thm * inference') list pp +val thm_to_string' : int -> thm -> string (* purely functional *) +val inference_to_string' : int -> inference' -> string +val thm_to_string : thm -> string (* using !LINE_LENGTH *) +val inference_to_string : inference' -> string + +(* A total comparison function for theorems *) +val thm_compare : thm * thm -> order + +(* Contradictions and unit clauses *) +val is_contradiction : thm -> bool +val dest_unit : thm -> formula +val is_unit : thm -> bool + +(* Derived rules and theorems *) +val CONTR : formula -> thm -> thm +val WEAKEN : formula list -> thm -> thm +val FRESH_VARS : thm -> thm +val FRESH_VARSL : thm list -> thm list +val UNIT_SQUASH : thm -> thm +val REFLEXIVITY : thm +val SYMMETRY : thm +val TRANSITIVITY : thm +val FUN_CONGRUENCE : string * int -> thm +val REL_CONGRUENCE : string * int -> thm + +end +(*#line 0.0 "fol/Thm1.sml"*) +(* ========================================================================= *) +(* INTERFACE TO THE LCF-STYLE LOGICAL KERNEL, PLUS SOME DERIVED RULES *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +(* +app load ["Useful", "Term1", "Kernel1", "Match1"]; +*) + +(* +*) +structure Thm1 :> Thm1 = +struct + +open Useful Term1 Kernel1 Match1; + +infixr |-> ::> oo ##; + +type subst = Subst1.subst; +val |<>| = Subst1.|<>|; +val op ::> = Subst1.::>; +val term_subst = Subst1.term_subst; +val formula_subst = Subst1.formula_subst; +val pp_subst = Subst1.pp_subst; + +(* ------------------------------------------------------------------------- *) +(* Annotated primitive inferences. *) +(* ------------------------------------------------------------------------- *) + +datatype inference' = + Axiom' of formula list +| Refl' of term +| Assume' of formula +| Inst' of subst * thm +| Factor' of thm +| Resolve' of formula * thm * thm +| Equality' of formula * int list * term * bool * thm + +fun primitive_inference (Axiom' cl ) = AXIOM cl + | primitive_inference (Refl' tm ) = REFL tm + | primitive_inference (Assume' l ) = ASSUME l + | primitive_inference (Inst' (s, th) ) = INST s th + | primitive_inference (Factor' th ) = FACTOR th + | primitive_inference (Resolve' (l, th1, th2) ) = RESOLVE l th1 th2 + | primitive_inference (Equality' (l, p, t, s, th)) = EQUALITY l p t s th; + +val clause = fst o dest_thm; + +(* ------------------------------------------------------------------------- *) +(* Pretty-printing of theorems *) +(* ------------------------------------------------------------------------- *) + +fun pp_thm pp th = + (PP.begin_block pp PP.INCONSISTENT 3; + PP.add_string pp "|- "; + pp_formula pp (list_mk_disj (clause th)); + PP.end_block pp); + +local + fun inf_to_string Axiom = "Axiom" + | inf_to_string Refl = "Refl" + | inf_to_string Assume = "Assume" + | inf_to_string Inst = "Inst" + | inf_to_string Factor = "Factor" + | inf_to_string Resolve = "Resolve" + | inf_to_string Equality = "Equality"; +in + val pp_inference = pp_map inf_to_string pp_string; +end; + +local + fun pp_inf (Axiom' a) = (Axiom, C (pp_list pp_formula) a) + | pp_inf (Refl' a) = (Refl, C pp_term a) + | pp_inf (Assume' a) = (Assume, C pp_formula a) + | pp_inf (Inst' a) = (Inst, C (pp_pair pp_subst pp_thm) a) + | pp_inf (Factor' a) = (Factor, C pp_thm a) + | pp_inf (Resolve' a) = (Resolve, C (pp_triple pp_formula pp_thm pp_thm) a) + | pp_inf (Equality' (lit, p, r, lr, th)) = + (Equality, + C (pp_record [("lit", unit_pp pp_formula lit), + ("path", unit_pp (pp_list pp_int) p), + ("res", unit_pp pp_term r), + ("lr", unit_pp pp_bool lr), + ("thm", unit_pp pp_thm th)]) ()); +in + fun pp_inference' pp inf = + let + open PP + val (i, ppf) = pp_inf inf + in + (begin_block pp INCONSISTENT 0; + pp_inference pp i; + add_break pp (1, 0); + ppf pp; + end_block pp) + end; +end; + +val pp_proof = pp_list (pp_pair pp_thm pp_inference'); + +(* Purely functional pretty-printing *) + +fun thm_to_string' len = PP.pp_to_string len pp_thm; +fun inference_to_string' len = PP.pp_to_string len pp_inference'; + +(* Pretty-printing using !LINE_LENGTH *) + +fun thm_to_string th = thm_to_string' (!LINE_LENGTH) th; +fun inference_to_string inf = inference_to_string' (!LINE_LENGTH) inf; + +(* ------------------------------------------------------------------------- *) +(* A total comparison function for theorems. *) +(* ------------------------------------------------------------------------- *) + +local + fun cmp Axiom Axiom = EQUAL + | cmp Axiom _ = LESS + | cmp _ Axiom = GREATER + | cmp Refl Refl = EQUAL + | cmp Refl _ = LESS + | cmp _ Refl = GREATER + | cmp Assume Assume = EQUAL + | cmp Assume _ = LESS + | cmp _ Assume = GREATER + | cmp Inst Inst = EQUAL + | cmp Inst _ = LESS + | cmp _ Inst = GREATER + | cmp Factor Factor = EQUAL + | cmp Factor _ = LESS + | cmp _ Factor = GREATER + | cmp Resolve Resolve = EQUAL + | cmp Resolve Equality = LESS + | cmp Equality Resolve = GREATER + | cmp Equality Equality = EQUAL; + + fun cm [] = EQUAL + | cm ((th1, th2) :: l) = + let + val (l1, (p1, ths1)) = dest_thm th1 + val (l2, (p2, ths2)) = dest_thm th2 + in + case Int.compare (length l1, length l2) of EQUAL + => (case lex_compare formula_compare (zip l1 l2) of EQUAL + => (case cmp p1 p2 of EQUAL + => cm (zip ths1 ths2 @ l) + | x => x) + | x => x) + | x => x + end +in + val thm_compare = cm o wrap; +end; + +(* ------------------------------------------------------------------------- *) +(* Reconstructing proofs. *) +(* ------------------------------------------------------------------------- *) + +fun reconstruct_resolvant cl1 cl2 (cl1', cl2') = + case (subtract (setify cl1) cl1', subtract (setify cl2) cl2') of + (_ :: _ :: _, _) => NONE + | (_, _ :: _ :: _) => NONE + | ([l], []) => SOME l + | ([], [l']) => SOME (negate l') + | ([l], [l']) => if negate l = l' then SOME l else NONE + | ([], []) => NONE; + +fun reconstruct_equality l r = + let + fun recon_fn p (f, args) (f', args') rest = + recon_tm + (if f <> f' orelse length args <> length args' then rest + else map (C cons p ## I) (enumerate 0 (zip args args')) @ rest) + and recon_tm [] = NONE + | recon_tm ((p, (tm, tm')) :: rest) = + if tm = l andalso tm' = r then SOME (rev p) + else + case (tm, tm') of (Fn a, Fn a') => recon_fn p a a' rest + | _ => recon_tm rest + + fun recon_lit (Not a) (Not a') = recon_lit a a' + | recon_lit (Atom a) (Atom a') = + if l <> r andalso a = a' then NONE else recon_tm [([], (a, a'))] + | recon_lit _ _ = NONE + in + fn (lit, lit') => + case recon_lit lit lit' of SOME p => SOME (lit, p) | NONE => NONE + end; + +fun reconstruct (cl, (Axiom, [])) = Axiom' cl + | reconstruct ([lit], (Refl, [])) = Refl' (lhs lit) + | reconstruct ([fm, _], (Assume, [])) = Assume' fm + | reconstruct (cl, (Inst, [th])) = + Inst' (matchl_literals |<>| (zip (clause th) cl), th) + | reconstruct (_, (Factor, [th])) = Factor' th + | reconstruct (cl, (Resolve, [th1, th2])) = + let + val f = reconstruct_resolvant (clause th1) (clause th2) + val l = + case f (cl, cl) of SOME l => l + | NONE => + case first f (List.tabulate (length cl, split cl)) of SOME l => l + | NONE => raise BUG "inference" "couldn't reconstruct resolvant" + in + Resolve' (l, th1, th2) + end + | reconstruct (Not fm :: cl, (Equality, [th])) = + let + val (tm1, tm2) = dest_eq fm + in + case first (reconstruct_equality tm1 tm2) (zip (clause th) cl) of + SOME (l, p) => Equality' (l, p, tm2, true, th) + | NONE => + case first (reconstruct_equality tm2 tm1) (zip (clause th) cl) of + SOME (l, p) => Equality' (l, p, tm1, false, th) + | NONE => raise BUG "inference" "couldn't reconstruct equality step" + end + | reconstruct _ = raise BUG "inference" "malformed inference"; + +fun inference th = + let + val i = reconstruct (dest_thm th) + val _ = + (primitive_inference i = th) orelse + raise BUG "inference" + ("failed:\nth = " ^ thm_to_string th ^ "\ninf = " ^ inference_to_string i + ^ "\ninf_th = " ^ thm_to_string (primitive_inference i)) + in + i + end; + +local + val empty = (Binarymap.mkDict thm_compare, []); + fun contains (m, _) th = Option.isSome (Binarymap.peek (m, th)); + fun add th (m, p) = (Binarymap.insert (m, th, ()), (th, inference th) :: p); + val finalize = snd; + + fun reduce (th, pf) = + if contains pf th then pf + else add th (foldl reduce pf (snd (snd (dest_thm th)))); +in + fun proof th = finalize (reduce (th, empty)); +end; + +(* ------------------------------------------------------------------------- *) +(* Contradictions and unit clauses. *) +(* ------------------------------------------------------------------------- *) + +val is_contradiction = null o clause; + +fun dest_unit th = + case clause th of [lit] => lit | _ => raise ERR "dest_unit" "not a unit"; + +val is_unit = can dest_unit; + +(* ------------------------------------------------------------------------- *) +(* Derived rules *) +(* ------------------------------------------------------------------------- *) + +fun CONTR lit th = RESOLVE (negate lit) (ASSUME lit) th; + +fun WEAKEN lits th = foldl (uncurry CONTR) th (rev lits); + +fun FRESH_VARSL ths = + let + val fvs = FVL (List.concat (map clause ths)) + val vvs = new_vars (length fvs) + val sub = Subst1.from_maplets (zipwith (curry op |->) fvs vvs) + in + map (INST sub) ths + end; + +val FRESH_VARS = unwrap o FRESH_VARSL o wrap; + +fun UNIT_SQUASH th = + let + fun squash env (x :: (xs as y :: _)) = squash (unify_literals env x y) xs + | squash env _ = env + in + FACTOR (INST (squash |<>| (clause th)) th) + end; + +val REFLEXIVITY = REFL (Var "x"); + +val SYMMETRY = + EQUALITY (mk_eq (Var "x", Var "x")) [0] (Var "y") true REFLEXIVITY; + +val TRANSITIVITY = + EQUALITY (mk_eq (Var "y", Var "z")) [0] (Var "x") false + (ASSUME (Not (mk_eq (Var "y", Var "z")))); + +fun FUN_CONGRUENCE (function, arity) = + let + val xs = List.tabulate (arity, fn i => Var ("x" ^ int_to_string i)) + val ys = List.tabulate (arity, fn i => Var ("y" ^ int_to_string i)) + fun f (i, th) = + EQUALITY (List.last (clause th)) [1,i] (List.nth (ys, i)) true th + val refl = INST (("x" |-> Fn (function, xs)) ::> |<>|) REFLEXIVITY + in + foldl f refl (rev (interval 0 arity)) + end; + +fun REL_CONGRUENCE (relation, arity) = + let + val xs = List.tabulate (arity, fn i => Var ("x" ^ int_to_string i)) + val ys = List.tabulate (arity, fn i => Var ("y" ^ int_to_string i)) + fun f (i, th) = + EQUALITY (List.last (clause th)) [i] (List.nth (ys, i)) true th + val refl = ASSUME (Not (Atom (Fn (relation, xs)))) + in + foldl f refl (rev (interval 0 arity)) + end; + +end +(*#line 0.0 "fol/Canon1.sig"*) +(* ========================================================================= *) +(* FIRST-ORDER LOGIC CANONICALIZATION *) +(* Created by Joe Hurd, September 2001 *) +(* Partly ported from the CAML-Light code accompanying John Harrison's book *) +(* ========================================================================= *) + +signature Canon1 = +sig + +type term = Term1.term +type formula = Term1.formula +type thm = Thm1.thm + +(* Simplification *) +val simplify : formula -> formula + +(* Negation normal form *) +val nnf : formula -> formula + +(* Prenex normal form *) +val prenex : formula -> formula +val pnf : formula -> formula + +(* Skolemization *) +val skolemize : formula -> formula +val full_skolemize : formula -> formula + +(* A tautology filter for clauses *) +val tautologous : formula list -> bool + +(* Conjunctive normal form *) +val purecnf : formula -> formula list list +val simpcnf : formula -> formula list list +val clausal : formula -> formula list list +val cnf : formula -> formula +val axiomatize : formula -> thm list +val eq_axiomatize : formula -> thm list (* Adds equality axioms *) +val eq_axiomatize' : formula -> thm list (* Adds if equality occurs *) + +end +(*#line 0.0 "fol/Canon1.sml"*) +(* ========================================================================= *) +(* FIRST-ORDER LOGIC CANONICALIZATION *) +(* Created by Joe Hurd, September 2001 *) +(* Partly ported from the CAML-Light code accompanying John Harrison's book *) +(* ========================================================================= *) + +(* +app load ["Useful", "Term1"]; +*) + +structure Canon1 :> Canon1 = +struct + +open Useful Term1 Thm1; + +infixr |-> ::> oo; + +type subst = Subst1.subst; +val |<>| = Subst1.|<>|; +val op ::> = Subst1.::>; +val term_subst = Subst1.term_subst; +val formula_subst = Subst1.formula_subst; + +(* ------------------------------------------------------------------------- *) +(* Simplification. *) +(* ------------------------------------------------------------------------- *) + +fun simplify1 (Not False) = True + | simplify1 (Not True) = False + | simplify1 (Not (Not fm)) = fm + | simplify1 (And (False, q)) = False + | simplify1 (And (p, False)) = False + | simplify1 (And (True, q)) = q + | simplify1 (And (p, True)) = p + | simplify1 (Or (False, q)) = q + | simplify1 (Or (p, False)) = p + | simplify1 (Or (True, q)) = True + | simplify1 (Or (p, True)) = True + | simplify1 (Imp (False, q)) = True + | simplify1 (Imp (True, q)) = q + | simplify1 (Imp (p, True)) = True + | simplify1 (Imp (Not p, False)) = p + | simplify1 (Imp (p, False)) = Not p + | simplify1 (Iff (True, q)) = q + | simplify1 (Iff (p, True)) = p + | simplify1 (Iff (False, Not q)) = q + | simplify1 (Iff (False, q)) = Not q + | simplify1 (Iff (Not p, False)) = p + | simplify1 (Iff (p, False)) = Not p + | simplify1 (fm as Forall (x, p)) = if mem x (FV p) then fm else p + | simplify1 (fm as Exists (x, p)) = if mem x (FV p) then fm else p + | simplify1 fm = fm; + +fun simplify (Not p) = simplify1 (Not (simplify p)) + | simplify (And (p, q)) = simplify1 (And (simplify p, simplify q)) + | simplify (Or (p, q)) = simplify1 (Or (simplify p, simplify q)) + | simplify (Imp (p, q)) = simplify1 (Imp (simplify p, simplify q)) + | simplify (Iff (p, q)) = simplify1 (Iff (simplify p, simplify q)) + | simplify (Forall (x, p)) = simplify1 (Forall (x, simplify p)) + | simplify (Exists (x, p)) = simplify1 (Exists (x, simplify p)) + | simplify fm = fm; + +(* ------------------------------------------------------------------------- *) +(* Negation normal form. *) +(* ------------------------------------------------------------------------- *) + +fun nnf (And (p, q)) = And (nnf p, nnf q) + | nnf (Or (p, q)) = Or (nnf p, nnf q) + | nnf (Imp (p, q)) = Or (nnf' p, nnf q) + | nnf (Iff (p, q)) = Or (And (nnf p, nnf q), And (nnf' p, nnf' q)) + | nnf (Forall (x, p)) = Forall (x, nnf p) + | nnf (Exists (x, p)) = Exists (x, nnf p) + | nnf (Not x) = nnf' x + | nnf fm = fm +and nnf' True = False + | nnf' False = True + | nnf' (And (p, q)) = Or (nnf' p, nnf' q) + | nnf' (Or (p, q)) = And (nnf' p, nnf' q) + | nnf' (Imp (p, q)) = And (nnf p, nnf' q) + | nnf' (Iff (p, q)) = Or (And (nnf p, nnf' q), And (nnf' p, nnf q)) + | nnf' (Forall (x, p)) = Exists (x, nnf' p) + | nnf' (Exists (x, p)) = Forall (x, nnf' p) + | nnf' (Not x) = nnf x + | nnf' fm = Not fm; + +(* ------------------------------------------------------------------------- *) +(* Prenex normal form. *) +(* ------------------------------------------------------------------------- *) + +fun pullquants fm = + (case fm of + And (Forall (x, p), Forall (y, q)) => pullquant_2 fm Forall And x y p q + | Or (Exists (x, p), Exists (y, q)) => pullquant_2 fm Exists Or x y p q + | And (Forall (x, p), q) => pullquant_l fm Forall And x p q + | And (p, Forall (x, q)) => pullquant_r fm Forall And x p q + | Or (Forall (x, p), q) => pullquant_l fm Forall Or x p q + | Or (p, Forall (x, q)) => pullquant_r fm Forall Or x p q + | And (Exists (x, p), q) => pullquant_l fm Exists And x p q + | And (p, Exists (x, q)) => pullquant_r fm Exists And x p q + | Or (Exists (x, p), q) => pullquant_l fm Exists Or x p q + | Or (p, Exists (x, q)) => pullquant_r fm Exists Or x p q + | _ => fm) +and pullquant_l fm Q C x p q = + let + val x' = variant x (FV fm) + in + Q (x', pullquants (C (formula_subst ((x |-> Var x') ::> |<>|) p, q))) + end +and pullquant_r fm Q C x p q = + let + val x' = variant x (FV fm) + in + Q (x', pullquants (C (p, formula_subst ((x |-> Var x') ::> |<>|) q))) + end +and pullquant_2 fm Q C x y p q = + let + val x' = variant x (FV fm) + in + Q (x', pullquants(C (formula_subst ((x |-> Var x') ::> |<>|) p, + formula_subst ((x |-> Var x') ::> |<>|) q))) + end; + +fun prenex (Forall (x, p)) = Forall (x, prenex p) + | prenex (Exists (x, p)) = Exists (x, prenex p) + | prenex (And (p, q)) = pullquants (And (prenex p, prenex q)) + | prenex (Or (p, q)) = pullquants (Or (prenex p, prenex q)) + | prenex fm = fm; + +val pnf = prenex o nnf o simplify; + +(* ------------------------------------------------------------------------- *) +(* Skolemization function. *) +(* ------------------------------------------------------------------------- *) + +fun skolem avoid (Exists (y, p)) = + let + val xs = subtract (FV p) [y] + val f = variant (if xs = [] then "c_" ^ y else "f_" ^ y) avoid + in + skolem avoid (formula_subst ((y |-> Fn (f, map Var xs)) ::> |<>|) p) + end + | skolem avoid (Forall (x, p)) = Forall (x, skolem avoid p) + | skolem avoid (And (p, q)) = skolem2 avoid And p q + | skolem avoid (Or (p, q)) = skolem2 avoid Or p q + | skolem _ fm = fm +and skolem2 avoid C p q = + let + val p' = skolem avoid p + val q' = skolem (union avoid (function_names p')) q + in + C (p', q') + end; + +fun skolemize fm = skolem (function_names fm) fm; + +val full_skolemize = specialize o prenex o skolemize o nnf o simplify; + +(* ------------------------------------------------------------------------- *) +(* A tautology filter for clauses. *) +(* ------------------------------------------------------------------------- *) + +fun tautologous cls = + let + val (pos, neg) = List.partition positive cls + in + intersect pos (map negate neg) <> [] + end; + +(* ------------------------------------------------------------------------- *) +(* Conjunctive Normal Form. *) +(* ------------------------------------------------------------------------- *) + +fun distrib s1 s2 = cartwith union s1 s2; + +fun purecnf (Or (p, q)) = distrib (purecnf p) (purecnf q) + | purecnf (And (p, q)) = union (purecnf p) (purecnf q) + | purecnf fm = [[fm]]; + +fun simpcnf True = [] + | simpcnf False = [[]] + | simpcnf fm = List.filter (non tautologous) (purecnf fm); + +val clausal = + List.concat o map (simpcnf o specialize o prenex) o flatten_conj o + skolemize o nnf o simplify + +val cnf = list_mk_conj o map list_mk_disj o clausal; + +val axiomatize = map AXIOM o clausal; + +fun eq_axiomatize fm = + let + val eqs = [REFLEXIVITY, SYMMETRY, TRANSITIVITY] + val rels = map REL_CONGRUENCE (relations_no_eq fm) + val funs = map FUN_CONGRUENCE (functions fm) + in + eqs @ funs @ rels @ axiomatize fm + end; + +fun eq_axiomatize' fm = (if eq_occurs fm then eq_axiomatize else axiomatize) fm; + +end +(*#line 0.0 "fol/Units1.sig"*) +(* ========================================================================= *) +(* A STORE IN WHICH TO CACHE UNIT THEOREMS *) +(* Created by Joe Hurd, November 2001 *) +(* ========================================================================= *) + +signature Units1 = +sig + +type 'a pp = 'a Useful.pp +type formula = Term1.formula +type thm = Thm1.thm + +type units + +val empty : units +val add : thm -> units -> units +val addl : thm list -> units -> units +val subsumes : units -> formula -> thm option +val prove : units -> formula list -> thm list option +val demod : units -> thm -> thm +val info : units -> string +val pp_units : units pp + +end +(*#line 0.0 "fol/Units1.sml"*) +(* ========================================================================= *) +(* A STORE IN WHICH TO CACHE UNIT THEOREMS *) +(* Created by Joe Hurd, November 2001 *) +(* ========================================================================= *) + +(* +app load + ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Match1"]; +*) + +(* +*) +structure Units1 :> Units1 = +struct + +open Useful Term1 Thm1 Match1; + +infix |-> ::> @> oo ##; + +structure N = LiteralNet1; + +(* ------------------------------------------------------------------------- *) +(* Auxiliary functions. *) +(* ------------------------------------------------------------------------- *) + +fun lift_options f = + let + fun g res [] = SOME (rev res) + | g res (x :: xs) = case f x of SOME y => g (y :: res) xs | NONE => NONE + in + g [] + end; + +(* ------------------------------------------------------------------------- *) +(* Operations on the raw unit cache. *) +(* ------------------------------------------------------------------------- *) + +type uns = thm N.literal_map; + +val uempty : uns = N.empty; + +fun uadd th uns = N.insert (dest_unit th |-> th) uns; + +fun usubsumes uns lit = + List.find (can (C match_literals lit) o dest_unit) + (rev (N.match uns lit)); + +fun uprove uns = + let + fun pr lit = + Option.map (fn th => INST (match_literals (dest_unit th) lit) th) + (usubsumes uns lit) + in + lift_options pr + end; + +fun udemod uns = + let + fun demod (lit, th) = + case uprove uns [negate lit] of NONE => th + | SOME [dth] => RESOLVE lit th dth + | SOME _ => raise BUG "unit_demod" "corrupt" + in + fn th => foldl demod th (clause th) + end; + +(* ------------------------------------------------------------------------- *) +(* The user interface. *) +(* ------------------------------------------------------------------------- *) + +type units = (thm, uns) sum; + +val empty = INR uempty; + +fun subsumes (INL th) = K (SOME th) + | subsumes (INR uns) = usubsumes uns; + +fun prove (INL th) = SOME o map (fn False => th | lit => CONTR lit th) + | prove (INR uns) = uprove uns; + +fun demod (INL th) = K th + | demod (INR uns) = udemod uns; + +fun info ((INL _) : units) = "*" + | info (INR uns) = int_to_string (N.size uns); + +val pp_units = pp_map info pp_string; + +(* Adding a theorem involves squashing it to a unit, if possible. *) + +fun add _ (U as INL _) = U + | add th (U as INR uns) = + if List.exists (Option.isSome o usubsumes uns) (clause th) then U + else + let + val th = udemod uns th + in + if is_contradiction th then INL th + else case total UNIT_SQUASH th of NONE => U | SOME th => INR (uadd th uns) + end; + +val addl = C (foldl (uncurry add)); + +end +(*#line 0.0 "fol/Problem1.sig"*) +(* ========================================================================= *) +(* SOME SAMPLE PROBLEMS TO TEST PROOF PROCEDURES *) +(* Created by Joe Hurd, September 2001 *) +(* Partly ported from the CAML-Light code accompanying John Harrison's book *) +(* ========================================================================= *) + +signature Problem1 = +sig + +type 'a quotation = 'a frag list +type 'a problem = {name : string, goal : 'a quotation} + +(* Accessing individual problems *) +val get : 'a problem list -> string -> 'a quotation + +(* The master collections *) +val nonequality : 'a problem list +val equality : 'a problem list +val tptp : 'a problem list + +(* Some compilations *) +(*val quick : 'a problem list *) + +end +(*#line 0.0 "fol/Problem1.sml"*) +(* ========================================================================= *) +(* SOME SAMPLE PROBLEMS TO TEST PROOF PROCEDURES *) +(* Created by Joe Hurd, September 2001 *) +(* Partly ported from the CAML-Light code accompanying John Harrison's book *) +(* ========================================================================= *) + +structure Problem1 :> Problem1 = +struct + +type 'a quotation = 'a frag list; + +type 'a problem = {name : string, goal : 'a quotation}; + +(* ========================================================================= *) +(* Accessing individual problems. *) +(* ========================================================================= *) + +fun extract (p : 'a problem list) n = + Option.valOf (List.find (fn {name, ...} => name = n) p); + +fun get p = #goal o extract p; + +(* ========================================================================= *) +(* Problems without equality. *) +(* ========================================================================= *) + +val nonequality = [ + +(* ------------------------------------------------------------------------- *) +(* Trivia (some of which demonstrate ex-bugs in provers). *) +(* ------------------------------------------------------------------------- *) + +{name = "TRUE", + goal = [ +QUOTE "\nT"]}, + +{name = "P_or_not_P", + goal = [ +QUOTE "\np \\/ ~p"]}, + +{name = "JH_test", + goal = [ +QUOTE "\n!x y. ?z. p x \\/ p y ==> p z"]}, + +{name = "CYCLIC", + goal = [ +QUOTE "\n(!x. p (g (c x))) ==> ?z. p (g z)"]}, + +{name = "MN_bug", + goal = [ +QUOTE "\n(!x. ?y. f y x x) ==> ?z. f z 0 0"]}, + +{name = "ERIC", + goal = [ +QUOTE "\n!x. ?v w. !y z. p x /\\ q y ==> (p v \\/ r w) /\\ (r z ==> q v)"]}, + +(* ------------------------------------------------------------------------- *) +(* Propositional Logic. *) +(* ------------------------------------------------------------------------- *) + +{name = "PROP_1", + goal = [ +QUOTE "\np ==> q <=> ~q ==> ~p"]}, + +{name = "PROP_2", + goal = [ +QUOTE "\n~~p <=> p"]}, + +{name = "PROP_3", + goal = [ +QUOTE "\n~(p ==> q) ==> q ==> p"]}, + +{name = "PROP_4", + goal = [ +QUOTE "\n~p ==> q <=> ~q ==> p"]}, + +{name = "PROP_5", + goal = [ +QUOTE "\n(p \\/ q ==> p \\/ r) ==> p \\/ (q ==> r)"]}, + +{name = "PROP_6", + goal = [ +QUOTE "\np \\/ ~p"]}, + +{name = "PROP_7", + goal = [ +QUOTE "\np \\/ ~~~p"]}, + +{name = "PROP_8", + goal = [ +QUOTE "\n((p ==> q) ==> p) ==> p"]}, + +{name = "PROP_9", + goal = [ +QUOTE "\n(p \\/ q) /\\ (~p \\/ q) /\\ (p \\/ ~q) ==> ~(~q \\/ ~q)"]}, + +{name = "PROP_10", + goal = [ +QUOTE "\n(q ==> r) /\\ (r ==> p /\\ q) /\\ (p ==> q /\\ r) ==> (p <=> q)"]}, + +{name = "PROP_11", + goal = [ +QUOTE "\np <=> p"]}, + +{name = "PROP_12", + goal = [ +QUOTE "\n((p <=> q) <=> r) <=> p <=> q <=> r"]}, + +{name = "PROP_13", + goal = [ +QUOTE "\np \\/ q /\\ r <=> (p \\/ q) /\\ (p \\/ r)"]}, + +{name = "PROP_14", + goal = [ +QUOTE "\n(p <=> q) <=> (q \\/ ~p) /\\ (~q \\/ p)"]}, + +{name = "PROP_15", + goal = [ +QUOTE "\np ==> q <=> ~p \\/ q"]}, + +{name = "PROP_16", + goal = [ +QUOTE "\n(p ==> q) \\/ (q ==> p)"]}, + +{name = "PROP_17", + goal = [ +QUOTE "\np /\\ (q ==> r) ==> s <=> (~p \\/ q \\/ s) /\\ (~p \\/ ~r \\/ s)"]}, + +{name = "MATHS4_EXAMPLE", + goal = [ +QUOTE "\n(a \\/ ~k ==> g) /\\ (g ==> q) /\\ ~q ==> k"]}, + +{name = "XOR_ASSOC", + goal = [ +QUOTE "\n~(~(p <=> q) <=> r) <=> ~(p <=> ~(q <=> r))"]}, + +(* ------------------------------------------------------------------------- *) +(* Monadic Predicate Logic. *) +(* ------------------------------------------------------------------------- *) + +(* The drinker's principle *) +{name = "P18", + goal = [ +QUOTE "\n?very_popular_guy. !whole_pub. drinks very_popular_guy ==> drinks whole_pub"]}, + +{name = "P19", + goal = [ +QUOTE "\n?x. !y z. (p y ==> q z) ==> p x ==> q x"]}, + +{name = "P20", + goal = [ +QUOTE "\n(!x y. ?z. !w. p x /\\ q y ==> r z /\\ u w) /\\ (!x y. p x /\\ q y) ==> ?z. r z"]}, + +{name = "P21", + goal = [ +QUOTE "\n(?x. p ==> q x) /\\ (?x. q x ==> p) ==> ?x. p <=> q x"]}, + +{name = "P22", + goal = [ +QUOTE "\n(!x. p <=> q x) ==> (p <=> !x. q x)"]}, + +{name = "P23", + goal = [ +QUOTE "\n(!x. p \\/ q x) <=> p \\/ !x. q x"]}, + +{name = "P24", + goal = [ + +QUOTE "\n~(?x. u x /\\ q x) /\\ (!x. p x ==> q x \\/ r x) /\\ ~(?x. p x ==> ?x. q x) /\\\n(!x. q x /\\ r x ==> u x) ==> ?x. p x /\\ r x"]}, + +{name = "P25", + goal = [ + +QUOTE "\n(?x. p x) /\\ (!x. u x ==> ~g x /\\ r x) /\\ (!x. p x ==> g x /\\ u x) /\\\n((!x. p x ==> q x) \\/ ?x. q x /\\ p x) ==> ?x. q x /\\ p x"]}, + +{name = "P26", + goal = [ + +QUOTE "\n((?x. p x) <=> ?x. q x) /\\ (!x y. p x /\\ q y ==> (r x <=> u y)) ==>\n((!x. p x ==> r x) <=> !x. q x ==> u x)"]}, + +{name = "P27", + goal = [ + +QUOTE "\n(?x. p x /\\ ~q x) /\\ (!x. p x ==> r x) /\\ (!x. u x /\\ s x ==> p x) /\\\n(?x. r x /\\ ~q x) ==> (!x. u x ==> ~r x) ==> !x. u x ==> ~s x"]}, + +{name = "P28", + goal = [ + +QUOTE "\n(!x. p x ==> !x. q x) /\\ ((!x. q x \\/ r x) ==> ?x. q x /\\ r x) /\\\n((?x. r x) ==> !x. l x ==> m x) ==> !x. p x /\\ l x ==> m x"]}, + +{name = "P29", + goal = [ + + +QUOTE "\n(?x. p x) /\\ (?x. g x) ==>\n((!x. p x ==> h x) /\\ (!x. g x ==> j x) <=>\n !x y. p x /\\ g y ==> h x /\\ j y)"]}, + +{name = "P30", + goal = [ + +QUOTE "\n(!x. p x \\/ g x ==> ~h x) /\\ (!x. (g x ==> ~u x) ==> p x /\\ h x) ==>\n!x. u x"]}, + +{name = "P31", + goal = [ + +QUOTE "\n~(?x. p x /\\ (g x \\/ h x)) /\\ (?x. q x /\\ p x) /\\ (!x. ~h x ==> j x) ==>\n?x. q x /\\ j x"]}, + +{name = "P32", + goal = [ + +QUOTE "\n(!x. p x /\\ (g x \\/ h x) ==> q x) /\\ (!x. q x /\\ h x ==> j x) /\\\n(!x. r x ==> h x) ==> !x. p x /\\ r x ==> j x"]}, + +{name = "P33", + goal = [ + +QUOTE "\n(!x. p a /\\ (p x ==> p b) ==> p c) <=>\n(!x. p a ==> p x \\/ p c) /\\ (p a ==> p b ==> p c)"]}, + +(* This gives rise to 5184 clauses when converted to CNF! *) +{name = "P34", + goal = [ + +QUOTE "\n((?x. !y. p x <=> p y) <=> (?x. q x) <=> !y. q y) <=>\n(?x. !y. q x <=> q y) <=> (?x. p x) <=> !y. p y"]}, + +{name = "P35", + goal = [ +QUOTE "\n?x y. p x y ==> !x y. p x y"]}, + +(* ------------------------------------------------------------------------- *) +(* Full predicate logic (without Identity and Functions) *) +(* ------------------------------------------------------------------------- *) + +{name = "P36", + goal = [ + +QUOTE "\n(!x. ?y. p x y) /\\ (!x. ?y. g x y) /\\\n(!x y. p x y \\/ g x y ==> !z. p y z \\/ g y z ==> h x z) ==> !x. ?y. h x y"]}, + +{name = "P37", + goal = [ + + +QUOTE "\n(!z. ?w. !x. ?y. (p x z ==> p y w) /\\ p y z /\\ (p y w ==> ?v. q v w)) /\\\n(!x z. ~p x z ==> ?y. q y z) /\\ ((?x y. q x y) ==> !x. r x x) ==>\n!x. ?y. r x y"]}, + +{name = "P38", + goal = [ + + + +QUOTE "\n(!x. p a /\\ (p x ==> ?y. p y /\\ r x y) ==> ?z w. p z /\\ r x w /\\ r w z) <=>\n!x.\n (~p a \\/ p x \\/ ?z w. p z /\\ r x w /\\ r w z) /\\\n (~p a \\/ ~(?y. p y /\\ r x y) \\/ ?z w. p z /\\ r x w /\\ r w z)"]}, + +{name = "P39", + goal = [ +QUOTE "\n~?x. !y. p y x <=> ~p y y"]}, + +{name = "P40", + goal = [ +QUOTE "\n(?y. !x. p x y <=> p x x) ==> ~!x. ?y. !z. p z y <=> ~p z x"]}, + +{name = "P41", + goal = [ +QUOTE "\n(!z. ?y. !x. p x y <=> p x z /\\ ~p x x) ==> ~?z. !x. p x z"]}, + +{name = "P42", + goal = [ +QUOTE "\n~?y. !x. p x y <=> ~?z. p x z /\\ p z x"]}, + +{name = "P43", + goal = [ +QUOTE "\n(!x y. q x y <=> !z. p z x <=> p z y) ==> !x y. q x y <=> q y x"]}, + +{name = "P44", + goal = [ + +QUOTE "\n(!x. p x ==> (?y. g y /\\ h x y) /\\ ?y. g y /\\ ~h x y) /\\\n(?x. j x /\\ !y. g y ==> h x y) ==> ?x. j x /\\ ~p x"]}, + +{name = "P45", + goal = [ + + + +QUOTE "\n(!x. p x /\\ (!y. g y /\\ h x y ==> j x y) ==> !y. g y /\\ h x y ==> r y) /\\\n~(?y. l y /\\ r y) /\\\n(?x. p x /\\ (!y. h x y ==> l y) /\\ !y. g y /\\ h x y ==> j x y) ==>\n?x. p x /\\ ~?y. g y /\\ h x y"]}, + +{name = "P46", + goal = [ + + +QUOTE "\n(!x. p x /\\ (!y. p y /\\ h y x ==> g y) ==> g x) /\\\n((?x. p x /\\ ~g x) ==> ?x. p x /\\ ~g x /\\ !y. p y /\\ ~g y ==> j x y) /\\\n(!x y. p x /\\ p y /\\ h x y ==> ~j y x) ==> !x. p x ==> g x"]}, + +{name = "P50", + goal = [ +QUOTE "\n(!x. f0 a x \\/ !y. f0 x y) ==> ?x. !y. f0 x y"]}, + +(* ------------------------------------------------------------------------- *) +(* Example from Manthey and Bry, CADE-9. *) +(* ------------------------------------------------------------------------- *) + +{name = "P55", + goal = [ + + + + + + + + +QUOTE "\nlives agatha /\\ lives butler /\\ lives charles /\\\n(killed agatha agatha \\/ killed butler agatha \\/ killed charles agatha) /\\\n(!x y. killed x y ==> hates x y /\\ ~richer x y) /\\\n(!x. hates agatha x ==> ~hates charles x) /\\\n(hates agatha agatha /\\ hates agatha charles) /\\\n(!x. lives x /\\ ~richer x agatha ==> hates butler x) /\\\n(!x. hates agatha x ==> hates butler x) /\\\n(!x. ~hates x agatha \\/ ~hates x butler \\/ ~hates x charles) ==>\nkilled agatha agatha /\\ ~killed butler agatha /\\ ~killed charles agatha"]}, + +{name = "P57", + goal = [ + +QUOTE "\np (f a b) (f b c) /\\ p (f b c) (f a c) /\\\n(!x y z. p x y /\\ p y z ==> p x z) ==> p (f a b) (f a c)"]}, + +(* ------------------------------------------------------------------------- *) +(* See info-hol, circa 1500. *) +(* ------------------------------------------------------------------------- *) + +{name = "P58", + goal = [ +QUOTE "\n!x. ?v w. !y z. p x /\\ q y ==> (p v \\/ r w) /\\ (r z ==> q v)"]}, + +{name = "P59", + goal = [ +QUOTE "\n(!x. p x <=> ~p (f x)) ==> ?x. p x /\\ ~p (f x)"]}, + +{name = "P60", + goal = [ +QUOTE "\n!x. p x (f x) <=> ?y. (!z. p z y ==> p z (f x)) /\\ p x y"]}, + +(* ------------------------------------------------------------------------- *) +(* From Gilmore's classic paper. *) +(* ------------------------------------------------------------------------- *) + +(* +JRH: Amazingly, this still seems non-trivial... in HOL it works at depth 45! +Joe: Confirmed (depth=45, inferences=263702, time=148s), though if lemmaizing + is used then a lemma is discovered at depth 29 that allows a much quicker + proof (depth=30, inferences=10039, time=5.5s). [13 Oct 2001] +*) +{name = "GILMORE_1", + goal = [ + + +QUOTE "\n?x. !y z.\n (f y ==> g y <=> f x) /\\ (f y ==> h y <=> g x) /\\\n ((f y ==> g y) ==> h y <=> h x) ==> f z /\\ g z /\\ h z"]}, + +(* +JRH: This is not valid, according to Gilmore +{name = "GILMORE_2", + goal = ` +?x y. !z. + (f x z <=> f z y) /\ (f z y <=> f z z) /\ (f x y <=> f y x) ==> + (f x y <=> f x z)`}, +*) + +{name = "GILMORE_3", + goal = [ + + +QUOTE "\n?x. !y z.\n ((f y z ==> g y ==> h x) ==> f x x) /\\ ((f z x ==> g x) ==> h z) /\\\n f x y ==> f z z"]}, + +{name = "GILMORE_4", + goal = [ +QUOTE "\n?x y. !z. (f x y ==> f y z /\\ f z z) /\\ (f x y /\\ g x y ==> g x z /\\ g z z)"]}, + +{name = "GILMORE_5", + goal = [ +QUOTE "\n(!x. ?y. f x y \\/ f y x) /\\ (!x y. f y x ==> f y y) ==> ?z. f z z"]}, + +{name = "GILMORE_6", + goal = [ + + + +QUOTE "\n!x. ?y.\n (?w. !v. f w x ==> g v w /\\ g w x) ==>\n (?w. !v. f w y ==> g v w /\\ g w y) \\/\n !z v. ?w. g v z \\/ h w y z ==> g z w"]}, + +{name = "GILMORE_7", + goal = [ + +QUOTE "\n(!x. k x ==> ?y. l y /\\ (f x y ==> g x y)) /\\\n(?z. k z /\\ !w. l w ==> f z w) ==> ?v w. k v /\\ l w /\\ g v w"]}, + +{name = "GILMORE_8", + goal = [ + + +QUOTE "\n?x. !y z.\n ((f y z ==> g y ==> !w. ?v. h w v x) ==> f x x) /\\\n ((f z x ==> g x) ==> !w. ?v. h w v z) /\\ f x y ==> f z z"]}, + +(* +JRH: This is still a very hard goal +Joe: With lemmaizing (in HOL): (depth=18, inferences=15632, time=21s) + Without: gave up waiting after (depth=25, inferences=2125072, time=3000s) + [13 Oct 2001] +*) +{name = "GILMORE_9", + goal = [ + + + + + + + +QUOTE "\n!x. ?y. !z.\n ((!w. ?v. f y w v /\\ g y w /\\ ~h y x) ==>\n (!w. ?v. f x w v /\\ g z u /\\ ~h x z) ==>\n !w. ?v. f x w v /\\ g y w /\\ ~h x y) /\\\n ((!w. ?v. f x w v /\\ g y w /\\ ~h x y) ==>\n ~(!w. ?v. f x w v /\\ g z w /\\ ~h x z) ==>\n (!w. ?v. f y w v /\\ g y w /\\ ~h y x) /\\\n !w. ?v. f z w v /\\ g y w /\\ ~h z y)"]}, + +(* ------------------------------------------------------------------------- *) +(* Translation of Gilmore procedure using separate definitions. *) +(* ------------------------------------------------------------------------- *) + +{name = "GILMORE_9a", + goal = [ + + +QUOTE "\n(!x y. p x y <=> !w. ?v. f x w v /\\ g y w /\\ ~h x y) ==>\n!x. ?y. !z.\n (p y x ==> p x z ==> p x y) /\\ (p x y ==> ~p x z ==> p y x /\\ p z y)"]}, + +(* ------------------------------------------------------------------------- *) +(* Example from Davis-Putnam papers where Gilmore procedure is poor. *) +(* ------------------------------------------------------------------------- *) + +{name = "DAVIS_PUTNAM_EXAMPLE", + goal = [ +QUOTE "\n?x y. !z. (f x y ==> f y z /\\ f z z) /\\ (f x y /\\ g x y ==> g x z /\\ g z z)"]}, + +(* ------------------------------------------------------------------------- *) +(* The interesting example where connections make the proof longer. *) +(* ------------------------------------------------------------------------- *) + +{name = "BAD_CONNECTIONS", + goal = [ + +QUOTE "\n~a /\\ (a \\/ b) /\\ (c \\/ d) /\\ (~b \\/ e \\/ f) /\\ (~c \\/ ~e) /\\ (~c \\/ ~f) /\\\n(~b \\/ g \\/ h) /\\ (~d \\/ ~g) /\\ (~d \\/ ~h) ==> F"]}, + +(* ------------------------------------------------------------------------- *) +(* The classic Los puzzle. (Clausal version MSC006-1 in the TPTP library.) *) +(* Note: this is actually in the decidable "AE" subset, though that doesn't *) +(* yield a very efficient proof. *) +(* ------------------------------------------------------------------------- *) + +{name = "LOS", + goal = [ + + +QUOTE "\n(!x y z. p x y ==> p y z ==> p x z) /\\\n(!x y z. q x y ==> q y z ==> q x z) /\\ (!x y. q x y ==> q y x) /\\\n(!x y. p x y \\/ q x y) ==> (!x y. p x y) \\/ !x y. q x y"]}, + +(* ------------------------------------------------------------------------- *) +(* The steamroller. *) +(* ------------------------------------------------------------------------- *) + +{name = "STEAM_ROLLER", + goal = [ + + + + + + + + + + + + +QUOTE "\n((!x. p1 x ==> p0 x) /\\ ?x. p1 x) /\\ ((!x. p2 x ==> p0 x) /\\ ?x. p2 x) /\\\n((!x. p3 x ==> p0 x) /\\ ?x. p3 x) /\\ ((!x. p4 x ==> p0 x) /\\ ?x. p4 x) /\\\n((!x. p5 x ==> p0 x) /\\ ?x. p5 x) /\\ ((?x. q1 x) /\\ !x. q1 x ==> q0 x) /\\\n(!x.\n p0 x ==>\n (!y. q0 y ==> r x y) \\/\n !y. p0 y /\\ s0 y x /\\ (?z. q0 z /\\ r y z) ==> r x y) /\\\n(!x y. p3 y /\\ (p5 x \\/ p4 x) ==> s0 x y) /\\\n(!x y. p3 x /\\ p2 y ==> s0 x y) /\\ (!x y. p2 x /\\ p1 y ==> s0 x y) /\\\n(!x y. p1 x /\\ (p2 y \\/ q1 y) ==> ~r x y) /\\\n(!x y. p3 x /\\ p4 y ==> r x y) /\\ (!x y. p3 x /\\ p5 y ==> ~r x y) /\\\n(!x. p4 x \\/ p5 x ==> ?y. q0 y /\\ r x y) ==>\n?x y. p0 x /\\ p0 y /\\ ?z. q1 z /\\ r y z /\\ r x y"]}, + +(* ------------------------------------------------------------------------- *) +(* An incestuous example used to establish completeness characterization. *) +(* ------------------------------------------------------------------------- *) + +{name = "MODEL_COMPLETENESS", + goal = [ + + + + + + + + +QUOTE "\n(!w x. sentence x ==> holds w x \\/ holds w (not x)) /\\\n(!w x. ~(holds w x /\\ holds w (not x))) ==>\n((!x.\n sentence x ==>\n (!w. models w s ==> holds w x) \\/\n !w. models w s ==> holds w (not x)) <=>\n !w v.\n models w s /\\ models v s ==>\n !x. sentence x ==> (holds w x <=> holds v x))"]} + +]; + +(* ========================================================================= *) +(* Problems with equality. *) +(* ========================================================================= *) + +val equality = [ + +(* ------------------------------------------------------------------------- *) +(* Trivia (some of which demonstrate ex-bugs in the prover). *) +(* ------------------------------------------------------------------------- *) + +{name = "REFLEXIVITY", + goal = [ +QUOTE "\nc = c"]}, + +{name = "SYMMETRY", + goal = [ +QUOTE "\n!x y. x = y ==> y = x"]}, + +{name = "TRANSITIVITY", + goal = [ +QUOTE "\n!x y z. x = y /\\ y = z ==> x = z"]}, + +{name = "TRANS_SYMM", + goal = [ +QUOTE "\n!x y z. x = y /\\ y = z ==> z = x"]}, + +{name = "SUBSTITUTIVITY", + goal = [ +QUOTE "\n!x y. f x /\\ x = y ==> f y"]}, + +{name = "CYCLIC_SUBSTITUTION_BUG", + goal = [ +QUOTE "\n(!x. y = g (c x)) ==> ?z. y = g z"]}, + +(* ------------------------------------------------------------------------- *) +(* Simple equality problems. *) +(* ------------------------------------------------------------------------- *) + +{name = "P48", + goal = [ +QUOTE "\n(a = b \\/ c = d) /\\ (a = c \\/ b = d) ==> a = d \\/ b = c"]}, + +{name = "P49", + goal = [ +QUOTE "\n(?x y. !z. z = x \\/ z = y) /\\ p a /\\ p b /\\ ~(a = b) ==> !x. p x"]}, + +{name = "P51", + goal = [ + +QUOTE "\n(?z w. !x y. f0 x y <=> x = z /\\ y = w) ==>\n?z. !x. (?w. !y. f0 x y <=> y = w) <=> x = z"]}, + +{name = "P52", + goal = [ + +QUOTE "\n(?z w. !x y. f0 x y <=> x = z /\\ y = w) ==>\n?w. !y. (?z. !x. f0 x y <=> x = z) <=> y = w"]}, + +(* ------------------------------------------------------------------------- *) +(* The Melham problem after an inverse skolemization step. *) +(* ------------------------------------------------------------------------- *) + +{name = "UNSKOLEMIZED_MELHAM", + goal = [ +QUOTE "\n(!x y. g x = g y ==> f x = f y) ==> !y. ?w. !x. y = g x ==> w = f x"]}, + +(* ------------------------------------------------------------------------- *) +(* The example always given for congruence closure. *) +(* ------------------------------------------------------------------------- *) + +{name = "CONGRUENCE_CLOSURE_EXAMPLE", + goal = [ +QUOTE "\n!x. f (f (f (f (f x)))) = x /\\ f (f (f x)) = x ==> f x = x"]}, + +(* ------------------------------------------------------------------------- *) +(* A simple example (see EWD1266a and the application to Morley's theorem). *) +(* ------------------------------------------------------------------------- *) + +{name = "EWD", + goal = [ + +QUOTE "\n(!x. f x ==> g x) /\\ (?x. f x) /\\ (!x y. g x /\\ g y ==> x = y) ==>\n!y. g y ==> f y"]}, + +{name = "EWD'", + goal = [ +QUOTE "\n(!x. f (f x) = f x) /\\ (!x. ?y. f y = x) ==> !x. f x = x"]}, + +(* ------------------------------------------------------------------------- *) +(* Wishnu Prasetya's example. *) +(* ------------------------------------------------------------------------- *) + +{name = "WISHNU", + goal = [ + +QUOTE "\n(?x. x = f (g x) /\\ !x'. x' = f (g x') ==> x = x') <=>\n?y. y = g (f y) /\\ !y'. y' = g (f y') ==> y = y'"]}, + +(* ------------------------------------------------------------------------- *) +(* An equality version of the Agatha puzzle. *) +(* ------------------------------------------------------------------------- *) + +{name = "AGATHA", + goal = [ + + + + + + + + + +QUOTE "\n(?x. lives x /\\ killed x agatha) /\\\n(lives agatha /\\ lives butler /\\ lives charles) /\\\n(!x. lives x ==> x = agatha \\/ x = butler \\/ x = charles) /\\\n(!x y. killed x y ==> hates x y) /\\ (!x y. killed x y ==> ~richer x y) /\\\n(!x. hates agatha x ==> ~hates charles x) /\\\n(!x. ~(x = butler) ==> hates agatha x) /\\\n(!x. ~richer x agatha ==> hates butler x) /\\\n(!x. hates agatha x ==> hates butler x) /\\ (!x. ?y. ~hates x y) /\\\n~(agatha = butler) ==>\nkilled agatha agatha /\\ ~killed butler agatha /\\ ~killed charles agatha"]}, + +(* ------------------------------------------------------------------------- *) +(* Group theory examples. *) +(* ------------------------------------------------------------------------- *) + +(* JRH: (Size 18, 61814 seconds.) *) +{name = "GROUP_RIGHT_INVERSE", + goal = [ + +QUOTE "\n(!x y z. x * (y * z) = x * y * z) /\\ (!x. e * x = x) /\\\n(!x. i x * x = e) ==> !x. x * i x = e"]}, + +{name = "GROUP_RIGHT_IDENTITY", + goal = [ + +QUOTE "\n(!x y z. x * (y * z) = x * y * z) /\\ (!x. e * x = x) /\\\n(!x. i x * x = e) ==> !x. x * e = x"]}, + +{name = "KLEIN_GROUP_COMMUTATIVE", + goal = [ + +QUOTE "\n(!x y z. x * (y * z) = x * y * z) /\\ (!x. e * x = x) /\\ (!x. x * e = x) /\\\n(!x. x * x = e) ==> !x y. x * y = y * x"]} + +]; + +(* ========================================================================= *) +(* Some sample problems from the TPTP archive. *) +(* Note: for brevity some relation/function names have been shortened. *) +(* ========================================================================= *) + +val tptp = [ + +(* ------------------------------------------------------------------------- *) +(* TPTP problems that have demonstrated bugs in the prover. *) +(* ------------------------------------------------------------------------- *) + +(* Solved trivially by meson without cache cutting, but not with. *) +{name = "PUZ011-1", + goal = [ + + + + + + + + + + + +QUOTE "\nocean atlantic /\\ ocean indian /\\ borders atlantic brazil /\\\nborders atlantic uruguay /\\ borders atlantic c_venesuela /\\\nborders atlantic c_zaire /\\ borders atlantic nigeria /\\\nborders atlantic angola /\\ borders indian india /\\\nborders indian pakistan /\\ borders indian iran /\\ borders indian somalia /\\\nborders indian kenya /\\ borders indian tanzania /\\ south_american brazil /\\\nsouth_american uruguay /\\ south_american c_venesuela /\\ african c_zaire /\\\nafrican nigeria /\\ african angola /\\ african somalia /\\ african kenya /\\\nafrican tanzania /\\ asian india /\\ asian pakistan /\\ asian iran ==>\n(!x y z.\n ~ocean x \\/ ~borders x y \\/ ~african y \\/ ~borders x z \\/ ~asian z) ==>\nF"]}, + +(* ------------------------------------------------------------------------- *) +(* Problems used by the fol unit test to exercise the TPTP parser. *) +(* ------------------------------------------------------------------------- *) + +{name = "PUZ001-1", + goal = [ + + + + + + + + +QUOTE "\nlives agatha /\\ lives butler /\\ lives charles /\\\n(!x y. ~killed x y \\/ ~richer x y) /\\\n(!x. ~hates agatha x \\/ ~hates charles x) /\\\n(!x. ~hates x agatha \\/ ~hates x butler \\/ ~hates x charles) /\\\nhates agatha agatha /\\ hates agatha charles /\\\n(!x y. ~killed x y \\/ hates x y) /\\\n(!x. ~hates agatha x \\/ hates butler x) /\\\n(!x. ~lives x \\/ richer x agatha \\/ hates butler x) ==>\nkilled butler agatha \\/ killed charles agatha ==> F"]}, + +{name = "PUZ020-1", + goal = [ + + + + + + + + + + + + + + + + + + + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y. ~(x = y) \\/ statement_by x = statement_by y) /\\\n(!x. ~person x \\/ knight x \\/ knave x) /\\\n(!x. ~person x \\/ ~knight x \\/ ~knave x) /\\\n(!x y. ~says x y \\/ a_truth y \\/ ~a_truth y) /\\\n(!x y. ~says x y \\/ ~(x = y)) /\\ (!x y. ~says x y \\/ y = statement_by x) /\\\n(!x y. ~person x \\/ ~(x = statement_by y)) /\\\n(!x. ~person x \\/ ~a_truth (statement_by x) \\/ knight x) /\\\n(!x. ~person x \\/ a_truth (statement_by x) \\/ knave x) /\\\n(!x y. ~(x = y) \\/ ~knight x \\/ knight y) /\\\n(!x y. ~(x = y) \\/ ~knave x \\/ knave y) /\\\n(!x y. ~(x = y) \\/ ~person x \\/ person y) /\\\n(!x y z. ~(x = y) \\/ ~says x z \\/ says y z) /\\\n(!x y z. ~(x = y) \\/ ~says z x \\/ says z y) /\\\n(!x y. ~(x = y) \\/ ~a_truth x \\/ a_truth y) /\\\n(!x y. ~knight x \\/ ~says x y \\/ a_truth y) /\\\n(!x y. ~knave x \\/ ~says x y \\/ ~a_truth y) /\\ person husband /\\\nperson c_wife /\\ ~(husband = c_wife) /\\\nsays husband (statement_by husband) /\\\n(~a_truth (statement_by husband) \\/ ~knight husband \\/ knight c_wife) /\\\n(a_truth (statement_by husband) \\/ ~knight husband) /\\\n(a_truth (statement_by husband) \\/ knight c_wife) /\\\n(~knight c_wife \\/ a_truth (statement_by husband)) ==> ~knight husband ==>\nF"]}, + +{name = "NUM001-1", + goal = [ + + + + + + + + +QUOTE "\n(!x. x == x) /\\ (!x y z. ~(x == y) \\/ ~(y == z) \\/ x == z) /\\\n(!x y. x + y == y + x) /\\ (!x y z. x + (y + z) == x + y + z) /\\\n(!x y. x + y - y == x) /\\ (!x y. x == x + y - y) /\\\n(!x y z. x - y + z == x + z - y) /\\ (!x y z. x + y - z == x - z + y) /\\\n(!x y z v. ~(x == y) \\/ ~(z == x + v) \\/ z == y + v) /\\\n(!x y z v. ~(x == y) \\/ ~(z == v + x) \\/ z == v + y) /\\\n(!x y z v. ~(x == y) \\/ ~(z == x - v) \\/ z == y - v) /\\\n(!x y z v. ~(x == y) \\/ ~(z == v - x) \\/ z == v - y) ==>\n~(a + b + c == a + (b + c)) ==> F"]}, + +{name = "ALG005-1", + goal = [ + + + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\\n(!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) /\\ (!x y. x + (y + x) = x) /\\\n(!x y. x + (x + y) = y + (y + x)) /\\\n(!x y z. x + y + z = x + z + (y + z)) /\\ (!x y. x * y = x + (x + y)) ==>\n~(a * b * c = a * (b * c)) ==> F"]}, + +{name = "GRP057-1", + goal = [ + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z v. x * i (i (i y * (i x * z)) * v * i (y * v)) = z) /\\\n(!x y. ~(x = y) \\/ i x = i y) /\\ (!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) ==>\n~(i a1 * a1 = i b1 * b1) \\/ ~(i b2 * b2 * a2 = a2) \\/\n~(a3 * b3 * c3 = a3 * (b3 * c3)) ==> F"]}, + +{name = "LCL009-1", + goal = [ + + +QUOTE "\n(!x y. ~p (x - y) \\/ ~p x \\/ p y) /\\\n(!x y z. p (x - y - (z - y - (x - z)))) ==>\n~p (a - b - c - (a - (b - c))) ==> F"]}, + +(* ------------------------------------------------------------------------- *) +(* Small problems that are tricky to prove. *) +(* ------------------------------------------------------------------------- *) + +{name = "COL060-3", + goal = [ + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. b % x % y % z = x % (y % z)) /\\ (!x y. t % x % y = y % x) /\\\n(!x y z. ~(x = y) \\/ x % z = y % z) /\\\n(!x y z. ~(x = y) \\/ z % x = z % y) ==>\n~(b % (b % (t % b) % b) % t % c_x % c_y % c_z = c_y % (c_x % c_z)) ==> F"]}, + +{name = "COL058-2", + goal = [ + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y. r (r 0 x) y = r x (r y y)) /\\ (!x y z. ~(x = y) \\/ r x z = r y z) /\\\n(!x y z. ~(x = y) \\/ r z x = r z y) ==>\n~(r (r (r 0 (r (r 0 (r 0 0)) (r 0 (r 0 0)))) (r 0 (r 0 0)))\n (r (r 0 (r (r 0 (r 0 0)) (r 0 (r 0 0)))) (r 0 (r 0 0))) =\n r (r 0 (r (r 0 (r 0 0)) (r 0 (r 0 0)))) (r 0 (r 0 0))) ==> F"]}, + +{name = "LCL107-1", + goal = [ + + + + +QUOTE "\n(!x y. ~p (x - y) \\/ ~p x \\/ p y) /\\\n(!x y z v w x' y'.\n p\n (x - y - z - (v - w - (x' - w - (x' - v) - y')) -\n (z - (y - x - y')))) ==> ~p (a - b - c - (e - b - (a - e - c))) ==> F"]}, + +{name = "LDA007-3", + goal = [ + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. f x (f y z) = f (f x y) (f x z)) /\\\n(!x y z. ~(x = y) \\/ f x z = f y z) /\\\n(!x y z. ~(x = y) \\/ f z x = f z y) /\\ tt = f t t /\\ ts = f t s /\\\ntt_ts = f tt ts /\\ tk = f t k /\\ tsk = f ts k ==>\n~(f t tsk = f tt_ts tk) ==> F"]}, + +{name = "GRP010-4", + goal = [ + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\ (!x y. ~(x = y) \\/ i x = i y) /\\\n(!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) /\\ (!x y z. x * y * z = x * (y * z)) /\\\n(!x. 1 * x = x) /\\ (!x. i x * x = 1) /\\ c * b = 1 ==> ~(b * c = 1) ==> F"]}, + +{name = "ALG006-1", + goal = [ + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\ (!x y. x + (y + x) = x) /\\\n(!x y. x + (x + y) = y + (y + x)) /\\\n(!x y z. x + y + z = x + z + (y + z)) ==> ~(a + c + b = a + b + c) ==> F"]}, + +{name = "BOO021-1", + goal = [ + + + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\ (!x y. ~(x = y) \\/ i x = i y) /\\\n(!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) /\\ (!x y. (x + y) * y = y) /\\\n(!x y z. x * (y + z) = y * x + z * x) /\\ (!x. x + i x = 1) /\\\n(!x y. x * y + y = y) /\\ (!x y z. x + y * z = (y + x) * (z + x)) /\\\n(!x. x * i x = 0) ==> ~(b * a = a * b) ==> F"]}, + +{name = "GEO002-4", + goal = [ + + + + + + + + + + + +QUOTE "\n(!x y z v. ~between x y z \\/ ~between y v z \\/ between x y v) /\\\n(!x y z. ~equidistant x y z z \\/ x == y) /\\\n(!x y z v w.\n ~between x y z \\/ ~between v z w \\/\n between x (outer_pasch y x v w z) v) /\\\n(!x y z v w.\n ~between x y z \\/ ~between v z w \\/\n between w y (outer_pasch y x v w z)) /\\\n(!x y z v. between x y (extension x y z v)) /\\\n(!x y z v. equidistant x (extension y x z v) z v) /\\\n(!x y z v. ~(x == y) \\/ ~between z v x \\/ between z v y) ==>\n~between a a b ==> F"]}, + +{name = "GRP057-1", + goal = [ + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y z v. x * i (i (i y * (i x * z)) * v * i (y * v)) = z) /\\\n(!x y. ~(x = y) \\/ i x = i y) /\\ (!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) ==>\n~(i a1 * a1 = i b1 * b1) \\/ ~(i b2 * b2 * a2 = a2) \\/\n~(a3 * b3 * c3 = a3 * (b3 * c3)) ==> F"]}, + +{name = "HEN006-3", + goal = [ + + + + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\\n(!x y. ~(x <= y) \\/ x / y = 0) /\\ (!x y. ~(x / y = 0) \\/ x <= y) /\\\n(!x y. x / y <= x) /\\ (!x y z. x / y / (z / y) <= x / z / y) /\\\n(!x. 0 <= x) /\\ (!x y. ~(x <= y) \\/ ~(y <= x) \\/ x = y) /\\ (!x. x <= 1) /\\\n(!x y z. ~(x = y) \\/ x / z = y / z) /\\\n(!x y z. ~(x = y) \\/ z / x = z / y) /\\\n(!x y z. ~(x = y) \\/ ~(x <= z) \\/ y <= z) /\\\n(!x y z. ~(x = y) \\/ ~(z <= x) \\/ z <= y) /\\ a / b <= d ==>\n~(a / d <= b) ==> F"]}, + +{name = "RNG035-7", + goal = [ + + + + + + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\ (!x. 0 + x = x) /\\\n(!x. x + 0 = x) /\\ (!x. n x + x = 0) /\\ (!x. x + n x = 0) /\\\n(!x y z. x + (y + z) = x + y + z) /\\ (!x y. x + y = y + x) /\\\n(!x y z. x * (y * z) = x * y * z) /\\\n(!x y z. x * (y + z) = x * y + x * z) /\\\n(!x y z. (x + y) * z = x * z + y * z) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\ (!x y. ~(x = y) \\/ n x = n y) /\\\n(!x y z. ~(x = y) \\/ x * z = y * z) /\\\n(!x y z. ~(x = y) \\/ z * x = z * y) /\\ (!x. x * (x * (x * x)) = x) ==>\na * b = c /\\ ~(b * a = c) ==> F"]}, + +{name = "ROB001-1", + goal = [ + + + + + + +QUOTE "\n(!x. x = x) /\\ (!x y. ~(x = y) \\/ y = x) /\\\n(!x y z. ~(x = y) \\/ ~(y = z) \\/ x = z) /\\ (!x y. x + y = y + x) /\\\n(!x y z. x + y + z = x + (y + z)) /\\\n(!x y. n (n (x + y) + n (x + n y)) = x) /\\\n(!x y z. ~(x = y) \\/ x + z = y + z) /\\\n(!x y z. ~(x = y) \\/ z + x = z + y) /\\ (!x y. ~(x = y) \\/ n x = n y) ==>\n~(n (a + n b) + n (n a + n b) = b) ==> F"]}, + +{name = "GRP128-4.003", + goal = [ + + + + + + + + + + + + + + + + +QUOTE "\n(!x y.\n ~elt x \\/ ~elt y \\/ product e_1 x y \\/ product e_2 x y \\/\n product e_3 x y) /\\\n(!x y.\n ~elt x \\/ ~elt y \\/ product x e_1 y \\/ product x e_2 y \\/\n product x e_3 y) /\\ elt e_1 /\\ elt e_2 /\\ elt e_3 /\\ ~(e_1 == e_2) /\\\n~(e_1 == e_3) /\\ ~(e_2 == e_1) /\\ ~(e_2 == e_3) /\\ ~(e_3 == e_1) /\\\n~(e_3 == e_2) /\\\n(!x y.\n ~elt x \\/ ~elt y \\/ product x y e_1 \\/ product x y e_2 \\/\n product x y e_3) /\\\n(!x y z v. ~product x y z \\/ ~product x y v \\/ z == v) /\\\n(!x y z v. ~product x y z \\/ ~product x v z \\/ y == v) /\\\n(!x y z v. ~product x y z \\/ ~product v y z \\/ x == v) ==>\n(!x y z v. product x y z \\/ ~product x z v \\/ ~product z y v) /\\\n(!x y z v. product x y z \\/ ~product v x z \\/ ~product v y x) /\\\n(!x y z v. ~product x y z \\/ ~product z y v \\/ product x z v) ==> F"]}, + +{name = "NUM014-1", + goal = [ + + + + + + +QUOTE "\n(!x. product x x (square x)) /\\\n(!x y z. ~product x y z \\/ product y x z) /\\\n(!x y z. ~product x y z \\/ divides x z) /\\\n(!x y z v.\n ~prime x \\/ ~product y z v \\/ ~divides x v \\/ divides x y \\/\n divides x z) /\\ prime a /\\ product a (square c) (square b) ==>\n~divides a b ==> F"]} + +]; + +(* ========================================================================= *) +(* A FEW SAMPLE THEOREMS TO CHECK LARGE RUNS *) +(* ========================================================================= *) + +(* val quick = + * [extract nonequality "TRUE", + * extract nonequality "P_or_not_P", + * extract nonequality "JH_test", + * extract nonequality "CYCLIC", + * extract nonequality "MN_bug", + * extract nonequality "ERIC", + * extract nonequality "MATHS4_EXAMPLE", + * extract nonequality "P18", + * extract nonequality "P39", + * extract nonequality "P59", + * extract nonequality "DAVIS_PUTNAM_EXAMPLE", + * extract nonequality "BAD_CONNECTIONS", + * + * extract equality "TRANS_SYMM", + * extract equality "CYCLIC_SUBSTITUTION_BUG", + * extract equality "P48"]; + *) +end +(*#line 0.0 "src/Meter1.sig"*) +(* ========================================================================= *) +(* METERING TIME AND INFERENCES *) +(* Created by Joe Hurd, November 2001 *) +(* ========================================================================= *) + +signature Meter1 = +sig + +type 'a pp = 'a Useful.pp + +(* Search limits *) +type limit = {time : real option, infs : int option} +val unlimited : limit +val expired : limit +val limit_to_string : limit -> string + +(* Meter readings *) +type meter_reading = {time : real, infs : int} +val zero_reading : meter_reading +val add_readings : meter_reading -> meter_reading -> meter_reading +val pp_meter_reading : meter_reading pp +val meter_reading_to_string : meter_reading -> string + +(* Meters record time and inferences *) +type meter +val new_meter : limit -> meter +val sub_meter : meter -> limit -> meter +val record_infs : meter -> int -> unit +val read_meter : meter -> meter_reading +val check_meter : meter -> bool +val pp_meter : meter pp + +end +(*#line 0.0 "src/Meter1.sml"*) +(* ========================================================================= *) +(* METERING TIME AND INFERENCES *) +(* Created by Joe Hurd, November 2001 *) +(* ========================================================================= *) + +(* +app load + ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Match1"]; +*) + +(* +*) +structure Meter1 :> Meter1 = +struct + +open Useful; + +infix |-> ::> @> oo ## ::* ::@; + +(* ------------------------------------------------------------------------- *) +(* Search limits *) +(* ------------------------------------------------------------------------- *) + +type limit = {time : real option, infs : int option}; + +val unlimited = {time = NONE, infs = NONE}; + +val expired = {time = SOME 0.0, infs = SOME 0}; + +fun limit_to_string {time, infs} = + "{time = " ^ + (case time of NONE => "unlimited" + | SOME r => Real.fmt (StringCvt.FIX (SOME 3)) r ^ "s") ^ + ", infs = " ^ + (case infs of NONE => "unlimited" | SOME i => int_to_string i) ^ + "}"; + +(* ------------------------------------------------------------------------- *) +(* Meter readings. *) +(* ------------------------------------------------------------------------- *) + +type meter_reading = {time : real, infs : int}; + +val zero_reading = {time = 0.0, infs = 0}; + +fun add_readings {time : real, infs} {time = time', infs = infs'} = + {time = time + time', infs = infs + infs'}; + +fun pp_meter_reading pp {time, infs} = + let + open PP + val () = begin_block pp INCONSISTENT 1 + val () = add_string pp "{"; + val () = begin_block pp INCONSISTENT 2 + val () = add_string pp "time =" + val () = add_break pp (1, 0) + val () = add_string pp (Real.fmt (StringCvt.FIX (SOME 3)) time) + val () = end_block pp + val () = add_string pp "," + val () = add_break pp (1, 0) + val () = begin_block pp INCONSISTENT 2 + val () = add_string pp "infs =" + val () = add_break pp (1, 0) + val () = pp_int pp infs + val () = end_block pp + val () = add_string pp "}" + val () = end_block pp + in + () + end; + +fun meter_reading_to_string r = + PP.pp_to_string (!LINE_LENGTH) pp_meter_reading r; + +(* ------------------------------------------------------------------------- *) +(* Meters record time and inferences. *) +(* ------------------------------------------------------------------------- *) + +type meter = {read : unit -> meter_reading, log : (int -> unit), lim : limit}; + +fun new_time_meter () = + let + val tmr = Timer.startCPUTimer () + fun read () = + (fn {usr, sys, ...} => Time.toReal (Time.+ (usr, sys))) + (Timer.checkCPUTimer tmr) + in + read + end; + +fun new_inference_meter () = + let + val infs = ref 0 + fun read () = !infs + in + (read, fn n => infs := !infs + n) + end; + +fun new_meter lim : meter = + let + val tread = new_time_meter () + val (iread, ilog) = new_inference_meter () + in + {read = (fn () => {time = tread (), infs = iread ()}), + log = ilog, lim = lim} + end; + +fun sub_meter {read, log, lim = _} lim = + let + val {time = init_time : real, infs = init_infs} = read () + fun sub {time, infs} = {time = time - init_time, infs = infs - init_infs} + in + {read = sub o read, log = log, lim = lim} + end; + +val read_meter = fn ({read, ...} : meter) => read (); + +val check_meter = fn ({read, lim = {time, infs}, ...} : meter) => + let + val {time = t, infs = i} = read () + in + (case time of NONE => true | SOME time => t < time) andalso + (case infs of NONE => true | SOME infs => i < infs) + end; + +val record_infs = fn ({log, ...} : meter) => log; + +val pp_meter = pp_map read_meter pp_meter_reading; + +end +(*#line 0.0 "src/Solver1.sig"*) +(* ========================================================================= *) +(* PACKAGING UP SOLVERS TO ALLOW THEM TO COOPERATE UNIFORMLY *) +(* Created by Joe Hurd, March 2002 *) +(* ========================================================================= *) + +signature Solver1 = +sig + +type 'a pp = 'a Useful.pp +type 'a stream = 'a Stream.stream +type formula = Term1.formula +type thm = Thm1.thm +type limit = Meter1.limit +type meter = Meter1.meter +type meter_reading = Meter1.meter_reading +type units = Units1.units + +(* The type of a generic solver *) + +type solver = formula list -> thm list option stream + +val contradiction_solver : thm -> solver + +(* Filters to cut off searching or drop subsumed solutions *) + +val solved_filter : solver -> solver +val subsumed_filter : solver -> solver + +(* User-friendly interface to generic solvers *) + +val solve : solver -> formula list -> thm list list +val find : solver -> formula list -> thm list option +val refute : solver -> thm option + +(* Solver nodes must construct themselves from the following form. *) + +type form = + {slice : meter ref, (* A meter to stop after each slice *) + units : units ref, (* Solvers share a unit cache *) + thms : thm list, (* Context, assumed consistent *) + hyps : thm list} (* Hypothesis, or set of support *) + +(* Solver nodes also incorporate a name. *) + +type node_data = {name : string, solver_con : form -> solver} +type solver_node + +val mk_solver_node : node_data -> solver_node +val pp_solver_node : solver_node pp + +(* At each step we schedule a time slice to the least cost solver node. *) + +val SLICE : limit ref + +type cost_fn = meter_reading -> real + +val time1 : cost_fn (* Time taken (in seconds) *) +val time2 : cost_fn (* Time squared *) +val infs1 : cost_fn (* Number of inferences made*) +val infs2 : cost_fn (* Inferences squared *) + +(* This allows us to hierarchically arrange solver nodes. *) + +val combine : (cost_fn * solver_node) list -> solver_node + +(* Overriding the 'natural' set of support from the problem. *) + +val set_of_support : (thm -> bool) -> solver_node -> solver_node +val everything : thm -> bool +val one_negative : thm -> bool +val one_positive : thm -> bool +val all_negative : thm -> bool (* This one is used by Metis1.prove *) +val all_positive : thm -> bool +val nothing : thm -> bool + +(* Initializing a solver node makes it ready for action. *) + +type init_data = {limit : limit, thms : thm list, hyps : thm list} + +val initialize : solver_node -> init_data -> solver + +end +(*#line 0.0 "src/Solver1.sml"*) +(* ========================================================================= *) +(* PACKAGING UP SOLVERS TO ALLOW THEM TO COOPERATE UNIFORMLY *) +(* Created by Joe Hurd, March 2002 *) +(* ========================================================================= *) + +(* +app load + ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Match1", "Meter1", "Units1", + "Solver1"]; +*) + +(* +*) +structure Solver1 :> Solver1 = +struct + +open Useful Term1 Match1 Thm1 Meter1; + +infix |-> ::> @> oo ##; + +structure S = Stream; +structure U = Units1; + +type 'a stream = 'a S.stream; +type units = U.units; + +val |<>| = Subst1.|<>|; +val op ::> = Subst1.::>; + +(* ------------------------------------------------------------------------- *) +(* Chatting. *) +(* ------------------------------------------------------------------------- *) + +val () = traces := {module = "Solver1", alignment = K 1} :: !traces; + +fun chat l m = trace {module = "Solver1", message = m, level = l}; + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +fun drop_after f = + S.fold (fn x => fn xs => S.CONS (x, if f x then K S.NIL else xs)) S.NIL; + +fun time_to_string t = + let val dp = if t < 10.0 then 2 else if t < 1000.0 then 1 else 0 + in Real.fmt (StringCvt.FIX (SOME dp)) t + end; + +fun infs_to_string i = + if i < 10000 then int_to_string i + else if i < 10000000 then int_to_string (i div 1000) ^ "K" + else int_to_string (i div 1000000) ^ "M"; + +val name_to_string = str o hd o explode; + +fun option_case n _ NONE = n + | option_case _ s (SOME _) = s; + +(* ------------------------------------------------------------------------- *) +(* The type of a generic solver. *) +(* ------------------------------------------------------------------------- *) + +type solver = formula list -> thm list option stream; + +local + fun contr th [False] = [th] + | contr th gs = map (C CONTR th) gs; +in + fun contradiction_solver th = + (assert (is_contradiction th) (ERR "contradiction_solver" "thm not |- F"); + fn gs => S.CONS (SOME (contr th gs), K S.NIL)); +end; + +(* ------------------------------------------------------------------------- *) +(* Filters to cut off searching or drop subsumed solutions. *) +(* ------------------------------------------------------------------------- *) + +local + fun concl [] = False + | concl [lit] = lit + | concl _ = raise BUG "concl" "not a literal"; +in + fun solved_filter solver goals = + let + fun solves goals' = can (matchl_literals |<>|) (zip goals' goals) + fun final NONE = false + | final (SOME ths) = solves (map (concl o clause) ths) + in + drop_after final (solver goals) + end; +end; + +local + fun munge s n = "MUNGED__" ^ int_to_string n ^ "__" ^ s; + fun munge_lit (n, Atom (Fn (p, a))) = Atom (Fn (munge p n, a)) + | munge_lit (n, Not (Atom (Fn (p, a)))) = Not (Atom (Fn (munge p n, a))) + | munge_lit _ = raise BUG "munge_lit" "bad literal"; + fun distinctivize fms = map munge_lit (enumerate 0 fms); + fun advance NONE s = (SOME NONE, s) + | advance (SOME ths) s = + let + val fms = distinctivize (List.mapPartial (total dest_unit) ths) + in + if non null (Subsume1.subsumed s fms) then (NONE, s) + else (SOME (SOME ths), Subsume1.add (fms |-> ()) s) + end + handle ERR_EXN _ => raise BUG "advance" "shouldn't fail"; +in + fun subsumed_filter s g = S.partial_maps advance Subsume1.empty (s g); +end; + +(* ------------------------------------------------------------------------- *) +(* User-friendly interface to generic solvers *) +(* ------------------------------------------------------------------------- *) + +fun raw_solve s = S.partial_map I o (subsumed_filter (solved_filter s)); + +fun solve s = S.to_list o (raw_solve s); + +fun find s = (fn S.NIL => NONE | S.CONS (x, _) => SOME x) o raw_solve s; + +fun refute s = Option.map unwrap (find s [False]); + +(* ------------------------------------------------------------------------- *) +(* Solver nodes must construct themselves from the following form. *) +(* ------------------------------------------------------------------------- *) + +type form = + {slice : meter ref, (* A meter to stop after each slice *) + units : units ref, (* Solvers share a unit cache *) + thms : thm list, (* Context, assumed consistent *) + hyps : thm list}; (* Hypothesis, no assumptions *) + +(* ------------------------------------------------------------------------- *) +(* Solver nodes also incorporate a name. *) +(* ------------------------------------------------------------------------- *) + +type node_data = {name : string, solver_con : form -> solver}; + +datatype solver_node = + Solver_node of {name : string, initial : string, solver_con : form -> solver}; + +fun mk_solver_node {name, solver_con} = + Solver_node + {name = name, initial = (str o hd o explode) name, solver_con = solver_con}; + +val pp_solver_node = pp_map (fn Solver_node {name, ...} => name) pp_string; + +(* ------------------------------------------------------------------------- *) +(* At each step we schedule a time slice to the least cost solver node. *) +(* ------------------------------------------------------------------------- *) + +val SLICE : limit ref = ref {time = SOME (1.0 / 3.0), infs = NONE}; + +type cost_fn = Meter1.meter_reading -> real; + +local + fun sq x : real = x * x; +in + val time1 : cost_fn = fn {time, ...} => time; + val time2 : cost_fn = fn {time, ...} => sq time; + val infs1 : cost_fn = fn {infs, ...} => Real.fromInt infs; + val infs2 : cost_fn = fn {infs, ...} => sq (Real.fromInt infs); +end; + +(* ------------------------------------------------------------------------- *) +(* This allows us to hierarchically arrange solver nodes. *) +(* ------------------------------------------------------------------------- *) + +local + fun name (Solver_node {name, ...}) = name; + fun initial (Solver_node {initial, ...}) = initial; + fun seq f [] = "" + | seq f (h :: t) = foldl (fn (n, s) => s ^ "," ^ f n) (f h) t; +in + fun combine_names csolvers = "[" ^ seq (name o snd) csolvers ^ "]"; + fun combine_initials csolvers = "[" ^ seq (initial o snd) csolvers ^ "]"; +end; + +datatype subnode = Subnode of + {name : string, + used : meter_reading, + cost : meter_reading -> real, + solns : (unit -> thm list option stream) option}; + +fun init_subnode (cost, (name, solver : solver)) goal = + Subnode + {name = name, + used = zero_reading, + cost = cost, + solns = SOME (fn () => solver goal)}; + +fun least_cost [] = K NONE + | least_cost _ = + (SOME o snd o min (fn (r, _) => fn (s, _) => r <= s) o + map (fn (n, Subnode {used, cost, ...}) => (cost used, n))) + +val choose_subnode = + W least_cost o + List.filter (fn (_, Subnode {solns, ...}) => Option.isSome solns) o + enumerate 0; + +fun subnode_info (Subnode {name, used = {time, infs}, solns, ...}) = + name_to_string name ^ "(" ^ time_to_string time ^ "," ^ + infs_to_string infs ^ ")" ^ (case solns of NONE => "*" | SOME _ => ""); + +local + fun seq f [] = "" + | seq f (h :: t) = foldl (fn (n, s) => s ^ "--" ^ f n) (f h) t; +in + fun status_info subnodes units = + "[" ^ seq subnode_info subnodes ^ "]--u=" ^ U.info units ^ "--"; +end; + +fun schedule check read stat = + let + fun sched nodes = + (chat 2 (stat nodes); + if not (check ()) then + (chat 1 "?\n"; S.CONS (NONE, fn () => sched nodes)) + else + case choose_subnode nodes of NONE => (chat 1 "!\n"; S.NIL) + | SOME n => + let + val Subnode {name, used, solns, cost} = List.nth (nodes, n) + val () = chat 1 name + val seq = (Option.valOf solns) () + val r = read () + val () = chat 2 ("--t=" ^ time_to_string (#time r) ^ "\n") + val used = add_readings used r + val (res, solns) = + case seq of S.NIL => (NONE, NONE) | S.CONS (a, r) => (a, SOME r) + val node = + Subnode {name = name, used = used, cost = cost, solns = solns} + val nodes = update_nth (K node) n nodes + val () = + case res of NONE => () + | SOME _ => (chat 2 (stat nodes); chat 1 "$\n") + in + S.CONS (res, fn () => sched nodes) + end) + in + sched + end; + +fun combine_solvers (n, i) csolvers {slice, units, thms, hyps} = + let + val () = chat 2 + (n ^ "--initializing--#thms=" ^ int_to_string (length thms) ^ + "--#hyps=" ^ int_to_string (length hyps) ^ ".\n") + val meter = ref (new_meter expired) + fun f (Solver_node {initial, solver_con, ...}) = + (initial, + solver_con {slice = meter, units = units, thms = thms, hyps = hyps}) + val cnodes = map (I ## f) csolvers + fun check () = + check_meter (!slice) andalso (meter := sub_meter (!slice) (!SLICE); true) + fun read () = read_meter (!meter) + fun stat s = status_info s (!units) + in + fn goal => schedule check read stat (map (C init_subnode goal) cnodes) + end; + +fun combine csolvers = + let + val n = combine_names csolvers + val i = combine_initials csolvers + in + Solver_node + {name = n, initial = i, solver_con = combine_solvers (n, i) csolvers} + end; + +(* ------------------------------------------------------------------------- *) +(* Overriding the 'natural' set of support from the problem. *) +(* ------------------------------------------------------------------------- *) + +fun sos_solver_con filt name solver_con {slice, units, thms, hyps} = + let + val () = chat 2 + (name ^ "--initializing--#thms=" ^ int_to_string (length thms) ^ + "--#hyps=" ^ int_to_string (length hyps) ^ ".\n") + val (hyps', thms') = List.partition filt (thms @ hyps) + in + solver_con {slice = slice, units = units, thms = thms', hyps = hyps'} + end; + +fun set_of_support filt (Solver_node {name, initial, solver_con}) = + let val name' = "!" ^ name + in + Solver_node + {name = name', initial = initial, + solver_con = sos_solver_con filt name' solver_con} + end; + +val everything : thm -> bool = K true; + +val one_negative = (fn x => null x orelse List.exists negative x) o clause; + +val one_positive = (fn x => null x orelse List.exists positive x) o clause; + +val all_negative = List.all negative o clause; + +val all_positive = List.all positive o clause; + +val nothing : thm -> bool = K false; + +(* ------------------------------------------------------------------------- *) +(* Initializing a solver node makes it ready for action. *) +(* ------------------------------------------------------------------------- *) + +type init_data = {limit : limit, thms : thm list, hyps : thm list} + +fun initialize (Solver_node {solver_con, ...}) {limit, thms, hyps} = + case List.find is_contradiction (thms @ hyps) of SOME th + => contradiction_solver th + | NONE => + let + val meter = ref (new_meter expired) + val units = ref U.empty + val solver = + solver_con {slice = meter, units = units, thms = thms, hyps = hyps} + in + fn g => + let val () = meter := new_meter limit + in drop_after (fn _ => not (check_meter (!meter))) (solver g) + end + end; + +end +(*#line 0.0 "src/Meson1.sig"*) +(* ========================================================================= *) +(* THE MESON PROOF PROCEDURE *) +(* Created by Joe Hurd, November 2001 *) +(* Partly ported from the CAML-Light code accompanying John Harrison's book *) +(* ========================================================================= *) + +signature Meson1 = +sig + +type solver_node = Solver1.solver_node + +(* Tuning parameters *) +type parameters = + {ancestor_pruning : bool, + ancestor_cutting : bool, + state_simplify : bool, + cache_cutting : bool, + divide_conquer : bool, + unit_lemmaizing : bool} + +val defaults : parameters + +(* The meson solver *) +val meson' : parameters -> solver_node +val meson : solver_node (* Uses defaults *) + +(* The delta preprocessor as a solver *) +val delta' : parameters -> solver_node +val delta : solver_node (* Uses defaults *) + +(* The prolog solver *) +val prolog' : parameters -> solver_node +val prolog : solver_node (* Uses defaults *) + +end +(*#line 0.0 "src/Meson1.sml"*) +(* ========================================================================= *) +(* THE MESON PROOF PROCEDURE *) +(* Created by Joe Hurd, November 2001 *) +(* Partly ported from the CAML-Light code accompanying John Harrison's book *) +(* ========================================================================= *) + +(* +app load + ["Useful", "Stream", "Mosml", "Term1", "Thm1", "Canon1", "Match1", + "Solver1", "Meter1", "Units1"]; +*) + +(* +*) +structure Meson1 :> Meson1 = +struct + +open Useful Term1 Match1 Thm1 Canon1 Meter1 Solver1; + +infix |-> ::> @> oo ##; + +structure S = Stream; +structure N = LiteralNet1; +structure U = Units1; + +val |<>| = Subst1.|<>|; +val op ::> = Subst1.::>; +val formula_subst = Subst1.formula_subst; + +(* ------------------------------------------------------------------------- *) +(* Chatting. *) +(* ------------------------------------------------------------------------- *) + +val () = traces := {module = "Meson1", alignment = K 1} :: !traces; + +fun chat l m = trace {module = "Meson1", message = m, level = l}; + +(* ------------------------------------------------------------------------- *) +(* Tuning parameters. *) +(* ------------------------------------------------------------------------- *) + +type parameters = + {ancestor_pruning : bool, + ancestor_cutting : bool, + state_simplify : bool, + cache_cutting : bool, + divide_conquer : bool, + unit_lemmaizing : bool}; + +val defaults = + {ancestor_pruning = true, + ancestor_cutting = true, + state_simplify = true, + cache_cutting = true, + divide_conquer = true, + unit_lemmaizing = true}; + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +fun halves n = let val n1 = n div 2 in (n1, n - n1) end; + +fun splittable [] = false + | splittable [_] = false + | splittable _ = true; + +(* +fun protect r f x = + let + val v = !r + val y = f x handle e as ERR_EXN _ => (r := v; raise e) + val () = r := v + in + y + end; + +fun until p = + let + open Stream + fun u NIL = NIL + | u (CONS (x, xs)) = CONS (x, if p x then K NIL else fn () => u (xs ())) + in + u + end; +*) + +local + val prefix = "_m"; +in + val mk_mvar = mk_prefix prefix o int_to_string; + fun mk_mvars n i = map (Var o mk_mvar) (interval n i); + val dest_mvar = string_to_int o dest_prefix prefix; +end; + +datatype 'a choice = CHOICE of unit -> 'a * 'a choice; + +fun dest_choice (CHOICE c) = c; + +val no_choice = (fn () => raise ERR "no_choice" "always fails"); + +fun binary_choice f g = + (fn () => + let val (a, c) = f () in (a, CHOICE (binary_choice (dest_choice c) g)) end + handle ERR_EXN _ => g ()); + +fun first_choice [] = no_choice + | first_choice [f] = f + | first_choice (f :: fs) = binary_choice f (first_choice fs); + +fun choice_stream f = + let val (a, CHOICE c) = f () in S.CONS (a, fn () => choice_stream c) end + handle ERR_EXN _ => S.NIL; + +fun swivel m n l = + let + val (l1, l') = split l m + val (l2, l3) = split l' n + in + l2 @ l1 @ l3 + end; + +fun thm_proves th False = is_contradiction th + | thm_proves th goal = + case clause th of [lit] => lit = goal | [] => true | _ => false; + +fun filter_meter meter = + S.filter (fn a => Option.isSome a orelse not (check_meter (!meter))); + +(* ------------------------------------------------------------------------- *) +(* Compiling the rule set used by meson. *) +(* ------------------------------------------------------------------------- *) + +type rule = {asms : formula list, c : formula, thm : thm, asmn : int}; + +datatype rules = Rules of rule N.literal_map; + +fun dest_rules (Rules r) = r; +val empty_rules = Rules N.empty; +val num_all_rules = N.size o dest_rules; +val num_initial_rules = #f o N.size_profile o dest_rules; +fun num_rules r = num_all_rules r - num_initial_rules r; +val rules_unify = N.unify o dest_rules; + +val pp_rules = + pp_map dest_rules + (N.pp_literal_map + (pp_map (fn {asms, c, ...} => (asms, c)) + (pp_binop " ==>" (pp_list pp_formula) pp_formula))); + +fun add_contrapositives chosen sos th (Rules ruls) = + let + val th = FRESH_VARS th + val lits = clause th + val lits' = map negate lits + val base = map (fn l => (subtract lits' [negate l], l)) (chosen lits) + val contrs = if sos then (lits', False) :: base else base + fun f (a, c) = c |-> {asms = a, c = c, thm = th, asmn = length a} + in + Rules (foldl (fn (h, t) => N.insert (f h) t) ruls contrs) + end; + +fun thms_to_rules chosen thms hyps = + let val f = uncurry o add_contrapositives chosen + in foldl (f true) (foldl (f false) empty_rules thms) hyps + end; + +val meson_rules = thms_to_rules I; + +val prolog_rules = thms_to_rules (wrap o hd); + +(* ------------------------------------------------------------------------- *) +(* Creating the delta goals. *) +(* ------------------------------------------------------------------------- *) + +val thms_to_delta_goals = + List.concat o + map (fn (f,n) => [Atom (Fn (f,new_vars n)), Not (Atom (Fn (f,new_vars n)))]) o + foldl (uncurry union) [] o + map relations o + List.concat o + map clause; + +(* ------------------------------------------------------------------------- *) +(* The state passed around by meson. *) +(* ------------------------------------------------------------------------- *) + +type state = {env : subst, depth : int, proof : thm list, offset : int}; + +fun update_env f ({env, depth, proof, offset} : state) = + {env = f env, depth = depth, proof = proof, offset = offset}; + +fun update_depth f ({env, depth, proof, offset} : state) = + {env = env, depth = f depth, proof = proof, offset = offset}; + +fun update_proof f ({env, depth, proof, offset} : state) = + {env = env, depth = depth, proof = f proof, offset = offset}; + +fun update_offset f ({env, depth, proof, offset} : state) = + {env = env, depth = depth, proof = proof, offset = f offset}; + +(* ------------------------------------------------------------------------- *) +(* Ancestor pruning. *) +(* ------------------------------------------------------------------------- *) + +fun ancestor_prune false _ _ = K false + | ancestor_prune true env g = + let + val g' = formula_subst env g + fun check a' = a' = g' + in + List.exists (check o formula_subst env) + end; + +(* ------------------------------------------------------------------------- *) +(* Ancestor cutting. *) +(* ------------------------------------------------------------------------- *) + +fun ancestor_cut false _ _ = K false + | ancestor_cut true env g = + let + val g' = negate (formula_subst env g) + fun check a' = a' = g' + in + List.exists (check o formula_subst env) + end; + +(* ------------------------------------------------------------------------- *) +(* Cache cutting. *) +(* ------------------------------------------------------------------------- *) + +fun cache_cont c ({offset, ...} : state) = + let + fun f v = case total dest_mvar v of NONE => true | SOME n => n < offset + val listify = Subst1.foldr (fn m as v |-> _ => if f v then cons m else I) [] + val mem = ref [] + fun purify (s as {env, depth = n, ...} : state) = + let + val l = listify env + fun p (n', l') = n <= n' andalso l = l' + in + if List.exists p (!mem) then raise ERR "cache_cut" "repetition" + else (mem := (n, l) :: (!mem); update_env (K (Subst1.from_maplets l)) s) + end + in + c o purify + end; + +fun cache_cut false = I + | cache_cut true = + fn f => fn a => fn g => fn c => fn s => f a g (cache_cont c s) s; + +(* ------------------------------------------------------------------------- *) +(* Unit clause shortcut. *) +(* ------------------------------------------------------------------------- *) + +fun grab_unit units (s as {proof = th :: _, ...} : state) = + (units := U.add th (!units); s) + | grab_unit _ {proof = [], ...} = raise BUG "grab_unit" "no thms"; + +fun use_unit units g c (s as {env, ...}) = + let val prove = partial (ERR "use_unit" "NONE") (U.prove (!units)) + in c (update_proof (cons (unwrap (prove [formula_subst env g]))) s) + end; + +fun unit_cut false _ = I + | unit_cut true units = + fn f => fn a => fn g => fn c => fn s => + use_unit units g c s handle ERR_EXN _ => f a g (c o grab_unit units) s; + +(* ------------------------------------------------------------------------- *) +(* The core of meson: ancestor unification or Prolog-style extension. *) +(* ------------------------------------------------------------------------- *) + +fun freshen_rule ({thm, asms, c, ...} : rule) i = + let + val fvs = FVL (c :: asms) + val fvn = length fvs + val mvs = mk_mvars i fvn + val sub = Subst1.from_maplets (zipwith (curry op|->) fvs mvs) + in + ((INST sub thm, map (formula_subst sub) asms, formula_subst sub c), i + fvn) + end; + +fun reward r = update_depth (fn n => n + r); + +fun spend m f c (s as {depth = n, ...} : state) = + let + val low = n - m + val () = assert (0 <= low) (ERR "meson" "impossible divide and conquer") + fun check (s' as {depth = n', ...} : state) = + if n' <= low then s' else raise ERR "meson" "divide and conquer" + in + f (c o check) s + end; + +local + fun unify env (th, asms, c) g = (th, asms, unify_literals env c g) + + fun match env (th, asms, c) g = + let val sub = match_literals c g + in (INST sub th, map (formula_subst sub) asms, env) + end; +in + fun next_state false env r g = unify env r g + | next_state true env r g = match env r g handle ERR_EXN _ => unify env r g; +end; + +local + fun mp _ th [] p = FACTOR th :: p + | mp env th (g :: gs) (th1 :: p) = + mp env (RESOLVE (formula_subst env g) (INST env th1) th) gs p + | mp _ _ (_ :: _) [] = raise BUG "modus_ponens" "fresh out of thms" +in + fun modus_ponens th gs (state as {env, ...}) = + update_proof (mp env (INST env th) (rev gs)) state; +end; + +fun swivelp m n = update_proof (swivel m n); + +fun meson_expand {parm : parameters, rules, cut, meter, saturated} = + let + fun expand ancestors g cont (state as {env, ...}) = + if not (check_meter (!meter)) then + (NONE, CHOICE (fn () => expand ancestors g cont state)) + else if ancestor_prune (#ancestor_pruning parm) env g ancestors then + raise ERR "meson" "ancestor pruning" + else if ancestor_cut (#ancestor_cutting parm) env g ancestors then + (record_infs (!meter) 1; cont (update_proof (cons (ASSUME g)) state)) + else + let + (*val () = print ("meson: " ^ formula_to_string g ^ ".\n")*) + fun reduction a () = + let + val state = update_env (K (unify_literals env g (negate a))) state + val state = update_proof (cons (ASSUME g)) state + in + (record_infs (!meter) 1; cont state) + end + val expansion = expand_rule ancestors g cont state + in + first_choice + (map reduction ancestors @ + map expansion (rules_unify rules (formula_subst env g))) () + end + and expand_rule ancestors g cont {env, depth, proof, offset} r () = + let + val depth = depth - #asmn r + val () = + if 0 <= depth then () + else (saturated := false; raise ERR "meson" "too deep") + val (r, offset) = freshen_rule r offset + val (th, asms, env) = next_state (#state_simplify parm) env r g + val () = record_infs (!meter) 1 + in + expands (g :: ancestors) asms (cont o modus_ponens th asms) + {env = env, depth = depth, proof = proof, offset = offset} + end + and expands ancestors g c (s as {depth = n, ...}) = + if #divide_conquer parm andalso splittable g then + let + val (l1, l2) = halves (length g) + val (g1, g2) = split g l1 + val (f1, f2) = Df (expands ancestors) (g1, g2) + val (n1, n2) = halves n + val s = update_depth (K n1) s + in + binary_choice + (fn () => f1 (f2 c o reward n2) s) + (fn () => f2 (spend (n1 + 1) f1 (c o swivelp l1 l2) o reward n2) s) () + end + else foldl (uncurry (cut expand ancestors)) c (rev g) s + in + cut expand [] + end; + +(* ------------------------------------------------------------------------- *) +(* Full meson procedure. *) +(* ------------------------------------------------------------------------- *) + +fun meson_finally g ({env, proof, ...} : state) = + let + val () = assert (length proof = length g) (BUG "meson" "bad final state") + val g' = map (formula_subst env) g + val proof' = map (INST env) (rev proof) + (*val () = (print "meson_finally: "; printVal (g', proof'); print ".\n")*) + val () = + assert (List.all (uncurry thm_proves) (zip proof' g')) + (BUG "meson" "did not prove goal list") + in + (SOME (FRESH_VARSL proof'), CHOICE no_choice) + end; + +fun raw_meson system goals depth = + choice_stream + (fn () => + foldl (uncurry (meson_expand system)) (meson_finally goals) (rev goals) + {env = |<>|, depth = depth, proof = [], offset = 0}); + +(* ------------------------------------------------------------------------- *) +(* Raw solvers. *) +(* ------------------------------------------------------------------------- *) + +type 'a system = + {parm : parameters, rules : rules, meter : meter ref, saturated : bool ref, + cut : + (formula list -> formula -> (state -> 'a) -> state -> 'a) -> + formula list -> formula -> (state -> 'a) -> state -> 'a}; + +fun mk_system parm units meter rules : 'a system = + let + val {cache_cutting = caching, unit_lemmaizing = lemmaizing, ...} = parm + in + {parm = parm, + rules = rules, + meter = meter, + saturated = ref false, + cut = unit_cut lemmaizing units o cache_cut caching} + end; + +fun meson' parm = + mk_solver_node + {name = "meson", + solver_con = + fn {slice, units, thms, hyps} => + let + val ruls = meson_rules thms hyps + val () = chat 2 + ("meson--initializing--#thms=" ^ int_to_string (length thms) ^ + "--#hyps=" ^ int_to_string (length hyps) ^ + "--#rules=" ^ int_to_string (num_rules ruls) ^ + "--#initial_rules=" ^ int_to_string (num_initial_rules ruls) ^ ".\n") + val system as {saturated = b, ...} = mk_system parm units slice ruls + fun d n = if !b then S.NIL else (b := true; S.CONS (n, fn () => d (n + 1))) + fun f q d = (chat 1 ("-" ^ int_to_string d); raw_meson system q d) + fun unit_check goals NONE = U.prove (!units) goals | unit_check _ s = s + in + fn goals => + filter_meter slice + (S.map (unit_check goals) (S.flatten (S.map (f goals) (d 0)))) + end}; + +val meson = meson' defaults; + +fun delta' parm = + mk_solver_node + {name = "delta", + solver_con = + fn {slice, units, thms, hyps} => + let + val ruls = meson_rules thms hyps + val dgoals = thms_to_delta_goals hyps + val () = chat 2 + ("delta--initializing--#thms=" ^ int_to_string (length thms) ^ + "--#hyps=" ^ int_to_string (length hyps) ^ + "--#rules=" ^ int_to_string (num_rules ruls) ^ + "--#delta_goals=" ^ int_to_string (length dgoals) ^ ".\n") + val system as {saturated = b, ...} = mk_system parm units slice ruls + val delta_goals = S.from_list dgoals + fun d n = if !b then S.NIL else (b := true; S.CONS (n, fn () => d (n + 1))) + fun f d g = (chat 1 "+"; S.map (K NONE) (raw_meson system [g] d)) + fun g d = (chat 1 (int_to_string d); S.flatten (S.map (f d) delta_goals)) + fun h () = S.flatten (S.map g (d 0)) + fun unit_check goals NONE = U.prove (!units) goals | unit_check _ s = s + in + case delta_goals of S.NIL => K S.NIL + | _ => fn goals => filter_meter slice (S.map (unit_check goals) (h ())) + end}; + +val delta = delta' defaults; + +val prolog_depth = case Int.maxInt of NONE => 1000000 | SOME i => i; + +fun prolog' parm = + mk_solver_node + {name = "prolog", + solver_con = + fn {slice, units, thms, hyps} => + let + val system = mk_system parm units slice (prolog_rules thms hyps) + fun comment S.NIL = "!\n" + | comment (S.CONS (NONE, _)) = "-" + | comment (S.CONS (SOME _, _)) = "$\n" + fun f t () = let val x = t () in chat 1 (comment x); x end + in + fn goals => S.map_thk f (fn () => raw_meson system goals prolog_depth) () + end}; + +val prolog = prolog' defaults; + +(* quick testing +load "Problem1"; +open Problem1; +val time = Mosml.time; +quotation := true; +installPP pp_term; +installPP pp_formula; +installPP Subst1.pp_subst; +installPP pp_rules; +installPP pp_thm; + +val limit : limit ref = ref {infs = NONE, time = SOME 30.0}; +fun prolog_solve d q = + try + (solve + (initialize prolog {limit = !limit, thms = d, hyps = []})) q; +fun meson_prove g = + try (time refute) + (initialize (set_of_support all_negative meson) + {limit = !limit, thms = [], hyps = axiomatize (Not (generalize g))}); +fun delta_prove g = + try (time refute) + (initialize (set_of_support all_negative delta) + {limit = !limit, thms = [], hyps = eq_axiomatize (Not (generalize g))}); + +(* Testing the delta prover *) + +val p48 = parse_formula (get equality "P48"); +delta_prove p48; + +(* Testing the prolog solver *) + +val database = (axiomatize o parse_formula) + [ + +QUOTE "subset nil nil /\\\n (!v x y. subset x y ==> subset (v :: x) (v :: y)) /\\\n (!v x y. subset x y ==> subset x (v :: y))"]; + +try (prolog_solve database) [parse_formula [QUOTE "subset x (0 :: 1 :: 2 :: nil)"]]; +(* takes ages +try (prolog_solve database) [parse_formula `subset (0 :: 1 :: 2 :: nil) x`]; +*) + +val database = (axiomatize o parse_formula) + [ + + +QUOTE "p 0 3 /\\\n (!x. p x 4) /\\\n (!x. p x 3 ==> p (s (s (s x))) 3) /\\\n (!x. p (s x) 3 ==> p x 3)"]; + +try (prolog_solve database) [parse_formula [QUOTE "p (s 0) 3"]]; + +(* Testing the meson prover *) + +meson_prove True; + +val p59 = parse_formula (get nonequality "P59"); +val ths = axiomatize (Not (generalize p59)); +val rules = meson_rules [] ths; +rules_unify rules (parse_formula [QUOTE "~P 0"]); +meson_prove p59; + +val p39 = parse_formula (get nonequality "P39"); +clausal (Not (generalize p39)); +axiomatize (Not (generalize p39)); +meson_prove p39; + +val num14 = parse_formula (get tptp "NUM014-1"); +meson_prove num14; + +val p55 = parse_formula (get nonequality "P55"); +meson_prove p55; + +val p26 = parse_formula (get nonequality "P26"); +clausal (Not (generalize p26)); +meson_prove p26; + +val los = parse_formula (get nonequality "LOS"); +meson_prove los; + +val reduced_num284 = parse_formula + [ + + + + + +QUOTE "fibonacci 0 (s 0) /\\ fibonacci (s 0) (s 0) /\\\n (!x y z x' y' z'.\n ~sum x (s (s 0)) z \\/ ~sum y (s 0) z \\/\n ~fibonacci x x' \\/ ~fibonacci y y' \\/ ~sum x' y' z' \\/\n fibonacci z z') /\\ (!x. sum x 0 x) /\\\n (!x y z. ~sum x y z \\/ sum x (s y) (s z)) /\\\n (!x. ~fibonacci (s (s (s (s (s (s (s (s 0)))))))) x) ==> F"]; +meson_prove reduced_num284; + +val p29 = parse_formula (get nonequality "P29"); +clausal (Not (generalize p29)); +meson_prove p29; + +val num1 = parse_formula (get tptp "NUM001-1"); +meson_prove num1; + +val model_completeness = parse_formula (get nonequality "MODEL_COMPLETENESS"); +meson_prove model_completeness; +*) + +end +(*#line 0.0 "src/Resolvers1.sig"*) +(* ========================================================================= *) +(* A TYPE TO FIND RESOLVANT CLAUSES *) +(* Created by Joe Hurd, April 2002 *) +(* ========================================================================= *) + +signature Resolvers1 = +sig + +type 'a pp = 'a Useful.pp +type formula = Term1.formula +type subst = Subst1.subst +type thm = Thm1.thm + +type resolvers +type resolvant = {mate : thm, sub : subst, res : thm} + +val empty_resolvers : resolvers +val add_resolver : thm -> resolvers -> resolvers +val find_resolvants : resolvers -> thm -> resolvant list +val resolvers_info : resolvers -> string +val pp_resolvers : resolvers pp + +end +(*#line 0.0 "src/Resolvers1.sml"*) +(* ========================================================================= *) +(* A TYPE TO FIND RESOLVANT CLAUSES *) +(* Created by Joe Hurd, April 2002 *) +(* ========================================================================= *) + +(* +app load ["Thm1", "Match1"]; +*) + +(* +*) +structure Resolvers1 :> Resolvers1 = +struct + +infix |-> ::>; + +open Useful Term1 Match1 Thm1 Canon1; + +structure N = LiteralNet1; + +val |<>| = Subst1.|<>|; +val op ::> = Subst1.::>; +val formula_subst = Subst1.formula_subst; + +(* ------------------------------------------------------------------------- *) +(* Chatting. *) +(* ------------------------------------------------------------------------- *) + +val () = traces := {module = "Resolvers1", alignment = K 1} :: !traces; + +fun chat l m = trace {module = "Resolvers1", message = m, level = l}; + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +fun trich l n = + case split l n of (_, []) => raise ERR "trich" "no exact" + | (l, h :: t) => (l, h, t); + +(* ------------------------------------------------------------------------- *) +(* The type definition with some simple operations. *) +(* ------------------------------------------------------------------------- *) + +type resolvers = (int * thm) N.literal_map; + +type resolvant = {mate : thm, sub : subst, res : thm}; + +val empty_resolvers : resolvers = N.empty; + +fun add_resolver th = + let fun add_lit ((n, lit), net) = N.insert (lit |-> (n, th)) net + in fn net => foldl add_lit net (enumerate 0 (clause th)) + end; + +fun resolvers_info (net : resolvers) = int_to_string (N.size net); + +val pp_resolvers = pp_map resolvers_info pp_string; + +val dest_resolvers : resolvers -> thm list = + map snd o List.filter (equal 0 o fst) o N.to_list; + +(* ------------------------------------------------------------------------- *) +(* A reference implementation for debugging. *) +(* ------------------------------------------------------------------------- *) + +fun canonize lits = + let + val nvars = enumerate 0 (FV (list_mk_conj lits)) + val ms = map (fn (n, v) => v |-> Var ("__" ^ (int_to_string n))) nvars + in + map (formula_subst (Subst1.from_maplets ms)) lits + end; + +local + fun subs acc [] = acc + | subs acc ((prev, []) :: others) = subs (prev :: acc) others + | subs acc ((prev, h :: t) :: others) = + subs acc ((h :: prev, t) :: (prev, t) :: others); +in + fun all_nonempty_subsets l = tl (subs [] [([], l)]); +end; + +fun pairs [] = raise ERR "pairs" "empty" + | pairs [h] = [] + | pairs (h :: (t as h' :: _)) = (h, h') :: pairs t; + +fun sanity_resolve_on th th' s s' = + let + val sub = unifyl_literals |<>| (pairs (s @ s')) + val lit = formula_subst sub (hd s) + val res = FACTOR (RESOLVE lit (INST sub th) (INST sub th')) + in + {mate = th', sub = sub, res = res} + end; + +fun sanity_resolve th th' = + List.mapPartial I + (cartwith (total o sanity_resolve_on th th') + (all_nonempty_subsets (clause th)) + (all_nonempty_subsets (map negate (clause th')))); + +fun sanity_resolvants net th = + List.concat (map (sanity_resolve th) (dest_resolvers net)); + +fun sanity_check net th (res : resolvant list) = + let + val () = chat 1 "X" + val f = PP.pp_to_string (!LINE_LENGTH) (pp_list (pp_map AXIOM pp_thm)) + val fast = map (canonize o clause o #res) res + val slow = map (canonize o clause o #res) (sanity_resolvants net th) + val () = + if subset fast slow then () + else + (print ("\nsanity_check: extra clauses:\nnet = " ^ + f (map clause (dest_resolvers net)) ^ "\nth = " ^ + thm_to_string th ^ "\nfast = " ^ f fast ^ "\nslow = " ^ f slow ^ + "\nextra = " ^ f (subtract fast slow) ^ + "\nmissing = " ^ f (subtract slow fast) ^ "\n"); + raise BUG "find_resolvants" "extra clauses!") + val () = + if subset slow fast then () + else + (print ("\nsanity_check: missing clauses:\nnet = " ^ + f (map clause (dest_resolvers net)) ^ "\nth = " ^ + thm_to_string th ^ "\nfast = " ^ f fast ^ "\nslow = " ^ f slow ^ + "\nmissing = " ^ f (subtract slow fast) ^ + "\nextra = " ^ f (subtract fast slow) ^ "\n"); + raise BUG "find_resolvants" "missing clauses") +(* + val () = + (print ("\nsanity_check: ok:\nnet = " ^ + f (map clause (dest_resolvers net)) ^ "\nth = " ^ + thm_to_string th ^ "\nres = " ^ f fast ^ "\n")) +*) + in + () + end; + +(* ------------------------------------------------------------------------- *) +(* The core engine for combined factor/resolution steps. *) +(* ------------------------------------------------------------------------- *) + +fun resolve_on s r th th' = + SOME (FACTOR (RESOLVE r (INST s th) (INST s th'))); + +fun resolve acc [] = acc + | resolve acc ((avoid, sub, res, []) :: others) = + resolve + (if mem res (map (formula_subst sub) avoid) then acc + else (res, sub) :: acc) others + | resolve acc ((avoid, sub, res, x :: xs) :: others) = + let + fun f c = resolve acc (c ((x :: avoid, sub, res, xs) :: others)) + in + case total (unify_literals sub res) x of NONE => f I + | SOME sub' + => f (cons (avoid, Subst1.refine sub sub', formula_subst sub' res, xs)) + end; + +fun resolve_from (n, th) (n', th') = + let + val (prev, lit, succ) = trich (clause th) n + val (prev', lit', succ') = trich (map negate (clause th')) n' + val sub = unify_literals |<>| lit lit' + val res = formula_subst sub lit + fun f (r, s) = Option.map (pair s) (resolve_on s r th th') + in + List.mapPartial f (resolve [] [(prev @ prev', sub, res, succ @ succ')]) + end; + +fun resolvants net th = + let + fun g (_, mate) ((sub, res), l) = {mate = mate, sub = sub, res = res} :: l + fun r m (u, acc) = + case total (resolve_from (m, th)) u of NONE => acc + | SOME l => foldl (g u) acc l + fun f ((m, lit), acc) = foldl (r m) acc (N.unify net (negate lit)) + val res = foldl f [] (enumerate 0 (clause th)) + (*val () = sanity_check net th res*) + in + res + end + +fun find_resolvants net th = + List.filter (non tautologous o clause o #res) (resolvants net th) + handle ERR_EXN _ => raise BUG "find_resolvants" "should never fail"; + +(* Quick testing +quotation := true; +installPP pp_formula; +installPP pp_term; +installPP pp_subst; +installPP pp_thm; +val th = AXIOM (map parse [`p(3, x, v)`, `q(x)`, `p(3, x, z)`]); +val th' = AXIOM (map parse [`~p(3, f(y), w)`, `~q(y)`, `~p(3, f(y), 4)`]); +try (resolve_from (0, th)) (0, th'); +try (resolve_from (2, th)) (0, th'); +try (resolve_from (0, th)) (2, th'); +try (resolve_from (2, th)) (2, th'); +val r = add_resolver th' empty_resolvers; +map #res (find_resolvants r th); +*) + +end +(*#line 0.0 "src/Theap1.sig"*) +(* ========================================================================= *) +(* A TYPE TO STORE CLAUSES WAITING TO BE USED (THEAP = THEOREM HEAP) *) +(* Created by Joe Hurd, April 2002 *) +(* ========================================================================= *) + +signature Theap1 = +sig + +type 'a subsume = 'a Subsume1.subsume +type thm = Thm1.thm + +(* Tuning parameters *) +type parameters = {fifo_skew : int, cleaning_freq : int} +val defaults : parameters + +(* Theorem HEAPs *) +type theap +val new_theap : parameters -> theap +val empty_theap : theap (* Uses defaults *) +val theap_size : theap -> int +val theap_add : thm -> theap -> theap +val theap_addl : thm list -> theap -> theap +val theap_remove : theap -> (thm * theap) option +val theap_subsumers : theap -> thm subsume +val theap_info : theap -> string (* Outputs "(size,weight)" *) + +end +(*#line 0.0 "src/Theap1.sml"*) +(* ========================================================================= *) +(* A TYPE TO STORE CLAUSES WAITING TO BE USED (THEAP = THEOREM HEAP) *) +(* Created by Joe Hurd, April 2002 *) +(* ========================================================================= *) + +(* +app load ["Heap", "Queue", "Thm1", "Subsumers1"]; +*) + +(* +*) +structure Theap1 :> Theap1 = +struct + +infix |->; + +open Useful Term1 Thm1; + +structure Q = Queue; +structure H = Heap; +structure S = Subsume1; + +type 'a queue = 'a Q.queue; +type 'a heap = 'a H.heap; +type 'a subsume = 'a S.subsume; + +(* ------------------------------------------------------------------------- *) +(* Tuning parameters. *) +(* ------------------------------------------------------------------------- *) + +type parameters = {fifo_skew : int, cleaning_freq : int} + +val defaults = {fifo_skew = 3, cleaning_freq = 1000}; + +(* ------------------------------------------------------------------------- *) +(* Theorem HEAPs. *) +(* ------------------------------------------------------------------------- *) + +type theap = + ((int * int) * (int * int)) * thm queue * (int * (int * thm) heap) * + thm subsume; + +local fun order ((m, _ : thm), (n, _ : thm)) = Int.compare (m, n); +in val empty_theap_heap = H.empty order; +end; + +fun new_theap {fifo_skew, cleaning_freq} = + ((D cleaning_freq, D fifo_skew), Q.empty, (0, empty_theap_heap), S.empty); + +val empty_theap: theap = new_theap defaults; + +fun theap_size (_, _, (_, h), _) = H.size h; +fun theap_weight (_, _, (w, _), _) = w; + +(* +fun clean_theap (((_, C), F), Q, (_, H), _) = + let + val hash = Polyhash.mkPolyTable (10000, ERR "cleap_theap" "not found") + fun mark (v, th) = Polyhash.insert hash (clause th, v) + val () = H.app mark H + fun add (v, th) (q, w, h, l) = + (Q.add th q, w + v, H.add (v, th) h, S.add (clause th |-> th) l) + fun check q n = + if Q.is_empty q then n + else + let + val th = Q.hd q + in + check (Q.tl q) + (case total (Polyhash.remove hash) (clause th) of NONE => n + | SOME v => add (v, th) n) + end + in + (fn (q, w, h, l) => (((C, C), F), q, (w, h), l)) + (check Q (Q.empty, 0, empty_theap_heap, S.empty)) + end; +*) + +(*fun theap_add th (h as (((0,_), _), _, _, _)) = theap_add th (clean_theap h)*) +fun theap_add th (((c, cm), f), q, (w, h), l) = + let + val cl = clause th + val v = formula_size (list_mk_disj cl) + val h' = H.add (v, th) h + in + (((c - 1, cm), f), Q.add th q, (w + v, h'), S.add (clause th |-> th) l) + end; + +fun theap_addl ths h = foldl (uncurry theap_add) h ths; + +fun theap_remove ((c, (0, f)), q, h, l) = + if Q.is_empty q then NONE + else SOME (Q.hd q, ((c, (f, f)), Q.tl q, h, l)) + | theap_remove ((c, (n, f)), q, (w, h), l) = + if H.is_empty h then NONE + else + let val ((v, x), h) = H.remove h + in SOME (x, ((c, (n - 1, f)), q, (w - v, h), l)) + end; + +fun theap_subsumers (_, _, _, l) = l; + +fun theap_info thp = + "(" ^ int_to_string (theap_size thp) ^ "," ^ + int_to_string (theap_weight thp) ^ ")"; + +end +(*#line 0.0 "src/Resolution1.sig"*) +(* ========================================================================= *) +(* THE RESOLUTION PROOF PROCEDURE *) +(* Created by Joe Hurd, November 2001 *) +(* ========================================================================= *) + +signature Resolution1 = +sig + +type solver_node = Solver1.solver_node + +(* Tuning parameters *) +type parameters = + {subsumption_checking : int, (* in the range 0..3 *) + positive_refinement : bool, + theap_parm : Theap1.parameters} + +val defaults : parameters + +(* Resolution *) +val resolution' : parameters -> solver_node +val resolution : solver_node (* Uses defaults *) + +end +(*#line 0.0 "src/Resolution1.sml"*) +(* ========================================================================= *) +(* THE RESOLUTION PROOF PROCEDURE *) +(* Created by Joe Hurd, November 2001 *) +(* ========================================================================= *) + +(* +app load + ["Useful", "Mosml", "Term1", "Thm1", "Canon1", "Theap1", + "Stream", "Solver1", "Meter1", "Units1", "Resolvers1"]; +*) + +(* +*) +structure Resolution1 :> Resolution1 = +struct + +open Useful Term1 Thm1 Canon1 Meter1 Solver1 Resolvers1 Theap1; + +infix |-> ::> @> oo ## ::* ::@; + +structure S = Stream; +structure U = Units1; + +type 'a subsume = 'a Subsume1.subsume; + +(* ------------------------------------------------------------------------- *) +(* Chatting. *) +(* ------------------------------------------------------------------------- *) + +val () = traces := {module = "Resolution1", alignment = K 1} :: !traces; + +fun chat l m = trace {module = "Resolution1", message = m, level = l}; + +(* ------------------------------------------------------------------------- *) +(* Tuning parameters. *) +(* ------------------------------------------------------------------------- *) + +type parameters = + {subsumption_checking : int, (* in the range 0..3 *) + positive_refinement : bool, + theap_parm : Theap1.parameters} + +val defaults = + {subsumption_checking = 1, + positive_refinement = true, + theap_parm = Theap1.defaults}; + +(* ------------------------------------------------------------------------- *) +(* Clause stores. *) +(* ------------------------------------------------------------------------- *) + +type store = thm subsume * resolvers; + +val empty_store : store = (Subsume1.empty, empty_resolvers); + +fun store_add th (s, r) = + (Subsume1.add (clause th |-> th) s, add_resolver th r); + +fun store_resolvants ((_, r) : store) = find_resolvants r; + +fun store_subsumed ((s, _) : store) = Subsume1.subsumed s o clause; + +fun store_info (s, r) = "(" ^ Subsume1.info s ^ "," ^ resolvers_info r ^ ")"; + +(* ------------------------------------------------------------------------- *) +(* Positive refinement. *) +(* ------------------------------------------------------------------------- *) + +local + val pos_th = List.all positive o clause; + + fun check true = K true + | check false = fn ({mate, ...} : resolvant) => pos_th mate; +in + fun positive_check false = K (K true) + | positive_check true = check o pos_th; +end; + +(* ------------------------------------------------------------------------- *) +(* Full resolution procedure. *) +(* ------------------------------------------------------------------------- *) + +exception Contradiction of thm; + +fun unit_strengthen units th = + (case first (U.subsumes units) (clause th) of SOME th => th + | NONE => U.demod units th); + +fun subsumption_check store th = + case store_subsumed store th of [] => SOME th | _ :: _ => NONE; + +fun theap_strengthen theap th = + (case Subsume1.strictly_subsumed (theap_subsumers theap) (clause th) of [] + => th + | (_, th) :: _ => th); + +fun resolve (parm : parameters) = + let + fun feedback k r = + int_to_string k ^ (if k = r then "" else "/" ^ int_to_string r) + + fun L n = n <= #subsumption_checking parm + val pos_filt = Option.filter o positive_check (#positive_refinement parm) + + fun ftest b f = if b then Option.mapPartial (subsumption_check f) else I + fun stest b s = if b then subsumption_check s else SOME + fun wpass b w = if b then theap_strengthen w else I + fun upass u = unit_strengthen u + + fun next_candidate u f s w = + case theap_remove w of NONE => NONE + | SOME (th, w) => + (case (ftest (L 1) f o stest (L 1) s o wpass (L 2) w o upass u) th of + NONE => next_candidate u f s w + | SOME th => SOME (th, w)) + + fun retention_test u f s th = + List.mapPartial + (Option.mapPartial (ftest (L 3) f o stest (L 3) s o upass u o #res) o + pos_filt th) + + fun check_add th = + if is_contradiction th then raise Contradiction th else U.add th + in + fn record => fn (facts, used, unused) => fn units => + (case next_candidate units facts used unused of NONE => NONE + | SOME (th, unused) => + let + val units = check_add th units + val used = store_add th used + val th = FRESH_VARS th + val resolvants = + store_resolvants facts th @ store_resolvants used th + val () = record (length resolvants) + val units = foldl (uncurry check_add) units (map #res resolvants) + val keep = retention_test units facts used th resolvants + val () = chat 2 (feedback (length keep) (length resolvants)) + val unused = theap_addl keep unused + in + SOME ((facts, used, unused), units) + end) + handle ERR_EXN _ => raise BUG "resolve" "shouldn't fail" + end; + +fun raw_resolution parm = + mk_solver_node + {name = "resolution", + solver_con = + fn {slice, units, thms, hyps} => + let + val resolve' = resolve parm + fun run wrap state = + if not (check_meter (!slice)) then S.CONS (NONE, wrap state) + else + (chat 1 "+"; + case resolve' (record_infs (!slice)) state (!units) of NONE => S.NIL + | SOME (state, units') => (units := units'; run wrap state)) + fun wrapper g (a as (_, _, w)) () = + (chat 2 (theap_info w); run (wrapper g) a) + handle Contradiction th => contradiction_solver th g + val facts = foldl (fn (t, l) => store_add t l) empty_store thms + val used = empty_store + val unused = theap_addl hyps (new_theap (#theap_parm parm)) + val () = chat 2 + ("resolution--initializing--#thms=" ^ int_to_string (length thms) ^ + "--#hyps=" ^ int_to_string (length hyps) ^ + "--facts=" ^ store_info facts ^ + "--unused=" ^ theap_info unused ^ ".\n") + in + fn goals => wrapper goals (facts, used, unused) () + end}; + +fun resolution' parm = + (if #positive_refinement parm then set_of_support everything else I) + (raw_resolution parm); + +val resolution = resolution' defaults; + +(* quick testing +load "Problem1"; +open Problem1; +val time = Mosml.time; +quotation := true; +installPP pp_term; +installPP pp_formula; +installPP Subst1.pp_subst; +installPP pp_thm; + +(* Testing the resolution prover *) + +val limit : limit ref = ref {infs = NONE, time = SOME 30.0}; +fun resolution_prove g = + try (time refute) + (initialize (set_of_support all_negative resolution) + {limit = !limit, thms = [], hyps = axiomatize (Not (generalize g))}); + +axiomatize (Not (generalize True)); +resolution_prove True; + +val prop13 = parse_formula (get nonequality "PROP_13"); +axiomatize (Not (generalize prop13)); +resolution_prove prop13; + +val p33 = parse_formula (get nonequality "P33"); +axiomatize (Not (generalize p33)); +resolution_prove p33; + +val p59 = parse_formula (get nonequality "P59"); +val ths = axiomatize (Not (generalize p59)); +resolution_prove p59; + +val p39 = parse_formula (get nonequality "P39"); +clausal (Not (generalize p39)); +axiomatize (Not (generalize p39)); +resolution_prove p39; + +val num14 = parse_formula (get tptp "NUM014-1"); +resolution_prove num14; + +val p55 = parse_formula (get nonequality "P55"); +resolution_prove p55; + +val p26 = parse_formula (get nonequality "P26"); +clausal (Not (generalize p26)); +resolution_prove p26; + +val los = parse_formula (get nonequality "LOS"); +resolution_prove los; + +val reduced_num284 = parse_formula + [ + + + + + +QUOTE "fibonacci 0 (s 0) /\\ fibonacci (s 0) (s 0) /\\\n (!x y z x' y' z'.\n ~sum x (s (s 0)) z \\/ ~sum y (s 0) z \\/\n ~fibonacci x x' \\/ ~fibonacci y y' \\/ ~sum x' y' z' \\/\n fibonacci z z') /\\ (!x. sum x 0 x) /\\\n (!x y z. ~sum x y z \\/ sum x (s y) (s z)) /\\\n (!x. ~fibonacci (s (s (s (s (s (s (s (s 0)))))))) x) ==> F"]; +resolution_prove reduced_num284; + +val p29 = parse_formula (get nonequality "P29"); +clausal (Not (generalize p29)); +resolution_prove p29; + +val num1 = parse_formula (get tptp "NUM001-1"); +resolution_prove num1; + +val gilmore9 = parse_formula (get nonequality "GILMORE_9"); +axiomatize (Not (generalize gilmore9)); +resolution_prove gilmore9; + +val model_completeness = parse_formula (get nonequality "MODEL_COMPLETENESS"); +resolution_prove model_completeness; +*) + +end +(*#line 0.0 "src/Metis1.sig"*) +(* ========================================================================= *) +(* THE METIS COMBINATION OF PROOF PROCEDURES FOR FIRST-ORDER LOGIC *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +signature Metis1 = +sig + +type formula = Term1.formula +type thm = Thm1.thm +type limit = Meter1.limit +type solver = Solver1.solver +type solver_node = Solver1.solver_node + +(* Tuning parameters *) +type Mparm = Meson1.parameters +type Rparm = Resolution1.parameters +type parameters = + {meson : bool, + delta : bool, + resolution : bool, + meson_parm : Mparm, + resolution_parm : Rparm} + +val defaults : parameters +val update_parm_meson : (bool -> bool) -> parameters -> parameters +val update_parm_delta : (bool -> bool) -> parameters -> parameters +val update_parm_resolution : (bool -> bool) -> parameters -> parameters +val update_parm_meson_parm : (Mparm -> Mparm) -> parameters -> parameters +val update_parm_resolution_parm : (Rparm -> Rparm) -> parameters -> parameters + +(* The metis combination of solvers *) +val metis' : parameters -> solver_node +val metis : solver_node (* Uses defaults *) + +(* A user-friendly interface *) +val settings : parameters ref (* Starts off as defaults *) +val limit : limit ref (* Starts off as 10 seconds *) +val raw_prove : formula -> thm option (* Expects a ==> b ==> F *) +val prove : formula -> thm option (* Adds eq axioms, converts to CNF *) +val query : formula -> solver (* Prolog query engine *) + +end +(*#line 0.0 "src/Metis1.sml"*) +(* ========================================================================= *) +(* THE METIS COMBINATION OF PROOF PROCEDURES FOR FIRST-ORDER LOGIC *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +(* +app load + ["Useful", "Mosml", "Term1", "Thm1", "Canon1", + "Solver1", "Meson1", "Resolution1"]; +*) + +(* +*) +structure Metis1 :> Metis1 = +struct + +open Useful Term1 Thm1 Meter1 Canon1 Solver1 Meson1 Resolution1; + +infix |-> ::> @> oo ## ::* ::@; + +(* ------------------------------------------------------------------------- *) +(* Tuning parameters. *) +(* ------------------------------------------------------------------------- *) + +type Mparm = Meson1.parameters; +type Rparm = Resolution1.parameters; + +type parameters = + {meson : bool, + delta : bool, + resolution : bool, + meson_parm : Mparm, + resolution_parm : Rparm}; + +val defaults = + {meson = true, + delta = true, + resolution = true, + meson_parm = Meson1.defaults, + resolution_parm = Resolution1.defaults}; + +fun update_parm_meson f parm = + let + val {meson, delta, resolution, meson_parm, resolution_parm} = parm + in + {meson = f meson, delta = delta, resolution = resolution, + meson_parm = meson_parm, resolution_parm = resolution_parm} + end; + +fun update_parm_delta f parm = + let + val {meson, delta, resolution, meson_parm, resolution_parm} = parm + in + {meson = meson, delta = f delta, resolution = resolution, + meson_parm = meson_parm, resolution_parm = resolution_parm} + end; + +fun update_parm_resolution f parm = + let + val {meson, delta, resolution, meson_parm, resolution_parm} = parm + in + {meson = meson, delta = delta, resolution = f resolution, + meson_parm = meson_parm, resolution_parm = resolution_parm} + end; + +fun update_parm_meson_parm f parm = + let + val {meson, delta, resolution, meson_parm, resolution_parm} = parm + in + {meson = meson, delta = delta, resolution = resolution, + meson_parm = f meson_parm, resolution_parm = resolution_parm} + end; + +fun update_parm_resolution_parm f parm = + let + val {meson, delta, resolution, meson_parm, resolution_parm} = parm + in + {meson = meson, delta = delta, resolution = resolution, + meson_parm = meson_parm, resolution_parm = f resolution_parm} + end; + +(* ------------------------------------------------------------------------- *) +(* The metis combination of solvers. *) +(* ------------------------------------------------------------------------- *) + +fun metis' {meson = m, delta = d, resolution = r, meson_parm, resolution_parm} = + combine + ((if m then cons (time1, meson' meson_parm) else I) + ((if r then cons (time1, resolution' resolution_parm) else I) + ((if d then cons (time2, delta' meson_parm) else I) + []))); + +val metis = metis' defaults; + +(* ------------------------------------------------------------------------- *) +(* A user-friendly interface. *) +(* ------------------------------------------------------------------------- *) + +val settings = ref defaults; + +val limit : limit ref = ref {time = NONE, infs = NONE}; + +fun raw_prove (Imp (a, Imp (b, False))) = + let + val (thms, hyps) = (axiomatize a, axiomatize b) + val solv = metis' (!settings) + in + refute (initialize solv {limit = !limit, thms = thms, hyps = hyps}) + end + | raw_prove _ = raise ERR "raw_prove" "formula not of type a ==> b ==> F"; + +fun prove g = + let + val hyps = eq_axiomatize' (Not (generalize g)) + val solv = set_of_support all_negative (metis' (!settings)) + in + refute (initialize solv {limit = !limit, thms = [], hyps = hyps}) + end; + +fun query database = + initialize prolog {thms = axiomatize database, hyps = [], limit = unlimited}; + +(* quick testing +val time = Mosml.time; +quotation := true; +installPP pp_term; +installPP pp_formula; +installPP Subst1.pp_subst; +installPP pp_thm; + +(* Testing the metis prover *) + +prove True; + +val p59 = parse_formula [QUOTE "(!x. P(x) <=> ~P(f(x))) ==> (?x. P(x) /\\ ~P(f(x)))"]; +val ths = axiomatize (Not (generalize p59)); +prove p59; + +val p39 = parse_formula [QUOTE "~(?x. !y. P(y,x) <=> ~P(y,y))"]; +clausal (Not (generalize p39)); +axiomatize (Not (generalize p39)); +prove p39; + +val num14 = parse_formula + [ + + + + + +QUOTE "(!X. product(X, X, square(X))) /\\\n (!Z X Y. ~product(X, Y, Z) \\/ product(Y, X, Z)) /\\\n (!Z X Y. ~product(X, Y, Z) \\/ divides(X, Z)) /\\\n (!Y X V Z.\n ~prime(X) \\/ ~product(Y, Z, V) \\/ ~divides(X, V) \\/ divides(X, Y) \\/\n divides(X, Z)) /\\ prime(a) /\\\n product(a, square(c), square(b)) /\\ ~divides(a, b) ==> F"]; +prove num14; + +val p26 = parse_formula + [ + +QUOTE "((?x. P(x)) <=> (?x. Q(x))) /\\\n (!x y. P(x) /\\ Q(y) ==> (R(x) <=> U(y))) ==>\n ((!x. P(x) ==> R(x)) <=> (!x. Q(x) ==> U(x)))"]; +clausal (Not (generalize p26)); +prove p26; + +val los = parse_formula + [ + +QUOTE "(!x y z. P x y ==> P y z ==> P x z) /\\\n (!x y z. Q x y ==> Q y z ==> Q x z) /\\ (!x y. Q x y ==> Q y x) /\\\n (!x y. P x y \\/ Q x y) ==> (!x y. P x y) \\/ !x y. Q x y"]; +try prove los; + +val puz2 = parse_formula + [ + + + + + + + + + + + + + + + + + + + + + + + + + + +QUOTE "(!X. equal(X, X)) /\\ (!Y X. ~equal(X, Y) \\/ equal(Y, X)) /\\\n (!Z X Y. ~equal(X, Y) \\/ ~equal(Y, Z) \\/ equal(X, Z)) /\\\n (!B A. ~equal(A, B) \\/ equal(every_one_but(A), every_one_but(B))) /\\\n (!E C D. ~equal(C, D) \\/ ~hates(C, E) \\/ hates(D, E)) /\\\n (!H F_avoid G.\n ~equal(F_avoid, G) \\/ ~hates(H, F_avoid) \\/ hates(H, G)) /\\\n (!K I J. ~equal(I, J) \\/ ~killed(I, K) \\/ killed(J, K)) /\\\n (!N L M. ~equal(L, M) \\/ ~killed(N, L) \\/ killed(N, M)) /\\\n (!P O.\n ~equal(O, P) \\/ ~lives_at_dreadsbury(O) \\/ lives_at_dreadsbury(P)) /\\\n (!S Q R. ~equal(Q, R) \\/ ~richer(Q, S) \\/ richer(R, S)) /\\\n (!V T_avoid U.\n ~equal(T_avoid, U) \\/ ~richer(V, T_avoid) \\/ richer(V, U)) /\\\n lives_at_dreadsbury(someone()) /\\ killed(someone(), aunt_agatha()) /\\\n lives_at_dreadsbury(aunt_agatha()) /\\ lives_at_dreadsbury(butler()) /\\\n lives_at_dreadsbury(charles()) /\\\n (!Person.\n ~lives_at_dreadsbury(Person) \\/ equal(Person, aunt_agatha()) \\/\n equal(Person, butler()) \\/ equal(Person, charles())) /\\\n (!Victim Killer. ~killed(Killer, Victim) \\/ hates(Killer, Victim)) /\\\n (!Victim Killer. ~killed(Killer, Victim) \\/ ~richer(Killer, Victim)) /\\\n (!Person. ~hates(aunt_agatha(), Person) \\/ ~hates(charles(), Person)) /\\\n (!Person. equal(Person, butler()) \\/ hates(aunt_agatha(), Person)) /\\\n (!Person. richer(Person, aunt_agatha()) \\/ hates(butler(), Person)) /\\\n (!Person. ~hates(aunt_agatha(), Person) \\/ hates(butler(), Person)) /\\\n (!Person. ~hates(Person, every_one_but(Person))) /\\\n ~equal(aunt_agatha(), butler()) /\\\n ~killed(aunt_agatha(), aunt_agatha()) ==> F"]; +prove puz2; + +val num284 = parse_formula + [ + + + + + + + +QUOTE "fibonacci(0, successor(0)) /\\ fibonacci(successor(0), successor(0)) /\\\n (!N2 N1 N F1 FN F2.\n ~sum(N1, successor(0), N) \\/ ~sum(N2, successor(successor(0)), N) \\/\n ~fibonacci(N1, F1) \\/ ~fibonacci(N2, F2) \\/ ~sum(F1, F2, FN) \\/\n fibonacci(N, FN)) /\\ (!X. sum(X, 0, X)) /\\\n (!Z X Y. ~sum(X, Y, Z) \\/ sum(X, successor(Y), successor(Z))) /\\\n (!Result.\n ~fibonacci(successor(successor(successor(successor(successor(successor(successor(successor(0)))))))),\n Result)) ==> F"]; +prove num284; + +val p29 = parse_formula + [ + +QUOTE "(?x. P(x)) /\\ (?x. G(x)) ==>\n ((!x. P(x) ==> H(x)) /\\ (!x. G(x) ==> J(x)) <=>\n (!x y. P(x) /\\ G(y) ==> H(x) /\\ J(y)))"]; +clausal (Not (generalize p29)); +prove p29; + +val num27 = parse_formula + [ + + + + + + + + + + + + + + + + + + + + + +QUOTE "(!A. equalish(add(A, 0), A)) /\\\n (!A B. equalish(add(A, successor(B)), successor(add(A, B)))) /\\\n (!A. equalish(multiply(A, 0), 0)) /\\\n (!A B. equalish(multiply(A, successor(B)), add(multiply(A, B), A))) /\\\n (!B A. ~equalish(successor(A), successor(B)) \\/ equalish(A, B)) /\\\n (!B A. ~equalish(A, B) \\/ equalish(successor(A), successor(B))) /\\\n (!C A B. ~less(A, B) \\/ ~less(C, A) \\/ less(C, B)) /\\\n (!C B A. ~equalish(add(successor(A), B), C) \\/ less(B, C)) /\\\n (!B A.\n ~less(A, B) \\/\n equalish(add(successor(predecessor_of_1st_minus_2nd(B, A)), A),\n B)) /\\ (!X. equalish(X, X)) /\\\n (!Y X. ~equalish(X, Y) \\/ equalish(Y, X)) /\\\n (!Z X Y. ~equalish(X, Y) \\/ ~equalish(Y, Z) \\/ equalish(X, Z)) /\\\n (!C A B. ~equalish(A, B) \\/ equalish(multiply(A, C), multiply(B, C))) /\\\n (!B A. ~less(A, B) \\/ ~equalish(A, B)) /\\\n (!B A. less(A, B) \\/ equalish(B, A) \\/ less(B, A)) /\\\n (!A. ~less(A, A)) /\\ (!A. ~equalish(successor(A), 0)) /\\\n (!C A B.\n ~less(A, B) \\/ equalish(C, 0) \\/\n less(multiply(A, C), multiply(B, C))) /\\ ~less(b(), a()) /\\\n less(multiply(b(), c()), multiply(a(), c())) /\\ ~equalish(c(), 0) ==>\n F"]; +prove num27; + +val model_completeness = parse_formula + [ + + + + + + + +QUOTE "(!M p. sentence(p) ==> holds(M,p) \\/ holds(M,not(p))) /\\\n (!M p. ~(holds(M,p) /\\ holds(M,not(p)))) ==>\n ((!p.\n sentence(p) ==>\n (!M. models(M,S) ==> holds(M,p)) \\/\n (!M. models(M,S) ==> holds(M,not(p)))) <=>\n (!M M'.\n models(M,S) /\\ models(M',S) ==>\n (!p. sentence(p) ==> (holds(M,p) <=> holds(M',p)))))"]; +prove model_completeness; + +val agatha = parse_formula + [ + + + + + + + + + + +QUOTE "lives(agatha()) /\\ lives(butler()) /\\ lives(charles()) /\\\n (killed(agatha(),agatha()) \\/ killed(butler(),agatha()) \\/\n killed(charles(),agatha())) /\\\n (!x y. killed(x,y) ==> hates(x,y) /\\ ~richer(x,y)) /\\\n (!x. hates(agatha(),x) ==> ~hates(charles(),x)) /\\\n (hates(agatha(),agatha()) /\\ hates(agatha(),charles())) /\\\n (!x. lives(x) /\\ ~richer(x,agatha()) ==> hates(butler(),x)) /\\\n (!x. hates(agatha(),x) ==> hates(butler(),x)) /\\\n (!x. ~hates(x,agatha()) \\/ ~hates(x,butler()) \\/ ~hates(x,charles()))\n ==>\n killed(agatha(),agatha()) /\\ ~killed(butler(),agatha()) /\\\n ~killed(charles(),agatha())"]; +prove agatha; + +val boo3 = parse_formula + [ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +QUOTE "(!X. equal(X, X)) /\\ (!Y X. ~equal(X, Y) \\/ equal(Y, X)) /\\\n (!Z X Y. ~equal(X, Y) \\/ ~equal(Y, Z) \\/ equal(X, Z)) /\\\n (!Y X. sum(X, Y, add(X, Y))) /\\ (!Y X. product(X, Y, multiply(X, Y))) /\\\n (!Z X Y. ~sum(X, Y, Z) \\/ sum(Y, X, Z)) /\\\n (!Z X Y. ~product(X, Y, Z) \\/ product(Y, X, Z)) /\\\n (!X. sum(additive_identity(), X, X)) /\\\n (!X. sum(X, additive_identity(), X)) /\\\n (!X. product(multiplicative_identity(), X, X)) /\\\n (!X. product(X, multiplicative_identity(), X)) /\\\n (!Z X Y V1 V3 V4 V2.\n ~product(X, Y, V1) \\/ ~product(X, Z, V2) \\/ ~sum(Y, Z, V3) \\/\n ~product(X, V3, V4) \\/ sum(V1, V2, V4)) /\\\n (!Z X Y V1 V3 V4 V2.\n ~product(X, Y, V1) \\/ ~product(X, Z, V2) \\/ ~sum(Y, Z, V3) \\/\n ~sum(V1, V2, V4) \\/ product(X, V3, V4)) /\\\n (!Z Y X V1 V3 V4 V2.\n ~product(Y, X, V1) \\/ ~product(Z, X, V2) \\/ ~sum(Y, Z, V3) \\/\n ~product(V3, X, V4) \\/ sum(V1, V2, V4)) /\\\n (!Z Y X V1 V3 V4 V2.\n ~product(Y, X, V1) \\/ ~product(Z, X, V2) \\/ ~sum(Y, Z, V3) \\/\n ~sum(V1, V2, V4) \\/ product(V3, X, V4)) /\\\n (!Z X Y V1 V3 V4 V2.\n ~sum(X, Y, V1) \\/ ~sum(X, Z, V2) \\/ ~product(Y, Z, V3) \\/\n ~sum(X, V3, V4) \\/ product(V1, V2, V4)) /\\\n (!Z X Y V1 V3 V4 V2.\n ~sum(X, Y, V1) \\/ ~sum(X, Z, V2) \\/ ~product(Y, Z, V3) \\/\n ~product(V1, V2, V4) \\/ sum(X, V3, V4)) /\\\n (!Z Y X V1 V3 V4 V2.\n ~sum(Y, X, V1) \\/ ~sum(Z, X, V2) \\/ ~product(Y, Z, V3) \\/\n ~sum(V3, X, V4) \\/ product(V1, V2, V4)) /\\\n (!Z Y X V1 V3 V4 V2.\n ~sum(Y, X, V1) \\/ ~sum(Z, X, V2) \\/ ~product(Y, Z, V3) \\/\n ~product(V1, V2, V4) \\/ sum(V3, X, V4)) /\\\n (!X. sum(inverse(X), X, multiplicative_identity())) /\\\n (!X. sum(X, inverse(X), multiplicative_identity())) /\\\n (!X. product(inverse(X), X, additive_identity())) /\\\n (!X. product(X, inverse(X), additive_identity())) /\\\n (!V X Y U. ~sum(X, Y, U) \\/ ~sum(X, Y, V) \\/ equal(U, V)) /\\\n (!V X Y U. ~product(X, Y, U) \\/ ~product(X, Y, V) \\/ equal(U, V)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~sum(X, W, Z) \\/ sum(Y, W, Z)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~sum(W, X, Z) \\/ sum(W, Y, Z)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~sum(W, Z, X) \\/ sum(W, Z, Y)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~product(X, W, Z) \\/ product(Y, W, Z)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~product(W, X, Z) \\/ product(W, Y, Z)) /\\\n (!W X Y Z. ~equal(X, Y) \\/ ~product(W, Z, X) \\/ product(W, Z, Y)) /\\\n (!W X Y. ~equal(X, Y) \\/ equal(add(X, W), add(Y, W))) /\\\n (!W X Y. ~equal(X, Y) \\/ equal(add(W, X), add(W, Y))) /\\\n (!W X Y. ~equal(X, Y) \\/ equal(multiply(X, W), multiply(Y, W))) /\\\n (!W X Y. ~equal(X, Y) \\/ equal(multiply(W, X), multiply(W, Y))) /\\\n (!Y X. ~equal(X, Y) \\/ equal(inverse(X), inverse(Y))) /\\\n ~product(x(), x(), x()) ==> F"]; +prove boo3; + +val fld5 = parse_formula + [ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +QUOTE "(!Y X V W Z U.\n sum(X, V, W) \\/ ~sum(X, Y, U) \\/ ~sum(Y, Z, V) \\/ ~sum(U, Z, W)) /\\\n (!X U Z W V Y.\n sum(U, Z, W) \\/ ~sum(X, Y, U) \\/ ~sum(Y, Z, V) \\/ ~sum(X, V, W)) /\\\n (!X. sum(additive_identity(), X, X) \\/ ~defined(X)) /\\\n (!X. sum(additive_inverse(X), X, additive_identity()) \\/ ~defined(X)) /\\\n (!Z Y X. sum(Y, X, Z) \\/ ~sum(X, Y, Z)) /\\\n (!Y X V W Z U.\n product(X, V, W) \\/ ~product(X, Y, U) \\/ ~product(Y, Z, V) \\/\n ~product(U, Z, W)) /\\\n (!X U Z W V Y.\n product(U, Z, W) \\/ ~product(X, Y, U) \\/ ~product(Y, Z, V) \\/\n ~product(X, V, W)) /\\\n (!X. product(multiplicative_identity(), X, X) \\/ ~defined(X)) /\\\n (!X.\n product(multiplicative_inverse(X), X, multiplicative_identity()) \\/\n sum(additive_identity(), X, additive_identity()) \\/ ~defined(X)) /\\\n (!Z Y X. product(Y, X, Z) \\/ ~product(X, Y, Z)) /\\\n (!X C D B Z A Y.\n sum(C, D, B) \\/ ~sum(X, Y, A) \\/ ~product(A, Z, B) \\/\n ~product(X, Z, C) \\/ ~product(Y, Z, D)) /\\\n (!X A Z B C D Y.\n product(A, Z, B) \\/ ~sum(X, Y, A) \\/ ~product(X, Z, C) \\/\n ~product(Y, Z, D) \\/ ~sum(C, D, B)) /\\\n (!X Y. defined(add(X, Y)) \\/ ~defined(X) \\/ ~defined(Y)) /\\\n defined(additive_identity()) /\\\n (!X. defined(additive_inverse(X)) \\/ ~defined(X)) /\\\n (!X Y. defined(multiply(X, Y)) \\/ ~defined(X) \\/ ~defined(Y)) /\\\n defined(multiplicative_identity()) /\\\n (!X.\n defined(multiplicative_inverse(X)) \\/ ~defined(X) \\/\n sum(additive_identity(), X, additive_identity())) /\\\n (!Y X. sum(X, Y, add(X, Y)) \\/ ~defined(X) \\/ ~defined(Y)) /\\\n (!Y X. product(X, Y, multiply(X, Y)) \\/ ~defined(X) \\/ ~defined(Y)) /\\\n (!Y X.\n sum(additive_identity(), X, Y) \\/ ~less_or_equal(X, Y) \\/\n ~less_or_equal(Y, X)) /\\\n (!Y X Z.\n less_or_equal(X, Z) \\/ ~less_or_equal(X, Y) \\/\n ~less_or_equal(Y, Z)) /\\\n (!Y X.\n less_or_equal(X, Y) \\/ less_or_equal(Y, X) \\/ ~defined(X) \\/\n ~defined(Y)) /\\\n (!X U V Z Y.\n less_or_equal(U, V) \\/ ~less_or_equal(X, Y) \\/ ~sum(X, Z, U) \\/\n ~sum(Y, Z, V)) /\\\n (!X Z Y.\n less_or_equal(additive_identity(), Z) \\/\n ~less_or_equal(additive_identity(), X) \\/\n ~less_or_equal(additive_identity(), Y) \\/ ~product(X, Y, Z)) /\\\n ~sum(additive_identity(), additive_identity(),\n multiplicative_identity()) /\\ defined(a()) /\\ defined(b()) /\\\n (!X. ~sum(a(), X, b())) ==> F"]; +prove fld5; +*) + +end +(*#line 0.0 "data/preamble.sml"*) +(* ========================================================================= *) +(* SETTING UP THE ENVIRONMENT IN WHICH WE CAN EXECUTE THE METIS PROVER *) +(* Created by Joe Hurd, September 2001 *) +(* ========================================================================= *) + +(* Loading the modules we use *) + +structure Main = +struct + +fun main _ = +let + +val () = app load + ["CommandLine", + "Milton", + "Useful", "Term1", "Canon1", "Tptp1", "Metis1", "Problem1"]; + +(* Infix operators *) + +infixr ## |-> ::> @> oo; + +(* Pretty printers *) + +val () = installPP Term1.pp_term; +val () = installPP Term1.pp_formula; +val () = installPP Subst1.pp_subst; +val () = installPP Thm1.pp_thm; + +(* Parsing quotations *) + +val () = quotation := true; + +(* Creating nice output *) + +local + fun dup _ 0 l = l | dup x n l = dup x (n - 1) (x :: l); + fun chs x n = implode (dup x n []); +in + fun advertize s = print ("==" ^ s ^ chs #"=" (77 - size s) ^ "\n\n"); + fun separator () = print (chs #"-" 79 ^ "\n\n"); +end; + +fun cutoff max = + let + fun cut feas sofa l = + let val poss = sofa ^ " ... " ^ Useful.int_to_string (length l) ^ " more" + in cut' (if size poss < max then poss else feas) sofa l + end + and cut' _ sofa [] = sofa + | cut' feas sofa (h :: t) = + let val sofa' = if sofa = "" then h else sofa ^ " " ^ h + in if size sofa' < max then cut feas sofa' t else feas + end + in + cut "" "" + end; + +local + fun b2s true = "on" | b2s false = "off"; + val i2s = Useful.int_to_string; + val l2s = Meter1.limit_to_string; +in + fun show (settings : Metis1.parameters) = + let + val {meson = Mactive, delta = Dactive, resolution = Ractive, + meson_parm = Mparm, resolution_parm = Rparm} = settings + in + "resolution = " ^ b2s Ractive ^ "\n" ^ + "meson = " ^ b2s Mactive ^ "\n" ^ + "delta = " ^ b2s Dactive ^ "\n" ^ + "\n" ^ + "resolution_parm:\n" ^ + " subsumption_checking = " ^ i2s (#subsumption_checking Rparm) ^ "\n" ^ + " positive_refinement = " ^ b2s (#positive_refinement Rparm) ^ "\n" ^ + " theap_parm:\n" ^ + " fifo_skew = " ^ i2s (#fifo_skew (#theap_parm Rparm)) ^ "\n" ^ + " theap_cleaning = " ^ i2s (#cleaning_freq (#theap_parm Rparm)) ^"\n"^ + "\n" ^ + "meson_parm:\n" ^ + " ancestor_pruning = " ^ b2s (#ancestor_pruning Mparm) ^ "\n" ^ + " ancestor_cutting = " ^ b2s (#ancestor_cutting Mparm) ^ "\n" ^ + " state_simplify = " ^ b2s (#state_simplify Mparm) ^ "\n" ^ + " cache_cutting = " ^ b2s (#cache_cutting Mparm) ^ "\n" ^ + " divide_conquer = " ^ b2s (#divide_conquer Mparm) ^ "\n" ^ + " unit_lemmaizing = " ^ b2s (#unit_lemmaizing Mparm) ^ "\n" ^ + "\n" ^ + "limit = " ^ l2s (!Metis1.limit) ^ "\n\n" + end; +end; + +(* The core proving function *) + +val cnf_normalization = ref false; + +fun with_cnf b = Useful.with_flag (cnf_normalization, Useful.K b); + +fun core_prove fm = + let + val prover = if !cnf_normalization then Metis1.prove else Metis1.raw_prove + in + case Useful.try prover fm of SOME _ + => print "METIS: SUCCESSFULLY PROVED\nMETIS: " + | NONE => print "METIS: FAILED TO PROVE\nMETIS: " + end; + +fun process name goal = + (print ("METIS: Problem " ^ name ^ "\n"); + Milton.time core_prove goal; + print "\n"); + +fun process_set (n, s) = + let + val () = advertize n + fun f {name, goal} = process name (Term1.parse_formula goal) + in + case s of [] => () + | p :: ps => (f p; app (fn x => (separator (); f x)) ps) + end; + +(* Get options from the command line *) + +local + open Useful Metis1; + + fun tlimit "-" = NONE | tlimit s = SOME (Real.fromInt (string_to_int s)); + + fun opts [] = 0 + | opts (x :: xs) = + if x = "-t" orelse x = "--time" then + case xs of [] => raise Fail "options: last argument -t / --time" + | y :: ys => (limit := {time = tlimit y, infs = NONE}; opts ys) + else if x = "-m" orelse x = "--meson" then + (settings := update_parm_meson not (!settings); opts xs) + else if x = "-r" orelse x = "--resolution" then + (settings := update_parm_resolution not (!settings); opts xs) + else if x = "-d" orelse x = "--delta" then + (settings := update_parm_delta not (!settings); opts xs) + else if x = "--" then length xs + else if hd (explode x) = #"-" then raise Fail ("unknown parameter: " ^ x) + else 1 + length xs; +in + fun options () = + let + val () = settings := update_parm_resolution (K false) (!settings); + val () = settings := update_parm_meson (K false) (!settings); + val () = settings := update_parm_delta (K false) (!settings); + + val l = (**CommandLine.arguments ()**) [] + val n = opts l + in + split l (length l - n) + end; +end; + +val (opts, work) = if Milton.ml = "MLton" then options () else ([], []); +(*#line 0.0 "data/benchmark.sml"*) +val pure = null ((**CommandLine.arguments ()**) []); + +local + open Useful Metis1; +in + val () = + if pure then settings:= update_parm_meson (K true) (!settings) else (); +end; + +local + open Useful Problem1; + fun extract p n = + (Option.valOf o List.find (fn {name, goal = _} => name = n)) p; + + val meson_prune = + if pure then ["P29", "LDA007-3", "GRP010-4", "GEO002-4"] else ["GEO002-4"]; + + val prune = + let + val {meson, resolution, ...} = !Metis1.settings + in + (fn f => List.filter (not o f)) + (case (meson, resolution) of (false, false) => K true + | (false, true) => C mem ["COL060-3"] + | (true, false) => C mem meson_prune + | (true, true) => K false) + end; + + val src0 = ["P26", "P29", "P46", "GILMORE_1", "LOS", "STEAM_ROLLER"]; + + val src1 = ["P48", "P49", "AGATHA"]; + + val src2 = + ["LCL009-1", "COL060-3", "COL058-2", "LCL107-1", "LDA007-3", + "GRP010-4", "BOO021-1", "GEO002-4", "GRP128-4.003"]; +in + val set0 = map (extract nonequality) (prune src0); + val set1 = map (extract equality) (prune src1); + val set2 = map (extract tptp) (prune src2); +end; + +val program = "benchmark" ^ (if pure then "*" else ""); + +val () = advertize (program ^ "==starting"); + +val () = advertize "settings"; + +val () = print (show (!Metis1.settings)); + +val () = with_cnf true process_set ("nonequality", set0); + +val () = with_cnf true process_set ("equality", set1); + +val () = with_cnf false process_set ("tptp", set2); + +val () = advertize (program ^ "==finishing"); + +in + () +end; + +fun doit n = + if n = 0 + then () + else (main (); doit (n - 1)) + +end diff --git a/benchmark/tests/mpuz.sml b/benchmark/tests/mpuz.sml new file mode 100644 index 0000000..f7a0208 --- /dev/null +++ b/benchmark/tests/mpuz.sml @@ -0,0 +1,141 @@ +(* + * Written by sweeks@sweeks.com on 1999-08-31. + * + * A solution to mpuz. (Try M-x mpuz in emacs.) + * This solution is very loosely based on an OCAML solution posted to + * comp.lang.ml by Laurent Vaucher . + *) + +(* override print so the benchmark is silent *) +fun print _ = () + +structure List = + struct + open List + + fun exists(l, p) = List.exists p l + + fun map(l, f) = List.map f l + + fun fold(l, b, f) = + let + fun loop(l, b) = + case l of + [] => b + | x :: l => loop(l, f(x, b)) + in loop(l, b) + end + + fun foreach(l, f) = fold(l, (), fn (x, ()) => f x) + end + +structure String = + struct + open String + + fun fold(s, b, f) = + let + val n = size s + fun loop(i, b) = + if i = n + then b + else loop(i + 1, f(String.sub(s, i), b)) + in loop(0, b) + end + end + +structure Mpuz = + struct + fun solve(a, b, c, d, e) = + let + fun printNewline() = print "\n" + val sub = Array.sub + val update = Array.update + + val letters = + List.fold + ([a, b, c, d, e], [], fn (s, letters) => + String.fold + (s, letters, fn (c, letters) => + if List.exists(letters, fn c' => c = c') + then letters + else c :: letters)) + + val letterValues = + Array.array(Char.ord Char.maxChar + 1, 0) + + fun letterValue(c) = + Array.sub(letterValues, ord c) + + fun setLetterValue(c, v) = + Array.update(letterValues, ord c, v) + + fun stringValue(s) = + String.fold(s, 0, fn (c, v) => v * 10 + letterValue c) + + fun printResult() = + (List.foreach + (letters, fn c => + print(concat[String.str(c), " = ", + Int.toString(letterValue(c)), " "])) + ; print "\n") + + fun testOk() = + let + val b0 = letterValue(String.sub(b, 1)) + val b1 = letterValue(String.sub(b, 0)) + val a = stringValue a + val b = stringValue b + val c = stringValue c + val d = stringValue d + val e = stringValue e + in if a * b0 = c + andalso a * b1 = d + andalso a * b = e + andalso c + d * 10 = e + then printResult() + else () + end + + val values = List.map([0, 1, 2, 3, 4, 5, 6, 7, 8, 9], fn v => + (v, ref false)) + + (* Try all assignments of values to letters. *) + fun loop(letters) = + case letters of + [] => testOk() + | c :: letters => + List.foreach + (values, fn (v, r) => + if !r + then () + else (r := true + ; setLetterValue(c, v) + ; loop(letters) + ; r := false)) + + in loop(letters) + end + end + +structure Main = + struct + fun doit() = + Mpuz.solve("AGH", "FB", "CBEE", "GHFD", "FGIJE") + (* + * Solution: + * J = 0 I = 1 D = 8 E = 2 C = 5 B = 6 F = 4 H = 7 G = 3 A = 9 + *) + + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in + loop size + end + end diff --git a/benchmark/tests/nucleic.sml b/benchmark/tests/nucleic.sml new file mode 100644 index 0000000..a8b298b --- /dev/null +++ b/benchmark/tests/nucleic.sml @@ -0,0 +1,3666 @@ +(* From the SML/NJ benchmark suite. *) +(* File: "nucleic.sml" *) + +structure Nucleic : sig + + val doit : unit -> unit + + end = struct + + type float = real + type intg = int + +(* -- MATH UTILITIES --------------------------------------------------------*) + + val constant_pi = 3.14159265358979323846 + val constant_minus_pi = ~3.14159265358979323846 + val constant_pi2 = 1.57079632679489661923 + val constant_minus_pi2 = ~1.57079632679489661923 + +fun math_atan2 y x = + if (x > 0.0) + then Math.atan (y / x) + else if Real.==(x, 0.0) + then if y < 0.0 + then constant_minus_pi2 + else Math.atan (y / x) + constant_minus_pi + else if Real.==(x, 0.0) + then constant_pi2 + else (Math.atan (y / x) + constant_pi) + +(* -- POINTS ----------------------------------------------------------------*) + +type pt = float * float * float + +fun pt_sub ((x1,y1,z1):pt) (x2,y2,z2) + = (x1 - x2, y1 - y2, z1 - z2) + +fun pt_dist (x1,y1,z1) (x2,y2,z2) = let + val dx = x1 - x2 + val dy = y1 - y2 + val dz = z1 - z2 + in + Math.sqrt ((dx * dx) + (dy * dy) + (dz * dz)) + end + +fun pt_phi (x,y,z) = let + val b = math_atan2 x z + in + math_atan2 + (((Math.cos b) * z + ((Math.sin b) * x))) y + end + +fun pt_theta (x,y,z) = math_atan2 x z + +(* -- COORDINATE TRANSFORMATIONS --------------------------------------------*) + +(* The notation for the transformations follows "Paul, R.P. (1981) Robot +|| Manipulators. MIT Press." with the exception that our transformation +|| matrices don't have the perspective terms and are the transpose of +|| Paul's one. See also "M\"antyl\"a, M. (1985) An Introduction to +|| Solid Modeling, Computer Science Press" Appendix A. +|| +|| The components of a transformation matrix are named like this: +|| +|| a b c +|| d e f +|| g h i +|| tx ty tz +|| +|| The components tx, ty, and tz are the translation vector. +*) + +type tfo + = float*float*float*float*float*float*float*float*float*float*float*float + +val tfo_id = (1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0) + +(* The function "tfo-apply" multiplies a transformation matrix, tfo, by a +|| point vector, p. The result is a new point. +|| +|| Note: in the measured program, this function was coded in assembler. +*) + +fun +tfo_apply (a,b,c,d,e,f,g,h,i,tx,ty,tz) (x:real,y:real,z:real) + = ( + ((x * a) + + (y * d) + + (z * g) + + tx) + , + ((x * b) + + (y * e) + + (z * h) + + ty) + , + ((x * c) + + (y * f) + + (z * i) + + tz) + ) + +(* The function "tfo-combine" multiplies two transformation matrices A and B. +|| The result is a new matrix which cumulates the transformations described +|| by A and B. +|| +|| Note: in the measured program, this function was coded in assembler. +*) + +fun +tfo_combine + (a_a:real,a_b:real,a_c:real,a_d:real,a_e:real,a_f:real,a_g:real,a_h:real,a_i:real,a_tx:real,a_ty:real,a_tz:real) + (b_a:real,b_b:real,b_c:real,b_d:real,b_e:real,b_f:real,b_g:real,b_h:real,b_i:real,b_tx:real,b_ty:real,b_tz:real) + = ( + ((a_a * b_a) + + (a_b * b_d) + + (a_c * b_g)) + , + ((a_a * b_b) + + (a_b * b_e) + + (a_c * b_h)) + , + ((a_a * b_c) + + (a_b * b_f) + + (a_c * b_i)) + , + ((a_d * b_a) + + (a_e * b_d) + + (a_f * b_g)) + , + ((a_d * b_b) + + (a_e * b_e) + + (a_f * b_h)) + , + ((a_d * b_c) + + (a_e * b_f) + + (a_f * b_i)) + , + ((a_g * b_a) + + (a_h * b_d) + + (a_i * b_g)) + , + ((a_g * b_b) + + (a_h * b_e) + + (a_i * b_h)) + , + ((a_g * b_c) + + (a_h * b_f) + + (a_i * b_i)) + , + ((a_tx * b_a) + + (a_ty * b_d) + + (a_tz * b_g) + + b_tx) + , + ((a_tx * b_b) + + (a_ty * b_e) + + (a_tz * b_h) + + b_ty) + , + ((a_tx * b_c) + + (a_ty * b_f) + + (a_tz * b_i) + + b_tz) + ) + +(* The function "tfo-inv-ortho" computes the inverse of a homogeneous +|| transformation matrix. +*) + +fun +tfo_inv_ortho ((a,b,c,d,e,f,g,h,i,tx,ty,tz):tfo) + = ( + a,d,g, + b,e,h, + c,f,i, + (~((a * tx) + + (b * ty) + + (c * tz))) + , + (~ ((d * tx) + + (e * ty) + + (f * tz))) + , + (~ ((g * tx) + + (h * ty) + + (i * tz))) + ) + +(* Given three points p1, p2, and p3, the function "tfo-align" computes +|| a transformation matrix such that point p1 gets mapped to (0,0,0), p2 gets +|| mapped to the Y axis and p3 gets mapped to the YZ plane. +*) + +fun tfo_align (x1:real,y1:real,z1:real) (x2:real,y2:real,z2:real) (x3,y3,z3) + = let + val x31 = x3 - x1 + val y31 = y3 - y1 + val z31 = z3 - z1 + val rotpy = pt_sub (x2,y2,z2) (x1,y1,z1) + val phi = pt_phi rotpy + val theta = pt_theta rotpy + val sinp = Math.sin phi + val sint = Math.sin theta + val cosp = Math.cos phi + val cost = Math.cos theta + val sinpsint = sinp * sint + val sinpcost = sinp * cost + val cospsint = cosp * sint + val cospcost = cosp * cost + val rotpz = ( + ((cost * x31) - + (sint * z31)) + , + ((sinpsint * x31) + + (cosp * y31) + + (sinpcost * z31)) + , + ((cospsint * x31) + + (~ (sinp * y31)) + + (cospcost * z31)) + ) + val rho = pt_theta rotpz + val cosr = Math.cos rho + val sinr = Math.sin rho + val x = (~ (x1 * cost)) + (z1 * sint) + val y = ((~ (x1 * sinpsint)) - (y1 * cosp)) - + (z1 * sinpcost) + val z = ((~ (x1 * cospsint) + (y1 * sinp))) - + (z1 * cospcost) + in + ( + ((cost * cosr) - (cospsint * sinr)) + , + sinpsint + , + ((cost * sinr + (cospsint * cosr))) + , + (sinp * sinr) + , + cosp + , + (~ (sinp * cosr)) + , + ((~ (sint * cosr)) - (cospcost * sinr)) + , + sinpcost + , + ((~ (sint * sinr) + (cospcost * cosr))) + , + ((x * cosr) - (z * sinr)) + , + y + , + ((x * sinr + (z * cosr))) + ) + end + +(* -- NUCLEIC ACID CONFORMATIONS DATA BASE ----------------------------------*) + +(* Numbering of atoms follows the paper: +|| +|| IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN) +|| (1983) Abbreviations and Symbols for the Description of +|| Conformations of Polynucleotide Chains. Eur. J. Biochem 131, +|| 9-15. +|| +|| In the atom names, we have used "*" instead of "'". +*) + +(* Define remaining atoms for each nucleotide type. *) + +datatype nuc_specific + = A of pt*pt*pt*pt*pt*pt*pt*pt + | C of pt*pt*pt*pt*pt*pt + | G of pt*pt*pt*pt*pt*pt*pt*pt*pt + | U of pt*pt*pt*pt*pt + +(* A N6 N7 N9 C8 H2 H61 H62 H8 +|| C N4 O2 H41 H42 H5 H6 +|| G N2 N7 N9 C8 O6 H1 H21 H22 H8 +|| U O2 O4 H3 H5 H6 +*) + +(* Define part common to all 4 nucleotide types. *) + +type nuc = tfo*tfo*tfo*tfo* + pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt* + pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt*pt* + pt*nuc_specific + +(* dgf-base-tfo ; defines the standard position for wc and wc-dumas +|| P-O3*-275-tfo ; defines the standard position for the connect function +|| P-O3*-180-tfo +|| P-O3*-60-tfo +|| P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2* H2** O2* H2* C3* +|| H3* O3* N1 N3 C2 C4 C5 C6) +*) + +fun +is_A (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,A _) + = true +| +is_A x + = false + +fun +is_C (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,C _) + = true +| +is_C x + = false + +fun +is_G (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G _) + = true +| +is_G x + = false + +fun +is_U (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,U _) + = true +| +is_U x + = false + +fun +nuc_C1' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = c1' + +fun +nuc_C2 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = c2 + +fun +nuc_C2' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = c2' + +fun +nuc_C3' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = c3' + +fun +nuc_C4 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = c4 + +fun +nuc_C4' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = c4' + +fun +nuc_C5 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = c5 + +fun +nuc_C5' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = c5' + +fun +nuc_C6 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = c6 + +fun +nuc_H1' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = h1' + +fun +nuc_H2' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = h2' + +fun +nuc_H2'' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = h2'' + +fun +nuc_H3' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = h3' + +fun +nuc_H4' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = h4' + +fun +nuc_H5' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = h5' + +fun +nuc_H5'' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = h5'' + +fun +nuc_N1 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = n1 + +fun +nuc_N3 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = n3 + +fun +nuc_O1P + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = o1p + +fun +nuc_O2P + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = o2p + +fun +nuc_O2' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = o2' + +fun +nuc_O3' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = o3' + +fun +nuc_O4' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = o4' + +fun +nuc_O5' + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = o5' + +fun +nuc_P + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = p + +fun +nuc_dgf_base_tfo + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = dgf_base_tfo + +fun +nuc_p_o3'_180_tfo + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = p_o3'_180_tfo + +fun +nuc_p_o3'_275_tfo + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = p_o3'_275_tfo + +fun +nuc_p_o3'_60_tfo + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,_) + = p_o3'_60_tfo + +fun +rA_N6 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8)) + = n6 +fun +rA_N7 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8)) + = n7 +fun +rA_N9 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8)) + = n9 +fun +rA_C8 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8)) + = c8 +fun +rA_H2 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8)) + = h2 +fun +rA_H61 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8)) + = h61 +fun +rA_H62 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8)) + = h62 +fun +rA_H8 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,A (n6,n7,n9,c8,h2,h61,h62,h8)) + = h8 + +fun +rC_N4 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,C (n4, o2, h41, h42, h5, h6)) + = n4 +fun +rC_O2 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,C (n4, o2, h41, h42, h5, h6)) + = o2 +fun +rC_H41 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,C (n4, o2, h41, h42, h5, h6)) + = h41 +fun +rC_H42 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,C (n4, o2, h41, h42, h5, h6)) + = h42 +fun +rC_H5 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,C (n4, o2, h41, h42, h5, h6)) + = h5 +fun +rC_H6 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,C (n4, o2, h41, h42, h5, h6)) + = h6 + +fun +rG_N2 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8)) + = n2 +fun +rG_N7 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8)) + = n7 +fun +rG_N9 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8)) + = n9 +fun +rG_C8 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8)) + = c8 +fun +rG_O6 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8)) + = o6 +fun +rG_H1 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8)) + = h1 +fun +rG_H21 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8)) + = h21 +fun +rG_H22 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8)) + = h22 +fun +rG_H8 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,G (n2,n7,n9,c8,o6,h1,h21,h22,h8)) + = h8 + +fun +rU_O2 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,U (o2,o4,h3,h5,h6)) + = o2 +fun +rU_O4 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,U (o2,o4,h3,h5,h6)) + = o4 +fun +rU_H3 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,U (o2,o4,h3,h5,h6)) + = h3 +fun +rU_H5 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,U (o2,o4,h3,h5,h6)) + = h5 +fun +rU_H6 + (dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, + p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', + c3',h3',o3',n1,n3,c2,c4,c5,c6,U (o2,o4,h3,h5,h6)) + = h6 + +(* Database of nucleotide conformations: *) + +val rA + = ( + ( (~0.0018), (~0.8207), (0.5714), (* dgf-base-tfo *) + (0.2679), (~0.5509), (~0.7904), + (0.9634), (0.1517), (0.2209), + (0.0073), (8.4030), (0.6232)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (5.4550), (8.2120), (~2.8810)), (* C5' *) + ( (5.4546), (8.8508), (~1.9978)), (* H5' *) + ( (5.7588), (8.6625), (~3.8259)), (* H5'' *) + ( (6.4970), (7.1480), (~2.5980)), (* C4' *) + ( (7.4896), (7.5919), (~2.5214)), (* H4' *) + ( (6.1630), (6.4860), (~1.3440)), (* O4' *) + ( (6.5400), (5.1200), (~1.4190)), (* C1' *) + ( (7.2763), (4.9681), (~0.6297)), (* H1' *) + ( (7.1940), (4.8830), (~2.7770)), (* C2' *) + ( (6.8667), (3.9183), (~3.1647)), (* H2'' *) + ( (8.5860), (5.0910), (~2.6140)), (* O2' *) + ( (8.9510), (4.7626), (~1.7890)), (* H2' *) + ( (6.5720), (6.0040), (~3.6090)), (* C3' *) + ( (5.5636), (5.7066), (~3.8966)), (* H3' *) + ( (7.3801), (6.3562), (~4.7350)), (* O3' *) + ( (4.7150), (0.4910), (~0.1360)), (* N1 *) + ( (6.3490), (2.1730), (~0.6020)), (* N3 *) + ( (5.9530), (0.9650), (~0.2670)), (* C2 *) + ( (5.2900), (2.9790), (~0.8260)), (* C4 *) + ( (3.9720), (2.6390), (~0.7330)), (* C5 *) + ( (3.6770), (1.3160), (~0.3660)), (* C6 *) + (A ( + ( (2.4280), (0.8450), (~0.2360)), (* N6 *) + ( (3.1660), (3.7290), (~1.0360)), (* N7 *) + ( (5.3170), (4.2990), (~1.1930)), (* N9 *) + ( (4.0100), (4.6780), (~1.2990)), (* C8 *) + ( (6.6890), (0.1903), (~0.0518)), (* H2 *) + ( (1.6470), (1.4460), (~0.4040)), (* H61 *) + ( (2.2780), (~0.1080), (~0.0280)), (* H62 *) + ( (3.4421), (5.5744), (~1.5482))) (* H8 *) + ) + ) + +val rA01 + = ( + ( (~0.0043), (~0.8175), (0.5759), (* dgf-base-tfo *) + (0.2617), (~0.5567), (~0.7884), + (0.9651), (0.1473), (0.2164), + (0.0359), (8.3929), (0.5532)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (5.4352), (8.2183), (~2.7757)), (* C5' *) + ( (5.3830), (8.7883), (~1.8481)), (* H5' *) + ( (5.7729), (8.7436), (~3.6691)), (* H5'' *) + ( (6.4830), (7.1518), (~2.5252)), (* C4' *) + ( (7.4749), (7.5972), (~2.4482)), (* H4' *) + ( (6.1626), (6.4620), (~1.2827)), (* O4' *) + ( (6.5431), (5.0992), (~1.3905)), (* C1' *) + ( (7.2871), (4.9328), (~0.6114)), (* H1' *) + ( (7.1852), (4.8935), (~2.7592)), (* C2' *) + ( (6.8573), (3.9363), (~3.1645)), (* H2'' *) + ( (8.5780), (5.1025), (~2.6046)), (* O2' *) + ( (8.9516), (4.7577), (~1.7902)), (* H2' *) + ( (6.5522), (6.0300), (~3.5612)), (* C3' *) + ( (5.5420), (5.7356), (~3.8459)), (* H3' *) + ( (7.3487), (6.4089), (~4.6867)), (* O3' *) + ( (4.7442), (0.4514), (~0.1390)), (* N1 *) + ( (6.3687), (2.1459), (~0.5926)), (* N3 *) + ( (5.9795), (0.9335), (~0.2657)), (* C2 *) + ( (5.3052), (2.9471), (~0.8125)), (* C4 *) + ( (3.9891), (2.5987), (~0.7230)), (* C5 *) + ( (3.7016), (1.2717), (~0.3647)), (* C6 *) + (A ( + ( (2.4553), (0.7925), (~0.2390)), (* N6 *) + ( (3.1770), (3.6859), (~1.0198)), (* N7 *) + ( (5.3247), (4.2695), (~1.1710)), (* N9 *) + ( (4.0156), (4.6415), (~1.2759)), (* C8 *) + ( (6.7198), (0.1618), (~0.0547)), (* H2 *) + ( (1.6709), (1.3900), (~0.4039)), (* H61 *) + ( (2.3107), (~0.1627), (~0.0373)), (* H62 *) + ( (3.4426), (5.5361), (~1.5199))) (* H8 *) + ) + ) + +val rA02 + = ( + ( (0.5566), (0.0449), (0.8296), (* dgf-base-tfo *) + (0.5125), (0.7673), (~0.3854), + (~0.6538), (0.6397), (0.4041), + (~9.1161), (~3.7679), (~2.9968)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (4.5778), (6.6594), (~4.0364)), (* C5' *) + ( (4.9220), (7.1963), (~4.9204)), (* H5' *) + ( (3.7996), (5.9091), (~4.1764)), (* H5'' *) + ( (5.7873), (5.8869), (~3.5482)), (* C4' *) + ( (6.0405), (5.0875), (~4.2446)), (* H4' *) + ( (6.9135), (6.8036), (~3.4310)), (* O4' *) + ( (7.7293), (6.4084), (~2.3392)), (* C1' *) + ( (8.7078), (6.1815), (~2.7624)), (* H1' *) + ( (7.1305), (5.1418), (~1.7347)), (* C2' *) + ( (7.2040), (5.1982), (~0.6486)), (* H2'' *) + ( (7.7417), (4.0392), (~2.3813)), (* O2' *) + ( (8.6785), (4.1443), (~2.5630)), (* H2' *) + ( (5.6666), (5.2728), (~2.1536)), (* C3' *) + ( (5.1747), (5.9805), (~1.4863)), (* H3' *) + ( (4.9997), (4.0086), (~2.1973)), (* O3' *) + ( (10.3245), (8.5459), (1.5467)), (* N1 *) + ( (9.8051), (6.9432), (~0.1497)), (* N3 *) + ( (10.5175), (7.4328), (0.8408)), (* C2 *) + ( (8.7523), (7.7422), (~0.4228)), (* C4 *) + ( (8.4257), (8.9060), (0.2099)), (* C5 *) + ( (9.2665), (9.3242), (1.2540)), (* C6 *) + (A ( + ( (9.0664), (10.4462), (1.9610)), (* N6 *) + ( (7.2750), (9.4537), (~0.3428)), (* N7 *) + ( (7.7962), (7.5519), (~1.3859)), (* N9 *) + ( (6.9479), (8.6157), (~1.2771)), (* C8 *) + ( (11.4063), (6.9047), (1.1859)), (* H2 *) + ( (8.2845), (11.0341), (1.7552)), (* H61 *) + ( (9.6584), (10.6647), (2.7198)), (* H62 *) + ( (6.0430), (8.9853), (~1.7594))) (* H8 *) + ) + ) + +val rA03 + = ( + ( (~0.5021), (0.0731), (0.8617), (* dgf-base-tfo *) + (~0.8112), (0.3054), (~0.4986), + (~0.2996), (~0.9494), (~0.0940), + (6.4273), (~5.1944), (~3.7807)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (4.1214), (6.7116), (~1.9049)), (* C5' *) + ( (3.3465), (5.9610), (~2.0607)), (* H5' *) + ( (4.0789), (7.2928), (~0.9837)), (* H5'' *) + ( (5.4170), (5.9293), (~1.8186)), (* C4' *) + ( (5.4506), (5.3400), (~0.9023)), (* H4' *) + ( (5.5067), (5.0417), (~2.9703)), (* O4' *) + ( (6.8650), (4.9152), (~3.3612)), (* C1' *) + ( (7.1090), (3.8577), (~3.2603)), (* H1' *) + ( (7.7152), (5.7282), (~2.3894)), (* C2' *) + ( (8.5029), (6.2356), (~2.9463)), (* H2'' *) + ( (8.1036), (4.8568), (~1.3419)), (* O2' *) + ( (8.3270), (3.9651), (~1.6184)), (* H2' *) + ( (6.7003), (6.7565), (~1.8911)), (* C3' *) + ( (6.5898), (7.5329), (~2.6482)), (* H3' *) + ( (7.0505), (7.2878), (~0.6105)), (* O3' *) + ( (9.6740), (4.7656), (~7.6614)), (* N1 *) + ( (9.0739), (4.3013), (~5.3941)), (* N3 *) + ( (9.8416), (4.2192), (~6.4581)), (* C2 *) + ( (7.9885), (5.0632), (~5.6446)), (* C4 *) + ( (7.6822), (5.6856), (~6.8194)), (* C5 *) + ( (8.5831), (5.5215), (~7.8840)), (* C6 *) + (A ( + ( (8.4084), (6.0747), (~9.0933)), (* N6 *) + ( (6.4857), (6.3816), (~6.7035)), (* N7 *) + ( (6.9740), (5.3703), (~4.7760)), (* N9 *) + ( (6.1133), (6.1613), (~5.4808)), (* C8 *) + ( (10.7627), (3.6375), (~6.4220)), (* H2 *) + ( (7.6031), (6.6390), (~9.2733)), (* H61 *) + ( (9.1004), (5.9708), (~9.7893)), (* H62 *) + ( (5.1705), (6.6830), (~5.3167))) (* H8 *) + ) + ) + +val rA04 + = ( + ( (~0.5426), (~0.8175), (0.1929), (* dgf-base-tfo *) + (0.8304), (~0.5567), (~0.0237), + (0.1267), (0.1473), (0.9809), + (~0.5075), (8.3929), (0.2229)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (5.4352), (8.2183), (~2.7757)), (* C5' *) + ( (5.3830), (8.7883), (~1.8481)), (* H5' *) + ( (5.7729), (8.7436), (~3.6691)), (* H5'' *) + ( (6.4830), (7.1518), (~2.5252)), (* C4' *) + ( (7.4749), (7.5972), (~2.4482)), (* H4' *) + ( (6.1626), (6.4620), (~1.2827)), (* O4' *) + ( (6.5431), (5.0992), (~1.3905)), (* C1' *) + ( (7.2871), (4.9328), (~0.6114)), (* H1' *) + ( (7.1852), (4.8935), (~2.7592)), (* C2' *) + ( (6.8573), (3.9363), (~3.1645)), (* H2'' *) + ( (8.5780), (5.1025), (~2.6046)), (* O2' *) + ( (8.9516), (4.7577), (~1.7902)), (* H2' *) + ( (6.5522), (6.0300), (~3.5612)), (* C3' *) + ( (5.5420), (5.7356), (~3.8459)), (* H3' *) + ( (7.3487), (6.4089), (~4.6867)), (* O3' *) + ( (3.6343), (2.6680), (2.0783)), (* N1 *) + ( (5.4505), (3.9805), (1.2446)), (* N3 *) + ( (4.7540), (3.3816), (2.1851)), (* C2 *) + ( (4.8805), (3.7951), (0.0354)), (* C4 *) + ( (3.7416), (3.0925), (~0.2305)), (* C5 *) + ( (3.0873), (2.4980), (0.8606)), (* C6 *) + (A ( + ( (1.9600), (1.7805), (0.7462)), (* N6 *) + ( (3.4605), (3.1184), (~1.5906)), (* N7 *) + ( (5.3247), (4.2695), (~1.1710)), (* N9 *) + ( (4.4244), (3.8244), (~2.0953)), (* C8 *) + ( (5.0814), (3.4352), (3.2234)), (* H2 *) + ( (1.5423), (1.6454), (~0.1520)), (* H61 *) + ( (1.5716), (1.3398), (1.5392)), (* H62 *) + ( (4.2675), (3.8876), (~3.1721))) (* H8 *) + ) + ) + +val rA05 + = ( + ( (~0.5891), (0.0449), (0.8068), (* dgf-base-tfo *) + (0.5375), (0.7673), (0.3498), + (~0.6034), (0.6397), (~0.4762), + (~0.3019), (~3.7679), (~9.5913)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (4.5778), (6.6594), (~4.0364)), (* C5' *) + ( (4.9220), (7.1963), (~4.9204)), (* H5' *) + ( (3.7996), (5.9091), (~4.1764)), (* H5'' *) + ( (5.7873), (5.8869), (~3.5482)), (* C4' *) + ( (6.0405), (5.0875), (~4.2446)), (* H4' *) + ( (6.9135), (6.8036), (~3.4310)), (* O4' *) + ( (7.7293), (6.4084), (~2.3392)), (* C1' *) + ( (8.7078), (6.1815), (~2.7624)), (* H1' *) + ( (7.1305), (5.1418), (~1.7347)), (* C2' *) + ( (7.2040), (5.1982), (~0.6486)), (* H2'' *) + ( (7.7417), (4.0392), (~2.3813)), (* O2' *) + ( (8.6785), (4.1443), (~2.5630)), (* H2' *) + ( (5.6666), (5.2728), (~2.1536)), (* C3' *) + ( (5.1747), (5.9805), (~1.4863)), (* H3' *) + ( (4.9997), (4.0086), (~2.1973)), (* O3' *) + ( (10.2594), (10.6774), (~1.0056)), (* N1 *) + ( (9.7528), (8.7080), (~2.2631)), (* N3 *) + ( (10.4471), (9.7876), (~1.9791)), (* C2 *) + ( (8.7271), (8.5575), (~1.3991)), (* C4 *) + ( (8.4100), (9.3803), (~0.3580)), (* C5 *) + ( (9.2294), (10.5030), (~0.1574)), (* C6 *) + (A ( + ( (9.0349), (11.3951), (0.8250)), (* N6 *) + ( (7.2891), (8.9068), (0.3121)), (* N7 *) + ( (7.7962), (7.5519), (~1.3859)), (* N9 *) + ( (6.9702), (7.8292), (~0.3353)), (* C8 *) + ( (11.3132), (10.0537), (~2.5851)), (* H2 *) + ( (8.2741), (11.2784), (1.4629)), (* H61 *) + ( (9.6733), (12.1368), (0.9529)), (* H62 *) + ( (6.0888), (7.3990), (0.1403))) (* H8 *) + ) + ) + +val rA06 + = ( + ( (~0.9815), (0.0731), (~0.1772), (* dgf-base-tfo *) + (0.1912), (0.3054), (~0.9328), + (~0.0141), (~0.9494), (~0.3137), + (5.7506), (~5.1944), (4.7470)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (4.1214), (6.7116), (~1.9049)), (* C5' *) + ( (3.3465), (5.9610), (~2.0607)), (* H5' *) + ( (4.0789), (7.2928), (~0.9837)), (* H5'' *) + ( (5.4170), (5.9293), (~1.8186)), (* C4' *) + ( (5.4506), (5.3400), (~0.9023)), (* H4' *) + ( (5.5067), (5.0417), (~2.9703)), (* O4' *) + ( (6.8650), (4.9152), (~3.3612)), (* C1' *) + ( (7.1090), (3.8577), (~3.2603)), (* H1' *) + ( (7.7152), (5.7282), (~2.3894)), (* C2' *) + ( (8.5029), (6.2356), (~2.9463)), (* H2'' *) + ( (8.1036), (4.8568), (~1.3419)), (* O2' *) + ( (8.3270), (3.9651), (~1.6184)), (* H2' *) + ( (6.7003), (6.7565), (~1.8911)), (* C3' *) + ( (6.5898), (7.5329), (~2.6482)), (* H3' *) + ( (7.0505), (7.2878), (~0.6105)), (* O3' *) + ( (6.6624), (3.5061), (~8.2986)), (* N1 *) + ( (6.5810), (3.2570), (~5.9221)), (* N3 *) + ( (6.5151), (2.8263), (~7.1625)), (* C2 *) + ( (6.8364), (4.5817), (~5.8882)), (* C4 *) + ( (7.0116), (5.4064), (~6.9609)), (* C5 *) + ( (6.9173), (4.8260), (~8.2361)), (* C6 *) + (A ( + ( (7.0668), (5.5163), (~9.3763)), (* N6 *) + ( (7.2573), (6.7070), (~6.5394)), (* N7 *) + ( (6.9740), (5.3703), (~4.7760)), (* N9 *) + ( (7.2238), (6.6275), (~5.2453)), (* C8 *) + ( (6.3146), (1.7741), (~7.3641)), (* H2 *) + ( (7.2568), (6.4972), (~9.3456)), (* H61 *) + ( (7.0437), (5.0478), (~10.2446)), (* H62 *) + ( (7.4108), (7.6227), (~4.8418))) (* H8 *) + ) + ) + +val rA07 + = ( + ( (0.2379), (0.1310), (~0.9624), (* dgf-base-tfo *) + (~0.5876), (~0.7696), (~0.2499), + (~0.7734), (0.6249), (~0.1061), + (30.9870), (~26.9344), (42.6416)), + ( (0.7529), (0.1548), (0.6397), (* P-O3'-275-tfo *) + (0.2952), (~0.9481), (~0.1180), + (0.5882), (0.2777), (~0.7595), + (~58.8919), (~11.3095), (6.0866)), + ( (~0.0239), (0.9667), (~0.2546), (* P-O3'-180-tfo *) + (0.9731), (~0.0359), (~0.2275), + (~0.2290), (~0.2532), (~0.9399), + (3.5401), (~29.7913), (52.2796)), + ( (~0.8912), (~0.4531), (0.0242), (* P-O3'-60-tfo *) + (~0.1183), (0.1805), (~0.9764), + (0.4380), (~0.8730), (~0.2145), + (19.9023), (54.8054), (15.2799)), + ( (41.8210), (8.3880), (43.5890)), (* P *) + ( (42.5400), (8.0450), (44.8330)), (* O1P *) + ( (42.2470), (9.6920), (42.9910)), (* O2P *) + ( (40.2550), (8.2030), (43.7340)), (* O5' *) + ( (39.3505), (8.4697), (42.6565)), (* C5' *) + ( (39.1377), (7.5433), (42.1230)), (* H5' *) + ( (39.7203), (9.3119), (42.0717)), (* H5'' *) + ( (38.0405), (8.9195), (43.2869)), (* C4' *) + ( (37.3687), (9.3036), (42.5193)), (* H4' *) + ( (37.4319), (7.8146), (43.9387)), (* O4' *) + ( (37.1959), (8.1354), (45.3237)), (* C1' *) + ( (36.1788), (8.5202), (45.3970)), (* H1' *) + ( (38.1721), (9.2328), (45.6504)), (* C2' *) + ( (39.1555), (8.7939), (45.8188)), (* H2'' *) + ( (37.7862), (10.0617), (46.7013)), (* O2' *) + ( (37.3087), (9.6229), (47.4092)), (* H2' *) + ( (38.1844), (10.0268), (44.3367)), (* C3' *) + ( (39.1578), (10.5054), (44.2289)), (* H3' *) + ( (37.0547), (10.9127), (44.3441)), (* O3' *) + ( (34.8811), (4.2072), (47.5784)), (* N1 *) + ( (35.1084), (6.1336), (46.1818)), (* N3 *) + ( (34.4108), (5.1360), (46.7207)), (* C2 *) + ( (36.3908), (6.1224), (46.6053)), (* C4 *) + ( (36.9819), (5.2334), (47.4697)), (* C5 *) + ( (36.1786), (4.1985), (48.0035)), (* C6 *) + (A ( + ( (36.6103), (3.2749), (48.8452)), (* N6 *) + ( (38.3236), (5.5522), (47.6595)), (* N7 *) + ( (37.3887), (7.0024), (46.2437)), (* N9 *) + ( (38.5055), (6.6096), (46.9057)), (* C8 *) + ( (33.3553), (5.0152), (46.4771)), (* H2 *) + ( (37.5730), (3.2804), (49.1507)), (* H61 *) + ( (35.9775), (2.5638), (49.1828)), (* H62 *) + ( (39.5461), (6.9184), (47.0041))) (* H8 *) + ) + ) + +val rA08 + = ( + ( (0.1084), (~0.0895), (~0.9901), (* dgf-base-tfo *) + (0.9789), (~0.1638), (0.1220), + (~0.1731), (~0.9824), (0.0698), + (~2.9039), (47.2655), (33.0094)), + ( (0.7529), (0.1548), (0.6397), (* P-O3'-275-tfo *) + (0.2952), (~0.9481), (~0.1180), + (0.5882), (0.2777), (~0.7595), + (~58.8919), (~11.3095), (6.0866)), + ( (~0.0239), (0.9667), (~0.2546), (* P-O3'-180-tfo *) + (0.9731), (~0.0359), (~0.2275), + (~0.2290), (~0.2532), (~0.9399), + (3.5401), (~29.7913), (52.2796)), + ( (~0.8912), (~0.4531), (0.0242), (* P-O3'-60-tfo *) + (~0.1183), (0.1805), (~0.9764), + (0.4380), (~0.8730), (~0.2145), + (19.9023), (54.8054), (15.2799)), + ( (41.8210), (8.3880), (43.5890)), (* P *) + ( (42.5400), (8.0450), (44.8330)), (* O1P *) + ( (42.2470), (9.6920), (42.9910)), (* O2P *) + ( (40.2550), (8.2030), (43.7340)), (* O5' *) + ( (39.4850), (8.9301), (44.6977)), (* C5' *) + ( (39.0638), (9.8199), (44.2296)), (* H5' *) + ( (40.0757), (9.0713), (45.6029)), (* H5'' *) + ( (38.3102), (8.0414), (45.0789)), (* C4' *) + ( (37.7842), (8.4637), (45.9351)), (* H4' *) + ( (37.4200), (7.9453), (43.9769)), (* O4' *) + ( (37.2249), (6.5609), (43.6273)), (* C1' *) + ( (36.3360), (6.2168), (44.1561)), (* H1' *) + ( (38.4347), (5.8414), (44.1590)), (* C2' *) + ( (39.2688), (5.9974), (43.4749)), (* H2'' *) + ( (38.2344), (4.4907), (44.4348)), (* O2' *) + ( (37.6374), (4.0386), (43.8341)), (* H2' *) + ( (38.6926), (6.6079), (45.4637)), (* C3' *) + ( (39.7585), (6.5640), (45.6877)), (* H3' *) + ( (37.8238), (6.0705), (46.4723)), (* O3' *) + ( (33.9162), (6.2598), (39.7758)), (* N1 *) + ( (34.6709), (6.5759), (42.0215)), (* N3 *) + ( (33.7257), (6.5186), (41.0858)), (* C2 *) + ( (35.8935), (6.3324), (41.5018)), (* C4 *) + ( (36.2105), (6.0601), (40.1932)), (* C5 *) + ( (35.1538), (6.0151), (39.2537)), (* C6 *) + (A ( + ( (35.3088), (5.7642), (37.9649)), (* N6 *) + ( (37.5818), (5.8677), (40.0507)), (* N7 *) + ( (37.0932), (6.3197), (42.1810)), (* N9 *) + ( (38.0509), (6.0354), (41.2635)), (* C8 *) + ( (32.6830), (6.6898), (41.3532)), (* H2 *) + ( (36.2305), (5.5855), (37.5925)), (* H61 *) + ( (34.5056), (5.7512), (37.3528)), (* H62 *) + ( (39.1318), (5.8993), (41.2285))) (* H8 *) + ) + ) + +val rA09 + = ( + ( (0.8467), (0.4166), (~0.3311), (* dgf-base-tfo *) + (~0.3962), (0.9089), (0.1303), + (0.3552), (0.0209), (0.9346), + (~42.7319), (~26.6223), (~29.8163)), + ( (0.7529), (0.1548), (0.6397), (* P-O3'-275-tfo *) + (0.2952), (~0.9481), (~0.1180), + (0.5882), (0.2777), (~0.7595), + (~58.8919), (~11.3095), (6.0866)), + ( (~0.0239), (0.9667), (~0.2546), (* P-O3'-180-tfo *) + (0.9731), (~0.0359), (~0.2275), + (~0.2290), (~0.2532), (~0.9399), + (3.5401), (~29.7913), (52.2796)), + ( (~0.8912), (~0.4531), (0.0242), (* P-O3'-60-tfo *) + (~0.1183), (0.1805), (~0.9764), + (0.4380), (~0.8730), (~0.2145), + (19.9023), (54.8054), (15.2799)), + ( (41.8210), (8.3880), (43.5890)), (* P *) + ( (42.5400), (8.0450), (44.8330)), (* O1P *) + ( (42.2470), (9.6920), (42.9910)), (* O2P *) + ( (40.2550), (8.2030), (43.7340)), (* O5' *) + ( (39.3505), (8.4697), (42.6565)), (* C5' *) + ( (39.1377), (7.5433), (42.1230)), (* H5' *) + ( (39.7203), (9.3119), (42.0717)), (* H5'' *) + ( (38.0405), (8.9195), (43.2869)), (* C4' *) + ( (37.6479), (8.1347), (43.9335)), (* H4' *) + ( (38.2691), (10.0933), (44.0524)), (* O4' *) + ( (37.3999), (11.1488), (43.5973)), (* C1' *) + ( (36.5061), (11.1221), (44.2206)), (* H1' *) + ( (37.0364), (10.7838), (42.1836)), (* C2' *) + ( (37.8636), (11.0489), (41.5252)), (* H2'' *) + ( (35.8275), (11.3133), (41.7379)), (* O2' *) + ( (35.6214), (12.1896), (42.0714)), (* H2' *) + ( (36.9316), (9.2556), (42.2837)), (* C3' *) + ( (37.1778), (8.8260), (41.3127)), (* H3' *) + ( (35.6285), (8.9334), (42.7926)), (* O3' *) + ( (38.1482), (15.2833), (46.4641)), (* N1 *) + ( (37.3641), (13.0968), (45.9007)), (* N3 *) + ( (37.5032), (14.1288), (46.7300)), (* C2 *) + ( (37.9570), (13.3377), (44.7113)), (* C4 *) + ( (38.6397), (14.4660), (44.3267)), (* C5 *) + ( (38.7473), (15.5229), (45.2609)), (* C6 *) + (A ( + ( (39.3720), (16.6649), (45.0297)), (* N6 *) + ( (39.1079), (14.3351), (43.0223)), (* N7 *) + ( (38.0132), (12.4868), (43.6280)), (* N9 *) + ( (38.7058), (13.1402), (42.6620)), (* C8 *) + ( (37.0731), (14.0857), (47.7306)), (* H2 *) + ( (39.8113), (16.8281), (44.1350)), (* H61 *) + ( (39.4100), (17.3741), (45.7478)), (* H62 *) + ( (39.0412), (12.9660), (41.6397))) (* H8 *) + ) + ) + +val rA10 + = ( + ( (0.7063), (0.6317), (~0.3196), (* dgf-base-tfo *) + (~0.0403), (~0.4149), (~0.9090), + (~0.7068), (0.6549), (~0.2676), + (6.4402), (~52.1496), (30.8246)), + ( (0.7529), (0.1548), (0.6397), (* P-O3'-275-tfo *) + (0.2952), (~0.9481), (~0.1180), + (0.5882), (0.2777), (~0.7595), + (~58.8919), (~11.3095), (6.0866)), + ( (~0.0239), (0.9667), (~0.2546), (* P-O3'-180-tfo *) + (0.9731), (~0.0359), (~0.2275), + (~0.2290), (~0.2532), (~0.9399), + (3.5401), (~29.7913), (52.2796)), + ( (~0.8912), (~0.4531), (0.0242), (* P-O3'-60-tfo *) + (~0.1183), (0.1805), (~0.9764), + (0.4380), (~0.8730), (~0.2145), + (19.9023), (54.8054), (15.2799)), + ( (41.8210), (8.3880), (43.5890)), (* P *) + ( (42.5400), (8.0450), (44.8330)), (* O1P *) + ( (42.2470), (9.6920), (42.9910)), (* O2P *) + ( (40.2550), (8.2030), (43.7340)), (* O5' *) + ( (39.4850), (8.9301), (44.6977)), (* C5' *) + ( (39.0638), (9.8199), (44.2296)), (* H5' *) + ( (40.0757), (9.0713), (45.6029)), (* H5'' *) + ( (38.3102), (8.0414), (45.0789)), (* C4' *) + ( (37.7099), (7.8166), (44.1973)), (* H4' *) + ( (38.8012), (6.8321), (45.6380)), (* O4' *) + ( (38.2431), (6.6413), (46.9529)), (* C1' *) + ( (37.3505), (6.0262), (46.8385)), (* H1' *) + ( (37.8484), (8.0156), (47.4214)), (* C2' *) + ( (38.7381), (8.5406), (47.7690)), (* H2'' *) + ( (36.8286), (8.0368), (48.3701)), (* O2' *) + ( (36.8392), (7.3063), (48.9929)), (* H2' *) + ( (37.3576), (8.6512), (46.1132)), (* C3' *) + ( (37.5207), (9.7275), (46.1671)), (* H3' *) + ( (35.9985), (8.2392), (45.9032)), (* O3' *) + ( (39.9117), (2.2278), (48.8527)), (* N1 *) + ( (38.6207), (3.6941), (47.4757)), (* N3 *) + ( (38.9872), (2.4888), (47.9057)), (* C2 *) + ( (39.2961), (4.6720), (48.1174)), (* C4 *) + ( (40.2546), (4.5307), (49.0912)), (* C5 *) + ( (40.5932), (3.2189), (49.4985)), (* C6 *) + (A ( + ( (41.4938), (2.9317), (50.4229)), (* N6 *) + ( (40.7195), (5.7755), (49.5060)), (* N7 *) + ( (39.1730), (6.0305), (47.9170)), (* N9 *) + ( (40.0413), (6.6250), (48.7728)), (* C8 *) + ( (38.5257), (1.5960), (47.4838)), (* H2 *) + ( (41.9907), (3.6753), (50.8921)), (* H61 *) + ( (41.6848), (1.9687), (50.6599)), (* H62 *) + ( (40.3571), (7.6321), (49.0452))) (* H8 *) + ) + ) + +val rAs = [rA01,rA02,rA03,rA04,rA05,rA06,rA07,rA08,rA09,rA10] + +val rC + = ( + ( (~0.0359), (~0.8071), (0.5894), (* dgf-base-tfo *) + (~0.2669), (0.5761), (0.7726), + (~0.9631), (~0.1296), (~0.2361), + (0.1584), (8.3434), (0.5434)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (5.2430), (~8.2420), (2.8260)), (* C5' *) + ( (5.1974), (~8.8497), (1.9223)), (* H5' *) + ( (5.5548), (~8.7348), (3.7469)), (* H5'' *) + ( (6.3140), (~7.2060), (2.5510)), (* C4' *) + ( (7.2954), (~7.6762), (2.4898)), (* H4' *) + ( (6.0140), (~6.5420), (1.2890)), (* O4' *) + ( (6.4190), (~5.1840), (1.3620)), (* C1' *) + ( (7.1608), (~5.0495), (0.5747)), (* H1' *) + ( (7.0760), (~4.9560), (2.7270)), (* C2' *) + ( (6.7770), (~3.9803), (3.1099)), (* H2'' *) + ( (8.4500), (~5.1930), (2.5810)), (* O2' *) + ( (8.8309), (~4.8755), (1.7590)), (* H2' *) + ( (6.4060), (~6.0590), (3.5580)), (* C3' *) + ( (5.4021), (~5.7313), (3.8281)), (* H3' *) + ( (7.1570), (~6.4240), (4.7070)), (* O3' *) + ( (5.2170), (~4.3260), (1.1690)), (* N1 *) + ( (4.2960), (~2.2560), (0.6290)), (* N3 *) + ( (5.4330), (~3.0200), (0.7990)), (* C2 *) + ( (2.9930), (~2.6780), (0.7940)), (* C4 *) + ( (2.8670), (~4.0630), (1.1830)), (* C5 *) + ( (3.9570), (~4.8300), (1.3550)), (* C6 *) + (C ( + ( (2.0187), (~1.8047), (0.5874)), (* N4 *) + ( (6.5470), (~2.5560), (0.6290)), (* O2 *) + ( (1.0684), (~2.1236), (0.7109)), (* H41 *) + ( (2.2344), (~0.8560), (0.3162)), (* H42 *) + ( (1.8797), (~4.4972), (1.3404)), (* H5 *) + ( (3.8479), (~5.8742), (1.6480))) (* H6 *) + ) + ) + +val rC01 + = ( + ( (~0.0137), (~0.8012), (0.5983), (* dgf-base-tfo *) + (~0.2523), (0.5817), (0.7733), + (~0.9675), (~0.1404), (~0.2101), + (0.2031), (8.3874), (0.4228)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (5.2416), (~8.2422), (2.8181)), (* C5' *) + ( (5.2050), (~8.8128), (1.8901)), (* H5' *) + ( (5.5368), (~8.7738), (3.7227)), (* H5'' *) + ( (6.3232), (~7.2037), (2.6002)), (* C4' *) + ( (7.3048), (~7.6757), (2.5577)), (* H4' *) + ( (6.0635), (~6.5092), (1.3456)), (* O4' *) + ( (6.4697), (~5.1547), (1.4629)), (* C1' *) + ( (7.2354), (~5.0043), (0.7018)), (* H1' *) + ( (7.0856), (~4.9610), (2.8521)), (* C2' *) + ( (6.7777), (~3.9935), (3.2487)), (* H2'' *) + ( (8.4627), (~5.1992), (2.7423)), (* O2' *) + ( (8.8693), (~4.8638), (1.9399)), (* H2' *) + ( (6.3877), (~6.0809), (3.6362)), (* C3' *) + ( (5.3770), (~5.7562), (3.8834)), (* H3' *) + ( (7.1024), (~6.4754), (4.7985)), (* O3' *) + ( (5.2764), (~4.2883), (1.2538)), (* N1 *) + ( (4.3777), (~2.2062), (0.7229)), (* N3 *) + ( (5.5069), (~2.9779), (0.9088)), (* C2 *) + ( (3.0693), (~2.6246), (0.8500)), (* C4 *) + ( (2.9279), (~4.0146), (1.2149)), (* C5 *) + ( (4.0101), (~4.7892), (1.4017)), (* C6 *) + (C ( + ( (2.1040), (~1.7437), (0.6331)), (* N4 *) + ( (6.6267), (~2.5166), (0.7728)), (* O2 *) + ( (1.1496), (~2.0600), (0.7287)), (* H41 *) + ( (2.3303), (~0.7921), (0.3815)), (* H42 *) + ( (1.9353), (~4.4465), (1.3419)), (* H5 *) + ( (3.8895), (~5.8371), (1.6762))) (* H6 *) + ) + ) + +val rC02 + = ( + ( (0.5141), (0.0246), (0.8574), (* dgf-base-tfo *) + (~0.5547), (~0.7529), (0.3542), + (0.6542), (~0.6577), (~0.3734), + (~9.1111), (~3.4598), (~3.2939)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (4.3825), (~6.6585), (4.0489)), (* C5' *) + ( (4.6841), (~7.2019), (4.9443)), (* H5' *) + ( (3.6189), (~5.8889), (4.1625)), (* H5'' *) + ( (5.6255), (~5.9175), (3.5998)), (* C4' *) + ( (5.8732), (~5.1228), (4.3034)), (* H4' *) + ( (6.7337), (~6.8605), (3.5222)), (* O4' *) + ( (7.5932), (~6.4923), (2.4548)), (* C1' *) + ( (8.5661), (~6.2983), (2.9064)), (* H1' *) + ( (7.0527), (~5.2012), (1.8322)), (* C2' *) + ( (7.1627), (~5.2525), (0.7490)), (* H2'' *) + ( (7.6666), (~4.1249), (2.4880)), (* O2' *) + ( (8.5944), (~4.2543), (2.6981)), (* H2' *) + ( (5.5661), (~5.3029), (2.2009)), (* C3' *) + ( (5.0841), (~6.0018), (1.5172)), (* H3' *) + ( (4.9062), (~4.0452), (2.2042)), (* O3' *) + ( (7.6298), (~7.6136), (1.4752)), (* N1 *) + ( (8.6945), (~8.7046), (~0.2857)), (* N3 *) + ( (8.6943), (~7.6514), (0.6066)), (* C2 *) + ( (7.7426), (~9.6987), (~0.3801)), (* C4 *) + ( (6.6642), (~9.5742), (0.5722)), (* C5 *) + ( (6.6391), (~8.5592), (1.4526)), (* C6 *) + (C ( + ( (7.9033), (~10.6371), (~1.3010)), (* N4 *) + ( (9.5840), (~6.8186), (0.6136)), (* O2 *) + ( (7.2009), (~11.3604), (~1.3619)), (* H41 *) + ( (8.7058), (~10.6168), (~1.9140)), (* H42 *) + ( (5.8585), (~10.3083), (0.5822)), (* H5 *) + ( (5.8197), (~8.4773), (2.1667))) (* H6 *) + ) + ) + +val rC03 + = ( + ( (~0.4993), (0.0476), (0.8651), (* dgf-base-tfo *) + (0.8078), (~0.3353), (0.4847), + (0.3132), (0.9409), (0.1290), + (6.2989), (~5.2303), (~3.8577)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (3.9938), (~6.7042), (1.9023)), (* C5' *) + ( (3.2332), (~5.9343), (2.0319)), (* H5' *) + ( (3.9666), (~7.2863), (0.9812)), (* H5'' *) + ( (5.3098), (~5.9546), (1.8564)), (* C4' *) + ( (5.3863), (~5.3702), (0.9395)), (* H4' *) + ( (5.3851), (~5.0642), (3.0076)), (* O4' *) + ( (6.7315), (~4.9724), (3.4462)), (* C1' *) + ( (7.0033), (~3.9202), (3.3619)), (* H1' *) + ( (7.5997), (~5.8018), (2.4948)), (* C2' *) + ( (8.3627), (~6.3254), (3.0707)), (* H2'' *) + ( (8.0410), (~4.9501), (1.4724)), (* O2' *) + ( (8.2781), (~4.0644), (1.7570)), (* H2' *) + ( (6.5701), (~6.8129), (1.9714)), (* C3' *) + ( (6.4186), (~7.5809), (2.7299)), (* H3' *) + ( (6.9357), (~7.3841), (0.7235)), (* O3' *) + ( (6.8024), (~5.4718), (4.8475)), (* N1 *) + ( (7.9218), (~5.5700), (6.8877)), (* N3 *) + ( (7.8908), (~5.0886), (5.5944)), (* C2 *) + ( (6.9789), (~6.3827), (7.4823)), (* C4 *) + ( (5.8742), (~6.7319), (6.6202)), (* C5 *) + ( (5.8182), (~6.2769), (5.3570)), (* C6 *) + (C ( + ( (7.1702), (~6.7511), (8.7402)), (* N4 *) + ( (8.7747), (~4.3728), (5.1568)), (* O2 *) + ( (6.4741), (~7.3461), (9.1662)), (* H41 *) + ( (7.9889), (~6.4396), (9.2429)), (* H42 *) + ( (5.0736), (~7.3713), (6.9922)), (* H5 *) + ( (4.9784), (~6.5473), (4.7170))) (* H6 *) + ) + ) + +val rC04 + = ( + ( (~0.5669), (~0.8012), (0.1918), (* dgf-base-tfo *) + (~0.8129), (0.5817), (0.0273), + (~0.1334), (~0.1404), (~0.9811), + (~0.3279), (8.3874), (0.3355)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (5.2416), (~8.2422), (2.8181)), (* C5' *) + ( (5.2050), (~8.8128), (1.8901)), (* H5' *) + ( (5.5368), (~8.7738), (3.7227)), (* H5'' *) + ( (6.3232), (~7.2037), (2.6002)), (* C4' *) + ( (7.3048), (~7.6757), (2.5577)), (* H4' *) + ( (6.0635), (~6.5092), (1.3456)), (* O4' *) + ( (6.4697), (~5.1547), (1.4629)), (* C1' *) + ( (7.2354), (~5.0043), (0.7018)), (* H1' *) + ( (7.0856), (~4.9610), (2.8521)), (* C2' *) + ( (6.7777), (~3.9935), (3.2487)), (* H2'' *) + ( (8.4627), (~5.1992), (2.7423)), (* O2' *) + ( (8.8693), (~4.8638), (1.9399)), (* H2' *) + ( (6.3877), (~6.0809), (3.6362)), (* C3' *) + ( (5.3770), (~5.7562), (3.8834)), (* H3' *) + ( (7.1024), (~6.4754), (4.7985)), (* O3' *) + ( (5.2764), (~4.2883), (1.2538)), (* N1 *) + ( (3.8961), (~3.0896), (~0.1893)), (* N3 *) + ( (5.0095), (~3.8907), (~0.0346)), (* C2 *) + ( (3.0480), (~2.6632), (0.8116)), (* C4 *) + ( (3.4093), (~3.1310), (2.1292)), (* C5 *) + ( (4.4878), (~3.9124), (2.3088)), (* C6 *) + (C ( + ( (2.0216), (~1.8941), (0.4804)), (* N4 *) + ( (5.7005), (~4.2164), (~0.9842)), (* O2 *) + ( (1.4067), (~1.5873), (1.2205)), (* H41 *) + ( (1.8721), (~1.6319), (~0.4835)), (* H42 *) + ( (2.8048), (~2.8507), (2.9918)), (* H5 *) + ( (4.7491), (~4.2593), (3.3085))) (* H6 *) + ) + ) + +val rC05 + = ( + ( (~0.6298), (0.0246), (0.7763), (* dgf-base-tfo *) + (~0.5226), (~0.7529), (~0.4001), + (0.5746), (~0.6577), (0.4870), + (~0.0208), (~3.4598), (~9.6882)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (4.3825), (~6.6585), (4.0489)), (* C5' *) + ( (4.6841), (~7.2019), (4.9443)), (* H5' *) + ( (3.6189), (~5.8889), (4.1625)), (* H5'' *) + ( (5.6255), (~5.9175), (3.5998)), (* C4' *) + ( (5.8732), (~5.1228), (4.3034)), (* H4' *) + ( (6.7337), (~6.8605), (3.5222)), (* O4' *) + ( (7.5932), (~6.4923), (2.4548)), (* C1' *) + ( (8.5661), (~6.2983), (2.9064)), (* H1' *) + ( (7.0527), (~5.2012), (1.8322)), (* C2' *) + ( (7.1627), (~5.2525), (0.7490)), (* H2'' *) + ( (7.6666), (~4.1249), (2.4880)), (* O2' *) + ( (8.5944), (~4.2543), (2.6981)), (* H2' *) + ( (5.5661), (~5.3029), (2.2009)), (* C3' *) + ( (5.0841), (~6.0018), (1.5172)), (* H3' *) + ( (4.9062), (~4.0452), (2.2042)), (* O3' *) + ( (7.6298), (~7.6136), (1.4752)), (* N1 *) + ( (8.5977), (~9.5977), (0.7329)), (* N3 *) + ( (8.5951), (~8.5745), (1.6594)), (* C2 *) + ( (7.7372), (~9.7371), (~0.3364)), (* C4 *) + ( (6.7596), (~8.6801), (~0.4476)), (* C5 *) + ( (6.7338), (~7.6721), (0.4408)), (* C6 *) + (C ( + ( (7.8849), (~10.7881), (~1.1289)), (* N4 *) + ( (9.3993), (~8.5377), (2.5743)), (* O2 *) + ( (7.2499), (~10.8809), (~1.9088)), (* H41 *) + ( (8.6122), (~11.4649), (~0.9468)), (* H42 *) + ( (6.0317), (~8.6941), (~1.2588)), (* H5 *) + ( (5.9901), (~6.8809), (0.3459))) (* H6 *) + ) + ) + +val rC06 + = ( + ( (~0.9837), (0.0476), (~0.1733), (* dgf-base-tfo *) + (~0.1792), (~0.3353), (0.9249), + (~0.0141), (0.9409), (0.3384), + (5.7793), (~5.2303), (4.5997)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (3.9938), (~6.7042), (1.9023)), (* C5' *) + ( (3.2332), (~5.9343), (2.0319)), (* H5' *) + ( (3.9666), (~7.2863), (0.9812)), (* H5'' *) + ( (5.3098), (~5.9546), (1.8564)), (* C4' *) + ( (5.3863), (~5.3702), (0.9395)), (* H4' *) + ( (5.3851), (~5.0642), (3.0076)), (* O4' *) + ( (6.7315), (~4.9724), (3.4462)), (* C1' *) + ( (7.0033), (~3.9202), (3.3619)), (* H1' *) + ( (7.5997), (~5.8018), (2.4948)), (* C2' *) + ( (8.3627), (~6.3254), (3.0707)), (* H2'' *) + ( (8.0410), (~4.9501), (1.4724)), (* O2' *) + ( (8.2781), (~4.0644), (1.7570)), (* H2' *) + ( (6.5701), (~6.8129), (1.9714)), (* C3' *) + ( (6.4186), (~7.5809), (2.7299)), (* H3' *) + ( (6.9357), (~7.3841), (0.7235)), (* O3' *) + ( (6.8024), (~5.4718), (4.8475)), (* N1 *) + ( (6.6920), (~5.0495), (7.1354)), (* N3 *) + ( (6.6201), (~4.5500), (5.8506)), (* C2 *) + ( (6.9254), (~6.3614), (7.4926)), (* C4 *) + ( (7.1046), (~7.2543), (6.3718)), (* C5 *) + ( (7.0391), (~6.7951), (5.1106)), (* C6 *) + (C ( + ( (6.9614), (~6.6648), (8.7815)), (* N4 *) + ( (6.4083), (~3.3696), (5.6340)), (* O2 *) + ( (7.1329), (~7.6280), (9.0324)), (* H41 *) + ( (6.8204), (~5.9469), (9.4777)), (* H42 *) + ( (7.2954), (~8.3135), (6.5440)), (* H5 *) + ( (7.1753), (~7.4798), (4.2735))) (* H6 *) + ) + ) + +val rC07 + = ( + ( (0.0033), (0.2720), (~0.9623), (* dgf-base-tfo *) + (0.3013), (~0.9179), (~0.2584), + (~0.9535), (~0.2891), (~0.0850), + (43.0403), (13.7233), (34.5710)), + ( (0.9187), (0.2887), (0.2694), (* P-O3'-275-tfo *) + (0.0302), (~0.7316), (0.6811), + (0.3938), (~0.6176), (~0.6808), + (~48.4330), (26.3254), (13.6383)), + ( (~0.1504), (0.7744), (~0.6145), (* P-O3'-180-tfo *) + (0.7581), (0.4893), (0.4311), + (0.6345), (~0.4010), (~0.6607), + (~31.9784), (~13.4285), (44.9650)), + ( (~0.6236), (~0.7810), (~0.0337), (* P-O3'-60-tfo *) + (~0.6890), (0.5694), (~0.4484), + (0.3694), (~0.2564), (~0.8932), + (12.1105), (30.8774), (46.0946)), + ( (33.3400), (11.0980), (46.1750)), (* P *) + ( (34.5130), (10.2320), (46.4660)), (* O1P *) + ( (33.4130), (12.3960), (46.9340)), (* O2P *) + ( (31.9810), (10.3390), (46.4820)), (* O5' *) + ( (30.8152), (11.1619), (46.2003)), (* C5' *) + ( (30.4519), (10.9454), (45.1957)), (* H5' *) + ( (31.0379), (12.2016), (46.4400)), (* H5'' *) + ( (29.7081), (10.7448), (47.1428)), (* C4' *) + ( (28.8710), (11.4416), (47.0982)), (* H4' *) + ( (29.2550), (9.4394), (46.8162)), (* O4' *) + ( (29.3907), (8.5625), (47.9460)), (* C1' *) + ( (28.4416), (8.5669), (48.4819)), (* H1' *) + ( (30.4468), (9.2031), (48.7952)), (* C2' *) + ( (31.4222), (8.9651), (48.3709)), (* H2'' *) + ( (30.3701), (8.9157), (50.1624)), (* O2' *) + ( (30.0652), (8.0304), (50.3740)), (* H2' *) + ( (30.1622), (10.6879), (48.6120)), (* C3' *) + ( (31.0952), (11.2399), (48.7254)), (* H3' *) + ( (29.1076), (11.1535), (49.4702)), (* O3' *) + ( (29.7883), (7.2209), (47.5235)), (* N1 *) + ( (29.1825), (5.0438), (46.8275)), (* N3 *) + ( (28.8008), (6.2912), (47.2263)), (* C2 *) + ( (30.4888), (4.6890), (46.7186)), (* C4 *) + ( (31.5034), (5.6405), (47.0249)), (* C5 *) + ( (31.1091), (6.8691), (47.4156)), (* C6 *) + (C ( + ( (30.8109), (3.4584), (46.3336)), (* N4 *) + ( (27.6171), (6.5989), (47.3189)), (* O2 *) + ( (31.7923), (3.2301), (46.2638)), (* H41 *) + ( (30.0880), (2.7857), (46.1215)), (* H42 *) + ( (32.5542), (5.3634), (46.9395)), (* H5 *) + ( (31.8523), (7.6279), (47.6603))) (* H6 *) + ) + ) + +val rC08 + = ( + ( (0.0797), (~0.6026), (~0.7941), (* dgf-base-tfo *) + (0.7939), (0.5201), (~0.3150), + (0.6028), (~0.6054), (0.5198), + (~36.8341), (41.5293), (1.6628)), + ( (0.9187), (0.2887), (0.2694), (* P-O3'-275-tfo *) + (0.0302), (~0.7316), (0.6811), + (0.3938), (~0.6176), (~0.6808), + (~48.4330), (26.3254), (13.6383)), + ( (~0.1504), (0.7744), (~0.6145), (* P-O3'-180-tfo *) + (0.7581), (0.4893), (0.4311), + (0.6345), (~0.4010), (~0.6607), + (~31.9784), (~13.4285), (44.9650)), + ( (~0.6236), (~0.7810), (~0.0337), (* P-O3'-60-tfo *) + (~0.6890), (0.5694), (~0.4484), + (0.3694), (~0.2564), (~0.8932), + (12.1105), (30.8774), (46.0946)), + ( (33.3400), (11.0980), (46.1750)), (* P *) + ( (34.5130), (10.2320), (46.4660)), (* O1P *) + ( (33.4130), (12.3960), (46.9340)), (* O2P *) + ( (31.9810), (10.3390), (46.4820)), (* O5' *) + ( (31.8779), (9.9369), (47.8760)), (* C5' *) + ( (31.3239), (10.6931), (48.4322)), (* H5' *) + ( (32.8647), (9.6624), (48.2489)), (* H5'' *) + ( (31.0429), (8.6773), (47.9401)), (* C4' *) + ( (31.0779), (8.2331), (48.9349)), (* H4' *) + ( (29.6956), (8.9669), (47.5983)), (* O4' *) + ( (29.2784), (8.1700), (46.4782)), (* C1' *) + ( (28.8006), (7.2731), (46.8722)), (* H1' *) + ( (30.5544), (7.7940), (45.7875)), (* C2' *) + ( (30.8837), (8.6410), (45.1856)), (* H2'' *) + ( (30.5100), (6.6007), (45.0582)), (* O2' *) + ( (29.6694), (6.4168), (44.6326)), (* H2' *) + ( (31.5146), (7.5954), (46.9527)), (* C3' *) + ( (32.5255), (7.8261), (46.6166)), (* H3' *) + ( (31.3876), (6.2951), (47.5516)), (* O3' *) + ( (28.3976), (8.9302), (45.5933)), (* N1 *) + ( (26.2155), (9.6135), (44.9910)), (* N3 *) + ( (27.0281), (8.8961), (45.8192)), (* C2 *) + ( (26.7044), (10.3489), (43.9595)), (* C4 *) + ( (28.1088), (10.3837), (43.7247)), (* C5 *) + ( (28.8978), (9.6708), (44.5535)), (* C6 *) + (C ( + ( (25.8715), (11.0249), (43.1749)), (* N4 *) + ( (26.5733), (8.2371), (46.7484)), (* O2 *) + ( (26.2707), (11.5609), (42.4177)), (* H41 *) + ( (24.8760), (10.9939), (43.3427)), (* H42 *) + ( (28.5089), (10.9722), (42.8990)), (* H5 *) + ( (29.9782), (9.6687), (44.4097))) (* H6 *) + ) + ) + +val rC09 + = ( + ( (0.8727), (0.4760), (~0.1091), (* dgf-base-tfo *) + (~0.4188), (0.6148), (~0.6682), + (~0.2510), (0.6289), (0.7359), + (~8.1687), (~52.0761), (~25.0726)), + ( (0.9187), (0.2887), (0.2694), (* P-O3'-275-tfo *) + (0.0302), (~0.7316), (0.6811), + (0.3938), (~0.6176), (~0.6808), + (~48.4330), (26.3254), (13.6383)), + ( (~0.1504), (0.7744), (~0.6145), (* P-O3'-180-tfo *) + (0.7581), (0.4893), (0.4311), + (0.6345), (~0.4010), (~0.6607), + (~31.9784), (~13.4285), (44.9650)), + ( (~0.6236), (~0.7810), (~0.0337), (* P-O3'-60-tfo *) + (~0.6890), (0.5694), (~0.4484), + (0.3694), (~0.2564), (~0.8932), + (12.1105), (30.8774), (46.0946)), + ( (33.3400), (11.0980), (46.1750)), (* P *) + ( (34.5130), (10.2320), (46.4660)), (* O1P *) + ( (33.4130), (12.3960), (46.9340)), (* O2P *) + ( (31.9810), (10.3390), (46.4820)), (* O5' *) + ( (30.8152), (11.1619), (46.2003)), (* C5' *) + ( (30.4519), (10.9454), (45.1957)), (* H5' *) + ( (31.0379), (12.2016), (46.4400)), (* H5'' *) + ( (29.7081), (10.7448), (47.1428)), (* C4' *) + ( (29.4506), (9.6945), (47.0059)), (* H4' *) + ( (30.1045), (10.9634), (48.4885)), (* O4' *) + ( (29.1794), (11.8418), (49.1490)), (* C1' *) + ( (28.4388), (11.2210), (49.6533)), (* H1' *) + ( (28.5211), (12.6008), (48.0367)), (* C2' *) + ( (29.1947), (13.3949), (47.7147)), (* H2'' *) + ( (27.2316), (13.0683), (48.3134)), (* O2' *) + ( (27.0851), (13.3391), (49.2227)), (* H2' *) + ( (28.4131), (11.5507), (46.9391)), (* C3' *) + ( (28.4451), (12.0512), (45.9713)), (* H3' *) + ( (27.2707), (10.6955), (47.1097)), (* O3' *) + ( (29.8751), (12.7405), (50.0682)), (* N1 *) + ( (30.7172), (13.1841), (52.2328)), (* N3 *) + ( (30.0617), (12.3404), (51.3847)), (* C2 *) + ( (31.1834), (14.3941), (51.8297)), (* C4 *) + ( (30.9913), (14.8074), (50.4803)), (* C5 *) + ( (30.3434), (13.9610), (49.6548)), (* C6 *) + (C ( + ( (31.8090), (15.1847), (52.6957)), (* N4 *) + ( (29.6470), (11.2494), (51.7616)), (* O2 *) + ( (32.1422), (16.0774), (52.3606)), (* H41 *) + ( (31.9392), (14.8893), (53.6527)), (* H42 *) + ( (31.3632), (15.7771), (50.1491)), (* H5 *) + ( (30.1742), (14.2374), (48.6141))) (* H6 *) + ) + ) + +val rC10 + = ( + ( (0.1549), (0.8710), (~0.4663), (* dgf-base-tfo *) + (0.6768), (~0.4374), (~0.5921), + (~0.7197), (~0.2239), (~0.6572), + (25.2447), (~14.1920), (50.3201)), + ( (0.9187), (0.2887), (0.2694), (* P-O3'-275-tfo *) + (0.0302), (~0.7316), (0.6811), + (0.3938), (~0.6176), (~0.6808), + (~48.4330), (26.3254), (13.6383)), + ( (~0.1504), (0.7744), (~0.6145), (* P-O3'-180-tfo *) + (0.7581), (0.4893), (0.4311), + (0.6345), (~0.4010), (~0.6607), + (~31.9784), (~13.4285), (44.9650)), + ( (~0.6236), (~0.7810), (~0.0337), (* P-O3'-60-tfo *) + (~0.6890), (0.5694), (~0.4484), + (0.3694), (~0.2564), (~0.8932), + (12.1105), (30.8774), (46.0946)), + ( (33.3400), (11.0980), (46.1750)), (* P *) + ( (34.5130), (10.2320), (46.4660)), (* O1P *) + ( (33.4130), (12.3960), (46.9340)), (* O2P *) + ( (31.9810), (10.3390), (46.4820)), (* O5' *) + ( (31.8779), (9.9369), (47.8760)), (* C5' *) + ( (31.3239), (10.6931), (48.4322)), (* H5' *) + ( (32.8647), (9.6624), (48.2489)), (* H5'' *) + ( (31.0429), (8.6773), (47.9401)), (* C4' *) + ( (30.0440), (8.8473), (47.5383)), (* H4' *) + ( (31.6749), (7.6351), (47.2119)), (* O4' *) + ( (31.9159), (6.5022), (48.0616)), (* C1' *) + ( (31.0691), (5.8243), (47.9544)), (* H1' *) + ( (31.9300), (7.0685), (49.4493)), (* C2' *) + ( (32.9024), (7.5288), (49.6245)), (* H2'' *) + ( (31.5672), (6.1750), (50.4632)), (* O2' *) + ( (31.8416), (5.2663), (50.3200)), (* H2' *) + ( (30.8618), (8.1514), (49.3749)), (* C3' *) + ( (31.1122), (8.9396), (50.0850)), (* H3' *) + ( (29.5351), (7.6245), (49.5409)), (* O3' *) + ( (33.1890), (5.8629), (47.7343)), (* N1 *) + ( (34.4004), (4.2636), (46.4828)), (* N3 *) + ( (33.2062), (4.8497), (46.7851)), (* C2 *) + ( (35.5600), (4.6374), (47.0822)), (* C4 *) + ( (35.5444), (5.6751), (48.0577)), (* C5 *) + ( (34.3565), (6.2450), (48.3432)), (* C6 *) + (C ( + ( (36.6977), (4.0305), (46.7598)), (* N4 *) + ( (32.1661), (4.5034), (46.2348)), (* O2 *) + ( (37.5405), (4.3347), (47.2259)), (* H41 *) + ( (36.7033), (3.2923), (46.0706)), (* H42 *) + ( (36.4713), (5.9811), (48.5428)), (* H5 *) + ( (34.2986), (7.0426), (49.0839))) (* H6 *) + ) + ) + +val rCs = [rC01,rC02,rC03,rC04,rC05,rC06,rC07,rC08,rC09,rC10] + +val rG + = ( + ( (~0.0018), (~0.8207), (0.5714), (* dgf-base-tfo *) + (0.2679), (~0.5509), (~0.7904), + (0.9634), (0.1517), (0.2209), + (0.0073), (8.4030), (0.6232)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (5.4550), (8.2120), (~2.8810)), (* C5' *) + ( (5.4546), (8.8508), (~1.9978)), (* H5' *) + ( (5.7588), (8.6625), (~3.8259)), (* H5'' *) + ( (6.4970), (7.1480), (~2.5980)), (* C4' *) + ( (7.4896), (7.5919), (~2.5214)), (* H4' *) + ( (6.1630), (6.4860), (~1.3440)), (* O4' *) + ( (6.5400), (5.1200), (~1.4190)), (* C1' *) + ( (7.2763), (4.9681), (~0.6297)), (* H1' *) + ( (7.1940), (4.8830), (~2.7770)), (* C2' *) + ( (6.8667), (3.9183), (~3.1647)), (* H2'' *) + ( (8.5860), (5.0910), (~2.6140)), (* O2' *) + ( (8.9510), (4.7626), (~1.7890)), (* H2' *) + ( (6.5720), (6.0040), (~3.6090)), (* C3' *) + ( (5.5636), (5.7066), (~3.8966)), (* H3' *) + ( (7.3801), (6.3562), (~4.7350)), (* O3' *) + ( (4.7150), (0.4910), (~0.1360)), (* N1 *) + ( (6.3490), (2.1730), (~0.6020)), (* N3 *) + ( (5.9530), (0.9650), (~0.2670)), (* C2 *) + ( (5.2900), (2.9790), (~0.8260)), (* C4 *) + ( (3.9720), (2.6390), (~0.7330)), (* C5 *) + ( (3.6770), (1.3160), (~0.3660)), (* C6 *) + (G ( + ( (6.8426), (0.0056), (~0.0019)), (* N2 *) + ( (3.1660), (3.7290), (~1.0360)), (* N7 *) + ( (5.3170), (4.2990), (~1.1930)), (* N9 *) + ( (4.0100), (4.6780), (~1.2990)), (* C8 *) + ( (2.4280), (0.8450), (~0.2360)), (* O6 *) + ( (4.6151), (~0.4677), (0.1305)), (* H1 *) + ( (6.6463), (~0.9463), (0.2729)), (* H21 *) + ( (7.8170), (0.2642), (~0.0640)), (* H22 *) + ( (3.4421), (5.5744), (~1.5482))) (* H8 *) + ) + ) + +val rG01 + = ( + ( (~0.0043), (~0.8175), (0.5759), (* dgf-base-tfo *) + (0.2617), (~0.5567), (~0.7884), + (0.9651), (0.1473), (0.2164), + (0.0359), (8.3929), (0.5532)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (5.4352), (8.2183), (~2.7757)), (* C5' *) + ( (5.3830), (8.7883), (~1.8481)), (* H5' *) + ( (5.7729), (8.7436), (~3.6691)), (* H5'' *) + ( (6.4830), (7.1518), (~2.5252)), (* C4' *) + ( (7.4749), (7.5972), (~2.4482)), (* H4' *) + ( (6.1626), (6.4620), (~1.2827)), (* O4' *) + ( (6.5431), (5.0992), (~1.3905)), (* C1' *) + ( (7.2871), (4.9328), (~0.6114)), (* H1' *) + ( (7.1852), (4.8935), (~2.7592)), (* C2' *) + ( (6.8573), (3.9363), (~3.1645)), (* H2'' *) + ( (8.5780), (5.1025), (~2.6046)), (* O2' *) + ( (8.9516), (4.7577), (~1.7902)), (* H2' *) + ( (6.5522), (6.0300), (~3.5612)), (* C3' *) + ( (5.5420), (5.7356), (~3.8459)), (* H3' *) + ( (7.3487), (6.4089), (~4.6867)), (* O3' *) + ( (4.7442), (0.4514), (~0.1390)), (* N1 *) + ( (6.3687), (2.1459), (~0.5926)), (* N3 *) + ( (5.9795), (0.9335), (~0.2657)), (* C2 *) + ( (5.3052), (2.9471), (~0.8125)), (* C4 *) + ( (3.9891), (2.5987), (~0.7230)), (* C5 *) + ( (3.7016), (1.2717), (~0.3647)), (* C6 *) + (G ( + ( (6.8745), (~0.0224), (~0.0058)), (* N2 *) + ( (3.1770), (3.6859), (~1.0198)), (* N7 *) + ( (5.3247), (4.2695), (~1.1710)), (* N9 *) + ( (4.0156), (4.6415), (~1.2759)), (* C8 *) + ( (2.4553), (0.7925), (~0.2390)), (* O6 *) + ( (4.6497), (~0.5095), (0.1212)), (* H1 *) + ( (6.6836), (~0.9771), (0.2627)), (* H21 *) + ( (7.8474), (0.2424), (~0.0653)), (* H22 *) + ( (3.4426), (5.5361), (~1.5199))) (* H8 *) + ) + ) + +val rG02 + = ( + ( (0.5566), (0.0449), (0.8296), (* dgf-base-tfo *) + (0.5125), (0.7673), (~0.3854), + (~0.6538), (0.6397), (0.4041), + (~9.1161), (~3.7679), (~2.9968)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (4.5778), (6.6594), (~4.0364)), (* C5' *) + ( (4.9220), (7.1963), (~4.9204)), (* H5' *) + ( (3.7996), (5.9091), (~4.1764)), (* H5'' *) + ( (5.7873), (5.8869), (~3.5482)), (* C4' *) + ( (6.0405), (5.0875), (~4.2446)), (* H4' *) + ( (6.9135), (6.8036), (~3.4310)), (* O4' *) + ( (7.7293), (6.4084), (~2.3392)), (* C1' *) + ( (8.7078), (6.1815), (~2.7624)), (* H1' *) + ( (7.1305), (5.1418), (~1.7347)), (* C2' *) + ( (7.2040), (5.1982), (~0.6486)), (* H2'' *) + ( (7.7417), (4.0392), (~2.3813)), (* O2' *) + ( (8.6785), (4.1443), (~2.5630)), (* H2' *) + ( (5.6666), (5.2728), (~2.1536)), (* C3' *) + ( (5.1747), (5.9805), (~1.4863)), (* H3' *) + ( (4.9997), (4.0086), (~2.1973)), (* O3' *) + ( (10.3245), (8.5459), (1.5467)), (* N1 *) + ( (9.8051), (6.9432), (~0.1497)), (* N3 *) + ( (10.5175), (7.4328), (0.8408)), (* C2 *) + ( (8.7523), (7.7422), (~0.4228)), (* C4 *) + ( (8.4257), (8.9060), (0.2099)), (* C5 *) + ( (9.2665), (9.3242), (1.2540)), (* C6 *) + (G ( + ( (11.6077), (6.7966), (1.2752)), (* N2 *) + ( (7.2750), (9.4537), (~0.3428)), (* N7 *) + ( (7.7962), (7.5519), (~1.3859)), (* N9 *) + ( (6.9479), (8.6157), (~1.2771)), (* C8 *) + ( (9.0664), (10.4462), (1.9610)), (* O6 *) + ( (10.9838), (8.7524), (2.2697)), (* H1 *) + ( (12.2274), (7.0896), (2.0170)), (* H21 *) + ( (11.8502), (5.9398), (0.7984)), (* H22 *) + ( (6.0430), (8.9853), (~1.7594))) (* H8 *) + ) + ) + +val rG03 + = ( + ( (~0.5021), (0.0731), (0.8617), (* dgf-base-tfo *) + (~0.8112), (0.3054), (~0.4986), + (~0.2996), (~0.9494), (~0.0940), + (6.4273), (~5.1944), (~3.7807)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (4.1214), (6.7116), (~1.9049)), (* C5' *) + ( (3.3465), (5.9610), (~2.0607)), (* H5' *) + ( (4.0789), (7.2928), (~0.9837)), (* H5'' *) + ( (5.4170), (5.9293), (~1.8186)), (* C4' *) + ( (5.4506), (5.3400), (~0.9023)), (* H4' *) + ( (5.5067), (5.0417), (~2.9703)), (* O4' *) + ( (6.8650), (4.9152), (~3.3612)), (* C1' *) + ( (7.1090), (3.8577), (~3.2603)), (* H1' *) + ( (7.7152), (5.7282), (~2.3894)), (* C2' *) + ( (8.5029), (6.2356), (~2.9463)), (* H2'' *) + ( (8.1036), (4.8568), (~1.3419)), (* O2' *) + ( (8.3270), (3.9651), (~1.6184)), (* H2' *) + ( (6.7003), (6.7565), (~1.8911)), (* C3' *) + ( (6.5898), (7.5329), (~2.6482)), (* H3' *) + ( (7.0505), (7.2878), (~0.6105)), (* O3' *) + ( (9.6740), (4.7656), (~7.6614)), (* N1 *) + ( (9.0739), (4.3013), (~5.3941)), (* N3 *) + ( (9.8416), (4.2192), (~6.4581)), (* C2 *) + ( (7.9885), (5.0632), (~5.6446)), (* C4 *) + ( (7.6822), (5.6856), (~6.8194)), (* C5 *) + ( (8.5831), (5.5215), (~7.8840)), (* C6 *) + (G ( + ( (10.9733), (3.5117), (~6.4286)), (* N2 *) + ( (6.4857), (6.3816), (~6.7035)), (* N7 *) + ( (6.9740), (5.3703), (~4.7760)), (* N9 *) + ( (6.1133), (6.1613), (~5.4808)), (* C8 *) + ( (8.4084), (6.0747), (~9.0933)), (* O6 *) + ( (10.3759), (4.5855), (~8.3504)), (* H1 *) + ( (11.6254), (3.3761), (~7.1879)), (* H21 *) + ( (11.1917), (3.0460), (~5.5593)), (* H22 *) + ( (5.1705), (6.6830), (~5.3167))) (* H8 *) + ) + ) + +val rG04 + = ( + ( (~0.5426), (~0.8175), (0.1929), (* dgf-base-tfo *) + (0.8304), (~0.5567), (~0.0237), + (0.1267), (0.1473), (0.9809), + (~0.5075), (8.3929), (0.2229)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (5.4352), (8.2183), (~2.7757)), (* C5' *) + ( (5.3830), (8.7883), (~1.8481)), (* H5' *) + ( (5.7729), (8.7436), (~3.6691)), (* H5'' *) + ( (6.4830), (7.1518), (~2.5252)), (* C4' *) + ( (7.4749), (7.5972), (~2.4482)), (* H4' *) + ( (6.1626), (6.4620), (~1.2827)), (* O4' *) + ( (6.5431), (5.0992), (~1.3905)), (* C1' *) + ( (7.2871), (4.9328), (~0.6114)), (* H1' *) + ( (7.1852), (4.8935), (~2.7592)), (* C2' *) + ( (6.8573), (3.9363), (~3.1645)), (* H2'' *) + ( (8.5780), (5.1025), (~2.6046)), (* O2' *) + ( (8.9516), (4.7577), (~1.7902)), (* H2' *) + ( (6.5522), (6.0300), (~3.5612)), (* C3' *) + ( (5.5420), (5.7356), (~3.8459)), (* H3' *) + ( (7.3487), (6.4089), (~4.6867)), (* O3' *) + ( (3.6343), (2.6680), (2.0783)), (* N1 *) + ( (5.4505), (3.9805), (1.2446)), (* N3 *) + ( (4.7540), (3.3816), (2.1851)), (* C2 *) + ( (4.8805), (3.7951), (0.0354)), (* C4 *) + ( (3.7416), (3.0925), (~0.2305)), (* C5 *) + ( (3.0873), (2.4980), (0.8606)), (* C6 *) + (G ( + ( (5.1433), (3.4373), (3.4609)), (* N2 *) + ( (3.4605), (3.1184), (~1.5906)), (* N7 *) + ( (5.3247), (4.2695), (~1.1710)), (* N9 *) + ( (4.4244), (3.8244), (~2.0953)), (* C8 *) + ( (1.9600), (1.7805), (0.7462)), (* O6 *) + ( (3.2489), (2.2879), (2.9191)), (* H1 *) + ( (4.6785), (3.0243), (4.2568)), (* H21 *) + ( (5.9823), (3.9654), (3.6539)), (* H22 *) + ( (4.2675), (3.8876), (~3.1721))) (* H8 *) + ) + ) + +val rG05 + = ( + ( (~0.5891), (0.0449), (0.8068), (* dgf-base-tfo *) + (0.5375), (0.7673), (0.3498), + (~0.6034), (0.6397), (~0.4762), + (~0.3019), (~3.7679), (~9.5913)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (4.5778), (6.6594), (~4.0364)), (* C5' *) + ( (4.9220), (7.1963), (~4.9204)), (* H5' *) + ( (3.7996), (5.9091), (~4.1764)), (* H5'' *) + ( (5.7873), (5.8869), (~3.5482)), (* C4' *) + ( (6.0405), (5.0875), (~4.2446)), (* H4' *) + ( (6.9135), (6.8036), (~3.4310)), (* O4' *) + ( (7.7293), (6.4084), (~2.3392)), (* C1' *) + ( (8.7078), (6.1815), (~2.7624)), (* H1' *) + ( (7.1305), (5.1418), (~1.7347)), (* C2' *) + ( (7.2040), (5.1982), (~0.6486)), (* H2'' *) + ( (7.7417), (4.0392), (~2.3813)), (* O2' *) + ( (8.6785), (4.1443), (~2.5630)), (* H2' *) + ( (5.6666), (5.2728), (~2.1536)), (* C3' *) + ( (5.1747), (5.9805), (~1.4863)), (* H3' *) + ( (4.9997), (4.0086), (~2.1973)), (* O3' *) + ( (10.2594), (10.6774), (~1.0056)), (* N1 *) + ( (9.7528), (8.7080), (~2.2631)), (* N3 *) + ( (10.4471), (9.7876), (~1.9791)), (* C2 *) + ( (8.7271), (8.5575), (~1.3991)), (* C4 *) + ( (8.4100), (9.3803), (~0.3580)), (* C5 *) + ( (9.2294), (10.5030), (~0.1574)), (* C6 *) + (G ( + ( (11.5110), (10.1256), (~2.7114)), (* N2 *) + ( (7.2891), (8.9068), (0.3121)), (* N7 *) + ( (7.7962), (7.5519), (~1.3859)), (* N9 *) + ( (6.9702), (7.8292), (~0.3353)), (* C8 *) + ( (9.0349), (11.3951), (0.8250)), (* O6 *) + ( (10.9013), (11.4422), (~0.9512)), (* H1 *) + ( (12.1031), (10.9341), (~2.5861)), (* H21 *) + ( (11.7369), (9.5180), (~3.4859)), (* H22 *) + ( (6.0888), (7.3990), (0.1403))) (* H8 *) + ) + ) + +val rG06 + = ( + ( (~0.9815), (0.0731), (~0.1772), (* dgf-base-tfo *) + (0.1912), (0.3054), (~0.9328), + (~0.0141), (~0.9494), (~0.3137), + (5.7506), (~5.1944), (4.7470)), + ( (~0.8143), (~0.5091), (~0.2788), (* P-O3'-275-tfo *) + (~0.0433), (~0.4257), (0.9038), + (~0.5788), (0.7480), (0.3246), + (1.5227), (6.9114), (~7.0765)), + ( (0.3822), (~0.7477), (0.5430), (* P-O3'-180-tfo *) + (0.4552), (0.6637), (0.5935), + (~0.8042), (0.0203), (0.5941), + (~6.9472), (~4.1186), (~5.9108)), + ( (0.5640), (0.8007), (~0.2022), (* P-O3'-60-tfo *) + (~0.8247), (0.5587), (~0.0878), + (0.0426), (0.2162), (0.9754), + (6.2694), (~7.0540), (3.3316)), + ( (2.8930), (8.5380), (~3.3280)), (* P *) + ( (1.6980), (7.6960), (~3.5570)), (* O1P *) + ( (3.2260), (9.5010), (~4.4020)), (* O2P *) + ( (4.1590), (7.6040), (~3.0340)), (* O5' *) + ( (4.1214), (6.7116), (~1.9049)), (* C5' *) + ( (3.3465), (5.9610), (~2.0607)), (* H5' *) + ( (4.0789), (7.2928), (~0.9837)), (* H5'' *) + ( (5.4170), (5.9293), (~1.8186)), (* C4' *) + ( (5.4506), (5.3400), (~0.9023)), (* H4' *) + ( (5.5067), (5.0417), (~2.9703)), (* O4' *) + ( (6.8650), (4.9152), (~3.3612)), (* C1' *) + ( (7.1090), (3.8577), (~3.2603)), (* H1' *) + ( (7.7152), (5.7282), (~2.3894)), (* C2' *) + ( (8.5029), (6.2356), (~2.9463)), (* H2'' *) + ( (8.1036), (4.8568), (~1.3419)), (* O2' *) + ( (8.3270), (3.9651), (~1.6184)), (* H2' *) + ( (6.7003), (6.7565), (~1.8911)), (* C3' *) + ( (6.5898), (7.5329), (~2.6482)), (* H3' *) + ( (7.0505), (7.2878), (~0.6105)), (* O3' *) + ( (6.6624), (3.5061), (~8.2986)), (* N1 *) + ( (6.5810), (3.2570), (~5.9221)), (* N3 *) + ( (6.5151), (2.8263), (~7.1625)), (* C2 *) + ( (6.8364), (4.5817), (~5.8882)), (* C4 *) + ( (7.0116), (5.4064), (~6.9609)), (* C5 *) + ( (6.9173), (4.8260), (~8.2361)), (* C6 *) + (G ( + ( (6.2717), (1.5402), (~7.4250)), (* N2 *) + ( (7.2573), (6.7070), (~6.5394)), (* N7 *) + ( (6.9740), (5.3703), (~4.7760)), (* N9 *) + ( (7.2238), (6.6275), (~5.2453)), (* C8 *) + ( (7.0668), (5.5163), (~9.3763)), (* O6 *) + ( (6.5754), (2.9964), (~9.1545)), (* H1 *) + ( (6.1908), (1.1105), (~8.3354)), (* H21 *) + ( (6.1346), (0.9352), (~6.6280)), (* H22 *) + ( (7.4108), (7.6227), (~4.8418))) (* H8 *) + ) + ) + +val rG07 + = ( + ( (0.0894), (~0.6059), (0.7905), (* dgf-base-tfo *) + (~0.6810), (0.5420), (0.4924), + (~0.7268), (~0.5824), (~0.3642), + (34.1424), (45.9610), (~11.8600)), + ( (~0.8644), (~0.4956), (~0.0851), (* P-O3'-275-tfo *) + (~0.0427), (0.2409), (~0.9696), + (0.5010), (~0.8345), (~0.2294), + (4.0167), (54.5377), (12.4779)), + ( (0.3706), (~0.6167), (0.6945), (* P-O3'-180-tfo *) + (~0.2867), (~0.7872), (~0.5460), + (0.8834), (0.0032), (~0.4686), + (~52.9020), (18.6313), (~0.6709)), + ( (0.4155), (0.9025), (~0.1137), (* P-O3'-60-tfo *) + (0.9040), (~0.4236), (~0.0582), + (~0.1007), (~0.0786), (~0.9918), + (~7.6624), (~25.2080), (49.5181)), + ( (31.3810), (0.1400), (47.5810)), (* P *) + ( (29.9860), (0.6630), (47.6290)), (* O1P *) + ( (31.7210), (~0.6460), (48.8090)), (* O2P *) + ( (32.4940), (1.2540), (47.2740)), (* O5' *) + ( (33.8709), (0.7918), (47.2113)), (* C5' *) + ( (34.1386), (0.5870), (46.1747)), (* H5' *) + ( (34.0186), (~0.0095), (47.9353)), (* H5'' *) + ( (34.7297), (1.9687), (47.6685)), (* C4' *) + ( (35.7723), (1.6845), (47.8113)), (* H4' *) + ( (34.6455), (2.9768), (46.6660)), (* O4' *) + ( (34.1690), (4.1829), (47.2627)), (* C1' *) + ( (35.0437), (4.7633), (47.5560)), (* H1' *) + ( (33.4145), (3.7532), (48.4954)), (* C2' *) + ( (32.4340), (3.3797), (48.2001)), (* H2'' *) + ( (33.3209), (4.6953), (49.5217)), (* O2' *) + ( (33.2374), (5.6059), (49.2295)), (* H2' *) + ( (34.2724), (2.5970), (48.9773)), (* C3' *) + ( (33.6373), (1.8935), (49.5157)), (* H3' *) + ( (35.3453), (3.1884), (49.7285)), (* O3' *) + ( (34.0511), (7.8930), (43.7791)), (* N1 *) + ( (34.9937), (6.3369), (45.3199)), (* N3 *) + ( (35.0882), (7.3126), (44.4200)), (* C2 *) + ( (33.7190), (5.9650), (45.5374)), (* C4 *) + ( (32.5845), (6.4770), (44.9458)), (* C5 *) + ( (32.7430), (7.5179), (43.9914)), (* C6 *) + (G ( + ( (36.3030), (7.7827), (44.1036)), (* N2 *) + ( (31.4499), (5.8335), (45.4368)), (* N7 *) + ( (33.2760), (4.9817), (46.4043)), (* N9 *) + ( (31.9235), (4.9639), (46.2934)), (* C8 *) + ( (31.8602), (8.1000), (43.3695)), (* O6 *) + ( (34.2623), (8.6223), (43.1283)), (* H1 *) + ( (36.5188), (8.5081), (43.4347)), (* H21 *) + ( (37.0888), (7.3524), (44.5699)), (* H22 *) + ( (31.0815), (4.4201), (46.7218))) (* H8 *) + ) + ) + +val rG08 + = ( + ( (0.2224), (0.6335), (0.7411), (* dgf-base-tfo *) + (~0.3644), (~0.6510), (0.6659), + (0.9043), (~0.4181), (0.0861), + (~47.6824), (~0.5823), (~31.7554)), + ( (~0.8644), (~0.4956), (~0.0851), (* P-O3'-275-tfo *) + (~0.0427), (0.2409), (~0.9696), + (0.5010), (~0.8345), (~0.2294), + (4.0167), (54.5377), (12.4779)), + ( (0.3706), (~0.6167), (0.6945), (* P-O3'-180-tfo *) + (~0.2867), (~0.7872), (~0.5460), + (0.8834), (0.0032), (~0.4686), + (~52.9020), (18.6313), (~0.6709)), + ( (0.4155), (0.9025), (~0.1137), (* P-O3'-60-tfo *) + (0.9040), (~0.4236), (~0.0582), + (~0.1007), (~0.0786), (~0.9918), + (~7.6624), (~25.2080), (49.5181)), + ( (31.3810), (0.1400), (47.5810)), (* P *) + ( (29.9860), (0.6630), (47.6290)), (* O1P *) + ( (31.7210), (~0.6460), (48.8090)), (* O2P *) + ( (32.4940), (1.2540), (47.2740)), (* O5' *) + ( (32.5924), (2.3488), (48.2255)), (* C5' *) + ( (33.3674), (2.1246), (48.9584)), (* H5' *) + ( (31.5994), (2.5917), (48.6037)), (* H5'' *) + ( (33.0722), (3.5577), (47.4258)), (* C4' *) + ( (33.0310), (4.4778), (48.0089)), (* H4' *) + ( (34.4173), (3.3055), (47.0316)), (* O4' *) + ( (34.5056), (3.3910), (45.6094)), (* C1' *) + ( (34.7881), (4.4152), (45.3663)), (* H1' *) + ( (33.1122), (3.1198), (45.1010)), (* C2' *) + ( (32.9230), (2.0469), (45.1369)), (* H2'' *) + ( (32.7946), (3.6590), (43.8529)), (* O2' *) + ( (33.5170), (3.6707), (43.2207)), (* H2' *) + ( (32.2730), (3.8173), (46.1566)), (* C3' *) + ( (31.3094), (3.3123), (46.2244)), (* H3' *) + ( (32.2391), (5.2039), (45.7807)), (* O3' *) + ( (39.3337), (2.7157), (44.1441)), (* N1 *) + ( (37.4430), (3.8242), (45.0824)), (* N3 *) + ( (38.7276), (3.7646), (44.7403)), (* C2 *) + ( (36.7791), (2.6963), (44.7704)), (* C4 *) + ( (37.2860), (1.5653), (44.1678)), (* C5 *) + ( (38.6647), (1.5552), (43.8235)), (* C6 *) + (G ( + ( (39.5123), (4.8216), (44.9936)), (* N2 *) + ( (36.2829), (0.6110), (44.0078)), (* N7 *) + ( (35.4394), (2.4314), (44.9931)), (* N9 *) + ( (35.2180), (1.1815), (44.5128)), (* C8 *) + ( (39.2907), (0.6514), (43.2796)), (* O6 *) + ( (40.3076), (2.8048), (43.9352)), (* H1 *) + ( (40.4994), (4.9066), (44.7977)), (* H21 *) + ( (39.0738), (5.6108), (45.4464)), (* H22 *) + ( (34.3856), (0.4842), (44.4185))) (* H8 *) + ) + ) + +val rG09 + = ( + ( (~0.9699), (~0.1688), (~0.1753), (* dgf-base-tfo *) + (~0.1050), (~0.3598), (0.9271), + (~0.2196), (0.9176), (0.3312), + (45.6217), (~38.9484), (~12.3208)), + ( (~0.8644), (~0.4956), (~0.0851), (* P-O3'-275-tfo *) + (~0.0427), (0.2409), (~0.9696), + (0.5010), (~0.8345), (~0.2294), + (4.0167), (54.5377), (12.4779)), + ( (0.3706), (~0.6167), (0.6945), (* P-O3'-180-tfo *) + (~0.2867), (~0.7872), (~0.5460), + (0.8834), (0.0032), (~0.4686), + (~52.9020), (18.6313), (~0.6709)), + ( (0.4155), (0.9025), (~0.1137), (* P-O3'-60-tfo *) + (0.9040), (~0.4236), (~0.0582), + (~0.1007), (~0.0786), (~0.9918), + (~7.6624), (~25.2080), (49.5181)), + ( (31.3810), (0.1400), (47.5810)), (* P *) + ( (29.9860), (0.6630), (47.6290)), (* O1P *) + ( (31.7210), (~0.6460), (48.8090)), (* O2P *) + ( (32.4940), (1.2540), (47.2740)), (* O5' *) + ( (33.8709), (0.7918), (47.2113)), (* C5' *) + ( (34.1386), (0.5870), (46.1747)), (* H5' *) + ( (34.0186), (~0.0095), (47.9353)), (* H5'' *) + ( (34.7297), (1.9687), (47.6685)), (* C4' *) + ( (34.5880), (2.8482), (47.0404)), (* H4' *) + ( (34.3575), (2.2770), (49.0081)), (* O4' *) + ( (35.5157), (2.1993), (49.8389)), (* C1' *) + ( (35.9424), (3.2010), (49.8893)), (* H1' *) + ( (36.4701), (1.2820), (49.1169)), (* C2' *) + ( (36.1545), (0.2498), (49.2683)), (* H2'' *) + ( (37.8262), (1.4547), (49.4008)), (* O2' *) + ( (38.0227), (1.6945), (50.3094)), (* H2' *) + ( (36.2242), (1.6797), (47.6725)), (* C3' *) + ( (36.4297), (0.8197), (47.0351)), (* H3' *) + ( (37.0289), (2.8480), (47.4426)), (* O3' *) + ( (34.3005), (3.5042), (54.6070)), (* N1 *) + ( (34.7693), (3.7936), (52.2874)), (* N3 *) + ( (34.4484), (4.2541), (53.4939)), (* C2 *) + ( (34.9354), (2.4584), (52.2785)), (* C4 *) + ( (34.8092), (1.5915), (53.3422)), (* C5 *) + ( (34.4646), (2.1367), (54.6085)), (* C6 *) + (G ( + ( (34.2514), (5.5708), (53.6503)), (* N2 *) + ( (35.0641), (0.2835), (52.9337)), (* N7 *) + ( (35.2669), (1.6690), (51.1915)), (* N9 *) + ( (35.3288), (0.3954), (51.6563)), (* C8 *) + ( (34.3151), (1.5317), (55.6650)), (* O6 *) + ( (34.0623), (3.9797), (55.4539)), (* H1 *) + ( (33.9950), (6.0502), (54.5016)), (* H21 *) + ( (34.3512), (6.1432), (52.8242)), (* H22 *) + ( (35.5414), (~0.6006), (51.2679))) (* H8 *) + ) + ) + +val rG10 + = ( + ( (~0.0980), (~0.9723), (0.2122), (* dgf-base-tfo *) + (~0.9731), (0.1383), (0.1841), + (~0.2083), (~0.1885), (~0.9597), + (17.8469), (38.8265), (37.0475)), + ( (~0.8644), (~0.4956), (~0.0851), (* P-O3'-275-tfo *) + (~0.0427), (0.2409), (~0.9696), + (0.5010), (~0.8345), (~0.2294), + (4.0167), (54.5377), (12.4779)), + ( (0.3706), (~0.6167), (0.6945), (* P-O3'-180-tfo *) + (~0.2867), (~0.7872), (~0.5460), + (0.8834), (0.0032), (~0.4686), + (~52.9020), (18.6313), (~0.6709)), + ( (0.4155), (0.9025), (~0.1137), (* P-O3'-60-tfo *) + (0.9040), (~0.4236), (~0.0582), + (~0.1007), (~0.0786), (~0.9918), + (~7.6624), (~25.2080), (49.5181)), + ( (31.3810), (0.1400), (47.5810)), (* P *) + ( (29.9860), (0.6630), (47.6290)), (* O1P *) + ( (31.7210), (~0.6460), (48.8090)), (* O2P *) + ( (32.4940), (1.2540), (47.2740)), (* O5' *) + ( (32.5924), (2.3488), (48.2255)), (* C5' *) + ( (33.3674), (2.1246), (48.9584)), (* H5' *) + ( (31.5994), (2.5917), (48.6037)), (* H5'' *) + ( (33.0722), (3.5577), (47.4258)), (* C4' *) + ( (34.0333), (3.3761), (46.9447)), (* H4' *) + ( (32.0890), (3.8338), (46.4332)), (* O4' *) + ( (31.6377), (5.1787), (46.5914)), (* C1' *) + ( (32.2499), (5.8016), (45.9392)), (* H1' *) + ( (31.9167), (5.5319), (48.0305)), (* C2' *) + ( (31.1507), (5.0820), (48.6621)), (* H2'' *) + ( (32.0865), (6.8890), (48.3114)), (* O2' *) + ( (31.5363), (7.4819), (47.7942)), (* H2' *) + ( (33.2398), (4.8224), (48.2563)), (* C3' *) + ( (33.3166), (4.5570), (49.3108)), (* H3' *) + ( (34.2528), (5.7056), (47.7476)), (* O3' *) + ( (28.2782), (6.3049), (42.9364)), (* N1 *) + ( (30.4001), (5.8547), (43.9258)), (* N3 *) + ( (29.6195), (6.1568), (42.8913)), (* C2 *) + ( (29.7005), (5.7006), (45.0649)), (* C4 *) + ( (28.3383), (5.8221), (45.2343)), (* C5 *) + ( (27.5519), (6.1461), (44.0958)), (* C6 *) + (G ( + ( (30.1838), (6.3385), (41.6890)), (* N2 *) + ( (27.9936), (5.5926), (46.5651)), (* N7 *) + ( (30.2046), (5.3825), (46.3136)), (* N9 *) + ( (29.1371), (5.3398), (47.1506)), (* C8 *) + ( (26.3361), (6.3024), (44.0495)), (* O6 *) + ( (27.8122), (6.5394), (42.0833)), (* H1 *) + ( (29.7125), (6.5595), (40.8235)), (* H21 *) + ( (31.1859), (6.2231), (41.6389)), (* H22 *) + ( (28.9406), (5.1504), (48.2059))) (* H8 *) + ) + ) + +val rGs = [rG01,rG02,rG03,rG04,rG05,rG06,rG07,rG08,rG09,rG10] + +val rU + = ( + ( (~0.0359), (~0.8071), (0.5894), (* dgf-base-tfo *) + (~0.2669), (0.5761), (0.7726), + (~0.9631), (~0.1296), (~0.2361), + (0.1584), (8.3434), (0.5434)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (5.2430), (~8.2420), (2.8260)), (* C5' *) + ( (5.1974), (~8.8497), (1.9223)), (* H5' *) + ( (5.5548), (~8.7348), (3.7469)), (* H5'' *) + ( (6.3140), (~7.2060), (2.5510)), (* C4' *) + ( (7.2954), (~7.6762), (2.4898)), (* H4' *) + ( (6.0140), (~6.5420), (1.2890)), (* O4' *) + ( (6.4190), (~5.1840), (1.3620)), (* C1' *) + ( (7.1608), (~5.0495), (0.5747)), (* H1' *) + ( (7.0760), (~4.9560), (2.7270)), (* C2' *) + ( (6.7770), (~3.9803), (3.1099)), (* H2'' *) + ( (8.4500), (~5.1930), (2.5810)), (* O2' *) + ( (8.8309), (~4.8755), (1.7590)), (* H2' *) + ( (6.4060), (~6.0590), (3.5580)), (* C3' *) + ( (5.4021), (~5.7313), (3.8281)), (* H3' *) + ( (7.1570), (~6.4240), (4.7070)), (* O3' *) + ( (5.2170), (~4.3260), (1.1690)), (* N1 *) + ( (4.2960), (~2.2560), (0.6290)), (* N3 *) + ( (5.4330), (~3.0200), (0.7990)), (* C2 *) + ( (2.9930), (~2.6780), (0.7940)), (* C4 *) + ( (2.8670), (~4.0630), (1.1830)), (* C5 *) + ( (3.9570), (~4.8300), (1.3550)), (* C6 *) + (U ( + ( (6.5470), (~2.5560), (0.6290)), (* O2 *) + ( (2.0540), (~1.9000), (0.6130)), (* O4 *) + ( (4.4300), (~1.3020), (0.3600)), (* H3 *) + ( (1.9590), (~4.4570), (1.3250)), (* H5 *) + ( (3.8460), (~5.7860), (1.6240))) (* H6 *) + ) + ) + +val rU01 + = ( + ( (~0.0137), (~0.8012), (0.5983), (* dgf-base-tfo *) + (~0.2523), (0.5817), (0.7733), + (~0.9675), (~0.1404), (~0.2101), + (0.2031), (8.3874), (0.4228)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (5.2416), (~8.2422), (2.8181)), (* C5' *) + ( (5.2050), (~8.8128), (1.8901)), (* H5' *) + ( (5.5368), (~8.7738), (3.7227)), (* H5'' *) + ( (6.3232), (~7.2037), (2.6002)), (* C4' *) + ( (7.3048), (~7.6757), (2.5577)), (* H4' *) + ( (6.0635), (~6.5092), (1.3456)), (* O4' *) + ( (6.4697), (~5.1547), (1.4629)), (* C1' *) + ( (7.2354), (~5.0043), (0.7018)), (* H1' *) + ( (7.0856), (~4.9610), (2.8521)), (* C2' *) + ( (6.7777), (~3.9935), (3.2487)), (* H2'' *) + ( (8.4627), (~5.1992), (2.7423)), (* O2' *) + ( (8.8693), (~4.8638), (1.9399)), (* H2' *) + ( (6.3877), (~6.0809), (3.6362)), (* C3' *) + ( (5.3770), (~5.7562), (3.8834)), (* H3' *) + ( (7.1024), (~6.4754), (4.7985)), (* O3' *) + ( (5.2764), (~4.2883), (1.2538)), (* N1 *) + ( (4.3777), (~2.2062), (0.7229)), (* N3 *) + ( (5.5069), (~2.9779), (0.9088)), (* C2 *) + ( (3.0693), (~2.6246), (0.8500)), (* C4 *) + ( (2.9279), (~4.0146), (1.2149)), (* C5 *) + ( (4.0101), (~4.7892), (1.4017)), (* C6 *) + (U ( + ( (6.6267), (~2.5166), (0.7728)), (* O2 *) + ( (2.1383), (~1.8396), (0.6581)), (* O4 *) + ( (4.5223), (~1.2489), (0.4716)), (* H3 *) + ( (2.0151), (~4.4065), (1.3290)), (* H5 *) + ( (3.8886), (~5.7486), (1.6535))) (* H6 *) + ) + ) + +val rU02 + = ( + ( (0.5141), (0.0246), (0.8574), (* dgf-base-tfo *) + (~0.5547), (~0.7529), (0.3542), + (0.6542), (~0.6577), (~0.3734), + (~9.1111), (~3.4598), (~3.2939)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (4.3825), (~6.6585), (4.0489)), (* C5' *) + ( (4.6841), (~7.2019), (4.9443)), (* H5' *) + ( (3.6189), (~5.8889), (4.1625)), (* H5'' *) + ( (5.6255), (~5.9175), (3.5998)), (* C4' *) + ( (5.8732), (~5.1228), (4.3034)), (* H4' *) + ( (6.7337), (~6.8605), (3.5222)), (* O4' *) + ( (7.5932), (~6.4923), (2.4548)), (* C1' *) + ( (8.5661), (~6.2983), (2.9064)), (* H1' *) + ( (7.0527), (~5.2012), (1.8322)), (* C2' *) + ( (7.1627), (~5.2525), (0.7490)), (* H2'' *) + ( (7.6666), (~4.1249), (2.4880)), (* O2' *) + ( (8.5944), (~4.2543), (2.6981)), (* H2' *) + ( (5.5661), (~5.3029), (2.2009)), (* C3' *) + ( (5.0841), (~6.0018), (1.5172)), (* H3' *) + ( (4.9062), (~4.0452), (2.2042)), (* O3' *) + ( (7.6298), (~7.6136), (1.4752)), (* N1 *) + ( (8.6945), (~8.7046), (~0.2857)), (* N3 *) + ( (8.6943), (~7.6514), (0.6066)), (* C2 *) + ( (7.7426), (~9.6987), (~0.3801)), (* C4 *) + ( (6.6642), (~9.5742), (0.5722)), (* C5 *) + ( (6.6391), (~8.5592), (1.4526)), (* C6 *) + (U ( + ( (9.5840), (~6.8186), (0.6136)), (* O2 *) + ( (7.8505), (~10.5925), (~1.2223)), (* O4 *) + ( (9.4601), (~8.7514), (~0.9277)), (* H3 *) + ( (5.9281), (~10.2509), (0.5782)), (* H5 *) + ( (5.8831), (~8.4931), (2.1028))) (* H6 *) + ) + ) + +val rU03 + = ( + ( (~0.4993), (0.0476), (0.8651), (* dgf-base-tfo *) + (0.8078), (~0.3353), (0.4847), + (0.3132), (0.9409), (0.1290), + (6.2989), (~5.2303), (~3.8577)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (3.9938), (~6.7042), (1.9023)), (* C5' *) + ( (3.2332), (~5.9343), (2.0319)), (* H5' *) + ( (3.9666), (~7.2863), (0.9812)), (* H5'' *) + ( (5.3098), (~5.9546), (1.8564)), (* C4' *) + ( (5.3863), (~5.3702), (0.9395)), (* H4' *) + ( (5.3851), (~5.0642), (3.0076)), (* O4' *) + ( (6.7315), (~4.9724), (3.4462)), (* C1' *) + ( (7.0033), (~3.9202), (3.3619)), (* H1' *) + ( (7.5997), (~5.8018), (2.4948)), (* C2' *) + ( (8.3627), (~6.3254), (3.0707)), (* H2'' *) + ( (8.0410), (~4.9501), (1.4724)), (* O2' *) + ( (8.2781), (~4.0644), (1.7570)), (* H2' *) + ( (6.5701), (~6.8129), (1.9714)), (* C3' *) + ( (6.4186), (~7.5809), (2.7299)), (* H3' *) + ( (6.9357), (~7.3841), (0.7235)), (* O3' *) + ( (6.8024), (~5.4718), (4.8475)), (* N1 *) + ( (7.9218), (~5.5700), (6.8877)), (* N3 *) + ( (7.8908), (~5.0886), (5.5944)), (* C2 *) + ( (6.9789), (~6.3827), (7.4823)), (* C4 *) + ( (5.8742), (~6.7319), (6.6202)), (* C5 *) + ( (5.8182), (~6.2769), (5.3570)), (* C6 *) + (U ( + ( (8.7747), (~4.3728), (5.1568)), (* O2 *) + ( (7.1154), (~6.7509), (8.6509)), (* O4 *) + ( (8.7055), (~5.3037), (7.4491)), (* H3 *) + ( (5.1416), (~7.3178), (6.9665)), (* H5 *) + ( (5.0441), (~6.5310), (4.7784))) (* H6 *) + ) + ) + +val rU04 + = ( + ( (~0.5669), (~0.8012), (0.1918), (* dgf-base-tfo *) + (~0.8129), (0.5817), (0.0273), + (~0.1334), (~0.1404), (~0.9811), + (~0.3279), (8.3874), (0.3355)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (5.2416), (~8.2422), (2.8181)), (* C5' *) + ( (5.2050), (~8.8128), (1.8901)), (* H5' *) + ( (5.5368), (~8.7738), (3.7227)), (* H5'' *) + ( (6.3232), (~7.2037), (2.6002)), (* C4' *) + ( (7.3048), (~7.6757), (2.5577)), (* H4' *) + ( (6.0635), (~6.5092), (1.3456)), (* O4' *) + ( (6.4697), (~5.1547), (1.4629)), (* C1' *) + ( (7.2354), (~5.0043), (0.7018)), (* H1' *) + ( (7.0856), (~4.9610), (2.8521)), (* C2' *) + ( (6.7777), (~3.9935), (3.2487)), (* H2'' *) + ( (8.4627), (~5.1992), (2.7423)), (* O2' *) + ( (8.8693), (~4.8638), (1.9399)), (* H2' *) + ( (6.3877), (~6.0809), (3.6362)), (* C3' *) + ( (5.3770), (~5.7562), (3.8834)), (* H3' *) + ( (7.1024), (~6.4754), (4.7985)), (* O3' *) + ( (5.2764), (~4.2883), (1.2538)), (* N1 *) + ( (3.8961), (~3.0896), (~0.1893)), (* N3 *) + ( (5.0095), (~3.8907), (~0.0346)), (* C2 *) + ( (3.0480), (~2.6632), (0.8116)), (* C4 *) + ( (3.4093), (~3.1310), (2.1292)), (* C5 *) + ( (4.4878), (~3.9124), (2.3088)), (* C6 *) + (U ( + ( (5.7005), (~4.2164), (~0.9842)), (* O2 *) + ( (2.0800), (~1.9458), (0.5503)), (* O4 *) + ( (3.6834), (~2.7882), (~1.1190)), (* H3 *) + ( (2.8508), (~2.8721), (2.9172)), (* H5 *) + ( (4.7188), (~4.2247), (3.2295))) (* H6 *) + ) + ) + +val rU05 + = ( + ( (~0.6298), (0.0246), (0.7763), (* dgf-base-tfo *) + (~0.5226), (~0.7529), (~0.4001), + (0.5746), (~0.6577), (0.4870), + (~0.0208), (~3.4598), (~9.6882)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (4.3825), (~6.6585), (4.0489)), (* C5' *) + ( (4.6841), (~7.2019), (4.9443)), (* H5' *) + ( (3.6189), (~5.8889), (4.1625)), (* H5'' *) + ( (5.6255), (~5.9175), (3.5998)), (* C4' *) + ( (5.8732), (~5.1228), (4.3034)), (* H4' *) + ( (6.7337), (~6.8605), (3.5222)), (* O4' *) + ( (7.5932), (~6.4923), (2.4548)), (* C1' *) + ( (8.5661), (~6.2983), (2.9064)), (* H1' *) + ( (7.0527), (~5.2012), (1.8322)), (* C2' *) + ( (7.1627), (~5.2525), (0.7490)), (* H2'' *) + ( (7.6666), (~4.1249), (2.4880)), (* O2' *) + ( (8.5944), (~4.2543), (2.6981)), (* H2' *) + ( (5.5661), (~5.3029), (2.2009)), (* C3' *) + ( (5.0841), (~6.0018), (1.5172)), (* H3' *) + ( (4.9062), (~4.0452), (2.2042)), (* O3' *) + ( (7.6298), (~7.6136), (1.4752)), (* N1 *) + ( (8.5977), (~9.5977), (0.7329)), (* N3 *) + ( (8.5951), (~8.5745), (1.6594)), (* C2 *) + ( (7.7372), (~9.7371), (~0.3364)), (* C4 *) + ( (6.7596), (~8.6801), (~0.4476)), (* C5 *) + ( (6.7338), (~7.6721), (0.4408)), (* C6 *) + (U ( + ( (9.3993), (~8.5377), (2.5743)), (* O2 *) + ( (7.8374), (~10.6990), (~1.1008)), (* O4 *) + ( (9.2924), (~10.3081), (0.8477)), (* H3 *) + ( (6.0932), (~8.6982), (~1.1929)), (* H5 *) + ( (6.0481), (~6.9515), (0.3446))) (* H6 *) + ) + ) + +val rU06 + = ( + ( (~0.9837), (0.0476), (~0.1733), (* dgf-base-tfo *) + (~0.1792), (~0.3353), (0.9249), + (~0.0141), (0.9409), (0.3384), + (5.7793), (~5.2303), (4.5997)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (3.9938), (~6.7042), (1.9023)), (* C5' *) + ( (3.2332), (~5.9343), (2.0319)), (* H5' *) + ( (3.9666), (~7.2863), (0.9812)), (* H5'' *) + ( (5.3098), (~5.9546), (1.8564)), (* C4' *) + ( (5.3863), (~5.3702), (0.9395)), (* H4' *) + ( (5.3851), (~5.0642), (3.0076)), (* O4' *) + ( (6.7315), (~4.9724), (3.4462)), (* C1' *) + ( (7.0033), (~3.9202), (3.3619)), (* H1' *) + ( (7.5997), (~5.8018), (2.4948)), (* C2' *) + ( (8.3627), (~6.3254), (3.0707)), (* H2'' *) + ( (8.0410), (~4.9501), (1.4724)), (* O2' *) + ( (8.2781), (~4.0644), (1.7570)), (* H2' *) + ( (6.5701), (~6.8129), (1.9714)), (* C3' *) + ( (6.4186), (~7.5809), (2.7299)), (* H3' *) + ( (6.9357), (~7.3841), (0.7235)), (* O3' *) + ( (6.8024), (~5.4718), (4.8475)), (* N1 *) + ( (6.6920), (~5.0495), (7.1354)), (* N3 *) + ( (6.6201), (~4.5500), (5.8506)), (* C2 *) + ( (6.9254), (~6.3614), (7.4926)), (* C4 *) + ( (7.1046), (~7.2543), (6.3718)), (* C5 *) + ( (7.0391), (~6.7951), (5.1106)), (* C6 *) + (U ( + ( (6.4083), (~3.3696), (5.6340)), (* O2 *) + ( (6.9679), (~6.6901), (8.6800)), (* O4 *) + ( (6.5626), (~4.3957), (7.8812)), (* H3 *) + ( (7.2781), (~8.2254), (6.5350)), (* H5 *) + ( (7.1657), (~7.4312), (4.3503))) (* H6 *) + ) + ) + +val rU07 + = ( + ( (~0.9434), (0.3172), (0.0971), (* dgf-base-tfo *) + (0.2294), (0.4125), (0.8816), + (0.2396), (0.8539), (~0.4619), + (8.3625), (~52.7147), (1.3745)), + ( (0.2765), (~0.1121), (~0.9545), (* P-O3'-275-tfo *) + (~0.8297), (0.4733), (~0.2959), + (0.4850), (0.8737), (0.0379), + (~14.7774), (~45.2464), (21.9088)), + ( (0.1063), (~0.6334), (~0.7665), (* P-O3'-180-tfo *) + (~0.5932), (~0.6591), (0.4624), + (~0.7980), (0.4055), (~0.4458), + (43.7634), (4.3296), (28.4890)), + ( (0.7136), (~0.5032), (~0.4873), (* P-O3'-60-tfo *) + (0.6803), (0.3317), (0.6536), + (~0.1673), (~0.7979), (0.5791), + (~17.1858), (41.4390), (~27.0751)), + ( (21.3880), (15.0780), (45.5770)), (* P *) + ( (21.9980), (14.5500), (46.8210)), (* O1P *) + ( (21.1450), (14.0270), (44.5420)), (* O2P *) + ( (22.1250), (16.3600), (44.9460)), (* O5' *) + ( (21.5037), (16.8594), (43.7323)), (* C5' *) + ( (20.8147), (17.6663), (43.9823)), (* H5' *) + ( (21.1086), (16.0230), (43.1557)), (* H5'' *) + ( (22.5654), (17.4874), (42.8616)), (* C4' *) + ( (22.1584), (17.7243), (41.8785)), (* H4' *) + ( (23.0557), (18.6826), (43.4751)), (* O4' *) + ( (24.4788), (18.6151), (43.6455)), (* C1' *) + ( (24.9355), (19.0840), (42.7739)), (* H1' *) + ( (24.7958), (17.1427), (43.6474)), (* C2' *) + ( (24.5652), (16.7400), (44.6336)), (* H2'' *) + ( (26.1041), (16.8773), (43.2455)), (* O2' *) + ( (26.7516), (17.5328), (43.5149)), (* H2' *) + ( (23.8109), (16.5979), (42.6377)), (* C3' *) + ( (23.5756), (15.5686), (42.9084)), (* H3' *) + ( (24.2890), (16.7447), (41.2729)), (* O3' *) + ( (24.9420), (19.2174), (44.8923)), (* N1 *) + ( (25.2655), (20.5636), (44.8883)), (* N3 *) + ( (25.1663), (21.2219), (43.8561)), (* C2 *) + ( (25.6911), (21.1219), (46.0494)), (* C4 *) + ( (25.8051), (20.4068), (47.2048)), (* C5 *) + ( (26.2093), (20.9962), (48.2534)), (* C6 *) + (U ( + ( (25.4692), (19.0221), (47.2053)), (* O2 *) + ( (25.0502), (18.4827), (46.0370)), (* O4 *) + ( (25.9599), (22.1772), (46.0966)), (* H3 *) + ( (25.5545), (18.4409), (48.1234)), (* H5 *) + ( (24.7854), (17.4265), (45.9883))) (* H6 *) + ) + ) + +val rU08 + = ( + ( (~0.0080), (~0.7928), (0.6094), (* dgf-base-tfo *) + (~0.7512), (0.4071), (0.5197), + (~0.6601), (~0.4536), (~0.5988), + (44.1482), (30.7036), (2.1088)), + ( (0.2765), (~0.1121), (~0.9545), (* P-O3'-275-tfo *) + (~0.8297), (0.4733), (~0.2959), + (0.4850), (0.8737), (0.0379), + (~14.7774), (~45.2464), (21.9088)), + ( (0.1063), (~0.6334), (~0.7665), (* P-O3'-180-tfo *) + (~0.5932), (~0.6591), (0.4624), + (~0.7980), (0.4055), (~0.4458), + (43.7634), (4.3296), (28.4890)), + ( (0.7136), (~0.5032), (~0.4873), (* P-O3'-60-tfo *) + (0.6803), (0.3317), (0.6536), + (~0.1673), (~0.7979), (0.5791), + (~17.1858), (41.4390), (~27.0751)), + ( (21.3880), (15.0780), (45.5770)), (* P *) + ( (21.9980), (14.5500), (46.8210)), (* O1P *) + ( (21.1450), (14.0270), (44.5420)), (* O2P *) + ( (22.1250), (16.3600), (44.9460)), (* O5' *) + ( (23.5096), (16.1227), (44.5783)), (* C5' *) + ( (23.5649), (15.8588), (43.5222)), (* H5' *) + ( (23.9621), (15.4341), (45.2919)), (* H5'' *) + ( (24.2805), (17.4138), (44.7151)), (* C4' *) + ( (25.3492), (17.2309), (44.6030)), (* H4' *) + ( (23.8497), (18.3471), (43.7208)), (* O4' *) + ( (23.4090), (19.5681), (44.3321)), (* C1' *) + ( (24.2595), (20.2496), (44.3524)), (* H1' *) + ( (23.0418), (19.1813), (45.7407)), (* C2' *) + ( (22.0532), (18.7224), (45.7273)), (* H2'' *) + ( (23.1307), (20.2521), (46.6291)), (* O2' *) + ( (22.8888), (21.1051), (46.2611)), (* H2' *) + ( (24.0799), (18.1326), (46.0700)), (* C3' *) + ( (23.6490), (17.4370), (46.7900)), (* H3' *) + ( (25.3329), (18.7227), (46.5109)), (* O3' *) + ( (22.2515), (20.1624), (43.6698)), (* N1 *) + ( (22.4760), (21.0609), (42.6406)), (* N3 *) + ( (23.6229), (21.3462), (42.3061)), (* C2 *) + ( (21.3986), (21.6081), (42.0236)), (* C4 *) + ( (20.1189), (21.3012), (42.3804)), (* C5 *) + ( (19.1599), (21.8516), (41.7578)), (* C6 *) + (U ( + ( (19.8919), (20.3745), (43.4387)), (* O2 *) + ( (20.9790), (19.8423), (44.0440)), (* O4 *) + ( (21.5235), (22.3222), (41.2097)), (* H3 *) + ( (18.8732), (20.1200), (43.7312)), (* H5 *) + ( (20.8545), (19.1313), (44.8608))) (* H6 *) + ) + ) + +val rU09 + = ( + ( (~0.0317), (0.1374), (0.9900), (* dgf-base-tfo *) + (~0.3422), (~0.9321), (0.1184), + (0.9391), (~0.3351), (0.0765), + (~32.1929), (25.8198), (~28.5088)), + ( (0.2765), (~0.1121), (~0.9545), (* P-O3'-275-tfo *) + (~0.8297), (0.4733), (~0.2959), + (0.4850), (0.8737), (0.0379), + (~14.7774), (~45.2464), (21.9088)), + ( (0.1063), (~0.6334), (~0.7665), (* P-O3'-180-tfo *) + (~0.5932), (~0.6591), (0.4624), + (~0.7980), (0.4055), (~0.4458), + (43.7634), (4.3296), (28.4890)), + ( (0.7136), (~0.5032), (~0.4873), (* P-O3'-60-tfo *) + (0.6803), (0.3317), (0.6536), + (~0.1673), (~0.7979), (0.5791), + (~17.1858), (41.4390), (~27.0751)), + ( (21.3880), (15.0780), (45.5770)), (* P *) + ( (21.9980), (14.5500), (46.8210)), (* O1P *) + ( (21.1450), (14.0270), (44.5420)), (* O2P *) + ( (22.1250), (16.3600), (44.9460)), (* O5' *) + ( (21.5037), (16.8594), (43.7323)), (* C5' *) + ( (20.8147), (17.6663), (43.9823)), (* H5' *) + ( (21.1086), (16.0230), (43.1557)), (* H5'' *) + ( (22.5654), (17.4874), (42.8616)), (* C4' *) + ( (23.0565), (18.3036), (43.3915)), (* H4' *) + ( (23.5375), (16.5054), (42.4925)), (* O4' *) + ( (23.6574), (16.4257), (41.0649)), (* C1' *) + ( (24.4701), (17.0882), (40.7671)), (* H1' *) + ( (22.3525), (16.9643), (40.5396)), (* C2' *) + ( (21.5993), (16.1799), (40.6133)), (* H2'' *) + ( (22.4693), (17.4849), (39.2515)), (* O2' *) + ( (23.0899), (17.0235), (38.6827)), (* H2' *) + ( (22.0341), (18.0633), (41.5279)), (* C3' *) + ( (20.9509), (18.1709), (41.5846)), (* H3' *) + ( (22.7249), (19.3020), (41.2100)), (* O3' *) + ( (23.8580), (15.0648), (40.5757)), (* N1 *) + ( (25.1556), (14.5982), (40.4523)), (* N3 *) + ( (26.1047), (15.3210), (40.7448)), (* C2 *) + ( (25.3391), (13.3315), (40.0020)), (* C4 *) + ( (24.2974), (12.5148), (39.6749)), (* C5 *) + ( (24.5450), (11.3410), (39.2610)), (* C6 *) + (U ( + ( (22.9633), (12.9979), (39.8053)), (* O2 *) + ( (22.8009), (14.2648), (40.2524)), (* O4 *) + ( (26.3414), (12.9194), (39.8855)), (* H3 *) + ( (22.1227), (12.3533), (39.5486)), (* H5 *) + ( (21.7989), (14.6788), (40.3650))) (* H6 *) + ) + ) + +val rU10 + = ( + ( (~0.9674), (0.1021), (~0.2318), (* dgf-base-tfo *) + (~0.2514), (~0.2766), (0.9275), + (0.0306), (0.9555), (0.2933), + (27.8571), (~42.1305), (~24.4563)), + ( (0.2765), (~0.1121), (~0.9545), (* P-O3'-275-tfo *) + (~0.8297), (0.4733), (~0.2959), + (0.4850), (0.8737), (0.0379), + (~14.7774), (~45.2464), (21.9088)), + ( (0.1063), (~0.6334), (~0.7665), (* P-O3'-180-tfo *) + (~0.5932), (~0.6591), (0.4624), + (~0.7980), (0.4055), (~0.4458), + (43.7634), (4.3296), (28.4890)), + ( (0.7136), (~0.5032), (~0.4873), (* P-O3'-60-tfo *) + (0.6803), (0.3317), (0.6536), + (~0.1673), (~0.7979), (0.5791), + (~17.1858), (41.4390), (~27.0751)), + ( (21.3880), (15.0780), (45.5770)), (* P *) + ( (21.9980), (14.5500), (46.8210)), (* O1P *) + ( (21.1450), (14.0270), (44.5420)), (* O2P *) + ( (22.1250), (16.3600), (44.9460)), (* O5' *) + ( (23.5096), (16.1227), (44.5783)), (* C5' *) + ( (23.5649), (15.8588), (43.5222)), (* H5' *) + ( (23.9621), (15.4341), (45.2919)), (* H5'' *) + ( (24.2805), (17.4138), (44.7151)), (* C4' *) + ( (23.8509), (18.1819), (44.0720)), (* H4' *) + ( (24.2506), (17.8583), (46.0741)), (* O4' *) + ( (25.5830), (18.0320), (46.5775)), (* C1' *) + ( (25.8569), (19.0761), (46.4256)), (* H1' *) + ( (26.4410), (17.1555), (45.7033)), (* C2' *) + ( (26.3459), (16.1253), (46.0462)), (* H2'' *) + ( (27.7649), (17.5888), (45.6478)), (* O2' *) + ( (28.1004), (17.9719), (46.4616)), (* H2' *) + ( (25.7796), (17.2997), (44.3513)), (* C3' *) + ( (25.9478), (16.3824), (43.7871)), (* H3' *) + ( (26.2154), (18.4984), (43.6541)), (* O3' *) + ( (25.7321), (17.6281), (47.9726)), (* N1 *) + ( (25.5136), (18.5779), (48.9560)), (* N3 *) + ( (25.2079), (19.7276), (48.6503)), (* C2 *) + ( (25.6482), (18.1987), (50.2518)), (* C4 *) + ( (25.9847), (16.9266), (50.6092)), (* C5 *) + ( (26.0918), (16.6439), (51.8416)), (* C6 *) + (U ( + ( (26.2067), (15.9515), (49.5943)), (* O2 *) + ( (26.0713), (16.3497), (48.3080)), (* O4 *) + ( (25.4890), (18.9105), (51.0618)), (* H3 *) + ( (26.4742), (14.9310), (49.8682)), (* H5 *) + ( (26.2346), (15.6394), (47.4975))) (* H6 *) + ) + ) + +val rUs = [rU01,rU02,rU03,rU04,rU05,rU06,rU07,rU08,rU09,rU10] + +val rG' + = ( + ( (~0.2067), (~0.0264), (0.9780), (* dgf-base-tfo *) + (0.9770), (~0.0586), (0.2049), + (0.0519), (0.9979), (0.0379), + (1.0331), (~46.8078), (~36.4742)), + ( (~0.8644), (~0.4956), (~0.0851), (* P-O3'-275-tfo *) + (~0.0427), (0.2409), (~0.9696), + (0.5010), (~0.8345), (~0.2294), + (4.0167), (54.5377), (12.4779)), + ( (0.3706), (~0.6167), (0.6945), (* P-O3'-180-tfo *) + (~0.2867), (~0.7872), (~0.5460), + (0.8834), (0.0032), (~0.4686), + (~52.9020), (18.6313), (~0.6709)), + ( (0.4155), (0.9025), (~0.1137), (* P-O3'-60-tfo *) + (0.9040), (~0.4236), (~0.0582), + (~0.1007), (~0.0786), (~0.9918), + (~7.6624), (~25.2080), (49.5181)), + ( (31.3810), (0.1400), (47.5810)), (* P *) + ( (29.9860), (0.6630), (47.6290)), (* O1P *) + ( (31.7210), (~0.6460), (48.8090)), (* O2P *) + ( (32.4940), (1.2540), (47.2740)), (* O5' *) + ( (32.1610), (2.2370), (46.2560)), (* C5' *) + ( (31.2986), (2.8190), (46.5812)), (* H5' *) + ( (32.0980), (1.7468), (45.2845)), (* H5'' *) + ( (33.3476), (3.1959), (46.1947)), (* C4' *) + ( (33.2668), (3.8958), (45.3630)), (* H4' *) + ( (33.3799), (3.9183), (47.4216)), (* O4' *) + ( (34.6515), (3.7222), (48.0398)), (* C1' *) + ( (35.2947), (4.5412), (47.7180)), (* H1' *) + ( (35.1756), (2.4228), (47.4827)), (* C2' *) + ( (34.6778), (1.5937), (47.9856)), (* H2'' *) + ( (36.5631), (2.2672), (47.4798)), (* O2' *) + ( (37.0163), (2.6579), (48.2305)), (* H2' *) + ( (34.6953), (2.5043), (46.0448)), (* C3' *) + ( (34.5444), (1.4917), (45.6706)), (* H3' *) + ( (35.6679), (3.3009), (45.3487)), (* O3' *) + ( (37.4804), (4.0914), (52.2559)), (* N1 *) + ( (36.9670), (4.1312), (49.9281)), (* N3 *) + ( (37.8045), (4.2519), (50.9550)), (* C2 *) + ( (35.7171), (3.8264), (50.3222)), (* C4 *) + ( (35.2668), (3.6420), (51.6115)), (* C5 *) + ( (36.2037), (3.7829), (52.6706)), (* C6 *) + (G ( + ( (39.0869), (4.5552), (50.7092)), (* N2 *) + ( (33.9075), (3.3338), (51.6102)), (* N7 *) + ( (34.6126), (3.6358), (49.5108)), (* N9 *) + ( (33.5805), (3.3442), (50.3425)), (* C8 *) + ( (35.9958), (3.6512), (53.8724)), (* O6 *) + ( (38.2106), (4.2053), (52.9295)), (* H1 *) + ( (39.8218), (4.6863), (51.3896)), (* H21 *) + ( (39.3420), (4.6857), (49.7407)), (* H22 *) + ( (32.5194), (3.1070), (50.2664))) (* H8 *) + ) + ) + +val rU' + = ( + ( (~0.0109), (0.5907), (0.8068), (* dgf-base-tfo *) + (0.2217), (~0.7853), (0.5780), + (0.9751), (0.1852), (~0.1224), + (~1.4225), (~11.0956), (~2.5217)), + ( (~0.8313), (~0.4738), (~0.2906), (* P-O3'-275-tfo *) + (0.0649), (0.4366), (~0.8973), + (0.5521), (~0.7648), (~0.3322), + (1.6833), (6.8060), (~7.0011)), + ( (0.3445), (~0.7630), (0.5470), (* P-O3'-180-tfo *) + (~0.4628), (~0.6450), (~0.6082), + (0.8168), (~0.0436), (~0.5753), + (~6.8179), (~3.9778), (~5.9887)), + ( (0.5855), (0.7931), (~0.1682), (* P-O3'-60-tfo *) + (0.8103), (~0.5790), (0.0906), + (~0.0255), (~0.1894), (~0.9816), + (6.1203), (~7.1051), (3.1984)), + ( (2.6760), (~8.4960), (3.2880)), (* P *) + ( (1.4950), (~7.6230), (3.4770)), (* O1P *) + ( (2.9490), (~9.4640), (4.3740)), (* O2P *) + ( (3.9730), (~7.5950), (3.0340)), (* O5' *) + ( (5.2430), (~8.2420), (2.8260)), (* C5' *) + ( (5.1974), (~8.8497), (1.9223)), (* H5' *) + ( (5.5548), (~8.7348), (3.7469)), (* H5'' *) + ( (6.3140), (~7.2060), (2.5510)), (* C4' *) + ( (5.8744), (~6.2116), (2.4731)), (* H4' *) + ( (7.2798), (~7.2260), (3.6420)), (* O4' *) + ( (8.5733), (~6.9410), (3.1329)), (* C1' *) + ( (8.9047), (~6.0374), (3.6446)), (* H1' *) + ( (8.4429), (~6.6596), (1.6327)), (* C2' *) + ( (9.2880), (~7.1071), (1.1096)), (* H2'' *) + ( (8.2502), (~5.2799), (1.4754)), (* O2' *) + ( (8.7676), (~4.7284), (2.0667)), (* H2' *) + ( (7.1642), (~7.4416), (1.3021)), (* C3' *) + ( (7.4125), (~8.5002), (1.2260)), (* H3' *) + ( (6.5160), (~6.9772), (0.1267)), (* O3' *) + ( (9.4531), (~8.1107), (3.4087)), (* N1 *) + ( (11.5931), (~9.0015), (3.6357)), (* N3 *) + ( (10.8101), (~7.8950), (3.3748)), (* C2 *) + ( (11.1439), (~10.2744), (3.9206)), (* C4 *) + ( (9.7056), (~10.4026), (3.9332)), (* C5 *) + ( (8.9192), (~9.3419), (3.6833)), (* C6 *) + (U ( + ( (11.3013), (~6.8063), (3.1326)), (* O2 *) + ( (11.9431), (~11.1876), (4.1375)), (* O4 *) + ( (12.5840), (~8.8673), (3.6158)), (* H3 *) + ( (9.2891), (~11.2898), (4.1313)), (* H5 *) + ( (7.9263), (~9.4537), (3.6977))) (* H6 *) + ) + ) + +(* -- PARTIAL INSTANTIATIONS ------------------------------------------------*) + +type var = intg*tfo*nuc + +fun atom_pos atom (i,t,n) = tfo_apply t (atom n) + +fun get_var id ((i,t,n)::rest) + = if id = i then (i,t,n) else get_var id rest + +(* -- SEARCH ----------------------------------------------------------------*) + +(* Queue operations (to efficiently append two lists of solutions) *) + +fun queue_to_list q = q + +val make_empty_queue = [] + +fun make_singleton_queue item = [item] + +fun append_queues q1 q2 = q1 @ q2 + +(* Sequential backtracking algorithm *) + +fun +search partial_inst [] constraint + = make_singleton_queue partial_inst +| +search partial_inst (h::t) constraint + = search_aux partial_inst t constraint (h partial_inst) + +and + +search_aux partial_inst domains constraint [] + = make_empty_queue +| +search_aux partial_inst domains constraint (h::t) + = if constraint h partial_inst then + append_queues + (search (h::partial_inst) domains constraint) + (search_aux partial_inst domains constraint t) + else + search_aux partial_inst domains constraint t + +(* -- DOMAINS ---------------------------------------------------------------*) + +(* Primary structure: strand A CUGCCACGUCUG, strand B CAGACGUGGCAG +|| +|| Secondary structure: strand A CUGCCACGUCUG +|| |||||||||||| +|| GACGGUGCAGAC strand B +|| +|| Tertiary structure: +|| +|| 5' end of strand A C1----G12 3' end of strand B +|| U2-------A11 +|| G3-------C10 +|| C4-----G9 +|| C5---G8 +|| A6 +|| G6-C7 +|| C5----G8 +|| A4-------U9 +|| G3--------C10 +|| A2-------U11 +|| 5' end of strand B C1----G12 3' end of strand A +|| +|| "helix", "stacked" and "connected" describe the spatial relationship +|| between two consecutive nucleotides. E.g. the nucleotides C1 and U2 +|| from the strand A. +|| +|| "wc" (stands for Watson-Crick and is a type of base-pairing), +|| and "wc-dumas" describe the spatial relationship between +|| nucleotides from two chains that are growing in opposite directions. +|| E.g. the nucleotides C1 from strand A and G12 from strand B. +*) + +(* Dynamic Domains *) + +(* Given, +|| "ref" a nucleotide which is already positioned, +|| "nuc" the nucleotide to be placed, +|| and "tfo" a transformation matrix which expresses the desired +|| relationship between "ref" and "nuc", +|| the function "dgf-base" computes the transformation matrix that +|| places the nucleotide "nuc" in the given relationship to "ref". +*) + +fun +dgf_base tfo (i,t,n) nuc + = let + val x = if is_A n then + tfo_align (tfo_apply t (nuc_C1' n)) + (tfo_apply t (rA_N9 n)) + (tfo_apply t (nuc_C4 n)) + else if is_C n then + tfo_align (tfo_apply t (nuc_C1' n)) + (tfo_apply t (nuc_N1 n)) + (tfo_apply t (nuc_C2 n)) + else if is_G n then + tfo_align (tfo_apply t (nuc_C1' n)) + (tfo_apply t (rG_N9 n)) + (tfo_apply t (nuc_C4 n)) + else + tfo_align (tfo_apply t (nuc_C1' n)) + (tfo_apply t (nuc_N1 n)) + (tfo_apply t (nuc_C2 n)) + in + tfo_combine (nuc_dgf_base_tfo nuc) + (tfo_combine tfo (tfo_inv_ortho x)) + end + +(* Placement of first nucleotide. *) + +fun +reference nuc i partial_inst = [ (i,tfo_id,nuc) ] + +(* The transformation matrix for wc is from: +|| +|| Chandrasekaran R. et al (1989) A Re-Examination of the Crystal +|| Structure of A-DNA Using Fiber Diffraction Data. J. Biomol. +|| Struct. & Dynamics 6(6):1189-1202. +*) + +val wc_tfo + = ( + (~1.0000), (0.0028), (~0.0019), + (0.0028), (0.3468), (~0.9379), + (~0.0019), (~0.9379), (~0.3468), + (~0.0080), (6.0730), (8.7208) + ) + +fun +wc nuc i j partial_inst + = [ (i,(dgf_base wc_tfo (get_var j partial_inst) nuc),nuc) ] + +val wc_Dumas_tfo + = ( + (~0.9737), (~0.1834), (0.1352), + (~0.1779), (0.2417), (~0.9539), + (0.1422), (~0.9529), (~0.2679), + (0.4837), (6.2649), (8.0285) + ) + +fun +wc_Dumas nuc i j partial_inst + = [ (i,(dgf_base wc_Dumas_tfo (get_var j partial_inst) nuc),nuc) ] + +val helix5'_tfo + = ( + (0.9886), (~0.0961), (0.1156), + (0.1424), (0.8452), (~0.5152), + (~0.0482), (0.5258), (0.8492), + (~3.8737), (0.5480), (3.8024) + ) + +fun +helix5' nuc i j partial_inst + = [ (i,(dgf_base helix5'_tfo (get_var j partial_inst) nuc),nuc) ] + +val helix3'_tfo + = ( + (0.9886), (0.1424), (~0.0482), + (~0.0961), (0.8452), (0.5258), + (0.1156), (~0.5152), (0.8492), + (3.4426), (2.0474), (~3.7042) + ) + +fun +helix3' nuc i j partial_inst + = [ (i,(dgf_base helix3'_tfo (get_var j partial_inst) nuc),nuc) ] + +val g37_a38_tfo + = ( + (0.9991), (0.0164), (~0.0387), + (~0.0375), (0.7616), (~0.6470), + (0.0189), (0.6478), (0.7615), + (~3.3018), (0.9975), (2.5585) + ) + +fun +g37_a38 nuc i j partial_inst + = (i,(dgf_base g37_a38_tfo (get_var j partial_inst) nuc),nuc) + +fun +stacked5' nuc i j partial_inst + = (g37_a38 nuc i j partial_inst) :: (helix5' nuc i j partial_inst) + +val a38_g37_tfo + = ( + (0.9991), (~0.0375), (0.0189), + (0.0164), (0.7616), (0.6478), + (~0.0387), (~0.6470), (0.7615), + (3.3819), (0.7718), (~2.5321) + ) + +fun +a38_g37 nuc i j partial_inst + = (i,(dgf_base a38_g37_tfo (get_var j partial_inst) nuc),nuc) + +fun +stacked3' nuc i j partial_inst + = (a38_g37 nuc i j partial_inst) :: (helix3' nuc i j partial_inst) + +fun +p_o3' nucs i j partial_inst + = let + val (k,t,n) = get_var j partial_inst + val align = tfo_inv_ortho + (tfo_align (tfo_apply t (nuc_O3' n)) + (tfo_apply t (nuc_C3' n)) + (tfo_apply t (nuc_C4' n))) + in + List.concat + (map (fn nuc => + [ (i,(tfo_combine (nuc_p_o3'_60_tfo nuc) align),nuc), + (i,(tfo_combine (nuc_p_o3'_180_tfo nuc) align),nuc), + (i,(tfo_combine (nuc_p_o3'_275_tfo nuc) align),nuc) ]) + nucs) + end + +(* -- PROBLEM STATEMENT -----------------------------------------------------*) + +(* Define anticodon problem -- Science 253:1255 Figure 3a, 3b and 3c *) + +fun anticodon_domains () + = [ + reference rC 27, + helix5' rC 28 27, + helix5' rA 29 28, + helix5' rG 30 29, + helix5' rA 31 30, + wc rU 39 31, + helix5' rC 40 39, + helix5' rU 41 40, + helix5' rG 42 41, + helix5' rG 43 42, + stacked3' rA 38 39, + stacked3' rG 37 38, + stacked3' rA 36 37, + stacked3' rA 35 36, + stacked3' rG 34 35, (*<-. Distan, *) + p_o3' rCs 32 31, (* | Constraint *) + p_o3' rUs 33 32 (*<-' 3.0 Angstrom *) + ] + +(* Anticodon constraint *) + +fun anticodon_constraint (i,t,n) partial_inst + = if i = 33 then + let + val p = atom_pos nuc_P (get_var 34 partial_inst) + val o3' = atom_pos nuc_O3' (i,t,n) + in + (pt_dist p o3') <= 3.0 + end + else + true + +(* Anticodon*) + + fun anticodon () = + queue_to_list (search [] (anticodon_domains ()) anticodon_constraint) + + fun anticodon_length () = length(anticodon()) + + + fun pseudoknot_domains () = + [ + reference rA 23, + wc_Dumas rU 8 23, + helix3' rG 22 23, + wc_Dumas rC 9 22, + helix3' rG 21 22, + wc_Dumas rC 10 21, + helix3' rC 20 21, + wc_Dumas rG 11 20, + helix3' rU' 19 20, (* <-. *) + wc_Dumas rA 12 19, (* | Distance *) +(* | Constraint *) +(* ; Helix 1 ; | 4.0 Angstroms *) + helix3' rC 3 19, (* | *) + wc_Dumas rG 13 3, (* | *) + helix3' rC 2 3, (* | *) + wc_Dumas rG 14 2, (* | *) + helix3' rC 1 2, (* | *) + wc_Dumas rG' 15 1, (* | *) +(* | *) +(* L2 LOOP | *) + p_o3' rUs 16 15, (* | *) + p_o3' rCs 17 16, (* | *) + p_o3' rAs 18 17, (* <-' *) +(* *) +(* L1 LOOP *) + helix3' rU 7 8, (* <-. *) + p_o3' rCs 4 3, (* | Constraint *) + stacked5' rU 5 4, (* | 4.5 Angstroms *) + stacked5' rC 6 5 (* <-' *) + ] + + fun pseudoknot_constraint (i, t, n) partial_inst = + case i of + 18 => + let + val p = atom_pos nuc_P (get_var 19 partial_inst) + val o3' = atom_pos nuc_O3' (i, t, n) + in + pt_dist p o3' <= 4.0 + end + | 6 => + let + val p = atom_pos nuc_P (get_var 7 partial_inst) + val o3' = atom_pos nuc_O3' (i, t, n) + in + pt_dist p o3' <= 4.5 + end + | _ => true + + fun pseudoknot () = + search [] (pseudoknot_domains ()) pseudoknot_constraint + + fun maximum (xs: real list) = + let + fun loop (m, l) = + case l of + [] => m + | x :: l => loop (if x > m then x else m, l) + in + case xs of + [] => raise Fail "bug" + | x :: xs => loop (x, xs) + end + + fun list_of_common_atoms n = + [ + nuc_P n, + nuc_O1P n, + nuc_O2P n, + nuc_O5' n, + nuc_C5' n, + nuc_H5' n, + nuc_H5'' n, + nuc_C4' n, + nuc_H4' n, + nuc_O4' n, + nuc_C1' n, + nuc_H1' n, + nuc_C2' n, + nuc_H2'' n, + nuc_O2' n, + nuc_H2' n, + nuc_C3' n, + nuc_H3' n, + nuc_O3' n, + nuc_N1 n, + nuc_N3 n, + nuc_C2 n, + nuc_C4 n, + nuc_C5 n, + nuc_C6 n + ] + + fun list_of_specific_atoms n = + if is_A n + then [ + rA_N6 n, + rA_N7 n, + rA_N9 n, + rA_C8 n, + rA_H2 n, + rA_H61 n, + rA_H62 n, + rA_H8 n + ] + else if is_C n + then [ + rC_N4 n, + rC_O2 n, + rC_H41 n, + rC_H42 n, + rC_H5 n, + rC_H6 n + ] + else if is_G n + then [ + rG_N2 n, + rG_N7 n, + rG_N9 n, + rG_C8 n, + rG_O6 n, + rG_H1 n, + rG_H21 n, + rG_H22 n, + rG_H8 n + ] + else [ + rU_O2 n, + rU_O4 n, + rU_H3 n, + rU_H5 n, + rU_H6 n + ] + + fun list_of_atoms n = + List.@ (list_of_common_atoms n, + list_of_specific_atoms n) + + fun var_most_distant_atom (i, t, n) = + let + fun distance pos = + let + val (x, y, z) = tfo_apply t pos + in + Real.Math.sqrt (x * x + y * y + z * z) + end + in + maximum (List.map distance (list_of_atoms n)) + end + + fun sol_most_distant_atom s = + maximum (List.map var_most_distant_atom s) + + fun most_distant_atom sols = + maximum (List.map sol_most_distant_atom sols) + + fun doit () = + let + val result = most_distant_atom (pseudoknot ()) + val x = result / 33.797594890762724 + val _ = + if x > 0.999999 andalso x < 1.000001 + then () + else raise Fail "bug" + in + () + end +end; + +signature BMARK = + sig + val doit : int -> unit + end; +(* main.sml + * + * COPYRIGHT (c) 1996 AT&T Research. + *) + +structure Main : BMARK = + struct + val doit = Nucleic.doit + + val doit = + fn size => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in + loop size + end + end; diff --git a/benchmark/tests/output1.sml b/benchmark/tests/output1.sml new file mode 100644 index 0000000..f64bfb2 --- /dev/null +++ b/benchmark/tests/output1.sml @@ -0,0 +1,22 @@ +structure Main = + struct + fun once () = + let + val count = 1000000000 + open TextIO + val out = openOut "/dev/null" + fun loop n = + if n = 0 + then () + else (output1 (out, #"a"); loop (n - 1)) + val _ = loop count + val _ = closeOut out + in + () + end + + fun doit n = + if n = 0 + then () + else (once (); doit (n - 1)) + end diff --git a/benchmark/tests/peek.sml b/benchmark/tests/peek.sml new file mode 100644 index 0000000..f2978e3 --- /dev/null +++ b/benchmark/tests/peek.sml @@ -0,0 +1,55 @@ +(* Written by Stephen Weeks (sweeks@sweeks.com). *) +structure Plist: + sig + type t + + val new: unit -> t + val addPeek: unit -> {add: t * 'a -> unit, + peek: t -> 'a option} + end = + struct + datatype t = T of exn list ref + + fun new () = T (ref []) + + fun addPeek () = + let + exception E of 'a + fun add (T r, x) = r := E x :: !r + fun peek (T r) = + let + val rec loop = + fn [] => NONE + | E x :: _ => SOME x + | _ :: l => loop l + in loop (!r) + end + in {add = add, peek = peek} + end + end + +structure Main = + struct + fun inner () = + let + val l = Plist.new () + val {add, peek} = Plist.addPeek () + val _ = add (l, 13) + fun loop (i, ac) = + if i = 0 + then ac + else loop (i - 1, ac + valOf (peek l)) + val n = loop (10000000, 0) + val _ = print (concat [Int.toString n, "\n"]) + in () + end + + fun doit size = + let + fun loop i = + if i = 0 + then () + else (inner (); loop (i - 1)) + in loop size + end + end diff --git a/benchmark/tests/pidigits.sml b/benchmark/tests/pidigits.sml new file mode 100644 index 0000000..65446ea --- /dev/null +++ b/benchmark/tests/pidigits.sml @@ -0,0 +1,138 @@ +structure Stream = +struct + datatype 'a u = Nil | Cons of 'a * 'a t + withtype 'a t = unit -> 'a u + + fun unfold (f : 'b -> ('a * 'b) option) : 'b -> 'a t = + let + fun loop b () = + case f b of + NONE => Nil + | SOME (x, b) => Cons (x, loop b) + in + loop + end + fun map (f : 'a -> 'b) : 'a t -> 'b t = + unfold (fn s => + case s () of + Nil => NONE + | Cons (x, xs) => SOME (f x, xs)) +end + +structure PiDigits = +struct + fun stream (next : 'b -> 'c) + (safe : 'b -> 'c -> bool) + (prod : 'b -> 'c -> 'b) + (cons : 'b -> 'a -> 'b) + : 'b -> 'a Stream.t -> 'c Stream.t = + let + fun loop z s () = + let + val y = next z + in + if safe z y + then Stream.Cons (y, loop (prod z y) s) + else (case s () of + Stream.Nil => Stream.Nil + | Stream.Cons (x, xs) => loop (cons z x) xs ()) + end + in + loop + end + + type lft = (IntInf.int * IntInf.int * IntInf.int * IntInf.int) + + val unit : lft = (1,0,0,1) + + fun comp (q,r,s,t) (u,v,w,x) : lft = (q*u+r*w, q*v+r*x, s*u+t*w, s*v+t*x) + + val pi = + let + val init = unit + val lfts = Stream.map (fn k => (k, 4*k+2, 0, 2*k+1)) (Stream.unfold (fn i => SOME (i, i+1)) 1) + fun floor_extr (q,r,s,t) x = (q * x + r) div (s * x + t) + fun next z = floor_extr z 3 + fun safe z n = n = floor_extr z 4 + fun prod z n = comp (10, ~10*n, 0, 1) z + fun cons z z' = comp z z' + in + stream next safe prod cons init lfts + end +end + +structure MainShootout = +struct + fun display n = + let + fun loop (ds, (k, col)) = + if k < n + then let + val col = + if col = 10 + then (print "\t:"; print (IntInf.toString k); print "\n"; + 1) + else col + 1 + in + case ds () of + Stream.Nil => raise Empty + | Stream.Cons (d, ds) => + (print (IntInf.toString d); + loop (ds, (k + 1, col))) + end + else (print (CharVector.tabulate (10 - col, fn _ => #" ")); + print "\t:"; print (IntInf.toString k); print "\n"; + ()) + in + loop (PiDigits.pi, (0, 0)) + end + fun usage name = + (TextIO.output (TextIO.stdErr, + concat ["usage: ", OS.Path.file name, " \n"]); + OS.Process.failure) + fun main (name, arguments) = + case arguments of + [n] => (case IntInf.fromString n of + SOME n => if n >= 1 + then (display n; OS.Process.success) + else usage name + | NONE => usage name) + | _ => usage name +end +(* +val _ = OS.Process.exit (Main.main (CommandLine.name (), CommandLine.arguments ())) +*) + +structure MainBenchmark = +struct + fun display n = + let + fun loop (ds, k, n) = + case ds () of + Stream.Nil => raise Empty + | Stream.Cons (d, ds) => + if d = 0 + then if n = 0 + then (print (IntInf.toString k); print "\n") + else loop (ds, k + 1, n - 1) + else loop (ds, k + 1, n) + in + loop (PiDigits.pi, 0, n) + end + fun usage name = + (TextIO.output (TextIO.stdErr, + concat ["usage: ", OS.Path.file name, " \n"]); + OS.Process.failure) + fun main (name, arguments) = + case arguments of + [n] => (case IntInf.fromString n of + SOME n => if n >= 1 + then (display n; OS.Process.success) + else usage name + | NONE => usage name) + | _ => usage name + + val doit = display o IntInf.fromInt +end + +structure Main = MainBenchmark diff --git a/benchmark/tests/psdes-random.sml b/benchmark/tests/psdes-random.sml new file mode 100644 index 0000000..ea29d15 --- /dev/null +++ b/benchmark/tests/psdes-random.sml @@ -0,0 +1,73 @@ +(* Written by Stephen Weeks (sweeks@sweeks.com). *) +(* + * Random number generator based on page 302 of Numerical Recipes in C. + *) +fun once () = + let + fun natFold (start, stop, ac, f) = + let + fun loop (i, ac) = + if i = stop + then ac + else loop (i + 1, f (i, ac)) + in loop (start, ac) + end + val niter: int = 4 + open Word32 + fun make (l: word list) = + let val a = Array.fromList l + in fn i => Array.sub (a, i) + end + val c1 = make [0wxbaa96887, 0wx1e17d32c, 0wx03bdcd3c, 0wx0f33d1b2] + val c2 = make [0wx4b0f3b58, 0wxe874f0c3, 0wx6955c5a6, 0wx55a7ca46] + val half: Word.word = 0w16 + fun reverse w = orb (>> (w, half), << (w, half)) + fun psdes (lword: word, irword: word): word * word = + natFold + (0, niter, (lword, irword), fn (i, (lword, irword)) => + let + val ia = xorb (irword, c1 i) + val itmpl = andb (ia, 0wxffff) + val itmph = >> (ia, half) + val ib = itmpl * itmpl + notb (itmph * itmph) + in (irword, + xorb (lword, itmpl * itmph + xorb (c2 i, reverse ib))) + end) + val zero: word = 0wx13 + val lword: word ref = ref 0w13 + val irword: word ref = ref 0w14 + val needTo = ref true + fun word () = + if !needTo + then + let + val (l, i) = psdes (!lword, !irword) + val _ = lword := l + val _ = irword := i + val _ = needTo := false + in + l + end + else (needTo := true + ; !irword) + fun loop (i, w) = + if i = 0 + then + if w = 0wx132B1B67 + then () + else raise Fail "bug" + else loop (Int.- (i, 1), w + word()) + in + loop (150000000, 0w0) + end + +structure Main = + struct + fun doit n = + if n = 0 + then () + else (once () + ; doit (n - 1)) + end + +val _ = Main.doit 2 diff --git a/benchmark/tests/ratio-regions.sml b/benchmark/tests/ratio-regions.sml new file mode 100644 index 0000000..32b1f0e --- /dev/null +++ b/benchmark/tests/ratio-regions.sml @@ -0,0 +1,625 @@ +(* + * Translated from Jeff Siskind's Scheme code by Stephen Weeks + * (sweeks@sweeks.com). + * Here is the description from Jeff Siskind (qobi@research.nj.nec.com) + * + * It is an implementation of Ratio + * Regions, an image segmentation/contour finding technique due to Ingemar Cox, + * Satish Rao, and Yu Zhong. The algorithm is a reduction to max flow, an + * unpublished technique that Satish described to me. Peter Blicher originally + * implemented this via a translation to Andrew Goldberg's generic max-flow code. + * I've reimplemented it, specializing the max-flow algorithm to the particular + * graphs that are produced by Satish's reduction instead of using Andrew's code. + * The max-flow algorithm is preflow-push with periodic relabeling and a + * wave-based heuristic for scheduling pushes and lifts due to Sebastien Roy. + *) + +fun print _ = () + +local + +fun doo(max: int, f: int -> unit): unit = + let fun loop i = if i >= max then () else (f i; loop(i + 1)) + in loop 0 + end + +fun zero x = x = 0 +val cons = op :: +val make_vector = Array.array +val vector_length = Array.length +val vector_ref = Array.sub +val vector_set = Array.update +val map_n_vector = Array.tabulate +val string_length = String.size +val string_ref = String.sub +fun write_char c = () (* TextIO.output1(TextIO.stdOut, c) *) +val modulo = Int.mod +val quotient = Int.quot +fun for_each(l, f) = List.app f l +fun negative x = x < 0 +fun positive x = x > 0 + +fun min l = + case l of + x :: l => let + fun loop(l, min) = + case l of + [] => min + | x :: l => loop(l, Int.min(min, x)) + in loop(l, x) + end + | _ => raise Fail "min" + +fun every_n(n, p) = + let fun loop i = i >= n orelse (p i andalso loop(i + 1)) + in loop 0 + end + +fun some(l, p) = List.exists p l + +fun some_n(n, p) = + let fun loop i = i < n andalso (p i orelse loop(i + 1)) + in loop 0 + end + +fun some_vector(v, p) = + let + fun loop i = + i < vector_length v + andalso (p(vector_ref(v, i)) + orelse loop(i + 1)) + in loop 0 + end + +fun x(x, _) = x +fun y(_, y) = y + +datatype 'a matrix = Matrix of 'a array array + +fun make_matrix(m: int, n: int, a: 'a): 'a matrix = + Matrix(map_n_vector(m, fn i => make_vector(n, a))) + +fun matrix_rows(Matrix a) = vector_length a +fun matrix_columns(Matrix a) = vector_length(vector_ref(a, 0)) +fun matrix_ref(Matrix a, i, j) = vector_ref(vector_ref(a, i), j) +fun matrix_set(Matrix a, i, j, x) = vector_set(vector_ref(a, i), j, x) + +datatype pormatValue = + Int of int + | String of string + +fun pormat(control_string: string, values: pormatValue list): unit = + let + fun loop(i: int, values: pormatValue list): unit = + if not(i = string_length control_string) + then + let val c = string_ref(control_string, i) + in if c = #"~" + then let val c2 = string_ref(control_string, i + 1) + in case (c2, values) of + (#"s", Int n :: values) => + (print(Int.toString n) ; loop(i + 2, values)) + | (#"a", String s :: values) => + (print s ; loop(i + 2, values)) + | (#"%", _) => + (print "\n"; loop(i + 2, values)) + | _ => (write_char c; loop(i + 1, values)) + end + else (write_char c ; loop(i + 1, values)) + end + else () + in loop(0, values) + end + +(* The vertices are s, t, and (y,x). + * C_RIGHT[y,x] is the capacity from (y,x) to (y,x+1) which is the same as the + * capacity from (y,x+1) to (y,x). + * C_DOWN[y,x] is the capacity from (y,x) to (y+1,x) which is the same as the + * capacity from (y+1,x) to (y,x). + * The capacity from s to (y,0), (0,x), (y,Y_1), (0,X_1) is implicitly + * infinite. + * The capacity from (x,y) to t is V*W[y,x]. + * F_RIGHT[y,x] is the preflow from (y,x) to (y,x+1) which is the negation of + * the preflow from (y,x+1) to (y,x). + * F_DOWN[y,x] is the preflow from (y,x) to (y+1,x) which is the negation of + * the preflow from (y+1,x) to (y,x). + * We do not record the preflow from s to (y,X_1), (y,0), (Y_1,x), and (0,x) + * and from (y,X_1), (y,0), (Y_1,x), and (0,x) to s. + * F_T[y,x] is the preflow from (y,x) to t. + * We do not record the preflow from t to (y,x). + * {C,F}_RIGHT[0:Y_1,0:X_2]. + * {C,F}_DOWN[0:Y_2,0:X_1]. + * F_T[0:Y_1,0:X_1] + * For now, we will keep all capacities (and thus all preflows) as integers. + * (CF_RIGHT y x) is the residual capacity from (y,x) to (y,x+1). + * (CF_LEFT y x) is the residual capacity from (y,x) to (y,x_1). + * (CF_DOWN y x) is the residual capacity from (y,x) to (y+1,x). + * (CF_UP y x) is the residual capacity from (y,x) to (y_1,x). + * We do not compute the residual capacities from s to (y,X_1), (y,0), + * (Y_1,x), and (0,x) because they are all infinite. + * We do not compute the residual capacities from (y,X_1), (y,0), (Y_1,x), + * and (0,x) to s because they will never be used. + * (CF_T y x) is the residual capacity from (y,x) to t. + * We do not compute the residual capacity from t to (y,x) because it will + * be used. + * (EF_RIGHT? y x) is true if there is an edge from (y,x) to (y,x+1) in the + * residual network. + * (EF_LEFT? y x) is true if there is an edge from (y,x) to (y,x_1) in the + * residual network. + * (EF_DOWN? y x) is true if there is an edge from (y,x) to (y+1,x) in the + * residual network. + * (EF_UP? y x) is true if there is an edge from (y,x) to (y_1,x) in the + * residual network. + * (EF_T? y x) is true if there is an edge from (y,x) to t in the + * residual network. + * There are always edges in the residual network from s to (y,X_1), (y,0), + * (Y_1,x), and (0,x). + * We don't care whether there are edges in the residual network from + * (y,X_1), (y,0), (Y_1,x), and (0,x) to s because they will never be used. + * We don't care whether there are edges in the residual network from t to + * (y,x) because they will never be used. + *) + +fun positive_min(x, y) = if negative x then y else Int.min(x, y) + +fun positive_minus(x, y) = if negative x then x else x - y + +fun positive_plus(x, y) = if negative x then x else x + y + +fun rao_ratio_region(c_right, c_down, w, lg_max_v) = + let val height = matrix_rows w + val width = matrix_columns w + val f_right = make_matrix(height, width - 1, 0) + val f_down = make_matrix(height - 1, width, 0) + val f_t = make_matrix(height, width, 0) + val h = make_matrix(height, width, 0) + val e = make_matrix(height, width, 0) + val marked = make_matrix(height, width, false) + val m1 = height * width + 2 + val m2 = 2 * height * width + 2 + val q = make_vector(2 * height * width + 3, []) + fun cf_right(y, x) = + matrix_ref(c_right, y, x) - matrix_ref(f_right, y, x) + fun cf_left(y, x) = + matrix_ref(c_right, y, x - 1) + matrix_ref(f_right, y, x - 1) + fun cf_down(y, x) = + matrix_ref(c_down, y, x) - matrix_ref(f_down, y, x) + fun cf_up(y, x) = + matrix_ref(c_down, y - 1, x) + matrix_ref(f_down, y - 1, x) + fun ef_right(y, x) = positive(cf_right(y, x)) + fun ef_left(y, x) = positive(cf_left(y, x)) + fun ef_down(y, x) = positive(cf_down(y, x)) + fun ef_up(y, x) = positive(cf_up(y, x)) + fun preflow_push v = + let + fun enqueue(y, x) = + if not(matrix_ref(marked, y, x)) + then + (vector_set(q, + matrix_ref(h, y, x), + (cons((x, y), + vector_ref(q, matrix_ref(h, y, x))))) + ; matrix_set(marked, y, x, true)) + else () + fun cf_t(y, x) = v * matrix_ref(w, y, x) - matrix_ref(f_t, y, x) + fun ef_t(y, x) = positive(cf_t(y, x)) + fun can_push_right(y, x) = + x < width - 1 + andalso not(zero(matrix_ref(e, y, x))) + andalso ef_right(y, x) + andalso matrix_ref(h, y, x) = matrix_ref(h, y, x + 1) + 1 + fun can_push_left(y, x) = + x > 0 + andalso not(zero(matrix_ref(e, y, x))) + andalso ef_left(y, x) + andalso matrix_ref(h, y, x) = matrix_ref(h, y, x - 1) + 1 + fun can_push_down(y, x) = + y < height - 1 + andalso not(zero(matrix_ref(e, y, x))) + andalso ef_down(y, x) + andalso matrix_ref(h, y, x) = matrix_ref(h, y + 1, x) + 1 + fun can_push_up(y, x) = + y > 0 + andalso not(zero(matrix_ref(e, y, x))) + andalso ef_up(y, x) + andalso matrix_ref(h, y, x) = matrix_ref(h, y - 1, x) + 1 + fun can_push_t(y, x) = + not(zero(matrix_ref(e, y, x))) + andalso ef_t(y, x) + andalso matrix_ref(h, y, x) = 1 + fun can_lift(y, x) = + not(zero(matrix_ref(e, y, x))) + andalso (if x = width - 1 + then matrix_ref(h, y, x) <= m1 + else (not(ef_right(y, x)) + orelse + matrix_ref(h, y, x) <= matrix_ref(h, y, x + 1))) + andalso (if x = 0 + then matrix_ref(h, y, x) <= m1 + else (not(ef_left(y, x)) + orelse + matrix_ref(h, y, x) <= matrix_ref(h, y, x - 1))) + andalso (if y = height - 1 + then matrix_ref(h, y, x) <= m1 + else (not(ef_down(y, x)) + orelse + matrix_ref(h, y, x) <= matrix_ref(h, y + 1, x))) + andalso (if y = 0 + then matrix_ref(h, y, x) <= m1 + else (not(ef_up(y, x)) + orelse + matrix_ref(h, y, x) <= matrix_ref(h, y - 1, x))) + andalso (not(ef_t(y, x)) orelse matrix_ref(h, y, x) = 0) + fun push_right(y, x) = + (* (pormat "Push right ~s ~s~%" y x) *) + let val df_u_v = positive_min(matrix_ref(e, y, x), cf_right(y, x)) + in matrix_set(f_right, y, x, matrix_ref(f_right, y, x) + df_u_v) + ; matrix_set(e, y, x, + positive_minus(matrix_ref(e, y, x), df_u_v)) + ; matrix_set(e, y, x + 1, + positive_plus(matrix_ref(e, y, x + 1), df_u_v)) + ; enqueue(y, x + 1) + end + fun push_left(y, x) = + (* (pormat "Push left ~s ~s~%" y x) *) + let val df_u_v = positive_min(matrix_ref(e, y, x), cf_left(y, x)) + in matrix_set(f_right, y, x - 1, + matrix_ref(f_right, y, x - 1) - df_u_v) + ; matrix_set(e, y, x, + positive_minus(matrix_ref(e, y, x), df_u_v)) + ; matrix_set(e, y, x - 1, + positive_plus(matrix_ref(e, y, x - 1), df_u_v)) + ; enqueue(y, x - 1) + end + + fun push_down(y, x) = + (* (pormat "Push down ~s ~s~%" y x) *) + let val df_u_v = positive_min(matrix_ref(e, y, x), cf_down(y, x)) + in matrix_set(f_down, y, x, matrix_ref(f_down, y, x) + df_u_v) + ; matrix_set(e, y, x, + positive_minus(matrix_ref(e, y, x), df_u_v)) + ; matrix_set(e, y + 1, x, + positive_plus(matrix_ref(e, y + 1, x), df_u_v)) + ; enqueue(y + 1, x) + end + fun push_up(y, x) = + (* ;;(pormat "Push up ~s ~s~%" y x) *) + let val df_u_v = positive_min(matrix_ref(e, y, x), cf_up(y, x)) + in matrix_set(f_down, y - 1, x, + matrix_ref(f_down, y - 1, x) - df_u_v) + ; matrix_set(e, y, x, + positive_minus(matrix_ref(e, y, x), df_u_v)) + ; matrix_set(e, y - 1, x, + positive_plus(matrix_ref(e, y - 1, x), df_u_v)) + ; enqueue(y - 1, x) + end + fun push_t(y, x) = + (* ;;(pormat "Push t ~s ~s~%" y x) *) + let val df_u_v = positive_min(matrix_ref(e, y, x), cf_t(y, x)) + in matrix_set(f_t, y, x, matrix_ref(f_t, y, x) + df_u_v) + ; matrix_set(e, y, x, + positive_minus(matrix_ref(e, y, x), df_u_v)) + end + fun lift(y, x) = + (* ;;(pormat "Lift ~s ~s~%" y x) *) + matrix_set + (h, y, x, + 1 + min[if x = width - 1 + then m1 + else if ef_right(y, x) + then matrix_ref(h, y, x + 1) + else m2, + if x = 0 + then m1 + else if ef_left(y, x) + then matrix_ref(h, y, x - 1) + else m2, + if y = height - 1 + then m1 + else if ef_down(y, x) + then matrix_ref(h, y + 1, x) + else m2, + if y = 0 + then m1 + else if ef_up(y, x) + then matrix_ref(h, y - 1, x) + else m2, + if ef_t(y, x) then 0 else m2]) + fun relabel() = + (* ;;(pormat "Relabel~%") *) + let + datatype 'a queue = + Nil + | Cons of 'a * 'a queue ref + fun null(q: 'q queue ref) = + case !q of + Nil => true + | _ => false + val q: (int * int) queue ref = ref Nil + val tail: (int * int) queue ref = ref Nil + fun enqueue(y, x, value) = + if value < matrix_ref(h, y, x) + then (matrix_set(h, y, x, value) + ; if not(matrix_ref(marked, y, x)) + then (matrix_set(marked, y, x, true) + ; (case !tail of + Nil => + (tail := Cons((x, y), ref Nil) + ; q := !tail) + | Cons(_, cdr) => + (cdr := Cons((x, y), ref Nil) + ; tail := !cdr))) + else ()) + else () + fun dequeue() = + case !q of + Nil => raise Fail "dequeue" + | Cons(p, rest) => + (matrix_set(marked, y p, x p, false) + ; q := !rest + ; if null q then tail := Nil else () + ; p) + in doo(height, fn y => + doo(width, fn x => + (matrix_set(h, y, x, m1) + ; matrix_set(marked, y, x, false)))) + ; doo(height, fn y => + doo(width, fn x => + if ef_t(y, x) + andalso matrix_ref(h, y, x) > 1 + then enqueue(y, x, 1) + else ())) + ; let + fun loop() = + if not(null q) + then + (let val p = dequeue() + val x = x p + val y = y p + val value = matrix_ref(h, y, x) + 1 + in if x > 0 andalso ef_right(y, x - 1) + then enqueue(y, x - 1, value) + else () + ; if x < width - 1 andalso ef_left(y, x + 1) + then enqueue(y, x + 1, value) + else () + ; if y > 0 andalso ef_down(y - 1, x) + then enqueue(y - 1, x, value) + else () + ; if y < height - 1 andalso ef_up(y + 1, x) + then enqueue(y + 1, x, value) + else () + end + ; loop()) + else () + in loop() + end + end (* relabel *) + in doo(height, fn y => + doo(width, fn x => + (matrix_set(e, y, x, 0) + ; matrix_set(f_t, y, x, 0)))) + ; doo(height, fn y => + doo(width - 1, fn x => + matrix_set(f_right, y, x, 0))) + ; doo(height - 1, fn y => + doo(width, fn x => + matrix_set(f_down, y, x, 0))) + ; doo(height, fn y => + (matrix_set(e, y, width - 1, ~1) + ; matrix_set(e, y, 0, ~1))) + ; doo(width - 1, fn x => + (matrix_set(e, height - 1, x, ~1) + ; matrix_set(e, 0, x, ~1))) + ; let val pushes = ref 0 + val lifts = ref 0 + val relabels = ref 0 + fun loop(i, p) = + if zero(modulo(i, 6)) andalso not p + then (relabel() + ; relabels := !relabels + 1 + ; if every_n(height, fn y => + every_n(width, fn x => + zero(matrix_ref(e, y, x)) + orelse + matrix_ref(h, y, x) = m1)) + then + (* Every vertex with excess capacity is not reachable from the sink in + * the inverse residual network. So terminate early because we have + * already found a min cut. In this case, the preflows and excess + * capacities will not be correct. But the cut is indicated by the + * heights. Vertices reachable from the source have height + * HEIGHT * WIDTH + 2 while vertices reachable from the sink have + * smaller height. Early termination is necessary with relabeling to + * prevent an infinite loop. The loop arises because vertices that are + * not reachable from the sink in the inverse residual network have + * their height reset to HEIGHT * WIDTH + 2 by the relabeling + * process. If there are such vertices with excess capacity, this is + * not high enough for the excess capacity to be pushed back to the + * perimeter. So after relabeling, vertices get lifted to try to push + * excess capacity back to the perimeter but then a relabeling happens + * to soon and foils this lifting. Terminating when all vertices with + * excess capacity are not reachable from the sink in the inverse + * residual network eliminates this problem. + *) + (pormat + ("~s push~a, ~s lift~a, ~s relabel~a, ~s wave~a, terminated early~%", + [Int(! pushes), + String(if !pushes = 1 then "" else "es"), + Int(! lifts), + String(if !lifts = 1 then "" else "s"), + Int(! relabels), + String(if !relabels = 1 then "" else "s"), + Int i, + String(if i = 1 then "" else "s")])) + else + (* We need to rebuild the priority queue after relabeling since the + * heights might have changed and the priority queue is indexed by + * height. This also assumes that a relabel is done before any pushes + * or lifts. + *) + (doo(vector_length q, fn k => + vector_set(q, k, [])) + ; doo(height, fn y => + doo(width, fn x => + matrix_set(marked, y, x, false))) + ; doo(height, fn y => + doo(width, fn x => + if not(zero(matrix_ref(e, y, x))) + then enqueue(y, x) + else ())) + ; loop(i, true))) + else if some_vector(q, fn ps => + some(ps, fn p => + let val x = x p + val y = y p + in can_push_right(y, x) + orelse can_push_left(y, x) + orelse can_push_down(y, x) + orelse can_push_up(y, x) + orelse can_push_t(y, x) + orelse can_lift(y, x) + end)) + then + ( + let fun loop k = + if not(negative k) + then + ( + let val ps = vector_ref(q, k) + in vector_set(q, k, []) + ; (for_each + (ps, fn p => + matrix_set(marked, y p, x p, + false))) + ; (for_each + (ps, fn p => + let val x = x p + val y = y p + in if can_push_right(y, x) + then (pushes := !pushes + 1 + ; push_right(y, x)) + else () + ; if can_push_left(y, x) + then (pushes := !pushes + 1 + ; push_left(y, x)) + else () + ; if can_push_down(y, x) + then (pushes := !pushes + 1 + ; push_down(y, x)) + else () + ; if can_push_up(y, x) + then (pushes := !pushes + 1 + ; push_up(y, x)) + else () + ; if can_push_t(y, x) + then (pushes := !pushes + 1 + ; push_t(y, x)) + else () + ; if can_lift(y, x) + then (lifts := !lifts + 1 + ; lift(y, x)) + else () + ; if not(zero(matrix_ref(e, y, x))) + then enqueue(y, x) + else () + end)) + end + ; loop(k - 1)) + else () + in loop(vector_length q - 1) + end + ; loop(i + 1, false)) + else + (* This is so MIN_CUT and MIN_CUT_INCLUDES_EVERY_EDGE_TO_T work. *) + (relabel() + ; relabels := !relabels + 1 + ; (pormat("~s push~a, ~s lift~a, ~s relabel~a, ~s wave~a~%", + [Int(! pushes), + String(if !pushes = 1 then "" else "es"), + Int(! lifts), + String(if !lifts = 1 then "" else "s"), + Int(! relabels), + String(if !relabels = 1 then "" else "s"), + Int i, + String(if i = 1 then "" else "s")]))) + in loop(0, false) + end + end + fun min_cut_includes_every_edge_to_t() = + (* This requires that a relabel was done immediately before returning from + * PREFLOW_PUSH. + *) + every_n(height, fn y => + every_n(width, fn x => + matrix_ref(h, y, x) = m1)) + fun min_cut() = + (* This requires that a relabel was done immediately before returning from + * PREFLOW_PUSH + *) + map_n_vector + (height, fn y => + map_n_vector(width, fn x => + not(matrix_ref(h, y, x) = m1))) + fun loop(lg_v, v_max) = + if negative lg_v + then (pormat("V-MAX=~s~%",[Int v_max]) + ; preflow_push(v_max + 1) + ; min_cut()) + else let val v = v_max + let + fun loop(i, c) = + if (zero i) + then c + else loop(i - 1, c + c) + in loop(lg_v, 1) + end + in pormat("LG-V=~s, V-MAX=~s, V=~s~%", + [Int lg_v, Int v_max, Int v]) + ; preflow_push v + ; loop(lg_v - 1, + if min_cut_includes_every_edge_to_t() + then v + else v_max) + end + in loop(lg_max_v, 0) + end + +in + +fun doit n = + let val height = n + val width = n + val lg_max_v = 15 + val c_right = make_matrix(height, width - 1, ~1) + val c_down = make_matrix(height - 1, width, ~1) + in doo(height, fn y => + doo(width - 1, fn x => + matrix_set + (c_right, y, x, + if (y >= quotient(height, 4) + andalso y < quotient(3 * height, 4) + andalso (x = quotient(width, 4) - 1 + orelse x = quotient(3 * width, 4) - 1)) + then 1 + else 128))) + ; doo(height - 1, fn y => + doo(width, fn x => + matrix_set + (c_down, y, x, + if (x >= quotient(width, 4) + andalso x < quotient(3 * width, 4) + andalso (y = quotient(height, 4) - 1 + orelse y = quotient(3 * height, 4) - 1)) + then 1 + else 128))) + ; rao_ratio_region(c_right, c_down, + make_matrix(height, width, 1), + lg_max_v) + end + +end + +structure Main = + struct + val doit = doit + end diff --git a/benchmark/tests/ray.sml b/benchmark/tests/ray.sml new file mode 100644 index 0000000..d72cea1 --- /dev/null +++ b/benchmark/tests/ray.sml @@ -0,0 +1,459 @@ +(* From the SML/NJ benchmark suite. *) + +(* objects.sml + * + * COPYRIGHT (c) 1992 AT&T Bell Laboratories + * + * Type declarations for the various objects in the ray tracer. + *) + +structure Objects = + struct + + datatype point = PT of {x : real, y : real, z : real} + + datatype vector = VEC of {l : real, m : real, n : real} + + datatype ray = Ray of {s : point, d : vector} + + datatype camera = Camera of { + vp : point, + ul : point, + ur : point, + ll : point, + lr : point + } + + datatype color = Color of {red : real, grn : real, blu : real} + + datatype sphere = Sphere of {c : point, r : real, color : color} + + datatype hit = Miss | Hit of {t : real, s : sphere} + + datatype visible = Visible of {h : point, s : sphere} + + datatype object + = TOP + | NUMBER of real + | NAME of string + | LIST of object list + | OPERATOR of object list -> object list + | MARK + | LITERAL of string + | UNMARK + | POINT of point + | VECTOR of vector + | RAY of ray + | CAMERA of camera + | COLOR of color + | SPHERE of sphere + | HIT + | VISIBLE + + end (* Objects *) +(* interp.sml + * + * COPYRIGHT (c) 1992 AT&T Bell Laboratories + *) + +structure Interp = + struct + + local + val exit = OS.Process.exit + fun ordof(s, i) = Char.ord(String.sub(s, i)) + exception NotAChar + exception NotAReal + fun fromStr x = + (case Char.fromString x + of SOME c => c + | NONE => raise NotAChar) + + fun strToReal s = + (case Real.fromString s + of SOME r => r + | _ => raise NotAReal) + + fun intToReal x = + (strToReal ((Int.toString x) ^ ".0")) + + + val explode = (fn x => map Char.toString (explode x)) + val implode = (fn x => implode (map fromStr x)) + + open Objects + val dict = ref ([] : {key : string, value : object} list) + fun dictInsert (NAME key, value) = let + fun find [] = [{key=key, value=value}] + | find (x::r) = if (key = #key x) + then {key=key, value=value}::r + else x :: (find r) + in + dict := find(!dict) + end + | dictInsert _ = raise Fail "dictInsert" + fun prObj outStrm obj = let + fun printf args = TextIO.output(outStrm, implode args) + fun pr (NUMBER n) = printf[" ", Real.toString n, "\n"] + | pr (NAME s) = printf[" ", s, "\n"] + | pr (LITERAL s) = printf[" ", s, "\n"] + | pr (LIST l) = app pr l + | pr MARK = printf[" MARK\n"] + | pr (OPERATOR _) = printf[" \n"] + | pr TOP = printf[" TOP OF STACK\n"] + | pr _ = printf[" \n"] + in + pr obj + end + in + + exception Stop + + fun error opName stk = let + fun prStk ([], _) = () + | prStk (_, 0) = () + | prStk (obj::r, i) = (prObj TextIO.stdErr obj; prStk(r, i-1)) + in + TextIO.output(TextIO.stdErr, "ERROR: "^opName^"\n"); + prStk (stk, 10); + raise (Fail opName) + end + + fun installOperator (name, rator) = + dictInsert (NAME name, OPERATOR rator) + + fun ps_def (v::k::r) = (dictInsert(k, v); r) + | ps_def stk = error "ps_def" stk + + local + fun binOp (f, opName) = let + fun g ((NUMBER arg1)::(NUMBER arg2)::r) = + NUMBER(f(arg2, arg1)) :: r + | g stk = error opName stk + in + g + end + in + val ps_add = binOp (op +, "add") + val ps_sub = binOp (op -, "sub") + val ps_mul = binOp (op *, "mul") + val ps_div = binOp (op /, "div") + end + + fun ps_rand stk = (NUMBER 0.5)::stk (** ??? **) + + fun ps_print (obj::r) = (prObj TextIO.stdOut obj; r) + | ps_print stk = error "print" stk + + fun ps_dup (obj::r) = (obj::obj::r) + | ps_dup stk = error "dup" stk + + fun ps_stop _ = raise Stop + + (* initialize dictionary and begin parsing input *) + fun parse inStrm = let + fun getc () = case TextIO.input1 inStrm of NONE => "" + | SOME c => Char.toString c + fun peek () = case TextIO.lookahead inStrm + of SOME x => Char.toString x + | _ => "" + (* parse one token from inStrm *) + fun toke deferred = let + fun doChar "" = exit OS.Process.success + | doChar "%" = let + fun lp "\n" = doChar(getc()) + | lp "" = exit OS.Process.success + | lp _ = lp(getc()) + in + lp(getc()) + end + | doChar "{" = (MARK, deferred+1) + | doChar "}" = (UNMARK, deferred-1) + | doChar c = if Char.isSpace (fromStr c) + then doChar(getc()) + else let + fun lp buf = (case peek() + of "{" => buf + | "}" => buf + | "%" => buf + | c => if Char.isSpace(fromStr c) + then buf + else (getc(); lp(c::buf)) + (* end case *)) + val tok = implode (rev (lp [c])) + val hd = ordof(tok, 0) + in + if (hd = ord (#"/")) + then (LITERAL(substring(tok, 1, size tok - 1)), deferred) + else + if ((Char.isDigit (chr hd)) orelse (hd = ord (#"-"))) + then (NUMBER(strToReal(tok)), deferred) + else (NAME tok, deferred) + end + in + doChar(getc()) + end + (* execute a token (if not deferred) *) + fun exec (UNMARK, stk, _) = let + fun lp ([], _) = raise Fail "MARK" + | lp (MARK::r, l) = (LIST l)::r + | lp (x::r, l) = lp (r, x::l) + in + lp (stk, []) + end + | exec (OPERATOR f, stk, 0) = f stk + | exec (LIST l, stk, 0) = let + fun execBody ([], stk) = stk + | execBody (obj::r, stk) = (exec(obj, stk, 0); execBody(r, stk)) + in + execBody (l, stk) + end + | exec (NAME s, stk, 0) = let + fun find [] = raise Fail "undefined name" + | find ({key, value}::r) = if (key = s) then value else find r + in + exec (find (!dict), stk, 0) + end + | exec (obj, stk, _) = obj::stk + fun lp (stk, level) = let + val (obj, level) = toke level + val stk = exec (obj, stk, level) + in + lp (stk, level) + end + in + installOperator ("add", ps_add); + installOperator ("def", ps_def); + installOperator ("div", ps_div); + installOperator ("dup", ps_dup); + installOperator ("mul", ps_mul); + installOperator ("print", ps_print); + installOperator ("rand", ps_rand); + installOperator ("stop", ps_stop); + installOperator ("sub", ps_sub); + (lp ([], 0)) handle Stop => () + end (* parse *) + + end (* local *) + + end (* Interp *) +(* ray.sml + * + * COPYRIGHT (c) 1992 AT&T Bell Laboratories + *) + +structure Ray = + struct + local open Objects in + + (** basic operations on points and vectors **) + + fun scaleVector (s, VEC{l, m, n}) = VEC{l=s*l, m=s*m, n=s*n} + + fun vecPlusVec (VEC{l, m, n}, VEC{l=l', m=m', n=n'}) = VEC{l=l+l', m=m+m', n=n+n'} + + fun vecPlusPt (VEC{l, m, n}, PT{x, y, z}) = PT{x=x+l, y=y+m, z=z+n} + + fun ptMinusPt (PT{x, y, z}, PT{x=x', y=y', z=z'}) = VEC{l=x-x', m=y-y', n=z-z'} + + fun wave (PT{x, y, z}, PT{x=x', y=y', z=z'}, w) = PT{ + x = w * (x' - x) + x, + y = w * (y' - y) + y, + z = w * (z' - z) + z + } + + fun dotProd (VEC{l, m, n}, VEC{l=l', m=m', n=n'}) = ((l*l') + (m*m') + (n*n')) + + (* normal vector to sphere *) + fun normalSphere (Visible{h, s as Sphere{c, ...}}) = let + val n = ptMinusPt(h, c) + val norm = Math.sqrt(dotProd(n, n)) + in + scaleVector(1.0 / norm, n) + end + + (* intersect a ray with a sphere *) + fun intersectSphere (Ray ray, s as Sphere sphere) = let + val a = dotProd(#d ray, #d ray) + val sdiffc = ptMinusPt(#s ray, #c sphere) + val b = 2.0 * dotProd(sdiffc, #d ray) + val c = dotProd(sdiffc, sdiffc) - (#r sphere * #r sphere) + val d = b*b - 4.0*a*c + in + if (d <= 0.0) + then Miss + else let + val d = Math.sqrt(d) + val t1 = (~b - d) / (2.0 * a) + val t2 = (~b + d) / (2.0 * a) + val t = if ((t1 > 0.0) andalso (t1 < t2)) then t1 else t2 + in + Hit{t=t, s=s} + end + end + + (* simple shading function *) + fun shade {light, phi} (visible as Visible{h, s}) = let + val l = ptMinusPt(light, h) + val n = normalSphere(visible) + val irradiance = phi * dotProd(l,n) / dotProd(l,l); + val irradiance = (if (irradiance < 0.0) then 0.0 else irradiance) + 0.05 + val Sphere{color=Color{red, grn, blu}, ...} = s + in + Color{red=red*irradiance, grn=grn*irradiance, blu=blu*irradiance} + end + + fun trace (ray as (Ray ray'), objList) = let + fun closest (Miss, x) = x + | closest (x, Miss) = x + | closest (h1 as Hit{t=t1, ...}, h2 as Hit{t=t2, ...}) = + if (t2 < t1) then h2 else h1 + fun lp ([], Hit{t, s}) = Visible{ + h = vecPlusPt(scaleVector(t, #d ray'), #s ray'), + s = s + } + | lp (s :: r, closestHit) = + lp (r, closest (closestHit, intersectSphere (ray, s))) + | lp _ = raise Fail "trace" + in + lp (objList, Miss) + end + + fun camera (Camera cam) (x, y) = let + val l = wave (#ul cam, #ll cam, y) + val r = wave (#ur cam, #lr cam, y) + val image_point = wave(l, r, x) + in + Ray{d = ptMinusPt(image_point, #vp cam), s = #vp cam} + end + + val shade = shade {light = PT{x = 10.0, y = ~10.0, z = ~10.0}, phi = 16.0} + val camera = camera (Camera{ + vp = PT{x = 0.0, y = 0.0, z = ~3.0}, + ul = PT{x = ~1.0, y = ~1.0, z = 0.0}, + ur = PT{x = 1.0, y = ~1.0, z = 0.0}, + ll = PT{x = ~1.0, y = 1.0, z = 0.0}, + lr = PT{x = 1.0, y = 1.0, z = 0.0} + }) + + fun image objList (x, y) = shade (trace(camera(x, y), objList)) + + fun picture (picName, objList) = let + val outStrm = TextIO.openOut picName + val image = image objList + val print = fn x => TextIO.output (outStrm, x) + fun putc c = TextIO.output1(outStrm, chr c) + fun doPixel (i, j) = let + val x = (real i) / 512.0 + val y = (real j) / 512.0 + val (Color c) = image (x, y) + fun cvt x = if (x >= 1.0) then 255 else floor(256.0*x) + in + putc (cvt (#red c)); + putc (cvt (#grn c)); + putc (cvt (#blu c)) + end + fun lp_j j = if (j < 512) + then let + fun lp_i i = if (i < 512) + then (doPixel(i, j); lp_i(i+1)) + else () + in + lp_i 0; lp_j(j+1) + end + else () + in + print "TYPE=dump\n"; + print "WINDOW=0 0 512 512\n"; + print "NCHAN=3\n"; + print "CHAN=rgb\n"; + print "\n"; + lp_j 0; + TextIO.closeOut outStrm + end + + end (* local *) + end; (* Ray *) +(* interface.sml + * + * COPYRIGHT (c) 1992 AT&T Bell Laboratories + * + * The interface between the interpreter and the ray tracer. + *) + +structure Interface = + struct + local + open Objects + in + + (* color pops three numbers and pushes a color object. + * usage: red-value green-value blue-value color + *) + fun ps_color ((NUMBER blu)::(NUMBER grn)::(NUMBER red)::r) = + (COLOR(Color{red=red, grn=grn, blu=blu})) :: r + | ps_color stk = Interp.error "color" stk + + (* pop radius, coordinates of center, and a color and push a sphere + * usage: radius x y z color-value sphere + *) + fun ps_sphere ( + (COLOR c)::(NUMBER z)::(NUMBER y)::(NUMBER x)::(NUMBER rad)::r + ) = SPHERE(Sphere{c=PT{x=x, y=y, z=z}, r=rad, color=c}) :: r + | ps_sphere stk = Interp.error "sphere" stk + + (* build an object list from solids on the stack, then invoke raytracer *) + fun ps_raytrace ((LITERAL picName)::r) = let + fun mkObjList ([], l) = l + | mkObjList ((SPHERE s)::r, l) = mkObjList(r, s::l) + | mkObjList (_::r, l) = mkObjList(r, l) + in + Ray.picture(picName, mkObjList(r, [])); + [] + end + | ps_raytrace stk = Interp.error "raytrace" stk + + (* add ray tracing operations to interpreter dictionary *) + fun rtInit () = ( + Interp.installOperator("color", ps_color); + Interp.installOperator("sphere", ps_sphere); + Interp.installOperator("raytrace", ps_raytrace)) + + end (* local *) + end; + +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; +(* main.sml + * + * COPYRIGHT (c) 1992 AT&T Bell Laboratories + * + * Main structure for running raytracer as benchmark. + *) + +structure Main : BMARK = + struct + + fun doit n = + let + fun loop n = + if n = 0 + then () + else + let + val strm = TextIO.openIn "DATA/ray" + val _ = Interface.rtInit() + val _ = Interp.parse strm + val _ = TextIO.closeIn strm + in + loop (n - 1) + end + in + loop n + end + + fun testit _ = () + end diff --git a/benchmark/tests/raytrace.sml b/benchmark/tests/raytrace.sml new file mode 100644 index 0000000..9edcff2 --- /dev/null +++ b/benchmark/tests/raytrace.sml @@ -0,0 +1,2388 @@ +(* + * Translated by Stephen Weeks (sweeks@sweeks.com) 2000-10-11 from the + * PLClub OCaml winning entry to the 2000 ICFP programming contest. + *) + +(* raytrace.sml *) +signature CAML = + sig + type float = real + type int = int + end + +structure Caml = +struct + +type int = int +type float = real + +val op div = Int.div + +exception Not_found +exception Failure of string + +fun failwith s = raise(Failure s) + +structure Char = + struct + open Char + val code = ord + val chr = chr + val unsafe_chr = chr + val lowercase = toLower + val uppercase = toUpper + end + +local + open TextIO +in + type out_channel = outstream + val open_out = openOut + val open_out_bin = open_out + fun output_string (out, s) = output(out, s) + val close_out = closeOut +end + +type float = real + +structure Array = + struct + local open Array + in + val array = array + val copy = copy + val of_list = fromList + val length = length + val sub = sub + val update = update + val unsafe_get = Array.sub + val unsafe_set = Array.update + val make = array + fun map f a = Array.tabulate(length a, fn i => f(Array.sub(a, i))) + val init = tabulate + end + end + +fun for(a: int, b, f) = + let + fun loop a = + if a > b + then () + else (f a; loop(a + 1)) + in loop a + end + +fun forDown(b: int, a, f) = + let + fun loop b = + if b < a + then () + else (f b; loop(b - 1)) + in loop b + end + +local + open Real + open Math +in + val abs_float = abs + val acos = acos + val asin = asin + val cos = cos + val float = fromInt + val float_of_int = float + val sin = sin + val sqrt = sqrt + val tan = tan + val truncate = trunc + val ** = Math.pow + infix 8 ** +end + +(* A hack for hash tables with string domain where performance doesn't matter. *) +structure Hashtbl: + sig + type ('a, 'b) t + + val add: ('a, 'b) t -> string -> 'b -> unit + val create: int -> ('a, 'b) t + val find: ('a, 'b) t -> string -> 'b + end = + struct + datatype ('a, 'b) t = T of (string * 'b) list ref + + fun create _ = T (ref []) + + fun add (T t) k d = t := (k, d) :: !t + + fun find (T (ref t)) k = + case List.find (fn (k', _) => k = k') t of + NONE => raise Not_found + | SOME(_, d) => d + end + +structure List = + struct + local open List + in + val iter = app + val map = map + val filter = filter + val nth = nth + val rev = rev + end + end + +fun exit i = Posix.Process.exit(Word8.fromInt i) + +end +structure Math = +struct + +open Caml + +val epsilon = 1E~5 + +val dtr = acos (~1.0) / 180.0 +val rtd = 180.0 / acos (~1.0) + +fun dcos t = cos (t * dtr) +fun dsin t = sin (t * dtr) +fun dtan t = tan (t * dtr) +fun dacos x = rtd * acos x + +val infinity = Real.posInf +val minus_infinity = Real.negInf + +fun max_float (x, y : float) = if x >= y then x else y + +end +signature MATRIX = + sig + include CAML + + (**** Matrix arithmetic ****) + + type t = float array (* 4-dimension matrix *) + type v = float * float * float * float (* 4-dimension vector *) + + (* Basic matrices *) + val identity : t + val translate : (*x:*)float * (*y:*)float * (*z:*)float -> t + val scale : (*x:*)float * (*y:*)float * (*z:*)float -> t + val uscale : float -> t + val unscale : (*x:*)float * (*y:*)float * (*z:*)float -> t + val unuscale : float -> t + val rotatex : float -> t + val rotatey : float -> t + val rotatez : float -> t + + (* Operations on matrices *) + val mul : t * t -> t + val vmul : t * v -> v + val transpose : t -> t + + val add_scaled : v * float * v -> v + val add : v * v -> v + val sub : v * v -> v + val prod : v * v -> float + val square : v -> float + val normalize : v -> v + val neg : v -> v + end +structure Matrix: MATRIX = +struct + +open Caml +open Math + +type t = float array +type v = float * float * float * float + +(**** Basic matrices ****) + +val identity = + Array.of_list[1.0, 0.0, 0.0, 0.0, + 0.0, 1.0, 0.0, 0.0, + 0.0, 0.0, 1.0, 0.0, + 0.0, 0.0, 0.0, 1.0] + +fun translate(x, y, z) = + Array.of_list[1.0, 0.0, 0.0, ~ x, + 0.0, 1.0, 0.0, ~ y, + 0.0, 0.0, 1.0, ~ z, + 0.0, 0.0, 0.0, 1.0] + +fun unscale(x, y, z) = + Array.of_list[ x, 0.0, 0.0, 0.0, + 0.0, y, 0.0, 0.0, + 0.0, 0.0, z, 0.0, + 0.0, 0.0, 0.0, 1.0] + +fun scale(x, y, z) = unscale (1.0 / x, 1.0 / y, 1.0 / z) + +fun unuscale s = unscale (s, s, s) + +fun uscale s = scale (s, s, s) + +fun rotatex t = + let + val co = dcos t + val si = dsin t + in + Array.of_list[ 1.0, 0.0, 0.0, 0.0, + 0.0, co, si, 0.0, + 0.0, ~ si, co, 0.0, + 0.0, 0.0, 0.0, 1.0 ] + end + +fun rotatey t = + let + val co = dcos t + val si = dsin t + in + Array.of_list[ co, 0.0, ~ si, 0.0, + 0.0, 1.0, 0.0, 0.0, + si, 0.0, co, 0.0, + 0.0, 0.0, 0.0, 1.0 ] + end + +fun rotatez t = + let + val co = dcos t + val si = dsin t + in + Array.of_list[ co, si, 0.0, 0.0, + ~ si, co, 0.0, 0.0, + 0.0, 0.0, 1.0, 0.0, + 0.0, 0.0, 0.0, 1.0 ] + end + +(*** Operations on matrices ***) + +fun get (m : t, i, j) = Array.unsafe_get (m, i * 4 + j) +fun set (m : t, i, j, v) = Array.unsafe_set (m, i * 4 + j, v) + +fun mul (m, m') = + let + val m'' = Array.make (16, 0.0) + in + for(0, 3, fn i => + for(0, 3, fn j => let + fun lp (4, s) = s + | lp (k, s) = lp (k+1, s + get(m, i, k) * get(m', k, j)) + in + set(m'', i, j, lp(0, 0.0)) + end)) + ; m'' + end + +fun transpose m = + let val m' = Array.make (16, 0.0) + in for(0, 3, fn i => + for(0, 3, fn j => + set (m', i, j, get (m, j, i)))) + ; m' + end + +fun vmul (m, (x, y, z, t)) = + (x * get(m, 0, 0) + y * get(m, 0, 1) + z * get(m, 0, 2) + t * get(m, 0, 3), + x * get(m, 1, 0) + y * get(m, 1, 1) + z * get(m, 1, 2) + t * get(m, 1, 3), + x * get(m, 2, 0) + y * get(m, 2, 1) + z * get(m, 2, 2) + t * get(m, 2, 3), + x * get(m, 3, 0) + y * get(m, 3, 1) + z * get(m, 3, 2) + t * get(m, 3, 3)) + +fun add_scaled (x: v, t, v: v) : v = + ( #1 x + t * #1 v, + #2 x + t * #2 v, + #3 x + t * #3 v, + #4 x + t * #4 v ) + +fun add (x: v, y: v) : v = + ( #1 x + #1 y, + #2 x + #2 y, + #3 x + #3 y, + #4 x + #4 y ) + +fun sub (x: v, y: v) : v = + (#1 x - #1 y, + #2 x - #2 y, + #3 x - #3 y, + #4 x - #4 y) + +fun prod (x: v, y: v) : real = + #1 x * #1 y + #2 x * #2 y + #3 x * #3 y + #4 x * #4 y + +fun square (vx, vy, vz, vt) : real = + vx * vx + vy * vy + vz * vz + vt * vt + +fun normalize (x: v): v = + let + val nx = sqrt (prod (x, x)) + in + (#1 x / nx, + #2 x / nx, + #3 x / nx, + #4 x / nx) + end + +fun neg (x: v) : v = + (~(#1 x), + ~(#2 x), + ~(#3 x), + ~(#4 x)) + +end +signature LEX_TOKEN_STRUCTS = + sig + end + +signature LEX_TOKEN = + sig + include LEX_TOKEN_STRUCTS + + datatype t = + Binder of string + | Bool of bool + | Eof + | Identifier of string + | Int of int + | Lbrace + | Lbracket + | Rbrace + | Rbracket + | Real of real + | String of string + end +functor LexToken(S: LEX_TOKEN_STRUCTS): LEX_TOKEN = +struct + +open S + +datatype t = + Binder of string + | Bool of bool + | Eof + | Identifier of string + | Int of int + | Lbrace + | Lbracket + | Rbrace + | Rbracket + | Real of real + | String of string + +end +type int = Int.int +functor Lex(structure Token: LEX_TOKEN)= + struct + structure UserDeclarations = + struct +val chars: char list ref = ref [] + +type lexarg = unit + +type lexresult = Token.t + +val eof: lexarg -> lexresult = + fn () => Token.Eof + +fun fail s = raise Fail s + +end (* end of user routines *) +exception LexError (* raised if illegal leaf action tried *) +structure Internal = + struct + +datatype yyfinstate = N of int +type statedata = {fin : yyfinstate list, trans: string} +(* transition & final state table *) +val tab = let +val s = [ + (0, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), + (1, +"\000\000\000\000\000\000\000\000\000\026\026\026\000\026\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\026\000\025\000\000\024\000\000\000\000\000\000\000\023\000\021\ +\\012\012\012\012\012\012\012\012\012\012\000\000\000\000\000\000\ +\\000\009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\ +\\009\009\009\009\009\009\009\009\009\009\009\011\000\010\000\000\ +\\000\009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\ +\\009\009\009\009\009\009\009\009\009\009\009\008\000\007\000\000\ +\\000" +), + (3, +"\000\000\000\000\000\000\000\000\000\027\029\029\000\028\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\ +\\027\027\027\027\027\027\027\027\027\027\027\027\027\027\027\000\ +\\000" +), + (5, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\030\030\031\030\030\030\030\030\030\030\030\030\030\030\030\030\ +\\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\ +\\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\ +\\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\ +\\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\ +\\030\030\030\030\030\030\030\030\030\030\030\030\030\030\030\000\ +\\000" +), + (9, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\009\000\000\ +\\009\009\009\009\009\009\009\009\009\009\000\000\000\000\000\000\ +\\000\009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\ +\\009\009\009\009\009\009\009\009\009\009\009\000\000\000\000\009\ +\\000\009\009\009\009\009\009\009\009\009\009\009\009\009\009\009\ +\\009\009\009\009\009\009\009\009\009\009\009\000\000\000\000\000\ +\\000" +), + (12, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\016\000\ +\\012\012\012\012\012\012\012\012\012\012\000\000\000\000\000\000\ +\\000\000\000\000\000\013\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\013\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), + (13, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\015\000\000\ +\\014\014\014\014\014\014\014\014\014\014\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), + (14, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\014\014\014\014\014\014\014\014\014\014\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), + (16, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\017\017\017\017\017\017\017\017\017\017\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), + (17, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\017\017\017\017\017\017\017\017\017\017\000\000\000\000\000\000\ +\\000\000\000\000\000\018\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\018\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), + (18, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\020\000\000\ +\\019\019\019\019\019\019\019\019\019\019\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), + (19, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\019\019\019\019\019\019\019\019\019\019\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), + (21, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\ +\\022\022\022\022\022\022\022\022\022\022\022\000\000\000\000\000\ +\\000\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\ +\\022\022\022\022\022\022\022\022\022\022\022\000\000\000\000\000\ +\\000" +), + (22, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\022\000\000\ +\\022\022\022\022\022\022\022\022\022\022\000\000\000\000\000\000\ +\\000\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\ +\\022\022\022\022\022\022\022\022\022\022\022\000\000\000\000\022\ +\\000\022\022\022\022\022\022\022\022\022\022\022\022\022\022\022\ +\\022\022\022\022\022\022\022\022\022\022\022\000\000\000\000\000\ +\\000" +), + (23, +"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\012\012\012\012\012\012\012\012\012\012\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), + (28, +"\000\000\000\000\000\000\000\000\000\000\029\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\\000" +), +(0, "")] +fun f x = x +val s = map f (rev (tl (rev s))) +exception LexHackingError +fun look ((j,x)::r, i) = if i = j then x else look(r, i) + | look ([], i) = raise LexHackingError +fun g {fin=x, trans=i} = {fin=x, trans=look(s,i)} +in Vector.fromList(map g +[{fin = [], trans = 0}, +{fin = [], trans = 1}, +{fin = [], trans = 1}, +{fin = [], trans = 3}, +{fin = [], trans = 3}, +{fin = [], trans = 5}, +{fin = [], trans = 5}, +{fin = [(N 13)], trans = 0}, +{fin = [(N 11)], trans = 0}, +{fin = [(N 49)], trans = 9}, +{fin = [(N 9)], trans = 0}, +{fin = [(N 7)], trans = 0}, +{fin = [(N 39)], trans = 12}, +{fin = [], trans = 13}, +{fin = [(N 35)], trans = 14}, +{fin = [], trans = 14}, +{fin = [], trans = 16}, +{fin = [(N 35)], trans = 17}, +{fin = [], trans = 18}, +{fin = [(N 35)], trans = 19}, +{fin = [], trans = 19}, +{fin = [], trans = 21}, +{fin = [(N 20)], trans = 22}, +{fin = [], trans = 23}, +{fin = [(N 43)], trans = 0}, +{fin = [(N 41)], trans = 0}, +{fin = [(N 5)], trans = 0}, +{fin = [(N 58)], trans = 0}, +{fin = [(N 55)], trans = 28}, +{fin = [(N 55)], trans = 0}, +{fin = [(N 62)], trans = 0}, +{fin = [(N 60),(N 62)], trans = 0}]) +end +structure StartStates = + struct + datatype yystartstate = STARTSTATE of int + +(* start state definitions *) + +val C = STARTSTATE 3; +val INITIAL = STARTSTATE 1; +val S = STARTSTATE 5; + +end +type result = UserDeclarations.lexresult + exception LexerError (* raised if illegal leaf action tried *) +end + +type int = Int.int +fun makeLexer (yyinput: int -> string) = +let val yygone0:int=1 + val yyb = ref "\n" (* buffer *) + val yybl: int ref = ref 1 (*buffer length *) + val yybufpos: int ref = ref 1 (* location of next character to use *) + val yygone: int ref = ref yygone0 (* position in file of beginning of buffer *) + val yydone = ref false (* eof found yet? *) + val yybegin: int ref = ref 1 (*Current 'start state' for lexer *) + + val YYBEGIN = fn (Internal.StartStates.STARTSTATE x) => + yybegin := x + +fun lex (yyarg as (())) = +let fun continue() : Internal.result = + let fun scan (s,AcceptingLeaves : Internal.yyfinstate list list,l,i0: int) = + let fun action (i: int,nil) = raise LexError + | action (i,nil::l) = action (i-1,l) + | action (i,(node::acts)::l) = + case node of + Internal.N yyk => + (let fun yymktext() = String.substring(!yyb,i0,i-i0) + val yypos: int = i0+ !yygone + fun REJECT() = action(i,acts::l) + open UserDeclarations Internal.StartStates + in (yybufpos := i; case yyk of + + (* Application actions *) + + 11 => (Token.Lbrace) +| 13 => (Token.Rbrace) +| 20 => let val yytext=yymktext() in Token.Binder(String.extract(yytext, 1, NONE)) end +| 35 => let val yytext=yymktext() in Token.Real(case Real.fromString yytext of + NONE => + fail(concat["bad real constant ", yytext]) + | SOME r => r) end +| 39 => let val yytext=yymktext() in Token.Int(case Int.fromString yytext of + NONE => + fail(concat["bad int constant ", yytext]) + | SOME i => i) end +| 41 => (chars := []; YYBEGIN S; continue()) +| 43 => (YYBEGIN C; continue()) +| 49 => let val yytext=yymktext() in Token.Identifier yytext end +| 5 => (continue()) +| 55 => (YYBEGIN INITIAL; continue()) +| 58 => (continue()) +| 60 => (let val s = (implode(rev(!chars)) before chars := nil) + in YYBEGIN INITIAL + ; Token.String s + end) +| 62 => let val yytext=yymktext() in chars := String.sub(yytext, 0) :: !chars + ; continue() end +| 7 => (Token.Lbracket) +| 9 => (Token.Rbracket) +| _ => raise Internal.LexerError + + ) end ) + + val {fin,trans} = Vector.sub(Internal.tab, s) + val NewAcceptingLeaves = fin::AcceptingLeaves + in if l = !yybl then + if trans = #trans(Vector.sub(Internal.tab,0)) + then action(l,NewAcceptingLeaves +) else let val newchars= if !yydone then "" else yyinput 1024 + in if (String.size newchars)=0 + then (yydone := true; + if (l=i0) then UserDeclarations.eof yyarg + else action(l,NewAcceptingLeaves)) + else (if i0=l then yyb := newchars + else yyb := String.substring(!yyb,i0,l-i0)^newchars; + yygone := !yygone+i0; + yybl := String.size (!yyb); + scan (s,AcceptingLeaves,l-i0,0)) + end + else let val NewChar = Char.ord(CharVector.sub(!yyb,l)) + val NewChar = if NewChar<128 then NewChar else 128 + val NewState = Char.ord(CharVector.sub(trans,NewChar)) + in if NewState=0 then action(l,NewAcceptingLeaves) + else scan(NewState,NewAcceptingLeaves,l+1,i0) + end + end +(* + val start= if String.substring(!yyb,!yybufpos-1,1)="\n" +then !yybegin+1 else !yybegin +*) + in scan(!yybegin (* start *),nil,!yybufpos,!yybufpos) + end +in continue end + in lex + end +end +signature PROGRAM = + sig + include CAML + (**** Basic types: programs, values, ... ****) + + datatype k = + Acos | Addi | Addf | Apply | Asin | Clampf | Cone | Cos | Cube + | Cylinder | Difference | Divi | Divf | Eqi | Eqf | Floor | Frac + | Get | Getx | Gety | Getz | If | Intersect | Length | Lessi | Lessf + | Light | Modi | Muli | Mulf | Negi | Negf | Plane | Point + | Pointlight | Real | Render | Rotatex | Rotatey | Rotatez | Scale + | Sin | Sphere | Spotlight | Sqrt | Subi | Subf | Translate | Union + | Uscale + + (* Program tokens *) + datatype t = + Fun of t list + | Arr of t list + | Ident of string + | Binder of string + | Int of int + | Float of float + | Bool of bool + | String of string + | Prim of k + + (* internal representation of program tokens *) + datatype t' = + Fun' of t' list + | Arr' of t' list + | Ident' of int (* index to environment stack *) + | Binder' + (* + | Int' of int + | Float' of float + | Bool' of bool + | String' of string + *) + | Prim' of k + | Val' of v (* inlined value *) + + (* Values *) + and v = + VInt of int + | VFloat of float + | VBool of bool + | VStr of string + | VClos of v list * t' list + | VFun of (v list -> v list) (* XXX for the compiler *) + | VArr of v array + | VPoint of v * v * v (* XXX Maybe these should be floats? *) + | VObj of obj + | VLight of v * v + | VPtLight of v * v + | VStLight of v * v * v * v * v + + and obj = + OObj of kind * closure ref + | OTransform of + obj * + Matrix.t * (* World to object *) + Matrix.t * (* Object to world *) + float * (* Scale factor *) + bool (* Isometry? *) + | OUnion of obj * obj + | OInter of obj * obj + | ODiff of obj * obj + + and kind = + OSphere + | OCube + | OCylind + | OCone + | OPlane + + and closure = + Unopt of v (* Unoptimized function *) + | Opt of v + | Cst of (float * float * float * float * float * float) + + (* Translation of an identifier *) + val translate : string -> t + + (* Get the name of an identifier *) +(* val name : t' -> string *) + + exception Stuck_computation of v list * v list * t' list + exception Stuck_computation' (* for compiler *) + + val read: TextIO.instream -> t list + end +structure Program: PROGRAM = +struct + +open Caml + +datatype k = + Acos | Addi | Addf | Apply | Asin | Clampf | Cone | Cos | Cube + | Cylinder | Difference | Divi | Divf | Eqi | Eqf | Floor | Frac + | Get | Getx | Gety | Getz | If | Intersect | Length | Lessi | Lessf + | Light | Modi | Muli | Mulf | Negi | Negf | Plane | Point + | Pointlight | Real | Render | Rotatex | Rotatey | Rotatez | Scale + | Sin | Sphere | Spotlight | Sqrt | Subi | Subf | Translate | Union + | Uscale + +datatype t = + Fun of t list + | Arr of t list + | Ident of string + | Binder of string + | Int of int + | Float of float + | Bool of bool + | String of string + | Prim of k + +datatype t' = + Fun' of t' list + | Arr' of t' list + | Ident' of int (* index to environment stack *) + | Binder' +(* + | Int' of int + | Float' of float + | Bool' of bool + | String' of string +*) + | Prim' of k + | Val' of v (* inlined value *) + +and v = + VInt of int + | VFloat of float + | VBool of bool + | VStr of string + | VClos of v list * t' list + | VFun of (v list -> v list) (* XXX for the compiler *) + | VArr of v array + | VPoint of v * v * v + | VObj of obj + | VLight of v * v + | VPtLight of v * v + | VStLight of v * v * v * v * v + +and obj = + OObj of kind * closure ref + | OTransform of + obj * + Matrix.t * (* World to object *) + Matrix.t * (* Object to world *) + float * (* Scale factor *) + bool (* Isometry? *) + | OUnion of obj * obj + | OInter of obj * obj + | ODiff of obj * obj + +and kind = + OSphere + | OCube + | OCylind + | OCone + | OPlane + +and closure = + Unopt of v + | Opt of v + | Cst of (float * float * float * float * float * float) + +fun create_hashtables size init = + let + val tbl: (string, t) Hashtbl.t = Hashtbl.create size +(* val tbl' = Hashtbl.create size *) + in + List.iter (fn (key, data) => Hashtbl.add tbl key data) init; +(* List.iter (fn (data, key) -> Hashtbl.add tbl' key data) init; *) + tbl (*, tbl' *) + end + +val keywords(*, keyword_name)*) = + create_hashtables 101 +(* Booleans are either the literal true or the literal false. *) + [ ("true", Bool true), + ("false", Bool false), +(* Operators (see appendix) *) + ("acos", Prim Acos), + ("addi", Prim Addi), + ("addf", Prim Addf), + ("apply", Prim Apply), + ("asin", Prim Asin), + ("clampf", Prim Clampf), + ("cone", Prim Cone), + ("cos", Prim Cos), + ("cube", Prim Cube), + ("cylinder", Prim Cylinder), + ("difference", Prim Difference), + ("divi", Prim Divi), + ("divf", Prim Divf), + ("eqi", Prim Eqi), + ("eqf", Prim Eqf), + ("floor", Prim Floor), + ("frac", Prim Frac), + ("get", Prim Get), + ("getx", Prim Getx), + ("gety", Prim Gety), + ("getz", Prim Getz), + ("if", Prim If), + ("intersect", Prim Intersect), + ("length", Prim Length), + ("lessi", Prim Lessi), + ("lessf", Prim Lessf), + ("light", Prim Light), + ("modi", Prim Modi), + ("muli", Prim Muli), + ("mulf", Prim Mulf), + ("negi", Prim Negi), + ("negf", Prim Negf), + ("plane", Prim Plane), + ("point", Prim Point), + ("pointlight", Prim Pointlight), + ("real", Prim Real), + ("render", Prim Render), + ("rotatex", Prim Rotatex), + ("rotatey", Prim Rotatey), + ("rotatez", Prim Rotatez), + ("scale", Prim Scale), + ("sin", Prim Sin), + ("sphere", Prim Sphere), + ("spotlight", Prim Spotlight), + ("sqrt", Prim Sqrt), + ("subi", Prim Subi), + ("subf", Prim Subf), + ("translate", Prim Translate), + ("union", Prim Union), + ("uscale", Prim Uscale)] + +fun translate i = + Hashtbl.find keywords i + handle Not_found => Ident i + +(* fun name token = + * Hashtbl.find keyword_name + * (match token with + * Prim' k -> Prim k + * | _ -> raise Not_found) + * + *) +exception Stuck_computation of v list * v list * t' list +exception Stuck_computation' (* for compiler *) + +structure LexToken = LexToken() +structure Lex = Lex(structure Token = LexToken) + +fun read(ins: TextIO.instream): t list = + let + val lex: unit -> LexToken.t = + Lex.makeLexer(fn n => TextIO.inputN(ins, n))() + local + val next: LexToken.t option ref = ref NONE + in + fun token(): LexToken.t = + case !next of + NONE => lex() + | SOME t => (next := NONE; t) + fun save(t: LexToken.t): unit = + next := SOME t + end + fun bad() = failwith "invalid input" + fun many(done: LexToken.t -> bool): t list = + let + fun loop(ac: t list) = + case one() of + NONE => if done(token()) + then rev ac + else bad() + | SOME t => loop(t :: ac) + in loop [] + end + and one(): t option = + let fun tok t = SOME t + in case token() of + LexToken.Binder x => tok(Binder x) + | LexToken.Bool b => tok(Bool b) + | LexToken.Identifier x => tok(translate x) + | LexToken.Int i => tok(Int i) + | LexToken.Lbrace => + SOME(Fun(many(fn LexToken.Rbrace => true | _ => false))) + | LexToken.Lbracket => + SOME(Arr(many(fn LexToken.Rbracket => true | _ =>false))) + | LexToken.Real r => tok(Float r) + | LexToken.String s => tok(String s) + | t => (save t; NONE) + end + in many(fn LexToken.Eof => true | _ => false) + end + +end +signature PPM = + sig + include CAML + + type pixmap + + val init : (*width:*)int * (*height:*)int -> pixmap + val dump : string * pixmap -> unit +(* val load : string -> pixmap *) + + val width : pixmap -> int + val height : pixmap -> int + + val get : pixmap * int * int * int -> int + val set : pixmap * int * int * int * int -> unit + val setp : pixmap * int * int * int * int * int -> unit + end +structure Ppm: PPM = +struct + +open Caml + +structure Array = Word8Array +structure Word = Word8 + +type pixmap = Array.array * int + +fun get ((img, width), i, j, k) = + Word.toInt (Array.sub (img, ((j * width) + i) * 3 + k)) + +fun set ((img, width), i, j, k, v) = + Array.update (img, ((j * width) + i) * 3 + k, Word.fromInt v) + +fun setp ((img, width), i, j, r, g, b) = + let val p = ((j * width) + i) * 3 + in Array.update(img, p, Word.fromInt r) + ; Array.update(img, p + 1, Word.fromInt g) + ; Array.update(img, p + 2, Word.fromInt b) + end + +fun init (width, height) = + (Array.array(height * width * 3, 0w0), width) + +fun width (s, width) = width +fun height (s, width) = Array.length s div width div 3 + +fun dump (file, (img, width)) = + let + val sz = Array.length img + val height = sz div 3 div width + val f = open_out_bin file + in output_string (f, "P6\n# PL Club - translated to SML\n") + ; output_string (f, concat[Int.toString width, " ", + Int.toString height, "\n255\n"]) + ; output_string (f, Byte.unpackString (Word8ArraySlice.slice + (img, 0, NONE))) + ; close_out f + end + +(* fun load file = + * let f = open_in_bin file in + * assert (input_line f = "P6"); + * assert ((input_line f).[0] = '#'); + * let s = input_line f in + * let i = ref 0 in + * while s.[!i] >= '0' && s.[!i] <= '9' do incr i done; + * let width = int_of_string (String.sub s 0 !i) in + * let height = + * int_of_string (String.sub s (!i + 1) (String.length s - !i - 1)) in + * assert (input_line f = "255"); + * let (s, _) as img = init width height in + * really_input f s 0 (String.length s); + * close_in f; + * img + *) +end +signature RENDER = + sig + include CAML + + val apply : (Program.v * Program.v list -> Program.v list) ref + val inline_closure : (Program.v -> Program.v) ref + + val f : + (*amb:*)(float * float * float) * (*lights:*) Program.v array * + (*obj:*)Program.obj * (*depth:*)int * (*fov:*)float * + (*wid:*)int * (*ht:*)int * + (*file:*)string -> unit + end +structure Render: RENDER = +struct + +open Caml +infix 9 ** +open Program + +(* Scene description *) +datatype kind = (* section 3.2 *) + SSphere of Matrix.v (* Center *) * float (* Square of the radius *) + | SEllips + | SCube of Matrix.v (* Normal x = 0 *) * + Matrix.v (* Normal y = 0 *) * + Matrix.v (* Normal z = 0 *) + | SCylind of Matrix.v (* Normal *) + | SCone of Matrix.v (* Normal *) + | SPlane of Matrix.v (* Equation *) * Matrix.v (* Normal *) + +datatype scene = (* section 3.7 *) + SObj of kind * closure ref (* surface function *) * Matrix.t + | SBound of scene * Matrix.v (* Center *) * float (* Square of the radius *) + | SUnion of scene * scene + | SInter of scene * scene + | SDiff of scene * scene + +datatype light = (* section 3.5 *) + Light of Matrix.v (* negated & normalized *) * (float * float * float) + | PtLight of Matrix.v * (float * float * float) + | StLight of Matrix.v * Matrix.v (* negated & normalized *) * + (float * float * float) * float (* cos *) * float + +type desc = + { amb : float * float * float, + lights : light array, + scene : scene } + +open Math +open Matrix + +(**** Scene calculation ****) + +(* Plane equation and normal in world coordinates *) +fun plane_eq(m, v) = + let + val n = vmul (transpose m, v ) + in + (n, normalize(#1 n, #2 n, #3 n, 0.0)) + end + +val origin = ( 0.0, 0.0, 0.0, 1.0 ) +val cube_center = ( 0.5, 0.5, 0.5, 1.0 ) +val cylinder_center = ( 0.0, 0.5, 0.0, 1.0 ) +val cone_center = ( 0.0, 1.0, 0.0, 1.0 ) + +fun intern_obj(m, m1, scale, isom, ob) = +(* apply transformations *) + case ob of + OObj (OSphere, f) => + if isom + then + let + val center = vmul (m1, origin) + val radius = scale * scale + in + SBound (SObj (SSphere (center, radius), f, m), center, radius) + end + else + let + val center = vmul (m1, origin) + val radius = scale * scale + in + SBound (SObj (SEllips, f, m), center, radius) + end + | OObj (OCube, f) => + let + val (nx, nx') = plane_eq(m, (1.0, 0.0, 0.0, 0.0)) + val (ny, ny') = plane_eq(m, (0.0, 1.0, 0.0, 0.0)) + val (nz, nz') = plane_eq(m, (0.0, 0.0, 1.0, 0.0)) + val c = SObj (SCube (nx', ny', nz'), f, m) + in + SBound (c, vmul (m1, cube_center), scale * scale * 0.75) + end + | OObj (OCylind, f) => + let + val (n, n') = plane_eq(m, (0.0, 1.0, 0.0, 0.0)) + val c = SObj (SCylind n', f, m) + in + SBound (c, vmul(m1, cylinder_center), scale * scale * 1.25) + end + | OObj (OCone, f) => + let + val (n, n') = plane_eq(m, (0.0, 1.0, 0.0, 0.0)) + val c = SObj (SCone n', f, m) + in + SBound (c, vmul(m1, cone_center), scale * scale) + end + | OObj (OPlane, f) => + let + val (n, n') = plane_eq(m, (0.0, 1.0, 0.0, 0.0)) + in + SObj (SPlane (n, n'), f, m) + end + | OTransform (o', m', m'1, scale', isom') => + intern_obj + (Matrix.mul(m', m), Matrix.mul(m1, m'1), + scale * scale', isom andalso isom', o') + | OUnion (o1, o2) => + SUnion (intern_obj(m, m1, scale, isom, o1), + intern_obj(m, m1, scale, isom, o2)) + | OInter (o1, o2) => + SInter (intern_obj(m, m1, scale, isom, o1), + intern_obj(m, m1, scale, isom, o2)) + | ODiff (ODiff (o1, o2), o3) => + (* Better to have unions that diffs for introducing bounds *) + intern_obj(m, m1, scale, isom, (ODiff (o1, OUnion (o2, o3)))) + | ODiff (o1, o2) => + SDiff (intern_obj(m, m1, scale, isom, o1), + intern_obj(m, m1, scale, isom, o2)) + +fun intern_lights a = + Array.map + (fn VLight (VPoint (VFloat x, VFloat y, VFloat z), + VPoint (VFloat r, VFloat g, VFloat b)) => + Light (normalize (neg (x, y, z, 0.0)), (r, g, b)) + | VPtLight (VPoint (VFloat x, VFloat y, VFloat z), + VPoint (VFloat r, VFloat g, VFloat b)) => + PtLight ((x, y, z, 1.0), (r, g, b)) + | VStLight (VPoint (VFloat x, VFloat y, VFloat z), + VPoint (VFloat x', VFloat y', VFloat z'), + VPoint (VFloat r, VFloat g, VFloat b), + VFloat cutoff, VFloat exp) => + StLight ((x, y, z, 1.0), + normalize (x - x', y - y', z - z', 0.0), + (r, g, b), dcos cutoff, exp) + | _ => + raise(Fail "assert false")) + a + +(**** Scene optimization ****) + +fun flatten_rec(sc, rem) = + case sc of + SUnion (sc1, sc2) => flatten_rec(sc1, flatten_rec(sc2, rem)) + | sc => sc :: rem + +fun flatten_union sc = flatten_rec(sc, []) + +fun object_cost k : int = + case k of + SSphere _ => 1 + | SEllips => 2 + | SCube _ => 4 + | SCylind _ => 2 + | SCone _ => 2 + | SPlane _ => 0 (* Planes do not have a bounding box anyway *) + +fun add_bound (r0, (x, r, cost, sc)) = + if r0 < 0.0 + then + if r < 0.0 orelse cost <= 1 + then (cost, sc) + else + (1, SBound (sc, x, r)) + else + (* Cost of bounds *) + let + val c0 = r0 + r * float cost + (* Cost ofout bounds *) + val c1 = r0 * float cost + in + if c0 < c1 then + (1, SBound (sc, x, r)) + else + (cost, sc) + end + +fun union_bound (dsc1 as (x1, r1, cost1, sc1), + dsc2 as (x2, r2, cost2, sc2)) = + if r1 < 0.0 then + let + val (cost2', sc2') = add_bound(r1, dsc2) + in + (x1, r1, cost1, SUnion (sc1, sc2')) + end + else if r2 < 0.0 then + let + val (cost1', sc1') = add_bound (r2, dsc1) + in + (x2, r2, cost2, SUnion (sc1', sc2)) + end + else + let + val d = sqrt (square (sub(x2, x1))) + val r1' = sqrt r1 + val r2' = sqrt r2 + in + if d + r2' <= r1' then + let + val (cost2', sc2') = add_bound (r1, dsc2) + in + (x1, r1, cost1 + cost2', SUnion (sc1, sc2')) + end + else if d + r1' <= r2' then + let + val (cost1', sc1') = add_bound (r2, dsc1) + in + (x2, r2, cost1' + cost2, SUnion (sc1', sc2)) + end + else + let + val r' = (r1' + r2' + d) * 0.5 + val r = r' * r' + val x = add_scaled (x1, (r' - r1') / d, sub(x2, x1)) + val (cost1', sc1') = add_bound (r, dsc1) + val (cost2', sc2') = add_bound (r, dsc2) + in + (x, r, cost1' + cost2', SUnion (sc1', sc2')) + end + end + +fun union_radius (dsc1 as (x1, r1, cost1, sc1), + dsc2 as (x2, r2, cost2, sc2)) = + let + val d = sqrt (square (sub (x2, x1))) + val r1' = sqrt r1 + val r2' = sqrt r2 + in + if d + r2' <= r1' then r1 else + if d + r1' <= r2' then r2 else + let + val r' = (r1' + r2' + d) * 0.5 + in + r' * r' + end + end + +fun merge2 l = + case l of + sc1 :: sc2 :: r => union_bound (sc1, sc2) :: merge2 r + | _ => l + +fun merge_union l = + case l of + [] => raise(Fail "assert false") + | [sc1] => sc1 + | l => merge_union (merge2 l) + +fun opt_union l = + case l of + [] => l + | [_] => l + | [sc1, sc2] => [union_bound(sc1, sc2)] + | _ => + let + val c = Array.of_list l + val n = Array.length c + val m = Array2.array(n, n, infinity) + val _ = + for(0, n - 1, fn i => + for(0, n - 1, fn j => + if i <> j + then Array2.update(m, i, j, + union_radius + (Array.sub(c, i), Array.sub(c, j))) + else ())) + val remain = Array.init (n, fn i => i) + val _ = + forDown + (n - 1, 1, fn k => + let + val gain = ref infinity + val i0 = ref 0 + val j0 = ref 0 + val _ = + for(0, k, fn i => + for(0, k, fn j => + let + val i' = Array.sub(remain, i) + val j' = Array.sub(remain, j) + in + if Array2.sub(m, i', j') < !gain + then + (gain := Array2.sub(m, i', j') + ; i0 := i + ; j0 := j) + else () + end)) + val i = Array.sub(remain, !i0) + val j = Array.sub(remain, !j0) + in + Array.update(remain, !j0, Array.sub(remain, k)); + Array.update(c, i, + union_bound (Array.sub(c, i), Array.sub(c, j))); + for(0, k - 1, fn j0 => + let + val j = Array.sub(remain, j0) + in + if i <> j + then + ( + Array2.update + (m, i, j, + union_radius + (Array.sub(c, i), Array.sub(c, j))); + Array2.update + (m, j, i, + union_radius + (Array.sub(c, i), Array.sub(c, j)))) + else () + end) + end) + in [Array.sub(c, Array.sub(remain, 0))] + end + +fun optimize_rec sc = + case sc of + SObj (kind, _, _) => + (origin, ~1.0, object_cost kind, sc) + | SUnion _ => + let + val l = List.map optimize_rec (flatten_union sc) + val unbounded = List.filter (fn (_, r, _, _) => r < 0.0) l + val bounded = List.filter (fn (_, r, _, _) => r >= 0.0) l + in + merge_union (opt_union bounded @ unbounded) + end + | SInter (sc1, sc2) => + let + val (x1, r1, cost1, sc1) = optimize_rec sc1 + val (x2, r2, cost2, sc2) = optimize_rec sc2 + in + (* XXX We could have a tighter bound... *) + if r2 < 0.0 then + (x2, r2, cost2, SInter (sc1, sc2)) + else if r1 < 0.0 then + (x1, r1, cost1, SInter (sc2, sc1)) + else if r1 < r2 then + (x1, r1, cost1, SInter (sc1, sc2)) + else + (x2, r2, cost1, SInter (sc2, sc1)) + end + | SDiff (sc1, sc2) => + let + val (x1, r1, cost1, sc1) = optimize_rec sc1 + val dsc2 as (x2, r2, cost2, sc2) = optimize_rec sc2 + val (cost2', sc2') = add_bound (r1, dsc2) + in + (x1, r1, cost1, SDiff (sc1, sc2')) + end + | SBound (sc1, x, r) => + let + val (_, _, cost1, sc1) = optimize_rec sc1 + in + (x, r, cost1, sc1) + end + +fun optimize sc = #2 (add_bound (~1.0, optimize_rec sc)) + +(**** Rendering ****) + +(* operations for intervals *) +fun union (l1, l2) : (float * scene * float * scene) list = (* ES: checked *) + case (l1, l2) of + ([], _) => l2 + | (_, []) => l1 + | ((i1 as (t1, o1, t1', o1')) :: r1, + (i2 as (t2, o2, t2', o2')) :: r2) => + if t1' < t2 + then i1 :: union(r1, l2) + else if t2' < t1 + then i2 :: union(l1, r2) + else + if t1 < t2 then + if t1' < t2' then + union(r1, (t1, o1, t2', o2')::r2) + else + union((t1, o1, t1', o1')::r1, r2) + else + if t1' < t2' then + union(r1, ((t2, o2, t2', o2')::r2)) + else + union((t2, o2, t1', o1')::r1, r2) + +fun inter (l1, l2) : (float * scene * float * scene) list = (* ES: checked *) + case (l1, l2) of + ([], _) => [] + | (_, []) => [] + | ((i1 as (t1, o1, t1', o1')) :: r1, + (i2 as (t2, o2, t2', o2')) :: r2) => + if t1' <= t2 + then inter(r1, l2) + else if t2' <= t1 + then inter(l1, r2) + else + if t1 < t2 then + if t1' < t2' then + (t2, o2, t1', o1') :: inter(r1, l2) + else + i2 :: inter(l1, r2) + else + if t1' < t2' then + i1 :: inter(r1, l2) + else + (t1, o1, t2', o2') :: inter(l1, r2) + +fun diff (l1, l2) : (float * scene * float * scene) list = (* ES: checked *) + case (l1, l2) of + ([], _) => [] + | (_, []) => l1 + | ((i1 as (t1, o1, t1', o1')) :: r1, + (i2 as (t2, o2, t2', o2')) :: r2) => + if t1' <= t2 + then i1 :: diff(r1, l2) + else if t2' <= t1 + then diff(l1, r2) + else + if t1 < t2 then + if t1' < t2' then + (t1, o1, t2, o2) :: diff(r1, l2) + else + (t1, o1, t2, o2) :: diff((t2', o2', t1', o1') :: r1, r2) + else + if t1' < t2' then + diff(r1, l2) + else + diff((t2', o2', t1', o1') :: r1, r2) + +(* intersection of ray and object *) +fun plane (orig, dir, scene, eq) : (float * scene * float * scene) list = + (* XXX Need to be checked *) + let + val porig = prod (eq, orig) + val pdir = prod (eq, dir) + val t = ~ porig / pdir + in + if porig < 0.0 then + if t > 0.0 then + [(0.0, scene, t, scene)] + else + [(0.0, scene, infinity, scene)] + else + if t > 0.0 then + [(t, scene, infinity, scene)] + else + [] + end + +fun band (obj, x, v, i) : (float * scene * float * scene) list = (* ES: checked *) + let + val t1 = ~ (i x) / (i v) + val t2 = (1.0 - (i x)) / (i v) + val t2' = if t1 >= t2 then t1 else t2 + in + if t2' < 0.0 then + [] + else + let val t1' = if t1 <= t2 then t1 else t2 + in + if t1' < 0.0 then + [(0.0, obj, t2', obj)] + else + [(t1', obj, t2', obj)] + end + end + +fun cube (orig, dir, scene, m): (float * scene * float * scene) list = + (* ES: checked *) + let + val x = vmul (m, orig) + val v = vmul (m, dir) + in + case band (scene, x, v, #1) of + [] => [] + | l0 => + case inter (l0, band (scene, x, v, #2)) of + [] => [] + | l1 => inter (l1, band (scene, x, v, #3)) + end + +fun sphere (orig, dir, scene, x, r2): (float * scene * float * scene) list = + let + val v = sub (x, orig) + (* Square of the distance between the origin and the center of the sphere *) + val v2 = square v + val dir2 = square dir + val p = prod (v, dir) + (* Square of the distance between the ray and the center *) + val d2 = v2 - p * p / dir2 + val delta = r2 - d2 + in if delta <= 0.0 + then [] + else + let + val sq = sqrt (delta / dir2) + val t1 = p / dir2 - sq + val t2 = p / dir2 + sq + in + if t2 < 0.0 + then [] + else + [(max_float (0.0, t1), scene, t2, scene)] + end + end + +fun ellipsoid (orig, dir, scene, m): (float * scene * float * scene) list = + (* ES: checked *) + let + val x = vmul (m, orig) + val v = vmul (m, dir) + val x2 = square x + val v2 = square v + val xv = prod (x, v) + val delta = xv * xv - v2 * (x2 - 2.0) + in + if delta <= 0.0 then + [] + else + let + val sq = sqrt delta + val t1 = (~ xv - sq) / v2 + val t2 = (~ xv + sq) / v2 + in if t2 < 0.0 then + [] + else + [(max_float (0.0, t1), scene, t2, scene)] + end + end + +fun cylinder (orig, dir, scene, m): (float * scene * float * scene) list = + let + val x = vmul (m, orig) + val v = vmul (m, dir) + val x2 = #1 x * #1 x + #3 x * #3 x - 1.0 + val v2 = #1 v * #1 v + #3 v * #3 v + val xv = #1 x * #1 v + #3 x * #3 v + val delta = xv * xv - v2 * x2 + in + if delta <= 0.0 then + [] + else + let + val sq = sqrt delta + val t1 = (~ xv - sq) / v2 + val t2 = (~ xv + sq) / v2 + in if t2 < 0.0 then + [] + else + inter + ([(max_float (0.0, t1), scene, t2, scene)], + band (scene, x, v, #2)) + end + end + +fun cone (orig, dir, scene, m): (float * scene * float * scene) list = + let + val x = vmul (m, orig) + val v = vmul (m, dir) + val x2 = #1 x * #1 x + #3 x * #3 x - #2 x * #2 x + val v2 = #1 v * #1 v + #3 v * #3 v - #2 v * #2 v + val xv = #1 x * #1 v + #3 x * #3 v - #2 x * #2 v + val delta = xv * xv - v2 * x2 + in + if delta <= 0.0 then + [] + else + let + val sq = sqrt delta + val t1 = (~ xv - sq) / v2 + val t2 = (~ xv + sq) / v2 + in + if t1 <= t2 then + if t2 < 0.0 then + [] + else + inter + ([(max_float(0.0, t1), scene, t2, scene)], + band (scene, x, v, #2)) + else + inter + (if t1 <= 0.0 then + [(0.0, scene, infinity, scene)] + else if t2 <= 0.0 then + [(t1, scene, infinity, scene)] + else + [(0.0, scene, t2, scene), (t1, scene, infinity, scene)], + band (scene, x, v, #2)) + end + end + +(* XXX Maybe we should check whether the sphere is completely behind us ? *) +fun intersect (orig, dir, x, r2) = + let + val (vx, vy, vz, vt) = sub (x, orig) + (* Square of the distance between the origin and the center of the sphere *) + val v2 = vx * vx + vy * vy + vz * vz + vt * vt + val (dx, dy, dz, dt) = dir + val dir2 = dx * dx + dy * dy + dz * dz + dt * dt + val p = vx * dx + vy * dy + vz * dz + vt * dt + (* Square of the distance between the ray and the center *) + val d2 = v2 - p * p / dir2 + in r2 > d2 + end + +fun find_all (orig, dir, scene) = + case scene of + SObj (SSphere (x, r2), _, m) => + sphere (orig, dir, scene, x, r2) + | SObj (SEllips, _, m) => + ellipsoid (orig, dir, scene, m) + | SObj (SCube _, _, m) => + cube (orig, dir, scene, m) + | SObj (SCylind _, _, m) => + cylinder (orig, dir, scene, m) + | SObj (SCone _, _, m) => + cone (orig, dir, scene, m) + | SObj (SPlane (eq, _), _, m) => + plane (orig, dir, scene, eq) + | SBound (sc, x, r2) => + if intersect (orig, dir, x, r2) + then find_all (orig, dir, sc) + else [] + | SUnion (sc1, sc2) => + union (find_all (orig, dir, sc1), find_all (orig, dir, sc2)) + | SInter (sc1, sc2) => + let val l1 = find_all (orig, dir, sc1) + in + case l1 of + [] => [] + | _ => inter(l1, find_all (orig, dir, sc2)) + end + | SDiff (sc1, sc2) => + let val l1 = find_all(orig, dir, sc1) + in + case l1 of + [] => [] + | _ => diff(l1, find_all(orig, dir, sc2)) + end + +fun filter_inter_list l = + case l of + (t, _, _, _)::r => + if t < epsilon + then filter_inter_list r + else l + | _ => l + +fun hit_from_inter bounded l0 = + let val l = filter_inter_list l0 + in + case l of + [] => false + | (t, _, _, _)::r => (not bounded orelse t <= 1.0) + end + +fun hit(orig, dir, scene, bounded) = + case scene of + SObj (kind, _, m) => + (case + (case kind of + SSphere (x, r2) => sphere (orig, dir, scene, x, r2) + | SEllips => ellipsoid (orig, dir, scene, m) + | SCube _ => cube (orig, dir, scene, m) + | SCylind _ => cylinder (orig, dir, scene, m) + | SCone _ => cone (orig, dir, scene, m) + | SPlane (eq, _) => plane (orig, dir, scene, eq)) of + [] => false + | [(t, _, _, _)] => + if bounded andalso t > 1.0 + then false + else if t < epsilon + then false + else true + | _ => true) + | SBound (sc, x, r2) => + intersect (orig, dir, x, r2) andalso hit (orig, dir, sc, bounded) + | SUnion (sc1, sc2) => + hit (orig, dir, sc1, bounded) orelse hit (orig, dir, sc2, bounded) + | SInter (sc1, sc2) => + let val l1 = find_all (orig, dir, sc1) + in + case l1 of + [] => false + | _ => hit_from_inter bounded (inter(l1, find_all (orig, dir, sc2))) + end + | SDiff (sc1, sc2) => + let + val l1 = find_all(orig, dir, sc1) + in + case l1 of + [] => false + | _ => hit_from_inter bounded (diff(l1, find_all(orig, dir, sc2))) + end + +fun visible (desc: desc, orig, dir, bounded) = + not (hit(orig, dir, #scene desc, bounded)) + +val black = (0.0, 0.0, 0.0) + +val apply : ((Program.v * Program.v list) -> Program.v list) ref = + ref (fn _ => raise(Fail "assert false")) +val inline_closure : (Program.v -> Program.v) ref = + ref (fn _ => raise(Fail "assert false")) + +(* Value between 0 and 1 from the sinus and cosinus *) +(* Actually, only the sign of the sinus is used *) +fun angle (si, co) = + let + val u = dacos co / 360.0 + in + if si > 0.0 then u else 1.0 - u + end + +(* XXX Check that 0 <= u,v <= 1 *) +fun texture_coord (kind, x: v) = (* section 3.6 *) (* ES: checked *) + let + fun ellipsOrSphere() = + let + val y = #2 x + val v = (y + 1.0) * 0.5 + in + if v < epsilon + then [VFloat v, VFloat 0.0, VInt 0] + else + let + val u = angle (#1 x, #3 x / sqrt (1.0 - y * y)) + in + [VFloat v, VFloat u, VInt 0] + end + end + in (* [v; u; face] *) + case kind of + SEllips => ellipsOrSphere() + | SSphere _ => ellipsOrSphere() + | SCube _ => + if abs_float (#3 x) < epsilon then + [VFloat (#2 x), VFloat (#1 x), VInt 0] + else if abs_float ((#3 x) - 1.0) < epsilon then + [VFloat (#2 x), VFloat (#1 x), VInt 1] + else if abs_float (#1 x) < epsilon then + [VFloat (#2 x), VFloat (#3 x), VInt 2] + else if abs_float ((#1 x) - 1.0) < epsilon then + [VFloat (#2 x), VFloat (#3 x), VInt 3] + else if abs_float ((#2 x) - 1.0) < epsilon then + [VFloat (#3 x), VFloat (#1 x), VInt 4] + else (* if abs_float (#2 x) < epsilon then *) + [VFloat (#3 x), VFloat (#1 x), VInt 5] + | SCylind _ => + if abs_float (#2 x) < epsilon then + [VFloat (((#3 x) + 1.0) * 0.5), VFloat (((#1 x) + 1.0) * 0.5), VInt 2] + else if abs_float ((#2 x) - 1.0) < epsilon then + [VFloat (((#3 x) + 1.0) * 0.5), VFloat (((#1 x) + 1.0) * 0.5), VInt 1] + else + let + val u = angle (#1 x, #3 x) + in + [VFloat (#2 x), VFloat u, VInt 0] + end + | SCone _ => + let val v = (#2 x) + in + if abs_float v < epsilon then + [VFloat v, VFloat 0.0, VInt 0] + else + if abs_float ((#2 x) - 1.0) < epsilon + then + [VFloat (((#3 x) + 1.0) * 0.5), + VFloat (((#1 x) + 1.0) * 0.5), + VInt 1] + else + let + val u = angle (#1 x, (#3 x) / v) + in + [VFloat v, VFloat u, VInt 0] + end + end + | SPlane _ => + [VFloat (#3 x), VFloat (#1 x), VInt 0] + end + +fun normal (kind, m, x', x) = + case kind of + SSphere (x0, _) => + normalize (sub (x, x0)) + | SEllips => + let val (n0, n1, n2, _) = vmul (transpose m, x') + in + normalize(n0, n1, n2, 0.0) + end + | SCylind n => + if abs_float (#2 x') < epsilon + orelse abs_float (#2 x') - 1.0 < epsilon then + n + else + (* XXX Could be optimized... *) + let + val (n0, n1, n2, _) = vmul (transpose m, (#1 x', 0.0, #3 x', 0.0)) + in + normalize(n0, n1, n2, 0.0) + end + | SCone n => + if abs_float (#2 x') - 1.0 < epsilon + then n + else + let + val (n0, n1, n2, _) = + vmul (transpose m, (#1 x', ~(#2 x'), #3 x', 0.0)) + in + normalize(n0, n1, n2, 0.0) + end + | SCube (nx, ny, nz) => + if abs_float (#3 x') < epsilon + orelse abs_float (#3 x') - 1.0 < epsilon + then nz + else if abs_float (#1 x') < epsilon + orelse abs_float (#1 x') - 1.0 < epsilon + then nx + else ny + | SPlane (_, n) => + n + +fun apply_surface_fun (f, v) = + case !apply(f, v) of + [VFloat n, VFloat ks, VFloat kd, + VPoint (VFloat cr, VFloat cg, VFloat cb)] => + (n, ks, kd, cr, cg, cb) + | _ => + failwith "A surface function returns some incorrect values" + +fun trace (desc: desc, depth: int, orig, dir) = + let + val dir = normalize dir + in + case filter_inter_list (find_all(orig, dir, #scene desc)) of + [] => black + | (t, ob, _, _) :: _ => trace_2(desc, depth, orig, dir, t, ob) + end + +and trace_2 (desc, depth: int, orig, dir, t, obj) = + let + val x = add_scaled (orig, t, dir) + in + case obj of + SObj (kind, f, m) => + let + val x' = vmul (m, x) + val (n, ks, kd, cr, cg, cb) = + (case !f of + Unopt g => + (* First we check whether the function would fail *) + let + val res = apply_surface_fun(g, texture_coord(kind, x')) + fun stuck() = f := Opt (!inline_closure g) + in + (* Then, we check whether it is a constant function *) + ((ignore (apply_surface_fun(g, + [VInt 0, VInt 0, VFloat 0.0])) + ; f := Cst res) + handle Stuck_computation _ => stuck() + | Stuck_computation' => stuck()) + ; res + end + | Opt g => + apply_surface_fun (g, texture_coord (kind, x')) + | Cst res => + res) + val nm = normal (kind, m, x', x) + val p = prod (dir, nm) + val nm = if p > 0.0 then neg nm else nm + val p = ~(abs_float p) + (* Ambient composant *) + val (ar, ag, ab) = #amb desc + val r = ref (kd * ar) + val g = ref (kd * ag) + val b = ref (kd * ab) + (* Lights *) + val lights = #lights desc + val _ = + for(0, Array.length lights - 1, fn i => + case (Array.sub(lights, i)) of + Light (ldir, (lr, lg, lb)) => + let + val p' = prod (ldir, nm) + in + if p' > 0.0 andalso visible (desc, x, ldir, false) + then + let + val int = + if ks > epsilon then + kd * p' + + ks * prod (normalize + (sub (ldir, dir)), + nm) ** n + else + kd * p' + in + r := !r + int * lr; + g := !g + int * lg; + b := !b + int * lb + end + else () + end + | PtLight (src, (lr, lg, lb)) => + let + val ldir = sub (src, x) + val ldir' = normalize ldir + val p' = prod (ldir', nm) + in + if p' > 0.0 andalso visible(desc, x, ldir, true) + then + let + val int = + if ks > epsilon + then + kd * p' + + ks * prod (normalize (sub (ldir', dir)), + nm) ** n + else + kd * p' + val int = 100.0 * int / (99.0 + square ldir) + in + r := !r + int * lr; + g := !g + int * lg; + b := !b + int * lb + end + else () + end + | StLight (src, maindir, (lr, lg, lb), cutoff, exp) => + let + val ldir = sub (src, x) + val ldir' = normalize ldir + val p' = prod (ldir', nm) + val p'' = prod (ldir', maindir) + in + if p' > 0.0 andalso p'' > cutoff + andalso visible(desc, x, ldir, true) + then + let + val int = + if ks > epsilon + then + kd * p' + + ks * prod (normalize (sub(ldir', dir)), + nm) ** n + else + kd * p' + val int = + 100.0 * int / (99.0 + square ldir) * + (p'' ** exp) + in + r := !r + int * lr; + g := !g + int * lg; + b := !b + int * lb + end + else () + end) + val _ = + (* Reflexion *) + if ks > epsilon andalso depth > 0 + then + let + val dir' = add_scaled (dir, ~2.0 * p, nm) + val (r', g', b') = trace(desc, depth - 1, x, dir') + in + r := !r + ks * r'; + g := !g + ks * g'; + b := !b + ks * b' + end + else () + in (!r * cr, !g * cg, !b * cb) + end + | _ => raise(Fail "assert false") + end + +fun conv c : int = + let + val i = truncate (c * 256.0) + in + if i < 0 then 0 else + if i >= 256 then 255 else + i + end + +fun f (amb, lights, obj, depth: int, fov, wid, ht, file) = + let + val scene = intern_obj(Matrix.identity, Matrix.identity, 1.0, true, obj) + val scene = optimize scene + val img = Ppm.init (wid, ht) + val orig = ( 0.0, 0.0, ~1.0, 1.0 ) + val width = 2.0 * dtan (0.5 * fov) + val delta = width / float wid + val x0 = ~ width / 2.0 + val y0 = delta * float ht / 2.0 + val desc = { amb = amb, lights = intern_lights lights, scene = scene } + in + for(0, ht - 1, fn j => + for(0, wid - 1, fn i => + let + val dir = + (x0 + (float i + 0.5) * delta, + y0 - (float j + 0.5) * delta, + 1.0, + 0.0) + val (r, g, b) = trace(desc, depth, orig, dir) + in + Ppm.setp (img, i, j, conv r, conv g, conv b) + end)) + ; Ppm.dump (file, img) + end + +end +signature EVAL = + sig + val f : Program.t list -> unit + end +structure Eval: EVAL = +struct + +open Caml +open Program + +val rtd = 180.0 / acos (~1.0) +val dtr = acos (~1.0) / 180.0 +fun deg x = rtd * x +fun rad x = dtr * x +val zero = VFloat 0.0 +val one = VFloat 1.0 + +fun lookup (env, s) : int = + case env of + [] => failwith ("Unbound variable \"" ^ s ^ "\"") + | s' :: env' => + if s = s' + then 0 + else 1 + (lookup(env', s)) + +(* XXX embed values *) +fun conv (absenv, p) = + case p of + [] => [] + | Float x :: Float y :: Float z :: Prim Point :: r => + Val' (VPoint (VFloat x, VFloat y, VFloat z)) :: conv(absenv, r) + | t :: r => + (case t of + Fun p' => Fun' (conv(absenv, p')) :: conv(absenv, r) + | Arr p' => Arr' (conv(absenv, p')) :: conv(absenv, r) + | Ident s => Ident' (lookup(absenv, s)) :: conv(absenv, r) + | Binder s => Binder' :: conv (s :: absenv, r) + | Int i => Val' (VInt i) :: conv(absenv, r) + | Float f => Val' (VFloat f) :: conv(absenv, r) + | Bool b => Val' (VBool b) :: conv(absenv, r) + | String s => Val' (VStr s) :: conv(absenv, r) + | Prim k => Prim' k :: conv(absenv, r)) + +fun inline (offset, env, p) = + case p of + [] => [] + | t :: r => + let + fun normal() = t :: inline(offset, env, r) + in case t of + Fun' p' => Fun' (inline(offset, env, p')) :: inline(offset, env, r) + | Arr' p' => Arr' (inline(offset, env, p')) :: inline(offset, env, r) + | Ident' i => + if i >= offset + then Val' (List.nth (env, i - offset)) :: inline(offset, env, r) + else normal() + | Binder' => Binder' :: inline (1 + offset, env, r) + | Prim' _ => normal() + | Val' _ => normal() + end + +val inline_closure = + fn (VClos (env, p)) => VClos ([], inline(0, env, p)) + | _ => failwith "a surface function was actually not a function" + +val _ = Render.inline_closure := inline_closure + +fun eval (env, st, p) = + case (st, p) of +(* inlined value *) + (_, Val' v :: r) => eval(env, (v :: st), r) +(* Rule 1 *) +(* Rule 2 *) + | (v::st', Binder' :: r) => eval((v :: env), st', r) +(* Rule 3 *) + | (_, Ident' i :: r) => + let val v = List.nth(env, i) + in eval(env, (v :: st), r) + end +(* Rule 4 *) + | (_, Fun' f :: r) => eval(env, (VClos (env, f) :: st), r) +(* Rule 5 *) + | (VClos (env', f) :: st', Prim' Apply :: r) => + eval(env, eval(env', st', f), r) +(* Rule 6 *) + | (_, Arr' a :: r) => + eval(env, (VArr (Array.of_list (List.rev (eval(env, [], a))))) :: st, r) +(* Rules 7 and 8 *) + | (VClos _ :: VClos (env', iftrue) :: VBool true :: st', Prim' If :: r) => + eval(env, eval(env', st', iftrue), r) + | (VClos (env', iffalse) :: VClos _ :: VBool false :: st', Prim' If :: r) => + eval(env, eval(env', st', iffalse), r) +(* Operations on numbers *) + | (VInt n2 :: VInt n1 :: st', Prim' Addi :: r) => + eval(env, (VInt (n1 + n2) :: st'), r) + | (VFloat f2 :: VFloat f1 :: st', Prim' Addf :: r) => + eval(env, (VFloat (f1 + f2) :: st'), r) + | (VFloat f :: st', Prim' Acos :: r) => + eval(env, (VFloat (deg (acos f)) :: st'), r) + | (VFloat f :: st', Prim' Asin :: r) => + eval(env, (VFloat (deg (asin f)) :: st'), r) + | ((vf as VFloat f):: st', Prim' Clampf :: r) => + let val f' = if f < 0.0 then zero else if f > 1.0 then one else vf + in eval(env, (f' :: st'), r) + end + | (VFloat f :: st', Prim' Cos :: r) => + eval(env, (VFloat (cos (rad f)) :: st'), r) + | (VInt n2 :: VInt n1 :: st', Prim' Divi :: r) => + eval(env, (VInt (n1 div n2) :: st'), r) + | (VFloat f2 :: VFloat f1 :: st', Prim' Divf :: r) => + eval(env, (VFloat (f1 / f2) :: st'), r) + | (VInt n2 :: VInt n1 :: st', Prim' Eqi :: r) => + eval(env, (VBool (n1 = n2) :: st'), r) + | (VFloat f2 :: VFloat f1 :: st', Prim' Eqf :: r) => + eval(env, (VBool (Real.==(f1, f2)) :: st'), r) + | (VFloat f :: st', Prim' Floor :: r) => + eval(env, (VInt (Real.floor f) :: st'), r) + | (VFloat f :: st', Prim' Frac :: r) => + eval(env, (VFloat (Real.realMod f) :: st'), r) + | (VInt n2 :: VInt n1 :: st', Prim' Lessi :: r) => + eval(env, (VBool (n1 < n2) :: st'), r) + | (VFloat f2 :: VFloat f1 :: st', Prim' Lessf :: r) => + eval(env, (VBool (f1 < f2) :: st'), r) + | (VInt n2 :: VInt n1 :: st', Prim' Modi :: r) => + eval(env, (VInt (n1 mod n2) :: st'), r) + | (VInt n2 :: VInt n1 :: st', Prim' Muli :: r) => + eval(env, (VInt (n1 * n2) :: st'), r) + | (VFloat f2 :: VFloat f1 :: st', Prim' Mulf :: r) => + eval(env, (VFloat (f1 * f2) :: st'), r) + | (VInt n :: st', Prim' Negi :: r) => eval(env, (VInt (~ n) :: st'), r) + | (VFloat f :: st', Prim' Negf :: r) => eval(env, (VFloat (~ f) :: st'), r) + | (VInt n :: st', Prim' Real :: r) => eval(env, (VFloat (float n) :: st'), r) + | (VFloat f :: st', Prim' Sin :: r) => eval(env, (VFloat (sin (rad f)) :: st'), r) + | (VFloat f :: st', Prim' Sqrt :: r) => eval(env, (VFloat (sqrt f) :: st'), r) + | (VInt n2 :: VInt n1 :: st', Prim' Subi :: r) => eval(env, (VInt (n1 - n2) :: st'), r) + | (VFloat f2 :: VFloat f1 :: st', Prim' Subf :: r) => + eval(env, (VFloat (f1 - f2) :: st'), r) +(* Operations on points *) + | (VPoint (x, _, _) :: st', Prim' Getx :: r ) => eval(env, (x :: st'), r) + | (VPoint (_, y, _) :: st', Prim' Gety :: r ) => eval(env, (y :: st'), r) + | (VPoint (_, _, z) :: st', Prim' Getz :: r ) => eval(env, (z :: st'), r) + | ((z as VFloat _) :: (y as VFloat _) :: (x as VFloat _) :: st', + Prim' Point :: r) => + eval(env, (VPoint (x, y, z) :: st'), r) + | (VInt i :: VArr a :: st', Prim' Get :: r) => + (* if compiled of "-unsafe" *) + if i < 0 orelse i >= Array.length a + then failwith "illegal access beyond array boundary" + else eval(env, (Array.sub(a, i) :: st'), r) + | (VArr a :: st', Prim' Length :: r) => + eval(env, (VInt (Array.length a) :: st'), r) +(* Geometric primitives *) + | ((f as VClos _) :: st', Prim' Sphere :: r ) => + eval(env, (VObj (OObj (OSphere, ref (Unopt f))) :: st'), r) + | ((f as VClos _) :: st', Prim' Cube :: r ) => + eval(env, (VObj (OObj (OCube, ref (Unopt f))) :: st'), r) + | ((f as VClos _) :: st', Prim' Cylinder :: r) => + eval(env, (VObj (OObj (OCylind, ref (Unopt f))) :: st'), r) + | ((f as VClos _) :: st', Prim' Cone :: r ) => + eval(env, (VObj (OObj (OCone, ref (Unopt f))) :: st'), r) + | ((f as VClos _) :: st', Prim' Plane :: r ) => + eval(env, (VObj (OObj (OPlane, ref (Unopt f))) :: st'), r) +(* Transformations *) + | (VFloat z :: VFloat y :: VFloat x :: VObj ob :: st', Prim' Translate :: r) => + eval(env, + (VObj (OTransform (ob, + Matrix.translate (x, y, z), + Matrix.translate (~ x, ~ y, ~ z), + 1.0, true)) :: st'), + r) + | (VFloat z :: VFloat y :: VFloat x :: VObj ob :: st', Prim' Scale :: r) => + eval( env, + (VObj (OTransform (ob, + Matrix.scale (x, y, z), + Matrix.unscale (x, y, z), + Real.max (abs_float x, + (Real.max (abs_float y, abs_float z))), + false)) :: st'), + r) + | (VFloat s :: VObj ob :: st', Prim' Uscale :: r) => + eval(env, + (VObj (OTransform (ob, Matrix.uscale s, Matrix.unuscale s, + abs_float s, true)) :: st'), + r) + | (VFloat t :: VObj ob :: st', Prim' Rotatex :: r) => + eval(env, + (VObj (OTransform (ob, Matrix.rotatex t, Matrix.rotatex (~ t), + 1.0, true)) :: st'), + r) + | (VFloat t :: VObj ob :: st', Prim' Rotatey :: r) => + eval(env, + (VObj (OTransform (ob, Matrix.rotatey t, Matrix.rotatey (~ t), + 1.0, true)) :: st'), + r) + | (VFloat t :: VObj ob :: st', Prim' Rotatez :: r) => + eval(env, + (VObj (OTransform (ob, Matrix.rotatez t, Matrix.rotatez (~ t), + 1.0, true)) :: st'), + r) +(* Lights *) + | ((color as VPoint _) :: (dir as VPoint _) :: st', Prim' Light :: r) => + eval(env, (VLight (dir, color) :: st'), r) + | ((color as VPoint _) :: (pos as VPoint _) :: st', Prim' Pointlight :: r) => + eval(env, (VPtLight (pos, color) :: st'), r) + | ((expon as VFloat _) :: (cutoff as VFloat _) :: (color as VPoint _) :: + (at as VPoint _) :: (pos as VPoint _) :: st', Prim' Spotlight :: r) => + eval(env, (VStLight (pos, at, color, cutoff, expon) :: st'), r) +(* Constructive geometry *) + | ((VObj o2) :: (VObj o1) :: st', Prim' Union :: r) => + eval(env, (VObj (OUnion (o1, o2)) :: st'), r) + | ((VObj o2) :: (VObj o1) :: st', Prim' Intersect :: r) => + eval(env, (VObj (OInter (o1, o2)) :: st'), r) + | ((VObj o2) :: (VObj o1) :: st', Prim' Difference :: r) => + eval(env, (VObj (ODiff (o1, o2)) :: st'), r) +(* Rendering *) + | (VStr file :: VInt ht :: VInt wid :: VFloat fov :: VInt depth :: + VObj obj :: VArr lights :: VPoint (VFloat ax, VFloat ay, VFloat az) :: + st', Prim' Render :: r) => +(* +amb the intensity of ambient light (a point). +lights is an array of lights used to illuminate the scene. +obj is the scene to render. +depth is an integer limit on the recursive depth of the ray tracing. +fov is the horizontal field of view in degrees (a real number). +wid is the width of the rendered image in pixels (an integer). +ht is the height of the rendered image in pixels (an integer). +file is a string specifying output file for the rendered image. +*) + (Render.f ((ax, ay, az), lights, obj, depth, fov, wid, ht, file) + ; eval(env, st', r)) +(* Termination *) + | (_, []) => st +(* Failure *) + | _ => + raise (Stuck_computation (env, st, p)) + +fun apply (f, st) = + case f of + VClos (env, p) => eval(env, st, p) + | _ => raise Fail "assert false" + +val _ = Render.apply := apply + +fun f p = + let + val st = eval([], [], (conv([], p))) + in + case st of + [] => () + | _ => failwith "error" + end handle Stuck_computation (env, st, p) => failwith "stuck" + +end +structure Main = + struct + fun doit () = + Eval.f (Program.read (TextIO.openIn "DATA/chess.gml")) + handle _ => () + + val doit = + fn n => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop n + end + end diff --git a/benchmark/tests/simple.sml b/benchmark/tests/simple.sml new file mode 100644 index 0000000..4274744 --- /dev/null +++ b/benchmark/tests/simple.sml @@ -0,0 +1,931 @@ +(* From the SML/NJ benchmark suite. *) +fun print _ = () +structure Control = + struct + val trace = ref false + end; +structure Array2 : sig + + type 'a array2 + exception Subscript + val array: (int*int) * 'a -> 'a array2 + val sub : 'a array2 * (int*int) -> 'a + val update : 'a array2 * (int*int) * 'a -> unit + val length : 'a array2 -> (int*int) + + end = struct + + type 'a array2 = {size : (int*int), value : 'a Array.array} + exception Subscript = Subscript + fun index ((i1:int,i2:int),(s1,s2)) = + if i1>=0 andalso i1=0 andalso i2 unit + val testit : TextIO.outstream -> unit + end; +(* Simple + * error: grid_max < 5 + *) +functor Simple(val grid_max: int val step_count: int) : BMARK = + struct + +fun fold f [] = (fn b => b) + | fold f (a::r) = (fn b => let fun f2(e,[]) = f(e,b) + | f2(e,a::r) = f(e,f2(a,r)) + in f2(a,r) + end) + + +fun min (x:real,y:real) = if x0 andalso endd>=start then + let fun f x = if x > endd then () else (body x; f(x+delta)) + in f start + end + else if endd<=start then + let fun f x = if x < endd then () else (body x; f(x+delta)) + in f start + end + else () +fun from(n,m) = if n>m then [] else n::from(n+1,m) +fun flatten [] = [] + | flatten (x::xs) = x @ flatten xs +fun pow(x:real,y:int) = if y = 0 then 1.0 else x * pow(x,y-1) +fun array2(bounds as ((l1,u1),(l2,u2)),v) = + (Array2.array((u1-l1+1, u2-l2+1),v), bounds) +fun sub2((A,((lb1:int,ub1:int),(lb2:int,ub2:int))),(k,l)) = + Array2.sub(A, (k-lb1, l-lb2)) +fun update2((A,((lb1,_),(lb2,_))),(k,l), v) = Array2.update(A,(k-lb1,l-lb2),v) +fun bounds2(_,b) = b +fun printarray2 (A as (M:real Array2.array2,((l1,u1),(l2,u2)))) = + for {from=l1,step=1,to=u1} (fn i => + (print "["; + for {from=l2,step=1,to=u2-1} (fn j => + print (Real.toString (sub2(A,(i,j))) ^ ", ")); + print (Real.toString (sub2(A,(i,u2))) ^ "]\n"))) +fun array1((l,u),v) = (Array.array(u-l+1,v),(l,u)) +fun sub1((A,(l:int,u:int)),i:int) = Array.sub(A,i-l) +fun update1((A,(l,_)),i,v) = Array.update(A,i-l,v) +fun bounds1(_,b) = b + +(* + * Specification of the state variable computation + *) +val grid_size = ((2,grid_max), (2,grid_max)) + +fun north (k,l) = (k-1,l) +fun south (k,l) = (k+1,l) + +fun east (k,l) = (k,l+1) +fun west (k,l) = (k,l-1) + +val northeast = north o east +val southeast = south o east +val northwest = north o west +val southwest = south o west + +fun farnorth x = (north o north ) x +fun farsouth x = (south o south) x +fun fareast x = (east o east) x +fun farwest x = (west o west) x + +fun zone_A(k,l) = (k,l) +fun zone_B(k,l) = (k+1,l) + +fun zone_C(k,l) = (k+1,l+1) +fun zone_D(k,l) = (k,l+1) + +val zone_corner_northeast = north +val zone_corner_northwest = northwest +fun zone_corner_southeast zone = zone +val zone_corner_southwest = west + +val ((kmin,kmax),(lmin,lmax)) = grid_size +val dimension_all_nodes = ((kmin-1,kmax+1),(lmin-1,lmax+1)) +fun for_all_nodes f = + for {from=kmin-1, step=1, to=kmax+1} (fn k => + for {from=lmin-1, step=1, to=lmax+1} (fn l => f k l)) + +val dimension_interior_nodes = ((kmin,kmax),(lmin,lmax)) +fun for_interior_nodes f = + for {from=kmin, step=1, to=kmax} (fn k => + for {from=lmin, step=1, to=lmax} (fn l => f k l)) + +val dimension_all_zones = ((kmin,kmax+1),(lmin,lmax+1)) +fun for_all_zones f = + for {from=kmin, step=1, to=kmax+1} (fn k => + for {from=lmin, step=1, to=lmax+1} (fn l => f (k,l))) + +val dimension_interior_zones = ((kmin+1,kmax),(lmin+1,lmax)) +fun for_interior_zones f = + for {from=kmin+1, step=1, to=kmax} (fn k => + for {from=lmin+1, step=1, to=lmax} (fn l => f (k,l))) + +fun map_interior_nodes f = + flatten(map (fn k => (map (fn l => f (k,l)) + (from(lmin,lmax)))) + (from(kmin,kmax))) +fun map_interior_zones f = + flatten(map (fn k => (map (fn l => f (k,l)) + (from(lmin+1,lmax)))) + (from(kmin+1,kmax))) + +fun for_north_ward_interior_zones f = + for {from=kmax, step= ~1, to=kmin+1} (fn k => + for {from=lmin+1, step=1, to=lmax} (fn l => f (k,l))) +fun for_west_ward_interior_zones f = + for {from=kmin+1, step=1, to=kmax} (fn k => + for {from=lmax, step= ~1, to=lmin+1} (fn l => f (k,l))) + + +fun for_north_zones f = for {from=lmin, step=1, to=lmax+1} (fn l => f (kmin,l)) +fun for_south_zones f = for {from=lmin+1, step=1, to=lmax} (fn l => f (kmax+1,l)) +fun for_east_zones f = for {from=kmin+1, step=1, to=kmax+1}(fn k => f (k,lmax+1)) +fun for_west_zones f = for {from=kmin+1, step=1, to=kmax+1}(fn k => f (k,lmin)) + +fun reflect dir node A = sub2(A, dir node) +val reflect_north = fn x => reflect north x +val reflect_south = fn x => reflect south x +val reflect_east = fn x => reflect east x +val reflect_west = fn x => reflect west x + +fun for_north_nodes f = + for {from=lmin, step=1, to=lmax-1} (fn l => f (kmin-1,l)) +fun for_south_nodes f = + for {from=lmin, step=1, to=lmax-1} (fn l => f (kmax+1,l)) +fun for_east_nodes f = + for {from=kmin, step=1, to=kmax-1} (fn k => f (k,lmax+1)) +fun for_west_nodes f = + for {from=kmin, step=1, to=kmax-1} (fn k => f (k,lmin-1)) + +val north_east_corner = (kmin-1,lmax+1) +val north_west_corner = (kmin-1,lmin-1) +val south_east_corner = (kmax+1,lmax+1) +val south_west_corner = (kmax+1,lmin-1) + +val west_of_north_east = (kmin-1, lmax) +val west_of_south_east = (kmax+1, lmax) +val north_of_south_east = (kmax, lmax+1) +val north_of_south_west = (kmax, lmin-1) + + + +(* + * Initialization of parameters + *) +val constant_heat_source = 0.0 +val deltat_maximum = 0.01 +val specific_heat = 0.1 +val p_coeffs = let val M = array2(((0,2),(0,2)), 0.0) + in update2(M, (1,1), 0.06698); M + end +val e_coeffs = let val M = array2(((0,2),(0,2)), 0.0) + in update2(M, (0,1), 0.1); M + end +val p_poly = array2(((1,4),(1,5)),p_coeffs) + +val e_poly = array2(((1,4),(1,5)), e_coeffs) + +val rho_table = let val V = array1((1,3), 0.0) + in update1(V,2,1.0); + update1(V,3,100.0); + V + end +val theta_table = let val V = array1((1,4), 0.0) + in update1(V,2,3.0); + update1(V,3,300.0); + update1(V,4,3000.0); + V + end + +val extract_energy_tables_from_constants = (e_poly,2,rho_table,theta_table) +val extract_pressure_tables_from_constants = (p_poly,2,rho_table,theta_table) + +val nbc = let val M = array2(dimension_all_zones, 1) + in for {from=lmin+1,step=1,to=lmax} (fn j => update2(M,(kmax+1, j),2)); + update2(M,(kmin,lmin),4); + update2(M,(kmin,lmax+1),4); + update2(M,(kmax+1,lmin),4); + update2(M,(kmax+1,lmax+1),4); + M + end +val pbb = let val A = array1((1,4), 0.0) + in update1(A,2,6.0); A + end +val pb = let val A = array1((1,4), 1.0) + in update1(A,2,0.0); update1(A,3,0.0); A + end +val qb = pb + +val all_zero_nodes = array2(dimension_all_nodes, 0.0) + +val all_zero_zones = array2(dimension_all_zones, 0.0) + + +(* + * Positional Coordinates. (page 9-10) + *) + +fun make_position_matrix interior_function = + let val r' = array2(dimension_all_nodes, 0.0) + val z' = array2(dimension_all_nodes, 0.0) + fun boundary_position (rx,zx,ry,zy,ra,za) = + let val (rax, zax) = (ra - rx, za - zx) + val (ryx, zyx) = (ry - rx, zy - zx) + val omega = 2.0*(rax*ryx + zax*zyx)/(ryx*ryx + zyx*zyx) + val rb = rx - rax + omega*ryx + val zb = zx - zax + omega*zyx + in (rb, zb) + end + + fun reflect_node (x_dir, y_dir, a_dir, node) = + let val rx = reflect x_dir node r' + val zx = reflect x_dir node z' + val ry = reflect y_dir node r' + val zy = reflect y_dir node z' + val ra = reflect a_dir node r' + val za = reflect a_dir node z' + in boundary_position (rx, zx, ry, zy, ra, za) + end + fun u2 (rv,zv) n = (update2(r',n,rv); update2(z',n,zv)) + in + for_interior_nodes (fn k => fn l => u2 (interior_function (k,l)) (k,l)); + for_north_nodes(fn n => u2 (reflect_node(south,southeast,farsouth,n)) n); + for_south_nodes (fn n => u2(reflect_node(north,northeast,farnorth,n)) n); + for_east_nodes (fn n => u2(reflect_node(west, southwest, farwest, n)) n); + for_west_nodes (fn n => u2(reflect_node(east, southeast, fareast, n)) n); + u2 (reflect_node(south, southwest, farsouth, west_of_north_east)) + west_of_north_east; + u2 (reflect_node(north, northwest, farnorth, west_of_south_east)) + west_of_south_east; + u2 (reflect_node(west, northwest, farwest, north_of_south_east)) + north_of_south_east; + u2 (reflect_node(east, northeast, fareast, north_of_south_west)) + north_of_south_west; + u2 (reflect_node(southwest, west, farwest, north_east_corner)) + north_east_corner; + u2 (reflect_node(northwest, west, farwest, south_east_corner)) + south_east_corner; + u2 (reflect_node(southeast, south, farsouth, north_west_corner)) + north_west_corner; + u2 (reflect_node(northeast, east, fareast, south_west_corner)) + south_west_corner; + (r',z') + end + + + +(* + * Physical Properties of a Zone (page 10) + *) +fun zone_area_vol ((r,z), zone) = + let val (r1,z1)=(sub2(r,zone_corner_southwest zone), + sub2(z,zone_corner_southwest zone)) + val (r2,z2)=(sub2(r,zone_corner_southeast zone), + sub2(z,zone_corner_southeast zone)) + val (r3,z3)=(sub2(r,zone_corner_northeast zone), + sub2(z,zone_corner_northeast zone)) + val (r4,z4)=(sub2(r,zone_corner_northwest zone), + sub2(z,zone_corner_northwest zone)) + val area1 = (r2-r1)*(z3-z1) - (r3-r2)*(z3-z2) + val radius1 = 0.3333 *(r1+r2+r3) + val volume1 = area1 * radius1 + val area2 = (r3-r1)*(z4-z3) - (r4-r3)*(z3-z1) + val radius2 = 0.3333 *(r1+r3+r4) + val volume2 = area2 * radius2 + in (area1+area2, volume1+volume2) + end + +(* + * Velocity (page 8) + *) +fun make_velocity((u,w),(r,z),p,q,alpha,rho,delta_t) = + let fun line_integral (p,z,node) : real = + sub2(p,zone_A node)*(sub2(z,west node) - sub2(z,north node)) + + sub2(p,zone_B node)*(sub2(z,south node) - sub2(z,west node)) + + sub2(p,zone_C node)*(sub2(z,east node) - sub2(z,south node)) + + sub2(p,zone_D node)*(sub2(z,north node) - sub2(z,east node)) + fun regional_mass node = + 0.5 * (sub2(rho, zone_A node)*sub2(alpha,zone_A node) + + sub2(rho, zone_B node)*sub2(alpha,zone_B node) + + sub2(rho, zone_C node)*sub2(alpha,zone_C node) + + sub2(rho, zone_D node)*sub2(alpha,zone_D node)) + fun velocity node = + let val d = regional_mass node + val n1 = ~(line_integral(p,z,node)) - line_integral(q,z,node) + val n2 = line_integral(p,r,node) + line_integral(q,r,node) + val u_dot = n1/d + val w_dot = n2/d + in (sub2(u,node)+delta_t*u_dot, sub2(w,node)+delta_t*w_dot) + end + val U = array2(dimension_interior_nodes,0.0) + val W = array2(dimension_interior_nodes,0.0) + in for_interior_nodes (fn k => fn l => let val (uv,wv) = velocity (k,l) + in update2(U,(k,l),uv); + update2(W,(k,l),wv) + end); + (U,W) + end + + + +fun make_position ((r,z),delta_t,(u',w')) = + let fun interior_position node = + (sub2(r,node) + delta_t*sub2(u',node), + sub2(z,node) + delta_t*sub2(w',node)) + in make_position_matrix interior_position + end + + +fun make_area_density_volume(rho, s, x') = + let val alpha' = array2(dimension_all_zones, 0.0) + val s' = array2(dimension_all_zones, 0.0) + val rho' = array2(dimension_all_zones, 0.0) + fun interior_area zone = + let val (area, vol) = zone_area_vol (x', zone) + val density = sub2(rho,zone)*sub2(s,zone) / vol + in (area,vol,density) + end + fun reflect_area_vol_density reflect_function = + (reflect_function alpha',reflect_function s',reflect_function rho') + fun update_asr (zone,(a,s,r)) = (update2(alpha',zone,a); + update2(s',zone,s); + update2(rho',zone,r)) + fun r_area_vol_den (reflect_dir,zone) = + let val asr = reflect_area_vol_density (reflect_dir zone) + in update_asr(zone, asr) + end + in + for_interior_zones (fn zone => update_asr(zone, interior_area zone)); + for_south_zones (fn zone => r_area_vol_den(reflect_north, zone)); + for_east_zones (fn zone => r_area_vol_den(reflect_west, zone)); + for_west_zones (fn zone => r_area_vol_den(reflect_east, zone)); + for_north_zones (fn zone => r_area_vol_den(reflect_south, zone)); + (alpha', rho', s') + end + + +(* + * Artifical Viscosity (page 11) + *) +fun make_viscosity(p,(u',w'),(r',z'), alpha',rho') = + let fun interior_viscosity zone = + let fun upper_del f = + 0.5 * ((sub2(f,zone_corner_southeast zone) - + sub2(f,zone_corner_northeast zone)) + + (sub2(f,zone_corner_southwest zone) - + sub2(f,zone_corner_northwest zone))) + fun lower_del f = + 0.5 * ((sub2(f,zone_corner_southeast zone) - + sub2(f,zone_corner_southwest zone)) + + (sub2(f,zone_corner_northeast zone) - + sub2(f,zone_corner_northwest zone))) + val xi = pow(upper_del r',2) + pow(upper_del z',2) + val eta = pow(lower_del r',2) + pow(lower_del z',2) + val upper_disc = (upper_del r')*(lower_del w') - + (upper_del z')*(lower_del u') + val lower_disc = (upper_del u')*(lower_del z') - + (upper_del w') * (lower_del r') + val upper_ubar = if upper_disc<0.0 then upper_disc/xi else 0.0 + val lower_ubar = if lower_disc<0.0 then lower_disc/eta else 0.0 + val gamma = 1.6 + val speed_of_sound = gamma*sub2(p,zone)/sub2(rho',zone) + val ubar = pow(upper_ubar,2) + pow(lower_ubar,2) + val viscosity = + sub2(rho',zone)*(1.5*ubar + 0.5*speed_of_sound*(Math.sqrt ubar)) + val length = Math.sqrt(pow(upper_del r',2) + pow(lower_del r',2)) + val courant_delta = 0.5* sub2(alpha',zone)/(speed_of_sound*length) + in (viscosity, courant_delta) + end + val q' = array2(dimension_all_zones, 0.0) + val d = array2(dimension_all_zones, 0.0) + fun reflect_viscosity_cdelta (direction, zone) = + sub2(q',direction zone) * sub1(qb, sub2(nbc,zone)) + fun do_zones (dir,zone) = + update2(q',zone,reflect_viscosity_cdelta (dir,zone)) + in + for_interior_zones (fn zone => let val (qv,dv) = interior_viscosity zone + in update2(q',zone,qv); + update2(d,zone,dv) + end); + for_south_zones (fn zone => do_zones(north,zone)); + for_east_zones (fn zone => do_zones(west,zone)); + for_west_zones (fn zone => do_zones(east,zone)); + for_north_zones (fn zone => do_zones(south,zone)); + (q', d) + end + +(* + * Pressure and Energy Polynomial (page 12) + *) + +fun polynomial(G,degree,rho_table,theta_table,rho_value,theta_value) = + let fun table_search (table, value) = + let val (low, high) = bounds1 table + fun search_down i = if value > sub1(table,i-1) then i + else search_down (i-1) + in + if value>sub1(table,high) then high+1 + else if value <= sub1(table,low) then low + else search_down high + end + val rho_index = table_search(rho_table, rho_value) + val theta_index = table_search(theta_table, theta_value) + val A = sub2(G, (rho_index, theta_index)) + fun from(n,m) = if n>m then [] else n::from(n+1,m) + fun f(i,j) = sub2(A,(i,j))*pow(rho_value,i)*pow(theta_value,j) + in + sum_list (map (fn i => sum_list(map (fn j => f (i,j)) (from(0,degree)))) + (from (0,degree))) + end +fun zonal_pressure (rho_value:real, theta_value:real) = + let val (G,degree,rho_table,theta_table) = + extract_pressure_tables_from_constants + in polynomial(G, degree, rho_table, theta_table, rho_value, theta_value) + end + + +fun zonal_energy (rho_value, theta_value) = + let val (G, degree, rho_table, theta_table) = + extract_energy_tables_from_constants + in polynomial(G, degree, rho_table, theta_table, rho_value, theta_value) + end +val dx = 0.000001 +val tiny = 0.000001 + + +fun newton_raphson (f,x) = + let fun iter (x,fx) = + if fx > tiny then + let val fxdx = f(x+dx) + val denom = fxdx - fx + in if denom < tiny then iter(x,tiny) + else iter(x-fx*dx/denom, fxdx) + end + else x + in iter(x, f x) + end + +(* + * Temperature (page 13-14) + *) + +fun make_temperature(p,epsilon,rho,theta,rho_prime,q_prime) = + let fun interior_temperature zone = + let val qkl = sub2(q_prime,zone) + val rho_kl = sub2(rho,zone) + val rho_prime_kl = sub2(rho_prime,zone) + val tau_kl = (1.0 /rho_prime_kl - 1.0/rho_kl) + fun energy_equation epsilon_kl theta_kl = + epsilon_kl - zonal_energy(rho_kl,theta_kl) + val epsilon_0 = sub2(epsilon,zone) + fun revised_energy pkl = epsilon_0 - (pkl + qkl) * tau_kl + fun revised_temperature epsilon_kl theta_kl = + newton_raphson ((energy_equation epsilon_kl), theta_kl) + fun revised_pressure theta_kl = zonal_pressure(rho_kl, theta_kl) + val p_0 = sub2(p,zone) + val theta_0 = sub2(theta,zone) + val epsilon_1 = revised_energy p_0 + val theta_1 = revised_temperature epsilon_1 theta_0 + val p_1 = revised_pressure theta_1 + val epsilon_2 = revised_energy p_1 + val theta_2 = revised_temperature epsilon_2 theta_1 + in theta_2 + end + val M = array2(dimension_all_zones, constant_heat_source) + in + for_interior_zones + (fn zone => update2(M, zone, interior_temperature zone)); + M + end + + +(* + * Heat conduction + *) + +fun make_cc(alpha_prime, theta_hat) = + let fun interior_cc zone = + (0.0001 * pow(sub2(theta_hat,zone),2) * + (Math.sqrt (abs(sub2(theta_hat,zone)))) / sub2(alpha_prime,zone)) + handle Sqrt => (print (Real.toString (sub2(theta_hat, zone))); + print ("\nzone =(" ^ Int.toString (#1 zone) ^ "," ^ + Int.toString (#2 zone) ^ ")\n"); + printarray2 theta_hat; + raise Sqrt) + val cc = array2(dimension_all_zones, 0.0) + in + for_interior_zones(fn zone => update2(cc,zone, interior_cc zone)); + for_south_zones(fn zone => update2(cc,zone, reflect_north zone cc)); + for_west_zones(fn zone => update2(cc,zone,reflect_east zone cc)); + for_east_zones(fn zone => update2(cc,zone,reflect_west zone cc)); + for_north_zones(fn zone => update2(cc,zone, reflect_south zone cc)); + cc + end + +fun make_sigma(deltat, rho_prime, alpha_prime) = + let fun interior_sigma zone = + sub2(rho_prime,zone)*sub2(alpha_prime,zone)*specific_heat/ deltat + val M = array2(dimension_interior_zones, 0.0) + fun ohandle zone = + (print (Real.toString (sub2(rho_prime, zone)) ^ " "); + print (Real.toString (sub2(alpha_prime, zone)) ^ " "); + print (Real.toString specific_heat ^ " "); + print (Real.toString deltat ^ "\n"); + raise Overflow) + + in if !Control.trace + then print ("\t\tmake_sigma:deltat = " ^ Real.toString deltat ^ "\n") + else (); +(*** for_interior_zones(fn zone => update2(M,zone, interior_sigma zone)) **) + for_interior_zones(fn zone => (update2(M,zone, interior_sigma zone) + handle Overflow => ohandle zone)); + M + end + +fun make_gamma ((r_prime,z_prime), cc, succeeding, adjacent) = + let fun interior_gamma zone = + let val r1 = sub2(r_prime, zone_corner_southeast zone) + val z1 = sub2(z_prime, zone_corner_southeast zone) + val r2 = sub2(r_prime, zone_corner_southeast (adjacent zone)) + val z2 = sub2(z_prime, zone_corner_southeast (adjacent zone)) + val cross_section = 0.5*(r1+r2)*(pow(r1 - r2,2)+pow(z1 - z2,2)) + val (c1,c2) = (sub2(cc, zone), sub2(cc, succeeding zone)) + val specific_conductivity = 2.0 * c1 * c2 / (c1 + c2) + in cross_section * specific_conductivity + end + val M = array2(dimension_all_zones, 0.0) + in + for_interior_zones(fn zone => update2(M,zone,interior_gamma zone)); + M + end + +fun make_ab(theta, sigma, Gamma, preceding) = + let val a = array2(dimension_all_zones, 0.0) + val b = array2(dimension_all_zones, 0.0) + fun interior_ab zone = + let val denom = sub2(sigma, zone) + sub2(Gamma, zone) + + sub2(Gamma, preceding zone) * + (1.0 - sub2(a, preceding zone)) + val nume1 = sub2(Gamma,zone) + val nume2 = sub2(Gamma,preceding zone)*sub2(b,preceding zone) + + sub2(sigma,zone) * sub2(theta,zone) + in (nume1/denom, nume2 / denom) + end + val f = fn zone => update2(b,zone,sub2(theta,zone)) + in + for_north_zones f; + for_south_zones f; + for_west_zones f; + for_east_zones f; + for_interior_zones(fn zone => let val ab = interior_ab zone + in update2(a,zone,#1 ab); + update2(b,zone,#2 ab) + end); + (a,b) + end + +fun make_theta (a, b, succeeding, int_zones) = + let val theta = array2(dimension_all_zones, constant_heat_source) + fun interior_theta zone = + sub2(a,zone) * sub2(theta,succeeding zone)+ sub2(b,zone) + in + int_zones (fn (k,l) => update2(theta, (k,l), interior_theta (k,l))); + theta + end + +fun compute_heat_conduction(theta_hat, deltat, x', alpha', rho') = + let val sigma = make_sigma(deltat, rho', alpha') + val _ = if !Control.trace then print "\tdone make_sigma\n" else () + + val cc = make_cc(alpha', theta_hat) + val _ = if !Control.trace then print "\tdone make_cc\n" else () + + val Gamma_k = make_gamma( x', cc, north, east) + val _ = if !Control.trace then print "\tdone make_gamma\n" else () + + val (a_k,b_k) = make_ab(theta_hat, sigma, Gamma_k, north) + val _ = if !Control.trace then print "\tdone make_ab\n" else () + + val theta_k = make_theta(a_k,b_k,south,for_north_ward_interior_zones) + val _ = if !Control.trace then print "\tdone make_theta\n" else () + + val Gamma_l = make_gamma(x', cc, west, south) + val _ = if !Control.trace then print "\tdone make_gamma\n" else () + + val (a_l,b_l) = make_ab(theta_k, sigma, Gamma_l, west) + val _ = if !Control.trace then print "\tdone make_ab\n" else () + + val theta_l = make_theta(a_l,b_l,east,for_west_ward_interior_zones) + val _ = if !Control.trace then print "\tdone make_theta\n" else () + in (theta_l, Gamma_k, Gamma_l) + end + + +(* + * Final Pressure and Energy calculation + *) +fun make_pressure(rho', theta') = + let val p = array2(dimension_all_zones, 0.0) + fun boundary_p(direction, zone) = + sub1(pbb, sub2(nbc, zone)) + + sub1(pb,sub2(nbc,zone)) * sub2(p, direction zone) + in + for_interior_zones + (fn zone => update2(p,zone,zonal_pressure(sub2(rho',zone), + sub2(theta',zone)))); + for_south_zones(fn zone => update2(p,zone,boundary_p(north,zone))); + for_east_zones(fn zone => update2(p,zone,boundary_p(west,zone))); + for_west_zones(fn zone => update2(p,zone,boundary_p(east,zone))); + for_north_zones(fn zone => update2(p,zone,boundary_p(south,zone))); + p + end + +fun make_energy(rho', theta') = + let val epsilon' = array2(dimension_all_zones, 0.0) + in + for_interior_zones + (fn zone => update2(epsilon', zone, zonal_energy(sub2(rho',zone), + sub2(theta',zone)))); + for_south_zones + (fn zone => update2(epsilon',zone, reflect_north zone epsilon')); + for_west_zones + (fn zone => update2(epsilon',zone, reflect_east zone epsilon')); + for_east_zones + (fn zone => update2(epsilon',zone, reflect_west zone epsilon')); + for_north_zones + (fn zone => update2(epsilon',zone, reflect_south zone epsilon')); + epsilon' + end + + +(* + * Energy Error Calculation (page 20) + *) + +fun compute_energy_error ((u',w'),(r',z'),p',q',epsilon',theta',rho',alpha', + Gamma_k,Gamma_l,deltat) = + let fun mass zone = sub2(rho',zone) * sub2(alpha',zone):real + val internal_energy = + sum_list (map_interior_zones (fn z => sub2(epsilon',z)*(mass z))) + fun kinetic node = + let val average_mass = 0.25*((mass (zone_A node)) + + (mass (zone_B node)) + + (mass (zone_C node)) + + (mass (zone_D node))) + val v_square = pow(sub2(u',node),2) + pow(sub2(w',node),2) + in 0.5 * average_mass * v_square + end + val kinetic_energy = sum_list (map_interior_nodes kinetic) + fun work_done (node1, node2) = + let val (r1, r2) = (sub2(r',node1), sub2(r',node2)) + val (z1, z2) = (sub2(z',node1), sub2(z',node2)) + val (u1, u2) = (sub2(p',node1), sub2(p',node2)) + val (w1, w2) = (sub2(z',node1), sub2(z',node2)) + val (p1, p2) = (sub2(p',node1), sub2(p',node2)) + val (q1, q2) = (sub2(q',node1), sub2(q',node2)) + val force = 0.5*(p1+p2+q1+q2) + val radius = 0.5* (r1+r2) + val area = 0.5* ((r1-r2)*(u1-u2) - (z1-z2)*(w1-w2)) + in force * radius * area * deltat + end + + fun from(n,m) = if n > m then [] else n::from(n+1,m) + val north_line = + map (fn l => (west(kmin,l),(kmin,l))) (from(lmin+1,lmax)) + val south_line = + map (fn l => (west(kmax,l),(kmax,l))) (from(lmin+1,lmax)) + val east_line = + map (fn k => (south(k,lmax),(k,lmax))) (from(kmin+1,kmax)) + val west_line = + map (fn k => (south(k,lmin+1),(k,lmin+1))) (from(kmin+1,kmax)) + + val w1 = sum_list (map work_done north_line) + val w2 = sum_list (map work_done south_line) + val w3 = sum_list (map work_done east_line) + val w4 = sum_list (map work_done west_line) + val boundary_work = w1 + w2 + w3 + w4 + + fun heat_flow Gamma (zone1,zone2) = + deltat * sub2(Gamma, zone1) * (sub2(theta',zone1) - sub2(theta',zone2)) + + val north_flow = + let val k = kmin+1 + in map (fn l => (north(k,l),(k,l))) (from(lmin+1,lmax)) + end + val south_flow = + let val k = kmax + in map (fn l => (south(k,l),(k,l))) (from(lmin+2,lmax-1)) + end + val east_flow = + let val l = lmax + in map (fn k => (east(k,l),(k,l))) (from(kmin+2,kmax)) + end + val west_flow = + let val l = lmin+1 + in map (fn k => (west(k,l),(k,l))) (from(kmin+2,kmax)) + end + + val h1 = sum_list (map (heat_flow Gamma_k) north_flow) + val h2 = sum_list (map (heat_flow Gamma_k) south_flow) + val h3 = sum_list (map (heat_flow Gamma_l) east_flow) + val h4 = sum_list (map (heat_flow Gamma_l) west_flow) + val boundary_heat = h1 + h2 + h3 + h4 + in + internal_energy + kinetic_energy - boundary_heat - boundary_work + end + +fun compute_time_step(d, theta_hat, theta') = + let val deltat_courant = + min_list (map_interior_zones (fn zone => sub2(d,zone))) + val deltat_conduct = + max_list (map_interior_zones + (fn z => (abs(sub2(theta_hat,z) - sub2(theta', z))/ + sub2(theta_hat,z)))) + val deltat_minimum = min (deltat_courant, deltat_conduct) + in min (deltat_maximum, deltat_minimum) + end + + +fun compute_initial_state () = + let + val v = (all_zero_nodes, all_zero_nodes) + val x = let fun interior_position (k,l) = + let val pi = 3.1415926535898 + val rp = real (lmax - lmin) + val z1 = real(10 + k - kmin) + val zz = (~0.5 + real(l - lmin) / rp) * pi + in (z1 * Math.cos zz, z1 * Math.sin zz) + end + in make_position_matrix interior_position + end + val (alpha,s) = + let val (alpha_prime,s_prime) = + let val A = array2(dimension_all_zones, 0.0) + val S = array2(dimension_all_zones, 0.0) + fun reflect_area_vol f = (f A, f S) + + fun u2 (f,z) = + let val (a,s) = reflect_area_vol(f z) + in update2(A,z,a); + update2(S,z,s) + end + in + for_interior_zones + (fn z => let val (a,s) = zone_area_vol(x, z) + in update2(A,z,a); + update2(S,z,s) + end); + for_south_zones (fn z => u2 (reflect_north, z)); + for_east_zones (fn z => u2 (reflect_west, z)); + for_west_zones (fn z => u2 (reflect_east, z)); + for_north_zones (fn z => u2 (reflect_south, z)); + (A,S) + end + in (alpha_prime,s_prime) + end + val rho = let val R = array2(dimension_all_zones, 0.0) + in for_all_zones (fn z => update2(R,z,1.4)); R + end + val theta = + let val T = array2(dimension_all_zones, constant_heat_source) + in for_interior_zones(fn z => update2(T,z,0.0001)); + T + end + val p = make_pressure(rho, theta) + val q = all_zero_zones + val epsilon = make_energy(rho, theta) + val deltat = 0.01 + val c = 0.0 + in + (v,x,alpha,s,rho,p,q,epsilon,theta,deltat,c) + end + + +fun compute_next_state state = + let + val (v,x,alpha,s,rho,p,q,epsilon,theta,deltat,c) = state + val v' = make_velocity (v, x, p, q, alpha, rho, deltat) + val _ = if !Control.trace then print "done make_velocity\n" else () + + val x' = make_position(x,deltat,v') + handle Overflow =>(printarray2 (#1 v'); + printarray2 (#2 v'); + raise Overflow) + val _ = if !Control.trace then print "done make_position\n" else () + + val (alpha',rho',s') = make_area_density_volume (rho, s , x') + val _ = if !Control.trace then print "done make_area_density_volume\n" + else () + + val (q',d) = make_viscosity (p, v', x', alpha', rho') + val _ = if !Control.trace then print "done make_viscosity\n" else () + + val theta_hat = make_temperature (p, epsilon, rho, theta, rho', q') + val _ = if !Control.trace then print "done make_temperature\n" else () + + val (theta',Gamma_k,Gamma_l) = + compute_heat_conduction (theta_hat, deltat, x', alpha', rho') + val _ = if !Control.trace then print "done compute_heat_conduction\n" + else () + + val p' = make_pressure(rho', theta') + val _ = if !Control.trace then print "done make_pressure\n" else () + + val epsilon' = make_energy (rho', theta') + val _ = if !Control.trace then print "done make_energy\n" else () + + val c' = compute_energy_error (v', x', p', q', epsilon', theta', rho', + alpha', Gamma_k, Gamma_l, deltat) + val _ = if !Control.trace then print "done compute_energy_error\n" + else () + + val deltat' = compute_time_step (d, theta_hat, theta') + val _ = if !Control.trace then print "done compute_time_step\n\n" else () + in + (v',x',alpha',s',rho',p',q', epsilon',theta',deltat',c') + end + +fun runit () = + let fun iter (i,state) = if i = 0 then state + else (print "."; + iter(i-1, compute_next_state state)) + in iter(step_count, compute_initial_state()) + end + +fun print_state ((v1,v2),(r,z),alpha,s,rho,p,q,epsilon,theta,deltat,c) = ( + print "Velocity matrices = \n"; + printarray2 v1; print "\n\n"; + printarray2 v2; + + print "\n\nPosition matrices = \n"; + printarray2 r; print "\n\n"; + printarray2 z; + + print "\n\nalpha = \n"; + printarray2 alpha; + + print "\n\ns = \n"; + printarray2 s; + + print "\n\nrho = \n"; + printarray2 rho; + + print "\n\nPressure = \n"; + printarray2 p; + + print "\n\nq = \n"; + printarray2 q; + + print "\n\nepsilon = \n"; + printarray2 epsilon; + + print "\n\ntheta = \n"; + printarray2 theta; + + print ("delatat = " ^ Real.toString (deltat : real)^ "\n"); + print ("c = " ^ Real.toString (c : real) ^ "\n")) + + fun testit outstrm = print_state (runit()) + + fun doit () = let + val (_, _, _, _, _, _, _, _, _, delta', c') = runit() + val delta = Real.trunc delta' + val c = Real.trunc (c' * 10000.0) + in + if (c = 6787 andalso delta = ~33093) + then () + else TextIO.output (TextIO.stdErr, "*** ERROR ***\n") + end + + val doit = + fn n => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop n + end + + + end; (* functor Simple *) +structure Main = Simple (val grid_max=100 val step_count=1); diff --git a/benchmark/tests/smith-normal-form.sml b/benchmark/tests/smith-normal-form.sml new file mode 100644 index 0000000..652d06d --- /dev/null +++ b/benchmark/tests/smith-normal-form.sml @@ -0,0 +1,398 @@ +(* Written by Henry Cejtin (henry@sourcelight.com). *) +signature MATRIX = + sig + type 'entry matrix + val make: int * int * (int * int -> 'entry) -> 'entry matrix + val height: 'entry matrix -> int + val width: 'entry matrix -> int + val fetch: 'entry matrix * int * int -> 'entry + val fetchRow: 'entry matrix * int -> int -> 'entry + val fetchCol: 'entry matrix * int -> int -> 'entry + val store: 'entry matrix * int * int * 'entry -> unit + val storeRow: 'entry matrix * int -> int * 'entry -> unit + val storeCol: 'entry matrix * int -> int * 'entry -> unit + val rowSwap: 'entry matrix * int * int -> unit + val colSwap: 'entry matrix * int * int -> unit + val rowOp: 'entry matrix * int * int * ('entry * 'entry -> 'entry) -> unit + val colOp: 'entry matrix * int * int * ('entry * 'entry -> 'entry) -> unit + val copy: 'entry matrix -> 'entry matrix + val map: 'entry1 matrix * ('entry1 -> 'entry2) -> 'entry2 matrix + val toString: 'entry matrix * ('entry -> string) -> string + end + +structure Matrix:> MATRIX = + struct + type 'entry matrix = int * int * 'entry array + + exception sizeError + + exception index + + exception foldError + + fun make (height: int, width: int, generator: int * int -> 'entry) + : 'entry matrix = + if height < 0 orelse width < 0 + then raise sizeError + else (height, + width, + Array.tabulate (height*width, + fn z => generator (z div width, + z mod width))) + + fun height (height, _, _) = height + + fun width (width, _, _) = width + + fun fetch ((height, width, mat), row, col) = + if 0 <= row + andalso row < height + andalso 0 <= col + andalso col < width + then Array.sub (mat, col + width*row) + else raise index + + fun fetchRow ((height, width, mat), row) = + if 0 <= row andalso row < height + then let val offset = width * row + in fn col => + if 0 <= col andalso col < width + then Array.sub (mat, col + offset) + else raise index + end + else raise index + + fun fetchCol ((height, width, mat), col) = + if 0 <= col andalso col < width + then fn row => + if 0 <= row andalso row < height + then Array.sub (mat, col + width*row) + else raise index + else raise index + + fun store ((height, width, mat), row, col, entry) = + if 0 <= row + andalso row < height + andalso 0 <= col + andalso col < width + then Array.update (mat, col + width*row, entry) + else raise index + + fun storeRow ((height, width, mat), row) = + if 0 <= row andalso row < height + then let val offset = width * row + in fn (col, entry) => + if 0 <= col andalso col < width + then Array.update (mat, col + offset, entry) + else raise index + end + else raise index + + fun storeCol ((height, width, mat), col) = + if 0 <= col andalso col < width + then fn (row, entry) => + if 0 <= row andalso row < height + then Array.update (mat, col + width*row, entry) + else raise index + else raise index + + fun swapLoop (from1: int -> 'entry, + to1: int * 'entry -> unit, + from2: int -> 'entry, + to2: int * 'entry -> unit, + limit: int): unit = + let fun loop (i: int): unit = + if i = limit + then () + else let val tmp = from1 i + in to1 (i, from2 i); + to2 (i, tmp); + loop (i + 1) + end + in loop 0 + end + + fun rowSwap (mat as (height, width, _), row1, row2): unit = + if 0 <= row1 andalso row1 < height + andalso 0 <= row2 andalso row2 < height + then if row1 = row2 + then () + else swapLoop (fetchRow (mat, row1), + storeRow (mat, row1), + fetchRow (mat, row2), + storeRow (mat, row2), + width) + else raise index + + fun colSwap (mat as (height, width, _), col1, col2): unit = + if 0 <= col1 andalso col1 < width + andalso 0 <= col2 andalso col2 < width + then if col1 = col2 + then () + else swapLoop (fetchCol (mat, col1), + storeCol (mat, col1), + fetchCol (mat, col2), + storeCol (mat, col2), + height) + else raise index + + fun opLoop (from1: int -> 'entry, + from2: int -> 'entry, + to2: int * 'entry -> unit, + limit: int, + f: 'entry * 'entry -> 'entry): unit = + let fun loop (i: int): unit = + if i = limit + then () + else ( + to2 (i, + f (from1 i, from2 i)); + loop (i + 1)) + in loop 0 + end + + fun rowOp (mat as (height, width, _), + row1, + row2, + f: 'entry * 'entry -> 'entry): unit = + if 0 <= row1 andalso row1 < height + andalso 0 <= row2 andalso row2 < height + andalso row1 <> row2 + then opLoop (fetchRow (mat, row1), + fetchRow (mat, row2), + storeRow (mat, row2), + width, + f) + else raise index + + fun colOp (mat as (height, width, _), + col1, + col2, + f: 'entry * 'entry -> 'entry): unit = + if 0 <= col1 andalso col1 < width + andalso 0 <= col2 andalso col2 < width + andalso col1 <> col2 + then opLoop (fetchCol (mat, col1), + fetchCol (mat, col2), + storeCol (mat, col2), + height, + f) + else raise index + + fun copy ((height, width, mat)) = + (height, + width, + Array.tabulate (Array.length mat, + fn i => Array.sub (mat, i))) + + fun map ((height, width, mat: 'entry1 Array.array), + f: 'entry1 -> 'entry2) + : 'entry2 matrix = + (height, + width, + Array.tabulate (Array.length mat, + fn i => f (Array.sub (mat, i)))) + + (* Natural fold a range of integers in reverse. *) + fun naturalFold (limit: int, + state: 'state, + folder: int * 'state -> 'state): 'state = + let fun loop (i: int, state: 'state) = + if i = 0 + then state + else loop (i - 1, folder (i - 1, state)) + in if limit < 0 + then raise foldError + else loop (limit, state) + end + + + local val blank8 = Byte.charToByte #" " + + fun makeBlanks size = + let val blanks = Word8Vector.tabulate (size, + fn _ => blank8) + in Byte.bytesToString blanks + end + + in fun toString (mat: 'entry matrix, f: 'entry -> string): string = + let val mat as (height, width, _) = map (mat, f) + fun maxSize from (i, width) = Int.max (String.size (from i), + width) + fun colWidth col = naturalFold (height, + 0, + maxSize (fetchCol (mat, + col))) + val widths = Vector.tabulate (width, colWidth) + fun doRow (row: int, ac: string list): string list = + let val from = fetchRow (mat, row) + fun loop (col: int, ac: string list) = + let val next = from col + val ac = next::ac + val s = String.size next + val pad = Vector.sub (widths, col) - s + val ac = if pad <= 0 + then ac + else (makeBlanks pad)::ac + in if col = 0 + then ac + else loop (col - 1, + " "::ac) + end + val ac = "\n"::ac + in if width = 0 + then ac + else loop (width - 1, ac) + end + val pieces = naturalFold (height, + [], + doRow) + in String.concat pieces + end + end + end + +val zero = IntInf.fromInt 0 + +fun smaller (a: IntInf.int, b: IntInf.int): bool = + (not (a = zero)) + andalso (b = zero orelse IntInf.< (IntInf.abs a , IntInf.abs b)) + +fun smithNormalForm (mat: IntInf.int Matrix.matrix): IntInf.int Matrix.matrix = + let val height = Matrix.height mat + val width = Matrix.width mat + val mat = Matrix.copy mat + val range = Int.min (width, height) + fun dd pos = + let val matCol = Matrix.fetchCol (mat, pos) + val matRow = Matrix.fetchRow (mat, pos) + val _ = print ("dd: pos = " ^ (Int.toString pos) ^ "\n") + fun swapRowLoop (best, bestRow, bestCol, row) = + if row >= height + then (Matrix.rowSwap (mat, pos, bestRow); + Matrix.colSwap (mat, pos, bestCol)) + else let val matRow = Matrix.fetchRow (mat, row) + fun swapColLoop (best, bestRow, bestCol, col) = + if col >= width + then swapRowLoop (best, bestRow, bestCol, row + 1) + else let val next = matRow col + in if smaller (next, best) + then swapColLoop (next, row, col, col + 1) + else swapColLoop (best, bestRow, bestCol, col + 1) + end + in swapColLoop (best, bestRow, bestCol, pos) + end + fun rowLoop row = + if row < height + then if (matCol row) = zero + then rowLoop (row + 1) + else (Matrix.rowOp (mat, + pos, + row, + let val x = IntInf.~ (IntInf.quot(matCol row, matCol pos)) + in fn (lhs, rhs) => IntInf.+ (IntInf.* (lhs, x), rhs) + end); + if (matCol row) = zero + then rowLoop (row + 1) + else hitPosAgain ()) + else let fun colLoop col = + if col < width + then if (matRow col) = zero + then colLoop (col + 1) + else (Matrix.colOp (mat, + pos, + col, + let val x = IntInf.~ (IntInf.quot (matRow col, matRow pos)) + in fn (lhs, rhs) => IntInf.+ (IntInf.* (lhs, x), rhs) + end); + if (matRow col) = zero + then colLoop (col + 1) + else hitPosAgain ()) + else () + in colLoop (pos + 1) + end + and hitPosAgain () = (swapRowLoop (zero, pos, pos, pos); + rowLoop (pos + 1)) + in hitPosAgain () + end + fun loop pos = + if pos = range + then mat + else (dd pos; + loop (pos + 1)) + in loop 0 + end + +val table = [[ 8, ~3, 1, 3, 6, 9, ~2, 4, ~9, ~9, 2, 3, 8, ~1, 3, ~5, 4, ~3, ~5, ~6, 8, 1, 4, ~5, 7, ~4, ~4, ~7, 7, 1, 4, ~3, 8, 4, ~4, ~8, 5, ~9, 3, ~4, 1, 9, ~8, ~6, ~2, 8, ~9, ~5, ~3, ~3], + [ 0, 8, ~6, ~2, ~3, 4, 5, ~2, 7, ~7, ~6, ~7, ~3, ~4, 9, 7, ~3, 3, 0, 3, 3, ~8, ~8, 2, 3, 8, 3, ~2, ~4, 3, ~6, ~6, ~2, 6, 5, ~1, ~3, 1, 8, ~8, 2, 1, ~7, ~7, ~7, ~3, ~6, 6, ~4, ~9], + [ 0, ~5, 8, ~9, 2, 4, 2, 7, ~4, 9, ~3, 6, ~2, 3, ~3, 0, ~9, 5, 8, ~1, 2, ~8, 3, 4, ~6, 5, ~6, ~5, ~8, 0, ~5, 3, ~2, ~5, 8, 7, ~1, 1, ~1, 7, 6, 3, 6, 5, 6, 8, 7, 9, 7, ~3], + [ 5, 4, 7, 2, 3, ~9, 7, ~7, 3, ~8, 7, 5, 5, ~2, ~6, ~3, 6, 5, 3, ~1, ~1, 4, 5, ~5, 5, 9, 9, 3, 8, ~3, ~1, 9, ~9, 6, ~7, 7, 4, 6, ~8, ~9, 0, ~3, ~2, ~7, 1, ~2, ~6, 7, 7, 7], + [ 2, 9, 9, 3, ~4, 0, 9, 2, 5, 3, ~5, ~3, ~1, 1, 8, ~6, 2, ~4, ~8, ~7, ~8, 4, 5, 8, ~1, ~1, 7, 2, 5, 5, ~4, ~7, ~3, ~7, 6, ~4, ~5, ~8, ~5, ~9, ~8, 5, ~5, ~5, 0, 8, 8, 6, 4, ~1], + [ 5, 5, 1, ~7, 3, ~5, 4, 9, 3, 4, 4, ~5, 7, ~1, 7, 4, ~7, 7, ~7, ~2, 9, ~9, 0, ~4, ~4, 0, 2, 6, 3, ~1, 6, 6, 8, ~6, ~4, ~9, 3, ~2, ~5, 5, ~3, 2, ~1, ~6, 9, 3, ~3, ~8, ~9, 7], + [ 7, 1, 2, 7, 6, 5, ~6, ~3, ~4, ~8, 0, 9, 6, 1, 2, ~5, 4, 4, 4, ~6, ~7, ~9, ~6, 2, ~4, 5, ~2, 1, 0, 1, ~8, 7, ~7, ~5, 4, 1, ~5, 4, ~4, ~2, ~3, 1, 1, 3, 4, ~4, ~5, 9, 8, ~2], + [ 6, 2, ~1, ~8, 4, ~7, 7, ~3, ~2, ~5, 3, 0, 3, ~9, 3, 3, 9, ~1, 4, 8, ~9, 6, ~5, 9, 5, ~1, ~1, ~9, 7, ~2, 3, 9, 8, 9, 2, 7, 7, 6, ~1, ~1, ~2, ~2, ~7, 3, ~6, 0, ~9, 4, 3, 7], + [ 0, ~6, ~3, ~7, ~1, 5, ~2, 8, ~5, ~3, ~8, 7, ~2, ~2, 0, ~8, 4, 8, 9, ~5, ~4, ~8, ~1, 7, 1, 1, 6, ~9, ~4, 0, 8, 4, 3, ~7, 6, 0, 1, 8, 6, ~1, ~1, ~7, 9, ~9, ~5, ~2, ~2, ~1, 1, 0], + [~4, 9, 6, ~3, ~2, ~6, ~3, 4, 8, ~8, 1, ~5, 9, 7, 9, 7, ~9, ~6, 6, 1, ~3, 3, ~3, ~7, 1, 7, ~7, 0, ~2, 7, ~4, ~6, 0, 1, ~3, ~5, ~9, ~7, 8, 4, 9, ~8, ~8, ~7, ~6, 7, 6, ~3, ~8, 5], + [ 6, 7, ~5, ~9, 6, 1, 8, 4, ~2, 7, ~7, ~1, ~9, 1, ~6, ~5, 4, 9, 6, 0, ~8, ~3, 1, ~3, 8, ~3, 2, 9, ~3, ~9, ~1, ~3, 4, 3, 2, ~9, ~5, ~3, 8, ~4, 8, 5, ~4, 7, 6, ~8, 7, 6, ~5, 5], + [ 1, 7, ~8, ~9, ~7, ~3, 8, 9, ~7, ~1, ~7, 4, 0, 0, 1, ~5, 9, ~8, ~1, ~2, 3, 5, 9, ~9, 5, 4, ~9, 1, ~4, ~2, 3, ~4, 8, ~6, ~4, ~8, ~5, ~5, 4, ~2, ~4, ~1, ~9, ~5, 2, ~9, 2, ~9, ~2, ~3], + [~5, ~4, ~4, 9, 2, 7, ~2, 6, 7, 2, ~9, 4, 2, 7, 8, ~9, 2, 5, 3, 9, 6, 3, 0, ~7, ~6, ~7, 6, ~2, 9, ~3, ~6, 9, ~9, 2, 2, ~6, ~1, 4, ~3, 3, 0, 6, ~3, 4, 9, 9, ~6, 5, 5, ~5], + [ 5, ~7, 8, ~4, 8, 8, ~4, ~9, 6, 0, ~3, 6, 0, 8, 8, ~6, ~2, 5, 4, ~1, ~8, 1, ~3, ~1, 2, 3, ~9, ~9, ~5, 1, 8, ~5, ~3, 0, ~4, ~9, 0, ~6, 3, ~1, ~7, 0, 8, 9, ~6, ~1, ~9, 1, ~6, 2], + [ 7, ~5, ~1, 5, ~2, 7, 0, ~7, ~1, 8, 8, ~3, 9, ~5, 7, ~8, ~8, ~4, 3, 2, ~1, 8, ~2, 1, 2, 5, 0, ~6, 7, 3, 3, 7, ~5, 5, ~1, 1, 0, ~8, 1, 0, 0, ~4, 6, 9, ~5, ~6, 3, ~5, 8, 5], + [~4, ~2, 3, ~3, ~1, 2, ~2, ~1, ~9, ~5, 1, 0, 0, 2, 9, ~3, ~9, 2, 9, 3, 8, ~3, 4, 8, 8, 3, ~3, ~1, ~4, 4, ~6, ~9, 5, ~2, 1, 3, ~7, ~5, ~6, ~5, ~8, 4, ~8, ~3, 5, 0, 7, ~9, 6, 2], + [ 5, 1, 4, ~3, ~1, ~9, 5, ~8, ~8, 6, 1, 1, ~2, 7, 5, 6, ~4, 2, ~7, 0, ~7, ~3, ~5, 9, 3, 4, ~6, 8, ~4, 3, 6, 0, 2, 3, ~6, 3, 9, 4, 1, ~4, 6, ~5, ~7, 0, ~1, ~8, ~3, ~9, 9, 7], + [ 2, ~6, ~1, 8, 4, ~3, ~1, ~6, ~2, ~8, ~2, ~1, ~1, ~5, ~9, ~8, 9, ~9, 5, 1, 9, ~1, ~6, 9, ~7, 2, 8, ~7, 4, ~9, 7, 6, ~2, 1, ~2, ~7, 8, 0, 5, 0, ~5, ~7, ~6, 0, 4, 0, 3, ~8, 5, 4], + [~2, 9, ~9, ~6, 1, ~8, 8, 4, ~6, 8, 1, ~3, ~7, 8, ~5, 2, ~8, 1, 3, ~2, 6, 6, 6, 1, 0, 0, ~7, 7, ~3, ~3, 0, ~4, 3, ~7, ~6, 7, 5, 9, ~5, 7, ~8, 2, 3, ~8, ~7, 6, ~5, ~5, ~8, ~9], + [~7, ~4, 4, 1, ~1, ~3, ~8, 3, 7, 9, 8, 3, 0, 4, 4, ~1, ~5, 4, 2, 2, 0, 6, ~6, 2, ~9, 8, ~9, 3, ~2, 2, 6, 6, 1, 7, 1, 0, ~8, 2, 3, ~3, 8, 9, 5, 5, ~6, 4, ~7, ~4, ~2, ~3], + [~5, 8, 6, 1, ~6, ~6, 6, 1, 1, ~3, ~9, ~6, 2, ~7, 2, ~1, 6, ~6, 0, 2, ~7, 8, ~8, 4, 9, ~3, 9, ~7, ~9, ~6, ~4, ~4, ~5, 8, 2, ~5, ~4, ~3, 5, 2, 1, ~3, ~3, ~7, ~9, 3, 7, ~7, 3, ~8], + [~4, ~7, ~2, 2, ~4, ~2, 6, ~3, ~1, ~4, 0, ~5, 9, 7, ~6, ~9, 7, ~9, ~6, 2, ~3, 1, 5, ~9, 4, ~5, 4, ~9, 1, ~2, ~2, 4, 0, 4, ~8, ~8, 3, ~1, ~5, ~4, ~9, ~7, 7, 6, 3, ~9, 6, 4, ~4, ~7], + [~9, 6, 6, ~5, ~1, ~7, 4, ~9, 4, ~1, 6, ~4, 7, 2, 8, 7, 3, 1, ~7, 7, 7, 9, 8, ~9, 7, 2, 1, 2, ~8, 4, 5, 6, 7, 2, ~7, 6, 8, 4, ~9, 7, ~5, 6, 9, ~1, 9, 2, 0, 9, 3, 6], + [ 4, ~3, 8, 0, ~2, ~2, 2, ~3, 8, 3, 1, ~8, ~5, ~2, 5, 6, 8, 0, ~3, 4, ~2, 4, ~9, ~5, 7, 6, ~4, ~7, 2, 4, ~3, ~8, ~9, 9, 8, ~9, 3, ~7, 4, ~7, ~5, 4, 9, 3, ~6, ~3, ~7, 4, 2, ~2], + [~8, ~8, 6, ~2, ~6, 8, ~3, 3, ~1, ~7, 1, 9, 1, 7, ~6, 8, ~2, ~9, ~1, 3, ~4, 7, 8, ~1, 9, ~9, 6, ~3, 5, 0, 2, 5, ~1, ~6, ~6, 1, 8, 6, ~3, ~9, ~1, 9, ~2, 9, ~8, ~7, ~3, 6, ~3, ~3], + [ 5, ~2, 3, 0, ~9, ~8, ~6, 1, 8, 0, 1, 2, ~8, ~2, 0, ~9, ~8, 0, 5, ~3, ~4, 5, 6, ~2, ~5, 0, ~9, 9, ~9, ~5, 9, 9, ~5, ~2, 4, 3, 8, ~8, ~7, 5, ~3, ~2, 2, 3, 9, 7, ~1, 0, 4, ~1], + [~4, 5, ~5, 7, 8, 9, 7, ~3, 1, 9, ~7, ~1, 8, ~5, ~1, 2, ~8, 1, 0, 9, ~8, ~1, 6, ~1, 9, ~8, 7, 4, ~8, 7, 0, ~6, 2, 3, 7, 4, ~3, ~5, 9, ~3, 0, 6, ~9, 2, 4, ~8, 6, ~7, 9, 1], + [ 7, 0, ~9, 6, 8, 2, 2, 5, ~6, ~6, 9, ~5, 9, 2, 2, ~8, 0, ~6, ~9, ~6, ~4, ~9, 8, ~2, 9, 7, ~5, ~1, 7, 2, ~7, 7, ~1, ~3, 6, 6, 1, ~4, 0, ~1, ~6, ~5, 6, ~7, ~3, ~2, 8, 2, ~9, 8], + [ 8, ~7, ~9, ~6, 9, ~7, ~7, 6, ~8, 9, 5, ~4, 1, ~7, ~8, ~6, ~3, 8, ~8, 1, ~8, 6, 9, ~3, ~7, 7, 1, 6, 1, 0, 8, ~5, ~8, 8, ~9, 0, 4, 4, 3, ~4, 6, ~3, ~9, 0, 4, ~4, ~5, ~9, ~5, ~8], + [~3, ~2, 8, 1, ~1, ~1, ~4, 3, 7, ~2, ~9, 9, ~8, ~9, 6, ~4, 7, ~1, ~5, ~3, ~9, 0, ~3, 0, 7, 9, 1, ~2, 7, ~9, ~6, 3, 3, ~4, ~7, ~3, ~4, ~8, ~2, ~3, ~9, ~2, ~6, 3, ~6, ~4, 7, ~5, ~8, ~1], + [~9, ~9, ~2, ~9, ~9, 9, 6, 6, 7, 5, ~1, ~2, 1, 5, 2, ~3, ~4, 1, ~6, 0, ~3, ~9, ~1, 7, 0, ~9, 5, ~2, ~2, 5, 3, 4, ~1, 6, ~6, 3, ~6, 7, ~1, 5, ~8, ~4, ~2, ~2, ~6, ~5, ~6, 3, ~1, 4], + [ 7, 7, 8, 7, 6, 1, ~2, 5, ~6, 9, 4, 8, 5, 0, ~4, ~2, ~2, ~5, ~2, ~6, 9, ~8, ~2, ~5, ~9, 3, ~6, ~3, ~4, ~5, ~2, 6, 1, 6, ~5, 0, ~3, ~2, 4, ~6, 1, 6, ~1, 3, ~9, 2, ~3, 1, 5, ~6], + [ 6, 4, ~7, 3, ~7, 9, 1, ~7, ~8, 0, ~6, 8, 4, 1, 9, 6, 8, 3, 0, 9, 0, 4, 9, ~7, ~7, 1, 5, 1, ~5, 6, 9, 2, 4, 1, ~9, 8, 4, 5, 8, 3, 2, ~9, ~6, ~9, 9, ~9, 7, ~6, ~4, 3], + [~3, ~9, ~4, 2, 3, 9, ~9, 8, ~9, 9, ~4, ~9, ~5, 5, 0, 7, 3, ~5, ~8, 2, ~3, 0, ~9, ~3, 1, 9, 4, 5, ~1, 8, 0, ~4, ~2, 9, ~4, ~1, 3, 5, 9, ~1, 1, 4, ~8, ~2, ~3, 5, 1, 5, ~6, 7], + [ 9, ~3, 2, ~9, 3, 4, 0, 7, ~5, 9, 0, ~6, 7, ~2, 3, ~7, 2, ~5, ~2, 6, 3, ~9, ~5, ~9, 5, 2, ~5, ~3, 8, ~5, 6, 2, 9, ~7, ~7, ~7, ~6, 9, ~3, 6, 0, 6, ~6, ~9, 4, ~3, ~9, 0, ~4, ~9], + [~4, ~8, 8, ~7, 7, 0, ~6, ~6, 8, ~9, ~4, 5, ~3, ~1, 7, ~5, ~6, ~1, 8, 6, ~2, 1, ~1, 5, ~9, 1, ~1, ~7, ~6, ~6, ~6, ~4, 6, 3, ~5, ~5, ~6, 2, 3, ~6, ~8, ~3, 8, ~2, ~5, ~4, ~3, 1, 4, ~4], + [ 4, ~6, 2, 6, 2, ~8, 8, 5, 8, ~2, 0, ~6, ~1, ~6, ~2, 2, 6, ~9, ~7, ~6, ~4, ~4, ~7, ~2, 8, 6, 3, ~7, ~6, 8, 2, 3, 4, 5, 3, 4, ~6, 8, 8, ~1, 4, ~5, 6, 2, 8, ~3, ~9, ~2, 6, 7], + [ 3, ~4, 0, ~3, ~5, 0, ~2, ~6, ~2, 8, 5, ~9, ~4, ~8, ~6, 0, 8, 9, 1, ~2, 8, 2, ~2, 8, 9, 3, 3, 5, ~9, ~3, ~2, 7, 2, 9, 0, 4, 8, ~9, 0, ~6, 9, ~9, 9, ~4, 8, ~8, ~8, 2, ~3, 2], + [~1, 3, ~9, ~8, ~7, 6, ~6, 3, 0, 5, ~5, 1, 2, ~2, ~3, 7, 7, 3, ~4, ~2, ~9, ~5, ~1, 9, 6, 8, 2, 8, 7, ~3, 4, 6, 6, 0, ~2, 2, ~7, ~7, 6, ~3, 8, 2, 1, 0, 8, ~1, 3, 9, 8, 6], + [ 1, ~2, ~3, 6, 5, 5, ~6, ~4, ~5, 1, 1, 6, ~7, ~4, ~3, 4, 4, ~8, ~9, 7, ~2, ~3, ~7, ~2, 1, 2, 0, 8, ~6, ~5, ~5, 7, 8, 5, ~2, 3, 9, 0, 5, 1, 3, ~4, ~6, 1, 4, ~9, ~2, 5, 4, 3], + [ 3, 3, 9, ~2, 6, 9, 4, 9, 4, ~8, 5, ~1, 3, ~2, 1, ~7, ~3, 2, 2, 0, ~3, 3, 8, 2, 0, ~5, 7, 1, 4, ~8, 8, ~9, ~1, 1, ~9, ~4, 5, 2, 2, 8, 6, 1, 6, ~2, 2, 7, 1, ~6, ~1, ~1], + [ 4, ~2, 4, ~1, ~5, ~1, 5, ~2, 3, ~4, ~5, 0, 2, ~4, 6, 4, ~3, 2, 2, 5, ~6, ~7, ~9, ~1, ~9, ~9, 6, 0, 6, 5, 9, ~1, 3, ~3, ~8, 8, ~8, 8, 4, 5, ~1, ~5, 1, 0, 3, ~2, 5, 6, 6, 5], + [~4, 9, 6, 8, ~9, 5, 5, ~3, ~7, 7, 6, 8, ~8, 0, 4, ~1, 9, 5, ~7, 0, ~1, ~2, 3, 6, 0, 4, ~3, 1, 4, 6, 4, 0, 5, ~1, 7, ~7, ~6, ~8, ~3, ~6, 7, ~1, ~3, ~2, ~3, ~5, 3, 1, ~8, ~9], + [~6, 4, ~5, 9, 9, ~7, ~1, ~8, ~4, 2, ~6, 0, ~6, ~6, 7, 6, 0, 1, 7, ~7, 0, ~4, ~6, ~8, ~9, 5, ~6, ~9, 2, ~7, ~2, ~6, 9, 4, ~5, 0, 4, ~4, ~5, 6, 9, 1, ~6, ~5, 3, ~1, 7, ~7, ~6, 7], + [~8, 7, 7, ~6, 7, ~4, 8, 0, ~9, ~8, ~3, 7, ~3, 3, 8, ~7, ~2, ~7, 5, 5, ~5, 4, 6, 2, 4, 1, 4, ~9, ~3, 8, 8, ~9, ~4, ~2, 1, ~3, 1, 3, 9, ~5, ~8, ~2, 7, 8, 9, 2, 0, 1, ~9, 6], + [~7, 1, ~9, 5, ~5, ~5, 7, 6, ~5, ~9, ~6, ~8, ~6, 9, 7, 9, 0, ~5, 7, 7, ~6, 4, 5, ~9, ~1, ~2, ~7, 3, ~5, ~2, ~5, 5, ~3, ~4, ~2, ~8, 2, ~8, 0, ~8, 0, ~8, 9, 8, ~5, ~5, 1, 3, 5, ~4], + [~8, ~8, 0, ~5, ~8, ~6, 3, ~6, ~4, 6, 1, ~5, ~6, ~8, ~4, ~6, ~2, ~6, 6, ~4, 8, 8, 4, ~5, ~1, 0, 9, ~8, ~3, ~1, ~8, 7, ~3, 0, ~7, 1, ~7, ~1, ~7, 3, ~7, 3, ~4, ~8, 8, ~7, ~9, ~8, 3, 2], + [ 3, 6, 8, ~9, 7, 1, ~9, 9, 3, 8, 6, 4, ~2, 1, ~8, 4, ~7, ~4, ~3, 3, ~5, ~6, ~7, ~2, 0, ~4, 5, 2, 5, 6, 3, ~8, 2, ~5, ~7, 6, 8, ~2, ~5, ~4, 9, 9, 2, ~2, ~2, 7, 4, 4, ~2, 3], + [ 6, 6, ~5, ~2, ~8, ~2, ~9, 0, 2, 4, ~6, ~9, 9, 0, ~8, ~3, ~1, ~2, ~1, 6, 8, 2, ~9, 5, ~2, 1, 7, ~6, 5, 1, ~1, 4, ~4, ~7, ~6, ~3, ~8, 2, 2, 5, 5, ~6, 5, 3, 3, 7, 4, 7, ~3, ~9], + [~9, 6, ~4, 1, 3, ~8, ~8, ~8, ~1, 5, 1, 1, ~1, 6, 5, 1, ~1, 5, ~8, 8, ~7, ~5, ~1, ~1, 6, ~8, ~3, ~1, ~2, ~6, ~5, ~5, ~6, 0, 2, 2, 7, ~1, ~5, ~7, ~1, ~3, 7, 6, 0, 2, 4, ~5, 0, ~4]] + +fun f (x, y) = List.nth (List.nth (table, x), y) +fun show m = print (Matrix.toString (m, IntInf.toString)) +structure Main = + struct + fun snf() = + let val dim = 35 + val big = Matrix.map (Matrix.make (dim, dim, f), IntInf.fromInt) + val entry = Matrix.fetch(smithNormalForm big, dim - 1, dim - 1) +(* val _ = print (concat [IntInf.toString entry, "\n"]) *) + in if entry = valOf (IntInf.fromString + "~1027954043102083189860753402541358641712697245") + then () + else raise Fail "bug" + end + fun doit n = + let + val rec loop = + fn 0 => () + | n => (snf(); loop(n - 1)) + in loop n + end + end diff --git a/benchmark/tests/string-concat.sml b/benchmark/tests/string-concat.sml new file mode 100644 index 0000000..eb8d0b4 --- /dev/null +++ b/benchmark/tests/string-concat.sml @@ -0,0 +1,18 @@ +structure Main = + struct + val alpha = CharVector.tabulate (26, fn i => chr (ord #"A" + i)) + fun doit n = + let + val len = 2017 + val s = CharVector.tabulate (len, fn i => + String.sub (alpha, i mod 26)) + fun loop n = + if n < 0 + then () + else + if 468705 = CharVector.foldl (fn (c, s) => s + ord c) 0 (String.concat [s, s, s]) + then loop (n - 1) + else raise Fail "bug" + in loop (n * 10000) + end + end diff --git a/benchmark/tests/tailfib.sml b/benchmark/tests/tailfib.sml new file mode 100644 index 0000000..1efc267 --- /dev/null +++ b/benchmark/tests/tailfib.sml @@ -0,0 +1,23 @@ + +fun fib'(0,a,b) = a + | fib'(n,a,b) = fib'(n-1,a+b,a) +fun fib n = fib'(n,0,1) + +structure Main = + struct + fun doit() = + if 701408733 <> fib 44 + then raise Fail "bug" + else () + + val doit = + fn n => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop (n * 1000000) + end + end diff --git a/benchmark/tests/tak.sml b/benchmark/tests/tak.sml new file mode 100644 index 0000000..9bcf4ff --- /dev/null +++ b/benchmark/tests/tak.sml @@ -0,0 +1,15 @@ +fun tak (x,y,z) = + if not (y < x) + then z + else tak (tak (x - 1, y, z), + tak (y - 1, z, x), + tak (z - 1, x, y)) + +val rec f = + fn 0 => () + | n => (tak (33,22,11); f (n-1)) + +structure Main = + struct + val doit = f + end diff --git a/benchmark/tests/tensor.sml b/benchmark/tests/tensor.sml new file mode 100644 index 0000000..bb0adef --- /dev/null +++ b/benchmark/tests/tensor.sml @@ -0,0 +1,2971 @@ +(* Obtained at http://www.arrakis.es/~worm/ *) + +signature MONO_VECTOR = + sig + type vector + type elem + val maxLen : int + val fromList : elem list -> vector + val tabulate : (int * (int -> elem)) -> vector + val length : vector -> int + val sub : (vector * int) -> elem + val extract : (vector * int * int option) -> vector + val concat : vector list -> vector + val mapi : ((int * elem) -> elem) -> (vector * int * int option) -> vector + val map : (elem -> elem) -> vector -> vector + val appi : ((int * elem) -> unit) -> (vector * int * int option) -> unit + val app : (elem -> unit) -> vector -> unit + val foldli : ((int * elem * 'a) -> 'a) -> 'a -> (vector * int * int option) -> 'a + val foldri : ((int * elem * 'a) -> 'a) -> 'a -> (vector * int * int option) -> 'a + val foldl : ((elem * 'a) -> 'a) -> 'a -> vector -> 'a + val foldr : ((elem * 'a) -> 'a) -> 'a -> vector -> 'a + end + +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + + Refer to the COPYRIGHT file for license conditions +*) + +(* COPYRIGHT + +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. All advertising materials mentioning features or use of this + software must display the following acknowledgement: + This product includes software developed by Juan Jose + Garcia Ripoll. + +4. The name of Juan Jose Garcia Ripoll may not be used to endorse + or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY JUAN JOSE GARCIA RIPOLL ``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 HE 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. +*) + +structure EvalTimer = + struct + local + val TIME = ref (Time.now()) + in + fun timerOn () = + (TIME := Time.now(); ()) + fun timerRead () = + Time.toMilliseconds(Time.-(Time.now(),!TIME)) + fun timerOff () = + let val delta = timerRead() + in + print "Elapsed: "; + print (LargeInt.toString delta); + print " ms\n" + end + fun time f = (timerOn(); f(); timerOff()) + end + end +structure Loop = + struct + fun all (a, b, f) = + if a > b then + true + else if f a then + all (a+1, b, f) + else + false + + fun any (a, b, f) = + if a > b then + false + else if f a then + true + else + any (a+1, b, f) + + fun app (a, b, f) = + if a < b then + (f a; app (a+1, b, f)) + else + () + + fun app' (a, b, d, f) = + if a < b then + (f a; app' (a+d, b, d, f)) + else + () + + fun appi' (a, b, d, f) = + if a < b then + (f a; appi' (a+d, b, d, f)) + else + () + end +(* + INDEX -Signature- + + Indices are a enumerable finite set of data with an order and a map + to a continous nonnegative interval of integers. In the sample + implementation, Index, each index is a list of integers, + [i1,...,in] + and each set of indices is defined by a shape, which has the same + shape of an index but with each integer incremented by one + shape = [k1,...,kn] + 0 <= i1 < k1 + + type storage = RowMajor | ColumnMajor + order : storage + Identifies: + 1) the underlying algorithms for this structure + 2) the most significant index + 3) the index that varies more slowly + 4) the total order + RowMajor means that first index is most significant and varies + more slowly, while ColumnMajor means that last index is the most + significant and varies more slowly. For instance + RowMajor => [0,0]<[0,1]<[1,0]<[1,1] (C, C++, Pascal) + ColumnMajor => [0,0]>[1,0]>[0,1]>[1,1] (Fortran) + last shape + first shape + Returns the last/first index that belongs to the sed defined by + 'shape'. + inBounds shape index + Checkes whether 'index' belongs to the set defined by 'shape'. + toInt shape index + As we said, indices can be sorted and mapped to a finite set of + integers. 'toInt' obtaines the integer number that corresponds to + a certain index. + indexer shape + It is equivalent to the partial evaluation 'toInt shape' but + optimized for 'shape'. + + next shape index + prev shape index + next' shape index + prev' shape index + Obtain the following or previous index to the one we supply. + next and prev return an object of type 'index option' so that + if there is no such following/previous, the output is NONE. + On the other hand, next'/prev' raise an exception when the + output is not well defined and their output is always of type + index. next/prev/next'/prev' raise an exception if 'index' + does not belong to the set of 'shape'. + + all shape f + any shape f + app shape f + Iterates 'f' over every index of the set defined by 'shape'. + 'all' stops when 'f' first returns false, 'any' stops when + 'f' first returns true and 'app' does not stop and discards the + output of 'f'. + + compare(a,b) + Returns LESS/GREATER/EQUAL according to the total order which + is defined in the set of all indices. + <,>,eq,<=,>=,<> + Reduced comparisons which are defined in terms of 'compare'. + + validShape t + validIndex t + Checks whether 't' conforms a valid shape or index. + + iteri shape f +*) + +signature INDEX = + sig + type t + type indexer = t -> int + datatype storage = RowMajor | ColumnMajor + + exception Index + exception Shape + + val order : storage + val toInt : t -> t -> int + val length : t -> int + val first : t -> t + val last : t -> t + val next : t -> t -> t option + val prev : t -> t -> t option + val next' : t -> t -> t + val prev' : t -> t -> t + val indexer : t -> (t -> int) + + val inBounds : t -> t -> bool + val compare : t * t -> order + val < : t * t -> bool + val > : t * t -> bool + val eq : t * t -> bool + val <= : t * t -> bool + val >= : t * t -> bool + val <> : t * t -> bool + val - : t * t -> t + + val validShape : t -> bool + val validIndex : t -> bool + + val all : t -> (t -> bool) -> bool + val any : t -> (t -> bool) -> bool + val app : t -> (t -> unit) -> unit + end +structure Index : INDEX = + struct + type t = int list + type indexer = t -> int + datatype storage = RowMajor | ColumnMajor + + exception Index + exception Shape + + val order = ColumnMajor + + fun validShape shape = List.all (fn x => x > 0) shape + + fun validIndex index = List.all (fn x => x >= 0) index + + fun toInt shape index = + let fun loop ([], [], accum, _) = accum + | loop ([], _, _, _) = raise Index + | loop (_, [], _, _) = raise Index + | loop (i::ri, l::rl, accum, fac) = + if (i >= 0) andalso (i < l) then + loop (ri, rl, i*fac + accum, fac*l) + else + raise Index + in loop (index, shape, 0, 1) + end + + (* ----- CACHED LINEAR INDEXER ----- + + An indexer is a function that takes a list of + indices, validates it and produces a nonnegative + integer number. In short, the indexer is the + mapper from indices to element positions in + arrays. + + 'indexer' builds such a mapper by optimizing + the most common cases, which are 1d and 2d + tensors. + *) + local + fun doindexer [] _ = raise Shape + | doindexer [a] [dx] = + let fun f [x] = if (x > 0) andalso (x < a) + then x + else raise Index + | f _ = raise Index + in f end + | doindexer [a,b] [dx, dy] = + let fun f [x,y] = if ((x > 0) andalso (x < a) andalso + (y > 0) andalso (y < b)) + then x + dy * y + else raise Index + | f _ = raise Index + in f end + | doindexer [a,b,c] [dx,dy,dz] = + let fun f [x,y,z] = if ((x > 0) andalso (x < a) andalso + (y > 0) andalso (y < b) andalso + (z > 0) andalso (z < c)) + then x + dy * y + dz * z + else raise Index + | f _ = raise Index + in f end + | doindexer shape memo = + let fun f [] [] accum [] = accum + | f _ _ _ [] = raise Index + | f (fac::rf) (ndx::ri) accum (dim::rd) = + if (ndx >= 0) andalso (ndx < dim) then + f rf ri (accum + ndx * fac) rd + else + raise Index + in f shape memo 0 + end + in + fun indexer shape = + let fun memoize accum [] = [] + | memoize accum (dim::rd) = + accum :: (memoize (dim * accum) rd) + in + if validShape shape + then doindexer shape (memoize 1 shape) + else raise Shape + end + end + + fun length shape = + let fun prod (a,b) = + if b < 0 then raise Shape else a * b + in foldl prod 1 shape + end + + fun first shape = map (fn x => 0) shape + + fun last [] = [] + | last (size :: rest) = + if size < 1 + then raise Shape + else size - 1 :: last rest + + fun next' [] [] = raise Subscript + | next' _ [] = raise Index + | next' [] _ = raise Index + | next' (dimension::restd) (index::resti) = + if (index + 1) < dimension + then (index + 1) :: resti + else 0 :: (next' restd resti) + + fun prev' [] [] = raise Subscript + | prev' _ [] = raise Index + | prev' [] _ = raise Index + | prev' (dimension::restd) (index::resti) = + if (index > 0) + then index - 1 :: resti + else dimension - 1 :: prev' restd resti + + fun next shape index = (SOME (next' shape index)) handle + Subscript => NONE + + fun prev shape index = (SOME (prev' shape index)) handle + Subscript => NONE + + fun inBounds shape index = + ListPair.all (fn (x,y) => (x >= 0) andalso (x < y)) + (index, shape) + + fun compare ([],[]) = EQUAL + | compare (_, []) = raise Index + | compare ([],_) = raise Index + | compare (a::ra, b::rb) = + case Int.compare (a,b) of + EQUAL => compare (ra,rb) + | LESS => LESS + | GREATER => GREATER + + local + fun iterator a inner = + let fun loop accum f = + let fun innerloop i = + if i < a + then if inner (i::accum) f + then innerloop (i+1) + else false + else true + in innerloop 0 + end + in loop + end + fun build_iterator [a] = + let fun loop accum f = + let fun innerloop i = + if i < a + then if f (i::accum) + then innerloop (i+1) + else false + else true + in innerloop 0 + end + in loop + end + | build_iterator (a::rest) = iterator a (build_iterator rest) + in + fun all shape = build_iterator shape [] + end + + local + fun iterator a inner = + let fun loop accum f = + let fun innerloop i = + if i < a + then if inner (i::accum) f + then true + else innerloop (i+1) + else false + in innerloop 0 + end + in loop + end + fun build_iterator [a] = + let fun loop accum f = + let fun innerloop i = + if i < a + then if f (i::accum) + then true + else innerloop (i+1) + else false + in innerloop 0 + end + in loop + end + | build_iterator (a::rest) = iterator a (build_iterator rest) + in + fun any shape = build_iterator shape [] + end + + local + fun iterator a inner = + let fun loop accum f = + let fun innerloop i = + if i < a + then (inner (i::accum) f; + innerloop (i+1)) + else () + in innerloop 0 + end + in loop + end + fun build_iterator [a] = + let fun loop accum f = + let fun innerloop i = + if i < a + then (f (i::accum); innerloop (i+1)) + else () + in innerloop 0 + end + in loop + end + | build_iterator (a::rest) = iterator a (build_iterator rest) + in + fun app shape = build_iterator shape [] + end + + fun a < b = compare(a,b) = LESS + fun a > b = compare(a,b) = GREATER + fun eq (a, b) = compare(a,b) = EQUAL + fun a <> b = not (a = b) + fun a <= b = not (a > b) + fun a >= b = not (a < b) + fun a - b = ListPair.map Int.- (a,b) + + end +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + + Refer to the COPYRIGHT file for license conditions +*) + +(* + TENSOR - Signature - + + Polymorphic tensors of any type. With 'tensor' we denote a (mutable) + array of any rank, with as many indices as one wishes, and that may + be traversed (map, fold, etc) according to any of those indices. + + type 'a tensor + Polymorphic tensor whose elements are all of type 'a. + val storage = RowMajor | ColumnMajor + RowMajor = data is stored in consecutive cells, first index + varying fastest (FORTRAN convention) + ColumnMajor = data is stored in consecutive cells, last + index varying fastest (C,C++,Pascal,CommonLisp convention) + new ([i1,...,in],init) + Build a new tensor with n indices, each of sizes i1...in, + filled with 'init'. + fromArray (shape,data) + fromList (shape,data) + Use 'data' to fill a tensor of that shape. An exception is + raised if 'data' is too large or too small to properly + fill the vector. Later use of a 'data' array is disregarded + -- one must think that the tensor now owns the array. + length tensor + rank tensor + shape tensor + Return the number of elements, the number of indices and + the shape (size of each index) of the tensor. + toArray tensor + Return the data of the tensor in the form of an array. + Mutation of this array may lead to unexpected behavior. + + sub (tensor,[i1,...,in]) + update (tensor,[i1,...,in],new_value) + Access the element that is indexed by the numbers [i1,..,in] + + app f a + appi f a + The same as 'map' and 'mapi' but the function 'f' outputs + nothing and no new array is produced, i.e. one only seeks + the side effect that 'f' may produce. + map2 operation a b + Apply function 'f' to pairs of elements of 'a' and 'b' + and build a new tensor with the output. Both operands + must have the same shape or an exception is raised. + The procedure is sequential, as specified by 'storage'. + foldl operation a n + Fold-left the elements of tensor 'a' along the n-th + index. + all test a + any test a + Folded boolean tests on the elements of the tensor. +*) + +signature TENSOR = + sig + structure Array : ARRAY + structure Index : INDEX + type index = Index.t + type 'a tensor + + val new : index * 'a -> 'a tensor + val tabulate : index * (index -> 'a) -> 'a tensor + val length : 'a tensor -> int + val rank : 'a tensor -> int + val shape : 'a tensor -> (index) + val reshape : index -> 'a tensor -> 'a tensor + val fromList : index * 'a list -> 'a tensor + val fromArray : index * 'a array -> 'a tensor + val toArray : 'a tensor -> 'a array + + val sub : 'a tensor * index -> 'a + val update : 'a tensor * index * 'a -> unit + val map : ('a -> 'b) -> 'a tensor -> 'b tensor + val map2 : ('a * 'b -> 'c) -> 'a tensor -> 'b tensor -> 'c tensor + val app : ('a -> unit) -> 'a tensor -> unit + val appi : (int * 'a -> unit) -> 'a tensor -> unit + val foldl : ('c * 'a -> 'c) -> 'c -> 'a tensor -> int -> 'c tensor + val all : ('a -> bool) -> 'a tensor -> bool + val any : ('a -> bool) -> 'a tensor -> bool + end + +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + + Refer to the COPYRIGHT file for license conditions +*) + +structure Tensor : TENSOR = + struct + structure Array = Array + structure Index = Index + + type index = Index.t + type 'a tensor = {shape : index, indexer : Index.indexer, data : 'a array} + + exception Shape + exception Match + exception Index + + local + (*----- LOCALS -----*) + + fun make' (shape, data) = + {shape = shape, indexer = Index.indexer shape, data = data} + + fun toInt {shape, indexer, data} index = indexer index + + fun array_map f a = + let fun apply index = f(Array.sub(a,index)) in + Array.tabulate(Array.length a, apply) + end + + fun splitList (l as (a::rest), place) = + let fun loop (left,here,right) 0 = (List.rev left,here,right) + | loop (_,_,[]) place = raise Index + | loop (left,here,a::right) place = + loop (here::left,a,right) (place-1) + in + if place <= 0 then + loop ([],a,rest) (List.length rest - place) + else + loop ([],a,rest) (place - 1) + end + + in + (*----- STRUCTURAL OPERATIONS & QUERIES ------*) + + fun new (shape, init) = + if not (Index.validShape shape) then + raise Shape + else + let val length = Index.length shape in + {shape = shape, + indexer = Index.indexer shape, + data = Array.array(length,init)} + end + + fun toArray {shape, indexer, data} = data + + fun length {shape, indexer, data} = Array.length data + + fun shape {shape, indexer, data} = shape + + fun rank t = List.length (shape t) + + fun reshape new_shape tensor = + if Index.validShape new_shape then + case (Index.length new_shape) = length tensor of + true => make'(new_shape, toArray tensor) + | false => raise Match + else + raise Shape + + fun fromArray (s, a) = + case Index.validShape s andalso + ((Index.length s) = (Array.length a)) of + true => make'(s, a) + | false => raise Shape + + fun fromList (s, a) = fromArray (s, Array.fromList a) + + fun tabulate (shape,f) = + if Index.validShape shape then + let val last = Index.last shape + val length = Index.length shape + val c = Array.array(length, f last) + fun dotable (c, indices, i) = + (Array.update(c, i, f indices); + case i of + 0 => c + | i => dotable(c, Index.prev' shape indices, i-1)) + in + make'(shape,dotable(c, Index.prev' shape last, length-1)) + end + else + raise Shape + + (*----- ELEMENTWISE OPERATIONS -----*) + + fun sub (t, index) = Array.sub(#data t, toInt t index) + + fun update (t, index, value) = + Array.update(toArray t, toInt t index, value) + + fun map f {shape, indexer, data} = + {shape = shape, indexer = indexer, data = array_map f data} + + fun map2 f t1 t2= + let val {shape, indexer, data} = t1 + val {shape=shape2, indexer=indexer2, data=data2} = t2 + fun apply i = f (Array.sub(data,i), Array.sub(data2,i)) + val len = Array.length data + in + if Index.eq(shape, shape2) then + {shape = shape, + indexer = indexer, + data = Array.tabulate(len, apply)} + else + raise Match + end + + fun appi f tensor = Array.appi f (toArray tensor) + + fun app f tensor = Array.app f (toArray tensor) + + fun all f tensor = + let val a = toArray tensor + in Loop.all(0, length tensor - 1, fn i => + f (Array.sub(a, i))) + end + + fun any f tensor = + let val a = toArray tensor + in Loop.any(0, length tensor - 1, fn i => + f (Array.sub(a, i))) + end + + fun foldl f init {shape, indexer, data=a} index = + let val (head,lk,tail) = splitList(shape, index) + val li = Index.length head + val lj = Index.length tail + val c = Array.array(li * lj,init) + fun loopi (0, _, _) = () + | loopi (i, ia, ic) = + (Array.update(c, ic, f(Array.sub(c,ic), Array.sub(a,ia))); + loopi (i-1, ia+1, ic+1)) + fun loopk (0, ia, _) = ia + | loopk (k, ia, ic) = (loopi (li, ia, ic); + loopk (k-1, ia+li, ic)) + fun loopj (0, _, _) = () + | loopj (j, ia, ic) = loopj (j-1, loopk(lk,ia,ic), ic+li) + in + loopj (lj, 0, 0); + make'(head @ tail, c) + end + + end + end (* Tensor *) + +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + + Refer to the COPYRIGHT file for license conditions +*) + +(* + MONO_TENSOR - signature - + + Monomorphic tensor of arbitrary data (not only numbers). Operations + should be provided to run the data in several ways, according to one + index. + + type tensor + The type of the tensor itself + type elem + The type of every element + val storage = RowMajor | ColumnMajor + RowMajor = data is stored in consecutive cells, first index + varying fastest (FORTRAN convention) + ColumnMajor = data is stored in consecutive cells, last + index varying fastest (C,C++,Pascal,CommonLisp convention) + new ([i1,...,in],init) + Build a new tensor with n indices, each of sizes i1...in, + filled with 'init'. + fromArray (shape,data) + fromList (shape,data) + Use 'data' to fill a tensor of that shape. An exception is + raised if 'data' is too large or too small to properly + fill the vector. Later use of a 'data' array is disregarded + -- one must think that the tensor now owns the array. + length tensor + rank tensor + shape tensor + Return the number of elements, the number of indices and + the shape (size of each index) of the tensor. + toArray tensor + Return the data of the tensor in the form of an array. + Mutation of this array may lead to unexpected behavior. + The data in the array is stored according to `storage'. + + sub (tensor,[i1,...,in]) + update (tensor,[i1,...,in],new_value) + Access the element that is indexed by the numbers [i1,..,in] + + map f a + mapi f a + Produce a new array by mapping the function sequentially + as specified by 'storage', to each element of tensor 'a'. + In 'mapi' the function receives a (indices,value) tuple, + while in 'map' it only receives the value. + app f a + appi f a + The same as 'map' and 'mapi' but the function 'f' outputs + nothing and no new array is produced, i.e. one only seeks + the side effect that 'f' may produce. + map2 operation a b + Apply function 'f' to pairs of elements of 'a' and 'b' + and build a new tensor with the output. Both operands + must have the same shape or an exception is raised. + The procedure is sequential, as specified by 'storage'. + foldl operation a n + Fold-left the elements of tensor 'a' along the n-th + index. + all test a + any test a + Folded boolean tests on the elements of the tensor. + + map', map2', foldl' + Polymorphic versions of map, map2, foldl. +*) + +signature MONO_TENSOR = + sig + structure Array : MONO_ARRAY + structure Index : INDEX + type index = Index.t + type elem + type tensor + type t = tensor + + val new : index * elem -> tensor + val tabulate : index * (index -> elem) -> tensor + val length : tensor -> int + val rank : tensor -> int + val shape : tensor -> (index) + val reshape : index -> tensor -> tensor + val fromList : index * elem list -> tensor + val fromArray : index * Array.array -> tensor + val toArray : tensor -> Array.array + + val sub : tensor * index -> elem + val update : tensor * index * elem -> unit + val map : (elem -> elem) -> tensor -> tensor + val map2 : (elem * elem -> elem) -> tensor -> tensor -> tensor + val app : (elem -> unit) -> tensor -> unit + val appi : (int * elem -> unit) -> tensor -> unit + val foldl : (elem * 'a -> 'a) -> 'a -> tensor -> tensor + val foldln : (elem * elem -> elem) -> elem -> tensor -> int -> tensor + val all : (elem -> bool) -> tensor -> bool + val any : (elem -> bool) -> tensor -> bool + + val map' : (elem -> 'a) -> tensor -> 'a Tensor.tensor + val map2' : (elem * elem -> 'a) -> tensor -> tensor -> 'a Tensor.tensor + val foldl' : ('a * elem -> 'a) -> 'a -> tensor -> int -> 'a Tensor.tensor + end + +(* + NUMBER - Signature - + + Guarantees a structure with a minimal number of mathematical operations + so as to build an algebraic structure named Tensor. + *) + +signature NUMBER = + sig + type t + val zero : t + val one : t + val ~ : t -> t + val + : t * t -> t + val - : t * t -> t + val * : t * t -> t + val / : t * t -> t + val toString : t -> string + end + +signature NUMBER = + sig + type t + val zero : t + val one : t + + val + : t * t -> t + val - : t * t -> t + val * : t * t -> t + val *+ : t * t * t -> t + val *- : t * t * t -> t + val ** : t * int -> t + + val ~ : t -> t + val abs : t -> t + val signum : t -> t + + val == : t * t -> bool + val != : t * t -> bool + + val toString : t -> string + val fromInt : int -> t + val scan : (char,'a) StringCvt.reader -> (t,'a) StringCvt.reader + end + +signature INTEGRAL_NUMBER = + sig + include NUMBER + + val quot : t * t -> t + val rem : t * t -> t + val mod : t * t -> t + val div : t * t -> t + + val compare : t * t -> order + val < : t * t -> bool + val > : t * t -> bool + val <= : t * t -> bool + val >= : t * t -> bool + + val max : t * t -> t + val min : t * t -> t + end + +signature FRACTIONAL_NUMBER = + sig + include NUMBER + + val pi : t + val e : t + + val / : t * t -> t + val recip : t -> t + + val ln : t -> t + val pow : t * t -> t + val exp : t -> t + val sqrt : t -> t + + val cos : t -> t + val sin : t -> t + val tan : t -> t + val sinh : t -> t + val cosh : t -> t + val tanh : t -> t + + val acos : t -> t + val asin : t -> t + val atan : t -> t + val asinh : t -> t + val acosh : t -> t + val atanh : t -> t + val atan2 : t * t -> t + end + +signature REAL_NUMBER = + sig + include FRACTIONAL_NUMBER + + val compare : t * t -> order + val < : t * t -> bool + val > : t * t -> bool + val <= : t * t -> bool + val >= : t * t -> bool + + val max : t * t -> t + val min : t * t -> t + end + +signature COMPLEX_NUMBER = + sig + include FRACTIONAL_NUMBER + + structure Real : REAL_NUMBER + type real = Real.t + + val make : real * real -> t + val split : t -> real * real + val realPart : t -> real + val imagPart : t -> real + val abs2 : t -> real + end + +structure INumber : INTEGRAL_NUMBER = + struct + open Int + type t = Int.int + val zero = 0 + val one = 1 + + infix ** + fun i ** n = + let fun loop 0 = 1 + | loop 1 = i + | loop n = + let val x = loop (Int.div(n, 2)) + val m = Int.mod(n, 2) + in + if m = 0 then + x * x + else + x * x * i + end + in if n < 0 + then raise Domain + else loop n + end + + fun signum i = case compare(i, 0) of + GREATER => 1 + | EQUAL => 0 + | LESS => ~1 + + infix == + infix != + fun a == b = a = b + fun a != b = (a <> b) + fun *+(b,c,a) = b * c + a + fun *-(b,c,a) = b * c - b + + fun scan getc = Int.scan StringCvt.DEC getc + end + +structure RNumber : REAL_NUMBER = + struct + open Real + open Real.Math + type t = Real.real + val zero = 0.0 + val one = 1.0 + + fun signum x = case compare(x,0.0) of + LESS => ~1.0 + | GREATER => 1.0 + | EQUAL => 0.0 + + fun recip x = 1.0 / x + + infix ** + fun i ** n = + let fun loop 0 = one + | loop 1 = i + | loop n = + let val x = loop (Int.div(n, 2)) + val m = Int.mod(n, 2) + in + if m = 0 then + x * x + else + x * x * i + end + in if Int.<(n, 0) + then raise Domain + else loop n + end + + fun max (a, b) = if a < b then b else a + fun min (a, b) = if a < b then a else b + + fun asinh x = ln (x + sqrt(1.0 + x * x)) + fun acosh x = ln (x + (x + 1.0) * sqrt((x - 1.0)/(x + 1.0))) + fun atanh x = ln ((1.0 + x) / sqrt(1.0 - x * x)) + + end +(* + Complex(R) - Functor - + + Provides support for complex numbers based on tuples. Should be + highly efficient as most operations can be inlined. + *) + +structure CNumber : COMPLEX_NUMBER = +struct + structure Real = RNumber + + type t = Real.t * Real.t + type real = Real.t + + val zero = (0.0,0.0) + val one = (1.0,0.0) + val pi = (Real.pi, 0.0) + val e = (Real.e, 0.0) + + fun make (r,i) = (r,i) : t + fun split z = z + fun realPart (r,_) = r + fun imagPart (_,i) = i + + fun abs2 (r,i) = Real.+(Real.*(r,r),Real.*(i,i)) (* FIXME!!! *) + fun arg (r,i) = Real.atan2(i,r) + fun modulus z = Real.sqrt(abs2 z) + fun abs z = (modulus z, 0.0) + fun signum (z as (r,i)) = + let val m = modulus z + in (Real./(r,m), Real./(i,m)) + end + + fun ~ (r1,i1) = (Real.~ r1, Real.~ i1) + fun (r1,i1) + (r2,i2) = (Real.+(r1,r2), Real.+(i1,i2)) + fun (r1,i1) - (r2,i2) = (Real.-(r1,r2), Real.-(i1,i1)) + fun (r1,i1) * (r2,i2) = (Real.-(Real.*(r1,r2),Real.*(i1,i2)), + Real.+(Real.*(r1,i2),Real.*(r2,i1))) + fun (r1,i1) / (r2,i2) = + let val modulus = abs2(r2,i2) + val (nr,ni) = (r1,i1) * (r2,i2) + in + (Real./(nr,modulus), Real./(ni,modulus)) + end + fun *+((r1,i1),(r2,i2),(r0,i0)) = + (Real.*+(Real.~ i1, i2, Real.*+(r1,r2,r0)), + Real.*+(r2, i2, Real.*+(r1,i2,i0))) + fun *-((r1,i1),(r2,i2),(r0,i0)) = + (Real.*+(Real.~ i1, i2, Real.*-(r1,r2,r0)), + Real.*+(r2, i2, Real.*-(r1,i2,i0))) + + infix ** + fun i ** n = + let fun loop 0 = one + | loop 1 = i + | loop n = + let val x = loop (Int.div(n, 2)) + val m = Int.mod(n, 2) + in + if m = 0 then + x * x + else + x * x * i + end + in if Int.<(n, 0) + then raise Domain + else loop n + end + + fun recip (r1, i1) = + let val modulus = abs2(r1, i1) + in (Real./(r1, modulus), Real./(Real.~ i1, modulus)) + end + fun ==(z, w) = Real.==(realPart z, realPart w) andalso Real.==(imagPart z, imagPart w) + fun !=(z, w) = Real.!=(realPart z, realPart w) andalso Real.!=(imagPart z, imagPart w) + fun fromInt i = (Real.fromInt i, 0.0) + fun toString (r,i) = + String.concat ["(",Real.toString r,",",Real.toString i,")"] + + fun exp (x, y) = + let val expx = Real.exp x + in (Real.*(x, (Real.cos y)), Real.*(x, (Real.sin y))) + end + + local + val half = Real.recip (Real.fromInt 2) + in + fun sqrt (z as (x,y)) = + if Real.==(x, 0.0) andalso Real.==(y, 0.0) then + zero + else + let val m = Real.+(modulus z, Real.abs x) + val u' = Real.sqrt (Real.*(m, half)) + val v' = Real./(Real.abs y , Real.+(u',u')) + val (u,v) = if Real.<(x, 0.0) then (v',u') else (u',v') + in (u, if Real.<(y, 0.0) then Real.~ v else v) + end + end + fun ln z = (Real.ln (modulus z), arg z) + + fun pow (z, n) = + let val l = ln z + in exp (l * n) + end + + fun sin (x, y) = (Real.*(Real.sin x, Real.cosh y), + Real.*(Real.cos x, Real.sinh y)) + fun cos (x, y) = (Real.*(Real.cos x, Real.cosh y), + Real.~ (Real.*(Real.sin x, Real.sinh y))) + fun tan (x, y) = + let val (sx, cx) = (Real.sin x, Real.cos x) + val (shy, chy) = (Real.sinh y, Real.cosh y) + val a = (Real.*(sx, chy), Real.*(cx, shy)) + val b = (Real.*(cx, chy), Real.*(Real.~ sx, shy)) + in a / b + end + + fun sinh (x, y) = (Real.*(Real.cos y, Real.sinh x), + Real.*(Real.sin y, Real.cosh x)) + fun cosh (x, y) = (Real.*(Real.cos y, Real.cosh x), + Real.*(Real.sin y, Real.sinh x)) + fun tanh (x, y) = + let val (sy, cy) = (Real.sin y, Real.cos y) + val (shx, chx) = (Real.sinh x, Real.cosh x) + val a = (Real.*(cy, shx), Real.*(sy, chx)) + val b = (Real.*(cy, chx), Real.*(sy, shx)) + in a / b + end + + fun asin (z as (x,y)) = + let val w = sqrt (one - z * z) + val (x',y') = ln ((Real.~ y, x) + w) + in (y', Real.~ x') + end + + fun acos (z as (x,y)) = + let val (x', y') = sqrt (one + z * z) + val (x'', y'') = ln (z + (Real.~ y', x')) + in (y'', Real.~ x'') + end + + fun atan (z as (x,y)) = + let val w = sqrt (one + z*z) + val (x',y') = ln ((Real.-(1.0, y), x) / w) + in (y', Real.~ x') + end + + fun atan2 (y, x) = atan(y / x) + + fun asinh x = ln (x + sqrt(one + x * x)) + fun acosh x = ln (x + (x + one) * sqrt((x - one)/(x + one))) + fun atanh x = ln ((one + x) / sqrt(one - x * x)) + + fun scan getc = + let val scanner = Real.scan getc + in fn stream => + case scanner stream of + NONE => NONE + | SOME (a, rest) => + case scanner rest of + NONE => NONE + | SOME (b, rest) => SOME (make(a,b), rest) + end + +end (* ComplexNumber *) + +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + + Refer to the COPYRIGHT file for license conditions +*) + +structure INumberArray = + struct + open Array + type array = INumber.t array + type vector = INumber.t vector + type elem = INumber.t + structure Vector = + struct + open Vector + type vector = INumber.t Vector.vector + type elem = INumber.t + end + fun map f a = tabulate(length a, fn x => (f (sub(a,x)))) + fun mapi f a = tabulate(length a, fn x => (f (x,sub(a,x)))) + fun map2 f a b = tabulate(length a, fn x => (f(sub(a,x),sub(b,x)))) + end + +structure RNumberArray = + struct + open Real64Array + val sub = Unsafe.Real64Array.sub + val update = Unsafe.Real64Array.update + fun map f a = tabulate(length a, fn x => (f (sub(a,x)))) + fun mapi f a = tabulate(length a, fn x => (f (x,sub(a,x)))) + fun map2 f a b = tabulate(length a, fn x => (f(sub(a,x),sub(b,x)))) + end + +(*--------------------- COMPLEX ARRAY -------------------------*) + +structure BasicCNumberArray = +struct + structure Complex : COMPLEX_NUMBER = CNumber + structure Array : MONO_ARRAY = RNumberArray + + type elem = Complex.t + type array = Array.array * Array.array + + val maxLen = Array.maxLen + + fun length (a,b) = Array.length a + + fun sub ((a,b),index) = Complex.make(Array.sub(a,index),Array.sub(b,index)) + + fun update ((a,b),index,z) = + let val (re,im) = Complex.split z in + Array.update(a, index, re); + Array.update(b, index, im) + end + + local + fun makeRange (a, start, NONE) = makeRange(a, start, SOME (length a - 1)) + | makeRange (a, start, SOME last) = + let val len = length a + val diff = last - start + in + if (start >= len) orelse (last >= len) then + raise Subscript + else if diff < 0 then + (a, start, 0) + else + (a, start, diff + 1) + end + + in + + fun array (size,z:elem) = + let val realsize = size * 2 + val r = Complex.realPart z + val i = Complex.imagPart z in + (Array.array(size,r), Array.array(size,i)) + end + + fun zeroarray size = + (Array.array(size,Complex.Real.zero), + Array.array(size,Complex.Real.zero)) + + fun tabulate (size,f) = + let val a = array(size, Complex.zero) + fun loop i = + case i = size of + true => a + | false => (update(a, i, f i); loop (i+1)) + in + loop 0 + end + + fun fromList list = + let val length = List.length list + val a = zeroarray length + fun loop (_, []) = a + | loop (i, z::rest) = (update(a, i, z); + loop (i+1, rest)) + in + loop(0,list) + end + + fun extract range = + let val (a, start, len) = makeRange range + fun copy i = sub(a, i + start) + in tabulate(len, copy) + end + + fun concat array_list = + let val total_length = foldl (op +) 0 (map length array_list) + val a = array(total_length, Complex.zero) + fun copy (_, []) = a + | copy (pos, v::rest) = + let fun loop i = + case i = 0 of + true => () + | false => (update(a, i+pos, sub(v, i)); loop (i-1)) + in (loop (length v - 1); copy(length v + pos, rest)) + end + in + copy(0, array_list) + end + + fun copy {src : array, si : int, len : int option, dst : array, di : int } = + let val (a, ia, la) = makeRange (src, si, len) + val (b, ib, lb) = makeRange (dst, di, len) + fun copy i = + case i < 0 of + true => () + | false => (update(b, i+ib, sub(a, i+ia)); copy (i-1)) + in copy (la - 1) + end + + val copyVec = copy + + fun modifyi f range = + let val (a, start, len) = makeRange range + val last = start + len + fun loop i = + case i >= last of + true => () + | false => (update(a, i, f(i, sub(a,i))); loop (i+1)) + in loop start + end + + fun modify f a = + let val last = length a + fun loop i = + case i >= last of + true => () + | false => (update(a, i, f(sub(a,i))); loop (i+1)) + in loop 0 + end + + fun app f a = + let val size = length a + fun loop i = + case i = size of + true => () + | false => (f(sub(a,i)); loop (i+1)) + in + loop 0 + end + + fun appi f range = + let val (a, start, len) = makeRange range + val last = start + len + fun loop i = + case i >= last of + true => () + | false => (f(i, sub(a,i)); loop (i+1)) + in + loop start + end + + fun map f a = + let val len = length a + val c = zeroarray len + fun loop ~1 = c + | loop i = (update(a, i, f(sub(a,i))); loop (i-1)) + in loop (len-1) + end + + fun map2 f a b = + let val len = length a + val c = zeroarray len + fun loop ~1 = c + | loop i = (update(c, i, f(sub(a,i),sub(b,i))); + loop (i-1)) + in loop (len-1) + end + + fun mapi f range = + let val (a, start, len) = makeRange range + fun rule i = f (i+start, sub(a, i+start)) + in tabulate(len, rule) + end + + fun foldli f init range = + let val (a, start, len) = makeRange range + val last = start + len - 1 + fun loop (i, accum) = + case i > last of + true => accum + | false => loop (i+1, f(i, sub(a,i), accum)) + in loop (start, init) + end + + fun foldri f init range = + let val (a, start, len) = makeRange range + val last = start + len - 1 + fun loop (i, accum) = + case i < start of + true => accum + | false => loop (i-1, f(i, sub(a,i), accum)) + in loop (last, init) + end + + fun foldl f init a = foldli (fn (_, a, x) => f(a,x)) init (a,0,NONE) + fun foldr f init a = foldri (fn (_, x, a) => f(x,a)) init (a,0,NONE) + end +end (* BasicCNumberArray *) + + +structure CNumberArray = + struct + structure Vector = + struct + open BasicCNumberArray + type vector = array + end : MONO_VECTOR + type vector = Vector.vector + open BasicCNumberArray + end (* CNumberArray *) +structure INumber : INTEGRAL_NUMBER = + struct + open Int + type t = Int.int + val zero = 0 + val one = 1 + infix ** + fun i ** n = + let fun loop 0 = 1 + | loop 1 = i + | loop n = + let val x = loop (Int.div(n, 2)) + val m = Int.mod(n, 2) + in + if m = 0 then + x * x + else + x * x * i + end + in if n < 0 + then raise Domain + else loop n + end + fun signum i = case compare(i, 0) of + GREATER => 1 + | EQUAL => 0 + | LESS => ~1 + infix == + infix != + fun a == b = a = b + fun a != b = (a <> b) + fun *+(b,c,a) = b * c + a + fun *-(b,c,a) = b * c - b + fun scan getc = Int.scan StringCvt.DEC getc + end +structure RNumber : REAL_NUMBER = + struct + open Real + open Real.Math + type t = Real.real + val zero = 0.0 + val one = 1.0 + fun signum x = case compare(x,0.0) of + LESS => ~1.0 + | GREATER => 1.0 + | EQUAL => 0.0 + fun recip x = 1.0 / x + infix ** + fun i ** n = + let fun loop 0 = one + | loop 1 = i + | loop n = + let val x = loop (Int.div(n, 2)) + val m = Int.mod(n, 2) + in + if m = 0 then + x * x + else + x * x * i + end + in if Int.<(n, 0) + then raise Domain + else loop n + end + fun max (a, b) = if a < b then b else a + fun min (a, b) = if a < b then a else b + fun asinh x = ln (x + sqrt(1.0 + x * x)) + fun acosh x = ln (x + (x + 1.0) * sqrt((x - 1.0)/(x + 1.0))) + fun atanh x = ln ((1.0 + x) / sqrt(1.0 - x * x)) + end +(* + Complex(R) - Functor - + Provides support for complex numbers based on tuples. Should be + highly efficient as most operations can be inlined. + *) +structure CNumber : COMPLEX_NUMBER = +struct + structure Real = RNumber + type t = Real.t * Real.t + type real = Real.t + val zero = (0.0,0.0) + val one = (1.0,0.0) + val pi = (Real.pi, 0.0) + val e = (Real.e, 0.0) + fun make (r,i) = (r,i) : t + fun split z = z + fun realPart (r,_) = r + fun imagPart (_,i) = i + fun abs2 (r,i) = Real.+(Real.*(r,r),Real.*(i,i)) (* FIXME!!! *) + fun arg (r,i) = Real.atan2(i,r) + fun modulus z = Real.sqrt(abs2 z) + fun abs z = (modulus z, 0.0) + fun signum (z as (r,i)) = + let val m = modulus z + in (Real./(r,m), Real./(i,m)) + end + fun ~ (r1,i1) = (Real.~ r1, Real.~ i1) + fun (r1,i1) + (r2,i2) = (Real.+(r1,r2), Real.+(i1,i2)) + fun (r1,i1) - (r2,i2) = (Real.-(r1,r2), Real.-(i1,i1)) + fun (r1,i1) * (r2,i2) = (Real.-(Real.*(r1,r2),Real.*(i1,i2)), + Real.+(Real.*(r1,i2),Real.*(r2,i1))) + fun (r1,i1) / (r2,i2) = + let val modulus = abs2(r2,i2) + val (nr,ni) = (r1,i1) * (r2,i2) + in + (Real./(nr,modulus), Real./(ni,modulus)) + end + fun *+((r1,i1),(r2,i2),(r0,i0)) = + (Real.*+(Real.~ i1, i2, Real.*+(r1,r2,r0)), + Real.*+(r2, i2, Real.*+(r1,i2,i0))) + fun *-((r1,i1),(r2,i2),(r0,i0)) = + (Real.*+(Real.~ i1, i2, Real.*-(r1,r2,r0)), + Real.*+(r2, i2, Real.*-(r1,i2,i0))) + infix ** + fun i ** n = + let fun loop 0 = one + | loop 1 = i + | loop n = + let val x = loop (Int.div(n, 2)) + val m = Int.mod(n, 2) + in + if m = 0 then + x * x + else + x * x * i + end + in if Int.<(n, 0) + then raise Domain + else loop n + end + fun recip (r1, i1) = + let val modulus = abs2(r1, i1) + in (Real./(r1, modulus), Real./(Real.~ i1, modulus)) + end + fun ==(z, w) = Real.==(realPart z, realPart w) andalso Real.==(imagPart z, imagPart w) + fun !=(z, w) = Real.!=(realPart z, realPart w) andalso Real.!=(imagPart z, imagPart w) + fun fromInt i = (Real.fromInt i, 0.0) + fun toString (r,i) = + String.concat ["(",Real.toString r,",",Real.toString i,")"] + fun exp (x, y) = + let val expx = Real.exp x + in (Real.*(x, (Real.cos y)), Real.*(x, (Real.sin y))) + end + local + val half = Real.recip (Real.fromInt 2) + in + fun sqrt (z as (x,y)) = + if Real.==(x, 0.0) andalso Real.==(y, 0.0) then + zero + else + let val m = Real.+(modulus z, Real.abs x) + val u' = Real.sqrt (Real.*(m, half)) + val v' = Real./(Real.abs y , Real.+(u',u')) + val (u,v) = if Real.<(x, 0.0) then (v',u') else (u',v') + in (u, if Real.<(y, 0.0) then Real.~ v else v) + end + end + fun ln z = (Real.ln (modulus z), arg z) + fun pow (z, n) = + let val l = ln z + in exp (l * n) + end + fun sin (x, y) = (Real.*(Real.sin x, Real.cosh y), + Real.*(Real.cos x, Real.sinh y)) + fun cos (x, y) = (Real.*(Real.cos x, Real.cosh y), + Real.~ (Real.*(Real.sin x, Real.sinh y))) + fun tan (x, y) = + let val (sx, cx) = (Real.sin x, Real.cos x) + val (shy, chy) = (Real.sinh y, Real.cosh y) + val a = (Real.*(sx, chy), Real.*(cx, shy)) + val b = (Real.*(cx, chy), Real.*(Real.~ sx, shy)) + in a / b + end + fun sinh (x, y) = (Real.*(Real.cos y, Real.sinh x), + Real.*(Real.sin y, Real.cosh x)) + fun cosh (x, y) = (Real.*(Real.cos y, Real.cosh x), + Real.*(Real.sin y, Real.sinh x)) + fun tanh (x, y) = + let val (sy, cy) = (Real.sin y, Real.cos y) + val (shx, chx) = (Real.sinh x, Real.cosh x) + val a = (Real.*(cy, shx), Real.*(sy, chx)) + val b = (Real.*(cy, chx), Real.*(sy, shx)) + in a / b + end + fun asin (z as (x,y)) = + let val w = sqrt (one - z * z) + val (x',y') = ln ((Real.~ y, x) + w) + in (y', Real.~ x') + end + fun acos (z as (x,y)) = + let val (x', y') = sqrt (one + z * z) + val (x'', y'') = ln (z + (Real.~ y', x')) + in (y'', Real.~ x'') + end + fun atan (z as (x,y)) = + let val w = sqrt (one + z*z) + val (x',y') = ln ((Real.-(1.0, y), x) / w) + in (y', Real.~ x') + end + fun atan2 (y, x) = atan(y / x) + fun asinh x = ln (x + sqrt(one + x * x)) + fun acosh x = ln (x + (x + one) * sqrt((x - one)/(x + one))) + fun atanh x = ln ((one + x) / sqrt(one - x * x)) + fun scan getc = + let val scanner = Real.scan getc + in fn stream => + case scanner stream of + NONE => NONE + | SOME (a, rest) => + case scanner rest of + NONE => NONE + | SOME (b, rest) => SOME (make(a,b), rest) + end +end (* ComplexNumber *) +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + Refer to the COPYRIGHT file for license conditions +*) +structure PrettyPrint :> + sig + datatype modifier = + Int of int | + Real of real | + Complex of CNumber.t | + String of string + val list : ('a -> string) -> 'a list -> unit + val intList : int list -> unit + val realList : real list -> unit + val stringList : string list -> unit + val array : ('a -> string) -> 'a array -> unit + val intArray : int array -> unit + val realArray : real array -> unit + val stringArray : string array -> unit + val sequence : + int -> ((int * 'a -> unit) -> 'b -> unit) -> ('a -> string) -> 'b -> unit + val print : modifier list -> unit + end = +struct + datatype modifier = + Int of int | + Real of real | + Complex of CNumber.t | + String of string + fun list _ [] = print "[]" + | list cvt (a::resta) = + let fun loop a [] = (print(cvt a); print "]") + | loop a (b::restb) = (print(cvt a); print ", "; loop b restb) + in + print "["; + loop a resta + end + fun boolList a = list Bool.toString a + fun intList a = list Int.toString a + fun realList a = list Real.toString a + fun stringList a = list (fn x => x) a + fun array cvt a = + let val length = Array.length a - 1 + fun print_one (i,x) = + (print(cvt x); if not(i = length) then print ", " else ()) + in + Array.appi print_one a + end + fun boolArray a = array Bool.toString a + fun intArray a = array Int.toString a + fun realArray a = array Real.toString a + fun stringArray a = array (fn x => x) a + fun sequence length appi cvt seq = + let val length = length - 1 + fun print_one (i:int,x) = + (print(cvt x); if not(i = length) then print ", " else ()) + in + print "["; + appi print_one seq; + print "]\n" + end + fun print b = + let fun printer (Int a) = INumber.toString a + | printer (Real a) = RNumber.toString a + | printer (Complex a) = CNumber.toString a + | printer (String a) = a + in List.app (fn x => (TextIO.print (printer x))) b + end +end (* PrettyPrint *) +fun print' x = List.app print x +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + Refer to the COPYRIGHT file for license conditions +*) +structure INumberArray = + struct + open Array + type array = INumber.t array + type vector = INumber.t vector + type elem = INumber.t + structure Vector = + struct + open Vector + type vector = INumber.t Vector.vector + type elem = INumber.t + end + fun map f a = tabulate(length a, fn x => (f (sub(a,x)))) + fun mapi f a = tabulate(length a, fn x => (f (x,sub(a,x)))) + fun map2 f a b = tabulate(length a, fn x => (f(sub(a,x),sub(b,x)))) + end +structure RNumberArray = + struct + open Real64Array + val sub = Unsafe.Real64Array.sub + val update = Unsafe.Real64Array.update + fun map f a = tabulate(length a, fn x => (f (sub(a,x)))) + fun mapi f a = tabulate(length a, fn x => (f (x,sub(a,x)))) + fun map2 f a b = tabulate(length a, fn x => (f(sub(a,x),sub(b,x)))) + end +(*--------------------- COMPLEX ARRAY -------------------------*) +structure BasicCNumberArray = +struct + structure Complex : COMPLEX_NUMBER = CNumber + structure Array : MONO_ARRAY = RNumberArray + type elem = Complex.t + type array = Array.array * Array.array + val maxLen = Array.maxLen + fun length (a,b) = Array.length a + fun sub ((a,b),index) = Complex.make(Array.sub(a,index),Array.sub(b,index)) + fun update ((a,b),index,z) = + let val (re,im) = Complex.split z in + Array.update(a, index, re); + Array.update(b, index, im) + end + local + fun makeRange (a, start, NONE) = makeRange(a, start, SOME (length a - 1)) + | makeRange (a, start, SOME last) = + let val len = length a + val diff = last - start + in + if (start >= len) orelse (last >= len) then + raise Subscript + else if diff < 0 then + (a, start, 0) + else + (a, start, diff + 1) + end + in + fun array (size,z:elem) = + let val realsize = size * 2 + val r = Complex.realPart z + val i = Complex.imagPart z in + (Array.array(size,r), Array.array(size,i)) + end + fun zeroarray size = + (Array.array(size,Complex.Real.zero), + Array.array(size,Complex.Real.zero)) + fun tabulate (size,f) = + let val a = array(size, Complex.zero) + fun loop i = + case i = size of + true => a + | false => (update(a, i, f i); loop (i+1)) + in + loop 0 + end + fun fromList list = + let val length = List.length list + val a = zeroarray length + fun loop (_, []) = a + | loop (i, z::rest) = (update(a, i, z); + loop (i+1, rest)) + in + loop(0,list) + end + fun extract range = + let val (a, start, len) = makeRange range + fun copy i = sub(a, i + start) + in tabulate(len, copy) + end + fun concat array_list = + let val total_length = foldl (op +) 0 (map length array_list) + val a = array(total_length, Complex.zero) + fun copy (_, []) = a + | copy (pos, v::rest) = + let fun loop i = + case i = 0 of + true => () + | false => (update(a, i+pos, sub(v, i)); loop (i-1)) + in (loop (length v - 1); copy(length v + pos, rest)) + end + in + copy(0, array_list) + end + fun copy {src : array, si : int, len : int option, dst : array, di : int } = + let val (a, ia, la) = makeRange (src, si, len) + val (b, ib, lb) = makeRange (dst, di, len) + fun copy i = + case i < 0 of + true => () + | false => (update(b, i+ib, sub(a, i+ia)); copy (i-1)) + in copy (la - 1) + end + val copyVec = copy + fun modifyi f range = + let val (a, start, len) = makeRange range + val last = start + len + fun loop i = + case i >= last of + true => () + | false => (update(a, i, f(i, sub(a,i))); loop (i+1)) + in loop start + end + fun modify f a = + let val last = length a + fun loop i = + case i >= last of + true => () + | false => (update(a, i, f(sub(a,i))); loop (i+1)) + in loop 0 + end + fun app f a = + let val size = length a + fun loop i = + case i = size of + true => () + | false => (f(sub(a,i)); loop (i+1)) + in + loop 0 + end + fun appi f range = + let val (a, start, len) = makeRange range + val last = start + len + fun loop i = + case i >= last of + true => () + | false => (f(i, sub(a,i)); loop (i+1)) + in + loop start + end + fun map f a = + let val len = length a + val c = zeroarray len + fun loop ~1 = c + | loop i = (update(a, i, f(sub(a,i))); loop (i-1)) + in loop (len-1) + end + fun map2 f a b = + let val len = length a + val c = zeroarray len + fun loop ~1 = c + | loop i = (update(c, i, f(sub(a,i),sub(b,i))); + loop (i-1)) + in loop (len-1) + end + fun mapi f range = + let val (a, start, len) = makeRange range + fun rule i = f (i+start, sub(a, i+start)) + in tabulate(len, rule) + end + fun foldli f init range = + let val (a, start, len) = makeRange range + val last = start + len - 1 + fun loop (i, accum) = + case i > last of + true => accum + | false => loop (i+1, f(i, sub(a,i), accum)) + in loop (start, init) + end + fun foldri f init range = + let val (a, start, len) = makeRange range + val last = start + len - 1 + fun loop (i, accum) = + case i < start of + true => accum + | false => loop (i-1, f(i, sub(a,i), accum)) + in loop (last, init) + end + fun foldl f init a = foldli (fn (_, a, x) => f(a,x)) init (a,0,NONE) + fun foldr f init a = foldri (fn (_, x, a) => f(x,a)) init (a,0,NONE) + end +end (* BasicCNumberArray *) +structure CNumberArray = + struct + structure Vector = + struct + open BasicCNumberArray + type vector = array + end : MONO_VECTOR + type vector = Vector.vector + open BasicCNumberArray + end (* CNumberArray *) +structure ITensor = + struct + structure Number = INumber + structure Array = INumberArray +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + Refer to the COPYRIGHT file for license conditions +*) +structure MonoTensor = + struct +(* PARAMETERS + structure Array = Array +*) + structure Index = Index + type elem = Array.elem + type index = Index.t + type tensor = {shape : index, indexer : Index.indexer, data : Array.array} + type t = tensor + exception Shape + exception Match + exception Index + local + (*----- LOCALS -----*) + fun make' (shape, data) = + {shape = shape, indexer = Index.indexer shape, data = data} + fun toInt {shape, indexer, data} index = indexer index + fun splitList (l as (a::rest), place) = + let fun loop (left,here,right) 0 = (List.rev left,here,right) + | loop (_,_,[]) place = raise Index + | loop (left,here,a::right) place = + loop (here::left,a,right) (place-1) + in + if place <= 0 then + loop ([],a,rest) (List.length rest - place) + else + loop ([],a,rest) (place - 1) + end + in + (*----- STRUCTURAL OPERATIONS & QUERIES ------*) + fun new (shape, init) = + if not (Index.validShape shape) then + raise Shape + else + let val length = Index.length shape in + {shape = shape, + indexer = Index.indexer shape, + data = Array.array(length,init)} + end + fun toArray {shape, indexer, data} = data + fun length {shape, indexer, data} = Array.length data + fun shape {shape, indexer, data} = shape + fun rank t = List.length (shape t) + fun reshape new_shape tensor = + if Index.validShape new_shape then + case (Index.length new_shape) = length tensor of + true => make'(new_shape, toArray tensor) + | false => raise Match + else + raise Shape + fun fromArray (s, a) = + case Index.validShape s andalso + ((Index.length s) = (Array.length a)) of + true => make'(s, a) + | false => raise Shape + fun fromList (s, a) = fromArray (s, Array.fromList a) + fun tabulate (shape,f) = + if Index.validShape shape then + let val last = Index.last shape + val length = Index.length shape + val c = Array.array(length, f last) + fun dotable (c, indices, i) = + (Array.update(c, i, f indices); + if i <= 1 + then c + else dotable(c, Index.prev' shape indices, i-1)) + in make'(shape,dotable(c, Index.prev' shape last, length-2)) + end + else + raise Shape + (*----- ELEMENTWISE OPERATIONS -----*) + fun sub (t, index) = Array.sub(#data t, toInt t index) + fun update (t, index, value) = + Array.update(toArray t, toInt t index, value) + fun map f {shape, indexer, data} = + {shape = shape, indexer = indexer, data = Array.map f data} + fun map2 f t1 t2= + let val {shape=shape1, indexer=indexer1, data=data1} = t1 + val {shape=shape2, indexer=indexer2, data=data2} = t2 + in + if Index.eq(shape1,shape2) then + {shape = shape1, + indexer = indexer1, + data = Array.map2 f data1 data2} + else + raise Match + end + fun appi f tensor = Array.appi f (toArray tensor) + fun app f tensor = Array.app f (toArray tensor) + fun all f tensor = + let val a = toArray tensor + in Loop.all(0, length tensor - 1, fn i => + f (Array.sub(a, i))) + end + fun any f tensor = + let val a = toArray tensor + in Loop.any(0, length tensor - 1, fn i => + f (Array.sub(a, i))) + end + fun foldl f init tensor = Array.foldl f init (toArray tensor) + fun foldln f init {shape, indexer, data=a} index = + let val (head,lk,tail) = splitList(shape, index) + val li = Index.length head + val lj = Index.length tail + val c = Array.array(li * lj,init) + fun loopi (0, _, _) = () + | loopi (i, ia, ic) = + (Array.update(c, ic, f(Array.sub(c,ic), Array.sub(a,ia))); + loopi (i-1, ia+1, ic+1)) + fun loopk (0, ia, _) = ia + | loopk (k, ia, ic) = (loopi (li, ia, ic); + loopk (k-1, ia+li, ic)) + fun loopj (0, _, _) = () + | loopj (j, ia, ic) = loopj (j-1, loopk(lk,ia,ic), ic+li) + in + loopj (lj, 0, 0); + make'(head @ tail, c) + end + (* --- POLYMORPHIC ELEMENTWISE OPERATIONS --- *) + fun array_map' f a = + let fun apply index = f(Array.sub(a,index)) in + Tensor.Array.tabulate(Array.length a, apply) + end + fun map' f t = Tensor.fromArray(shape t, array_map' f (toArray t)) + fun map2' f t1 t2 = + let val d1 = toArray t1 + val d2 = toArray t2 + fun apply i = f (Array.sub(d1,i), Array.sub(d2,i)) + val len = Array.length d1 + in + if Index.eq(shape t1, shape t2) then + Tensor.fromArray(shape t1, Tensor.Array.tabulate(len,apply)) + else + raise Match + end + fun foldl' f init {shape, indexer, data=a} index = + let val (head,lk,tail) = splitList(shape, index) + val li = Index.length head + val lj = Index.length tail + val c = Tensor.Array.array(li * lj,init) + fun loopi (0, _, _) = () + | loopi (i, ia, ic) = + (Tensor.Array.update(c,ic,f(Tensor.Array.sub(c,ic),Array.sub(a,ia))); + loopi (i-1, ia+1, ic+1)) + fun loopk (0, ia, _) = ia + | loopk (k, ia, ic) = (loopi (li, ia, ic); + loopk (k-1, ia+li, ic)) + fun loopj (0, _, _) = () + | loopj (j, ia, ic) = loopj (j-1, loopk(lk,ia,ic), ic+li) + in + loopj (lj, 0, 0); + make'(head @ tail, c) + end + end + end (* MonoTensor *) + open MonoTensor + local + (* + LEFT INDEX CONTRACTION: + a = a(i1,i2,...,in) + b = b(j1,j2,...,jn) + c = c(i2,...,in,j2,...,jn) + = sum(a(k,i2,...,jn)*b(k,j2,...jn)) forall k + MEANINGFUL VARIABLES: + lk = i1 = j1 + li = i2*...*in + lj = j2*...*jn + *) + fun do_fold_first a b c lk lj li = + let fun loopk (0, _, _, accum) = accum + | loopk (k, ia, ib, accum) = + let val delta = Number.*(Array.sub(a,ia),Array.sub(b,ib)) + in loopk (k-1, ia+1, ib+1, Number.+(delta,accum)) + end + fun loopj (0, ib, ic) = c + | loopj (j, ib, ic) = + let fun loopi (0, ia, ic) = ic + | loopi (i, ia, ic) = + (Array.update(c, ic, loopk(lk, ia, ib, Number.zero)); + loopi(i-1, ia+lk, ic+1)) + in + loopj(j-1, ib+lk, loopi(li, 0, ic)) + end + in loopj(lj, 0, 0) + end + in + fun +* ta tb = + let val (rank_a,lk::rest_a,a) = (rank ta, shape ta, toArray ta) + val (rank_b,lk2::rest_b,b) = (rank tb, shape tb, toArray tb) + in if not(lk = lk2) + then raise Match + else let val li = Index.length rest_a + val lj = Index.length rest_b + val c = Array.array(li*lj,Number.zero) + in fromArray(rest_a @ rest_b, + do_fold_first a b c lk li lj) + end + end + end + local + (* + LAST INDEX CONTRACTION: + a = a(i1,i2,...,in) + b = b(j1,j2,...,jn) + c = c(i2,...,in,j2,...,jn) + = sum(mult(a(i1,i2,...,k),b(j1,j2,...,k))) forall k + MEANINGFUL VARIABLES: + lk = in = jn + li = i1*...*i(n-1) + lj = j1*...*j(n-1) + *) + fun do_fold_last a b c lk lj li = + let fun loopi (0, ia, ic, fac) = () + | loopi (i, ia, ic, fac) = + let val old = Array.sub(c,ic) + val inc = Number.*(Array.sub(a,ia),fac) + in + Array.update(c,ic,Number.+(old,inc)); + loopi(i-1, ia+1, ic+1, fac) + end + fun loopj (j, ib, ic) = + let fun loopk (0, ia, ib) = () + | loopk (k, ia, ib) = + (loopi(li, ia, ic, Array.sub(b,ib)); + loopk(k-1, ia+li, ib+lj)) + in case j of + 0 => c + | _ => (loopk(lk, 0, ib); + loopj(j-1, ib+1, ic+li)) + end (* loopj *) + in + loopj(lj, 0, 0) + end + in + fun *+ ta tb = + let val (rank_a,shape_a,a) = (rank ta, shape ta, toArray ta) + val (rank_b,shape_b,b) = (rank tb, shape tb, toArray tb) + val (lk::rest_a) = List.rev shape_a + val (lk2::rest_b) = List.rev shape_b + in if not(lk = lk2) + then raise Match + else let val li = Index.length rest_a + val lj = Index.length rest_b + val c = Array.array(li*lj,Number.zero) + in fromArray(List.rev rest_a @ List.rev rest_b, + do_fold_last a b c lk li lj) + end + end + end + (* ALGEBRAIC OPERATIONS *) + infix ** + infix == + infix != + fun a + b = map2 Number.+ a b + fun a - b = map2 Number.- a b + fun a * b = map2 Number.* a b + fun a ** i = map (fn x => (Number.**(x,i))) a + fun ~ a = map Number.~ a + fun abs a = map Number.abs a + fun signum a = map Number.signum a + fun a == b = map2' Number.== a b + fun a != b = map2' Number.!= a b + fun toString a = raise Domain + fun fromInt a = new([1], Number.fromInt a) + (* TENSOR SPECIFIC OPERATIONS *) + fun *> n = map (fn x => Number.*(n,x)) + fun print t = + (PrettyPrint.intList (shape t); + TextIO.print "\n"; + PrettyPrint.sequence (length t) appi Number.toString t) + fun normInf a = + let fun accum (y,x) = Number.max(x,Number.abs y) + in foldl accum Number.zero a + end + end (* NumberTensor *) +structure RTensor = + struct + structure Number = RNumber + structure Array = RNumberArray +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + Refer to the COPYRIGHT file for license conditions +*) +structure MonoTensor = + struct +(* PARAMETERS + structure Array = Array +*) + structure Index = Index + type elem = Array.elem + type index = Index.t + type tensor = {shape : index, indexer : Index.indexer, data : Array.array} + type t = tensor + exception Shape + exception Match + exception Index + local + (*----- LOCALS -----*) + fun make' (shape, data) = + {shape = shape, indexer = Index.indexer shape, data = data} + fun toInt {shape, indexer, data} index = indexer index + fun splitList (l as (a::rest), place) = + let fun loop (left,here,right) 0 = (List.rev left,here,right) + | loop (_,_,[]) place = raise Index + | loop (left,here,a::right) place = + loop (here::left,a,right) (place-1) + in + if place <= 0 then + loop ([],a,rest) (List.length rest - place) + else + loop ([],a,rest) (place - 1) + end + in + (*----- STRUCTURAL OPERATIONS & QUERIES ------*) + fun new (shape, init) = + if not (Index.validShape shape) then + raise Shape + else + let val length = Index.length shape in + {shape = shape, + indexer = Index.indexer shape, + data = Array.array(length,init)} + end + fun toArray {shape, indexer, data} = data + fun length {shape, indexer, data} = Array.length data + fun shape {shape, indexer, data} = shape + fun rank t = List.length (shape t) + fun reshape new_shape tensor = + if Index.validShape new_shape then + case (Index.length new_shape) = length tensor of + true => make'(new_shape, toArray tensor) + | false => raise Match + else + raise Shape + fun fromArray (s, a) = + case Index.validShape s andalso + ((Index.length s) = (Array.length a)) of + true => make'(s, a) + | false => raise Shape + fun fromList (s, a) = fromArray (s, Array.fromList a) + fun tabulate (shape,f) = + if Index.validShape shape then + let val last = Index.last shape + val length = Index.length shape + val c = Array.array(length, f last) + fun dotable (c, indices, i) = + (Array.update(c, i, f indices); + if i <= 1 + then c + else dotable(c, Index.prev' shape indices, i-1)) + in make'(shape,dotable(c, Index.prev' shape last, length-2)) + end + else + raise Shape + (*----- ELEMENTWISE OPERATIONS -----*) + fun sub (t, index) = Array.sub(#data t, toInt t index) + fun update (t, index, value) = + Array.update(toArray t, toInt t index, value) + fun map f {shape, indexer, data} = + {shape = shape, indexer = indexer, data = Array.map f data} + fun map2 f t1 t2= + let val {shape=shape1, indexer=indexer1, data=data1} = t1 + val {shape=shape2, indexer=indexer2, data=data2} = t2 + in + if Index.eq(shape1,shape2) then + {shape = shape1, + indexer = indexer1, + data = Array.map2 f data1 data2} + else + raise Match + end + fun appi f tensor = Array.appi f (toArray tensor) + fun app f tensor = Array.app f (toArray tensor) + fun all f tensor = + let val a = toArray tensor + in Loop.all(0, length tensor - 1, fn i => + f (Array.sub(a, i))) + end + fun any f tensor = + let val a = toArray tensor + in Loop.any(0, length tensor - 1, fn i => + f (Array.sub(a, i))) + end + fun foldl f init tensor = Array.foldl f init (toArray tensor) + fun foldln f init {shape, indexer, data=a} index = + let val (head,lk,tail) = splitList(shape, index) + val li = Index.length head + val lj = Index.length tail + val c = Array.array(li * lj,init) + fun loopi (0, _, _) = () + | loopi (i, ia, ic) = + (Array.update(c, ic, f(Array.sub(c,ic), Array.sub(a,ia))); + loopi (i-1, ia+1, ic+1)) + fun loopk (0, ia, _) = ia + | loopk (k, ia, ic) = (loopi (li, ia, ic); + loopk (k-1, ia+li, ic)) + fun loopj (0, _, _) = () + | loopj (j, ia, ic) = loopj (j-1, loopk(lk,ia,ic), ic+li) + in + loopj (lj, 0, 0); + make'(head @ tail, c) + end + (* --- POLYMORPHIC ELEMENTWISE OPERATIONS --- *) + fun array_map' f a = + let fun apply index = f(Array.sub(a,index)) in + Tensor.Array.tabulate(Array.length a, apply) + end + fun map' f t = Tensor.fromArray(shape t, array_map' f (toArray t)) + fun map2' f t1 t2 = + let val d1 = toArray t1 + val d2 = toArray t2 + fun apply i = f (Array.sub(d1,i), Array.sub(d2,i)) + val len = Array.length d1 + in + if Index.eq(shape t1, shape t2) then + Tensor.fromArray(shape t1, Tensor.Array.tabulate(len,apply)) + else + raise Match + end + fun foldl' f init {shape, indexer, data=a} index = + let val (head,lk,tail) = splitList(shape, index) + val li = Index.length head + val lj = Index.length tail + val c = Tensor.Array.array(li * lj,init) + fun loopi (0, _, _) = () + | loopi (i, ia, ic) = + (Tensor.Array.update(c,ic,f(Tensor.Array.sub(c,ic),Array.sub(a,ia))); + loopi (i-1, ia+1, ic+1)) + fun loopk (0, ia, _) = ia + | loopk (k, ia, ic) = (loopi (li, ia, ic); + loopk (k-1, ia+li, ic)) + fun loopj (0, _, _) = () + | loopj (j, ia, ic) = loopj (j-1, loopk(lk,ia,ic), ic+li) + in + loopj (lj, 0, 0); + make'(head @ tail, c) + end + end + end (* MonoTensor *) + open MonoTensor + local + (* + LEFT INDEX CONTRACTION: + a = a(i1,i2,...,in) + b = b(j1,j2,...,jn) + c = c(i2,...,in,j2,...,jn) + = sum(a(k,i2,...,jn)*b(k,j2,...jn)) forall k + MEANINGFUL VARIABLES: + lk = i1 = j1 + li = i2*...*in + lj = j2*...*jn + *) + fun do_fold_first a b c lk lj li = + let fun loopk (0, _, _, accum) = accum + | loopk (k, ia, ib, accum) = + let val delta = Number.*(Array.sub(a,ia),Array.sub(b,ib)) + in loopk (k-1, ia+1, ib+1, Number.+(delta,accum)) + end + fun loopj (0, ib, ic) = c + | loopj (j, ib, ic) = + let fun loopi (0, ia, ic) = ic + | loopi (i, ia, ic) = + (Array.update(c, ic, loopk(lk, ia, ib, Number.zero)); + loopi(i-1, ia+lk, ic+1)) + in + loopj(j-1, ib+lk, loopi(li, 0, ic)) + end + in loopj(lj, 0, 0) + end + in + fun +* ta tb = + let val (rank_a,lk::rest_a,a) = (rank ta, shape ta, toArray ta) + val (rank_b,lk2::rest_b,b) = (rank tb, shape tb, toArray tb) + in if not(lk = lk2) + then raise Match + else let val li = Index.length rest_a + val lj = Index.length rest_b + val c = Array.array(li*lj,Number.zero) + in fromArray(rest_a @ rest_b, + do_fold_first a b c lk li lj) + end + end + end + local + (* + LAST INDEX CONTRACTION: + a = a(i1,i2,...,in) + b = b(j1,j2,...,jn) + c = c(i2,...,in,j2,...,jn) + = sum(mult(a(i1,i2,...,k),b(j1,j2,...,k))) forall k + MEANINGFUL VARIABLES: + lk = in = jn + li = i1*...*i(n-1) + lj = j1*...*j(n-1) + *) + fun do_fold_last a b c lk lj li = + let fun loopi (0, ia, ic, fac) = () + | loopi (i, ia, ic, fac) = + let val old = Array.sub(c,ic) + val inc = Number.*(Array.sub(a,ia),fac) + in + Array.update(c,ic,Number.+(old,inc)); + loopi(i-1, ia+1, ic+1, fac) + end + fun loopj (j, ib, ic) = + let fun loopk (0, ia, ib) = () + | loopk (k, ia, ib) = + (loopi(li, ia, ic, Array.sub(b,ib)); + loopk(k-1, ia+li, ib+lj)) + in case j of + 0 => c + | _ => (loopk(lk, 0, ib); + loopj(j-1, ib+1, ic+li)) + end (* loopj *) + in + loopj(lj, 0, 0) + end + in + fun *+ ta tb = + let val (rank_a,shape_a,a) = (rank ta, shape ta, toArray ta) + val (rank_b,shape_b,b) = (rank tb, shape tb, toArray tb) + val (lk::rest_a) = List.rev shape_a + val (lk2::rest_b) = List.rev shape_b + in if not(lk = lk2) + then raise Match + else let val li = Index.length rest_a + val lj = Index.length rest_b + val c = Array.array(li*lj,Number.zero) + in fromArray(List.rev rest_a @ List.rev rest_b, + do_fold_last a b c lk li lj) + end + end + end + (* ALGEBRAIC OPERATIONS *) + infix ** + infix == + infix != + fun a + b = map2 Number.+ a b + fun a - b = map2 Number.- a b + fun a * b = map2 Number.* a b + fun a ** i = map (fn x => (Number.**(x,i))) a + fun ~ a = map Number.~ a + fun abs a = map Number.abs a + fun signum a = map Number.signum a + fun a == b = map2' Number.== a b + fun a != b = map2' Number.!= a b + fun toString a = raise Domain + fun fromInt a = new([1], Number.fromInt a) + (* TENSOR SPECIFIC OPERATIONS *) + fun *> n = map (fn x => Number.*(n,x)) + fun print t = + (PrettyPrint.intList (shape t); + TextIO.print "\n"; + PrettyPrint.sequence (length t) appi Number.toString t) + fun a / b = map2 Number./ a b + fun recip a = map Number.recip a + fun ln a = map Number.ln a + fun pow (a, b) = map (fn x => (Number.pow(x,b))) a + fun exp a = map Number.exp a + fun sqrt a = map Number.sqrt a + fun cos a = map Number.cos a + fun sin a = map Number.sin a + fun tan a = map Number.tan a + fun sinh a = map Number.sinh a + fun cosh a = map Number.cosh a + fun tanh a = map Number.tanh a + fun asin a = map Number.asin a + fun acos a = map Number.acos a + fun atan a = map Number.atan a + fun asinh a = map Number.asinh a + fun acosh a = map Number.acosh a + fun atanh a = map Number.atanh a + fun atan2 (a,b) = map2 Number.atan2 a b + fun normInf a = + let fun accum (y,x) = Number.max(x,Number.abs y) + in foldl accum Number.zero a + end + fun norm1 a = + let fun accum (y,x) = Number.+(x,Number.abs y) + in foldl accum Number.zero a + end + fun norm2 a = + let fun accum (y,x) = Number.+(x, Number.*(y,y)) + in Number.sqrt(foldl accum Number.zero a) + end + end (* RTensor *) +structure CTensor = +struct + structure Number = CNumber + structure Array = CNumberArray +(* + Copyright (c) Juan Jose Garcia Ripoll. + All rights reserved. + Refer to the COPYRIGHT file for license conditions +*) +structure MonoTensor = + struct +(* PARAMETERS + structure Array = Array +*) + structure Index = Index + type elem = Array.elem + type index = Index.t + type tensor = {shape : index, indexer : Index.indexer, data : Array.array} + type t = tensor + exception Shape + exception Match + exception Index + local + (*----- LOCALS -----*) + fun make' (shape, data) = + {shape = shape, indexer = Index.indexer shape, data = data} + fun toInt {shape, indexer, data} index = indexer index + fun splitList (l as (a::rest), place) = + let fun loop (left,here,right) 0 = (List.rev left,here,right) + | loop (_,_,[]) place = raise Index + | loop (left,here,a::right) place = + loop (here::left,a,right) (place-1) + in + if place <= 0 then + loop ([],a,rest) (List.length rest - place) + else + loop ([],a,rest) (place - 1) + end + in + (*----- STRUCTURAL OPERATIONS & QUERIES ------*) + fun new (shape, init) = + if not (Index.validShape shape) then + raise Shape + else + let val length = Index.length shape in + {shape = shape, + indexer = Index.indexer shape, + data = Array.array(length,init)} + end + fun toArray {shape, indexer, data} = data + fun length {shape, indexer, data} = Array.length data + fun shape {shape, indexer, data} = shape + fun rank t = List.length (shape t) + fun reshape new_shape tensor = + if Index.validShape new_shape then + case (Index.length new_shape) = length tensor of + true => make'(new_shape, toArray tensor) + | false => raise Match + else + raise Shape + fun fromArray (s, a) = + case Index.validShape s andalso + ((Index.length s) = (Array.length a)) of + true => make'(s, a) + | false => raise Shape + fun fromList (s, a) = fromArray (s, Array.fromList a) + fun tabulate (shape,f) = + if Index.validShape shape then + let val last = Index.last shape + val length = Index.length shape + val c = Array.array(length, f last) + fun dotable (c, indices, i) = + (Array.update(c, i, f indices); + if i <= 1 + then c + else dotable(c, Index.prev' shape indices, i-1)) + in make'(shape,dotable(c, Index.prev' shape last, length-2)) + end + else + raise Shape + (*----- ELEMENTWISE OPERATIONS -----*) + fun sub (t, index) = Array.sub(#data t, toInt t index) + fun update (t, index, value) = + Array.update(toArray t, toInt t index, value) + fun map f {shape, indexer, data} = + {shape = shape, indexer = indexer, data = Array.map f data} + fun map2 f t1 t2= + let val {shape=shape1, indexer=indexer1, data=data1} = t1 + val {shape=shape2, indexer=indexer2, data=data2} = t2 + in + if Index.eq(shape1,shape2) then + {shape = shape1, + indexer = indexer1, + data = Array.map2 f data1 data2} + else + raise Match + end + fun appi f tensor = Array.appi f (toArray tensor, 0, NONE) + fun app f tensor = Array.app f (toArray tensor) + fun all f tensor = + let val a = toArray tensor + in Loop.all(0, length tensor - 1, fn i => + f (Array.sub(a, i))) + end + fun any f tensor = + let val a = toArray tensor + in Loop.any(0, length tensor - 1, fn i => + f (Array.sub(a, i))) + end + fun foldl f init tensor = Array.foldl f init (toArray tensor) + fun foldln f init {shape, indexer, data=a} index = + let val (head,lk,tail) = splitList(shape, index) + val li = Index.length head + val lj = Index.length tail + val c = Array.array(li * lj,init) + fun loopi (0, _, _) = () + | loopi (i, ia, ic) = + (Array.update(c, ic, f(Array.sub(c,ic), Array.sub(a,ia))); + loopi (i-1, ia+1, ic+1)) + fun loopk (0, ia, _) = ia + | loopk (k, ia, ic) = (loopi (li, ia, ic); + loopk (k-1, ia+li, ic)) + fun loopj (0, _, _) = () + | loopj (j, ia, ic) = loopj (j-1, loopk(lk,ia,ic), ic+li) + in + loopj (lj, 0, 0); + make'(head @ tail, c) + end + (* --- POLYMORPHIC ELEMENTWISE OPERATIONS --- *) + fun array_map' f a = + let fun apply index = f(Array.sub(a,index)) in + Tensor.Array.tabulate(Array.length a, apply) + end + fun map' f t = Tensor.fromArray(shape t, array_map' f (toArray t)) + fun map2' f t1 t2 = + let val d1 = toArray t1 + val d2 = toArray t2 + fun apply i = f (Array.sub(d1,i), Array.sub(d2,i)) + val len = Array.length d1 + in + if Index.eq(shape t1, shape t2) then + Tensor.fromArray(shape t1, Tensor.Array.tabulate(len,apply)) + else + raise Match + end + fun foldl' f init {shape, indexer, data=a} index = + let val (head,lk,tail) = splitList(shape, index) + val li = Index.length head + val lj = Index.length tail + val c = Tensor.Array.array(li * lj,init) + fun loopi (0, _, _) = () + | loopi (i, ia, ic) = + (Tensor.Array.update(c,ic,f(Tensor.Array.sub(c,ic),Array.sub(a,ia))); + loopi (i-1, ia+1, ic+1)) + fun loopk (0, ia, _) = ia + | loopk (k, ia, ic) = (loopi (li, ia, ic); + loopk (k-1, ia+li, ic)) + fun loopj (0, _, _) = () + | loopj (j, ia, ic) = loopj (j-1, loopk(lk,ia,ic), ic+li) + in + loopj (lj, 0, 0); + make'(head @ tail, c) + end + end + end (* MonoTensor *) + open MonoTensor + local + (* + LEFT INDEX CONTRACTION: + a = a(i1,i2,...,in) + b = b(j1,j2,...,jn) + c = c(i2,...,in,j2,...,jn) + = sum(a(k,i2,...,jn)*b(k,j2,...jn)) forall k + MEANINGFUL VARIABLES: + lk = i1 = j1 + li = i2*...*in + lj = j2*...*jn + *) + fun do_fold_first a b c lk lj li = + let fun loopk (0, _, _, r, i) = Number.make(r,i) + | loopk (k, ia, ib, r, i) = + let val (ar, ai) = Array.sub(a,ia) + val (br, bi) = Array.sub(b,ib) + val dr = ar * br - ai * bi + val di = ar * bi + ai * br + in loopk (k-1, ia+1, ib+1, r+dr, i+di) + end + fun loopj (0, ib, ic) = c + | loopj (j, ib, ic) = + let fun loopi (0, ia, ic) = ic + | loopi (i, ia, ic) = + (Array.update(c, ic, loopk(lk, ia, ib, RNumber.zero, RNumber.zero)); + loopi(i-1, ia+lk, ic+1)) + in loopj(j-1, ib+lk, loopi(li, 0, ic)) + end + in loopj(lj, 0, 0) + end + in + fun +* ta tb = + let val (rank_a,lk::rest_a,a) = (rank ta, shape ta, toArray ta) + val (rank_b,lk2::rest_b,b) = (rank tb, shape tb, toArray tb) + in if not(lk = lk2) + then raise Match + else let val li = Index.length rest_a + val lj = Index.length rest_b + val c = Array.array(li*lj,Number.zero) + in fromArray(rest_a @ rest_b, do_fold_first a b c lk li lj) + end + end + end + local + (* + LAST INDEX CONTRACTION: + a = a(i1,i2,...,in) + b = b(j1,j2,...,jn) + c = c(i2,...,in,j2,...,jn) + = sum(mult(a(i1,i2,...,k),b(j1,j2,...,k))) forall k + MEANINGFUL VARIABLES: + lk = in = jn + li = i1*...*i(n-1) + lj = j1*...*j(n-1) + *) + fun do_fold_last a b c lk lj li = + let fun loopi(0, _, _, _, _) = () + | loopi(i, ia, ic, br, bi) = + let val (cr,ci) = Array.sub(c,ic) + val (ar,ai) = Array.sub(a,ia) + val dr = (ar * br - ai * bi) + val di = (ar * bi + ai * br) + in + Array.update(c,ic,Number.make(cr+dr,ci+di)); + loopi(i-1, ia+1, ic+1, br, bi) + end + fun loopj(j, ib, ic) = + let fun loopk(0, _, _) = () + | loopk(k, ia, ib) = + let val (br, bi) = Array.sub(b,ib) + in + loopi(li, ia, ic, br, bi); + loopk(k-1, ia+li, ib+lj) + end + in case j of + 0 => c + | _ => (loopk(lk, 0, ib); + loopj(j-1, ib+1, ic+li)) + end (* loopj *) + in + loopj(lj, 0, 0) + end + in + fun *+ ta tb = + let val (rank_a,shape_a,a) = (rank ta, shape ta, toArray ta) + val (rank_b,shape_b,b) = (rank tb, shape tb, toArray tb) + val (lk::rest_a) = List.rev shape_a + val (lk2::rest_b) = List.rev shape_b + in + if not(lk = lk2) then + raise Match + else + let val li = Index.length rest_a + val lj = Index.length rest_b + val c = Array.array(li*lj,Number.zero) + in + fromArray(List.rev rest_a @ List.rev rest_b, + do_fold_last a b c lk li lj) + end + end + end + (* ALGEBRAIC OPERATIONS *) + infix ** + infix == + infix != + fun a + b = map2 Number.+ a b + fun a - b = map2 Number.- a b + fun a * b = map2 Number.* a b + fun a ** i = map (fn x => (Number.**(x,i))) a + fun ~ a = map Number.~ a + fun abs a = map Number.abs a + fun signum a = map Number.signum a + fun a == b = map2' Number.== a b + fun a != b = map2' Number.!= a b + fun toString a = raise Domain + fun fromInt a = new([1], Number.fromInt a) + (* TENSOR SPECIFIC OPERATIONS *) + fun *> n = map (fn x => Number.*(n,x)) + fun print t = + (PrettyPrint.intList (shape t); + TextIO.print "\n"; + PrettyPrint.sequence (length t) appi Number.toString t) + fun a / b = map2 Number./ a b + fun recip a = map Number.recip a + fun ln a = map Number.ln a + fun pow (a, b) = map (fn x => (Number.pow(x,b))) a + fun exp a = map Number.exp a + fun sqrt a = map Number.sqrt a + fun cos a = map Number.cos a + fun sin a = map Number.sin a + fun tan a = map Number.tan a + fun sinh a = map Number.sinh a + fun cosh a = map Number.cosh a + fun tanh a = map Number.tanh a + fun asin a = map Number.asin a + fun acos a = map Number.acos a + fun atan a = map Number.atan a + fun asinh a = map Number.asinh a + fun acosh a = map Number.acosh a + fun atanh a = map Number.atanh a + fun atan2 (a,b) = map2 Number.atan2 a b + fun normInf a = + let fun accum (y,x) = RNumber.max(x, Number.realPart(Number.abs y)) + in foldl accum RNumber.zero a + end + fun norm1 a = + let fun accum (y,x) = RNumber.+(x, Number.realPart(Number.abs y)) + in foldl accum RNumber.zero a + end + fun norm2 a = + let fun accum (y,x) = RNumber.+(x, Number.abs2 y) + in RNumber.sqrt(foldl accum RNumber.zero a) + end +end (* CTensor *) +structure MathFile = +struct + +type file = TextIO.instream + +exception Data + +fun assert NONE = raise Data + | assert (SOME a) = a + +(* ------------------ INPUT --------------------- *) + +fun intRead file = assert(TextIO.scanStream INumber.scan file) +fun realRead file = assert(TextIO.scanStream RNumber.scan file) +fun complexRead file = assert(TextIO.scanStream CNumber.scan file) + +fun listRead eltScan file = + let val length = intRead file + fun eltRead file = assert(TextIO.scanStream eltScan file) + fun loop (0,accum) = accum + | loop (i,accum) = loop(i-1, eltRead file :: accum) + in + if length < 0 + then raise Data + else List.rev(loop(length,[])) + end + +fun intListRead file = listRead INumber.scan file +fun realListRead file = listRead RNumber.scan file +fun complexListRead file = listRead CNumber.scan file + +fun intTensorRead file = + let val shape = intListRead file + val length = Index.length shape + val first = intRead file + val a = ITensor.Array.array(length, first) + fun loop 0 = ITensor.fromArray(shape, a) + | loop j = (ITensor.Array.update(a, length-j, intRead file); + loop (j-1)) + in loop (length - 1) + end + +fun realTensorRead file = + let val shape = intListRead file + val length = Index.length shape + val first = realRead file + val a = RTensor.Array.array(length, first) + fun loop 0 = RTensor.fromArray(shape, a) + | loop j = (RTensor.Array.update(a, length-j, realRead file); + loop (j-1)) + in loop (length - 1) + end + +fun complexTensorRead file = + let val shape = intListRead file + val length = Index.length shape + val first = complexRead file + val a = CTensor.Array.array(length, first) + fun loop j = if j = length + then CTensor.fromArray(shape, a) + else (CTensor.Array.update(a, j, complexRead file); + loop (j+1)) + in loop 1 + end + +(* ------------------ OUTPUT -------------------- *) +fun linedOutput(file, x) = (TextIO.output(file, x); TextIO.output(file, "\n")) + +fun intWrite file x = linedOutput(file, INumber.toString x) +fun realWrite file x = linedOutput(file, RNumber.toString x) +fun complexWrite file x = + let val (r,i) = CNumber.split x + in linedOutput(file, concat [RNumber.toString r, " ", RNumber.toString i]) + end + +fun listWrite converter file x = + (intWrite file (length x); + List.app (fn x => (linedOutput(file, converter x))) x) + +fun intListWrite file x = listWrite INumber.toString file x +fun realListWrite file x = listWrite RNumber.toString file x +fun complexListWrite file x = listWrite CNumber.toString file x + +fun intTensorWrite file x = (intListWrite file (ITensor.shape x); ITensor.app (fn x => (intWrite file x)) x) +fun realTensorWrite file x = (intListWrite file (RTensor.shape x); RTensor.app (fn x => (realWrite file x)) x) +fun complexTensorWrite file x = (intListWrite file (CTensor.shape x); CTensor.app (fn x => (complexWrite file x)) x) +end + +fun loop 0 _ = () + | loop n f = (f(); loop (n-1) f) + +fun test_operator new list_op list_sizes = + let fun test_many list_op size = + let fun test_op (times,f) = + let val a = new size + in (EvalTimer.timerOn(); + loop times (fn _ => f(a,a)); + let val t = LargeInt.toInt(EvalTimer.timerRead()) div times + val i = StringCvt.padLeft #" " 6 (Int.toString t) + in print i + end) + end + in + print (Int.toString size); + print " "; + List.app test_op list_op; + print "\n" + end + in List.app (test_many list_op) list_sizes + end + +structure Main = + struct + fun one() = + let + val _ = + let val operators = [(20, RTensor.+), (20, RTensor.* ), (20, RTensor./), + (4, fn (a,b) => RTensor.+* a b), + (4, fn (a,b) => RTensor.*+ a b)] + fun constructor size = RTensor.new([size,size],1.0) + in + print "Real tensors: (+, *, /, +*, *+)\n"; + test_operator constructor operators [100,200,300,400,500]; + print "\n\n" + end + + val _ = + let val operators = [(20, CTensor.+), (20, CTensor.* ), (20, CTensor./), + (4, fn (a,b) => CTensor.+* a b), + (4, fn (a,b) => CTensor.*+ a b)] + fun constructor size = CTensor.new([size,size],CNumber.one) + in + print "Real tensors: (+, *, /, +*, *+)\n"; + test_operator constructor operators [100,200,300,400,500]; + print "\n\n" + end + in () + end + + fun doit n = + if n = 0 + then () + else (one () + ; doit (n - 1)) + end diff --git a/benchmark/tests/tsp.sml b/benchmark/tests/tsp.sml new file mode 100644 index 0000000..39f3118 --- /dev/null +++ b/benchmark/tests/tsp.sml @@ -0,0 +1,492 @@ +(* From the SML/NJ benchmark suite. *) +(* tree.sml + * + * COPYRIGHT (c) 1994 AT&T Bell Laboratories. + * + * Trees for the TSP program. + *) + +structure Tree = + struct + + datatype tree + = NULL + | ND of { + left : tree, right : tree, + x : real, y : real, + sz : int, + prev : tree ref, next : tree ref + } + + fun mkNode (l, r, x, y, sz) = ND{ + left = l, right = r, x = x, y = y, sz = sz, + prev = ref NULL, next = ref NULL + } + + fun printTree (outS, NULL) = () + | printTree (outS, ND{x, y, left, right, ...}) = ( + TextIO.output(outS, String.concat [ + Real.toString x, " ", Real.toString y, "\n"]); + printTree (outS, left); + printTree (outS, right)) + + fun printList (outS, NULL) = () + | printList (outS, start as ND{next, ...}) = let + fun cycle (ND{next=next', ...}) = (next = next') + | cycle _ = false + fun prt (NULL) = () + | prt (t as ND{x, y, next, ...}) = ( + TextIO.output(outS, String.concat [ + Real.toString x, " ", Real.toString y, "\n" + ]); + if (cycle (!next)) + then () + else prt (!next)) + in + prt start + end + + end; + +(* tsp.sml + * + * COPYRIGHT (c) 1994 AT&T Bell Laboratories. + *) + +structure TSP : sig + + val tsp : (Tree.tree * int) -> Tree.tree + + end = struct + + structure T = Tree + + fun setPrev (T.ND{prev, ...}, x) = prev := x + fun setNext (T.ND{next, ...}, x) = next := x + fun link (a as T.ND{next, ...}, b as T.ND{prev, ...}) = ( + next := b; prev := a) + + fun sameNd (T.ND{next, ...}, T.ND{next=next', ...}) = (next = next') + | sameNd (T.NULL, T.NULL) = true + | sameNd _ = false + + (* Find Euclidean distance from a to b *) + fun distance (T.ND{x=ax, y=ay, ...}, T.ND{x=bx, y=by, ...}) = + Math.sqrt(((ax-bx)*(ax-bx)+(ay-by)*(ay-by))) + | distance _ = raise Fail "distance" + + (* sling tree nodes into a list -- requires root to be tail of list, and + * only fills in next field, not prev. + *) + fun makeList T.NULL = T.NULL + | makeList (t as T.ND{left, right, next = t_next, ...}) = let + val retVal = (case (makeList left, makeList right) + of (T.NULL, T.NULL) => t + | (l as T.ND{...}, T.NULL) => (setNext(left, t); l) + | (T.NULL, r as T.ND{...}) => (setNext(right, t); r) + | (l as T.ND{...}, r as T.ND{...}) => ( + setNext(right, t); setNext(left, r); l) + (* end case *)) + in + t_next := T.NULL; + retVal + end + + (* reverse orientation of list *) + fun reverse T.NULL = () + | reverse (t as T.ND{next, prev, ...}) = let + fun rev (_, T.NULL) = () + | rev (back, tmp as T.ND{prev, next, ...}) = let + val tmp' = !next + in + next := back; setPrev(back, tmp); + rev (tmp, tmp') + end + in + setNext (!prev, T.NULL); + prev := T.NULL; + rev (t, !next) + end + + (* Use closest-point heuristic from Cormen Leiserson and Rivest *) + fun conquer (T.NULL) = T.NULL + | conquer t = let + val (cycle as T.ND{next=cycle_next, prev=cycle_prev, ...}) = makeList t + fun loop (T.NULL) = () + | loop (t as T.ND{next=ref doNext, prev, ...}) = + let + fun findMinDist (min, minDist, tmp as T.ND{next, ...}) = + if (sameNd(cycle, tmp)) + then min + else let + val test = distance(t, tmp) + in + if (test < minDist) + then findMinDist (tmp, test, !next) + else findMinDist (min, minDist, !next) + end + val (min as T.ND{next=ref min_next, prev=ref min_prev, ...}) = + findMinDist (cycle, distance(t, cycle), !cycle_next) + val minToNext = distance(min, min_next) + val minToPrev = distance(min, min_prev) + val tToNext = distance(t, min_next) + val tToPrev = distance(t, min_prev) + in + if ((tToPrev - minToPrev) < (tToNext - minToNext)) + then ( (* insert between min and min_prev *) + link (min_prev, t); + link (t, min)) + else ( + link (min, t); + link (t, min_next)); + loop doNext + end + val t' = !cycle_next + in + (* Create initial cycle *) + cycle_next := cycle; cycle_prev := cycle; + loop t'; + cycle + end + + (* Merge two cycles as per Karp *) + fun merge (a as T.ND{next, ...}, b, t) = let + fun locateCycle (start as T.ND{next, ...}) = let + fun findMin (min, minDist, tmp as T.ND{next, ...}) = + if (sameNd(start, tmp)) + then (min, minDist) + else let val test = distance(t, tmp) + in + if (test < minDist) + then findMin (tmp, test, !next) + else findMin (min, minDist, !next) + end + val (min as T.ND{next=ref next', prev=ref prev', ...}, minDist) = + findMin (start, distance(t, start), !next) + val minToNext = distance(min, next') + val minToPrev = distance(min, prev') + val tToNext = distance(t, next') + val tToPrev = distance(t, prev') + in + if ((tToPrev - minToPrev) < (tToNext - minToNext)) + (* would insert between min and prev *) + then (prev', tToPrev, min, minDist) + (* would insert between min and next *) + else (min, minDist, next', tToNext) + end + (* Compute location for first cycle *) + val (p1, tToP1, n1, tToN1) = locateCycle a + (* compute location for second cycle *) + val (p2, tToP2, n2, tToN2) = locateCycle b + (* Now we have 4 choices to complete: + * 1:t,p1 t,p2 n1,n2 + * 2:t,p1 t,n2 n1,p2 + * 3:t,n1 t,p2 p1,n2 + * 4:t,n1 t,n2 p1,p2 + *) + val n1ToN2 = distance(n1, n2) + val n1ToP2 = distance(n1, p2) + val p1ToN2 = distance(p1, n2) + val p1ToP2 = distance(p1, p2) + fun choose (testChoice, test, choice, minDist) = + if (test < minDist) then (testChoice, test) else (choice, minDist) + val (choice, minDist) = (1, tToP1+tToP2+n1ToN2) + val (choice, minDist) = choose(2, tToP1+tToN2+n1ToP2, choice, minDist) + val (choice, minDist) = choose(3, tToN1+tToP2+p1ToN2, choice, minDist) + val (choice, minDist) = choose(4, tToN1+tToN2+p1ToP2, choice, minDist) + in + case choice + of 1 => ( (* 1:p1,t t,p2 n2,n1 -- reverse 2! *) + reverse n2; + link (p1, t); + link (t, p2); + link (n2, n1)) + | 2 => ( (* 2:p1,t t,n2 p2,n1 -- OK *) + link (p1, t); + link (t, n2); + link (p2, n1)) + | 3 => ( (* 3:p2,t t,n1 p1,n2 -- OK *) + link (p2, t); + link (t, n1); + link (p1, n2)) + | 4 => ( (* 4:n1,t t,n2 p2,p1 -- reverse 1! *) + reverse n1; + link (n1, t); + link (t, n2); + link (p2, p1)) + (* end case *); + t + end (* merge *) + + (* Compute TSP for the tree t -- use conquer for problems <= sz * *) + fun tsp (t as T.ND{left, right, sz=sz', ...}, sz) = + if (sz' <= sz) + then conquer t + else merge (tsp(left, sz), tsp(right, sz), t) + | tsp (T.NULL, _) = T.NULL + + end; + +(* rand-sig.sml + * + * COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file for details. + * COPYRIGHT (c) 1998 by AT&T Laboratories. + * + * Signature for a simple random number generator. + * + *) + +signature RAND = + sig + + type rand = Word.word + + val randMin : rand + val randMax : rand + + val random : rand -> rand + (* Given seed, return value randMin <= v <= randMax + * Iteratively using the value returned by random as the + * next seed to random will produce a sequence of pseudo-random + * numbers. + *) + + val mkRandom : rand -> unit -> rand + (* Given seed, return function generating a sequence of + * random numbers randMin <= v <= randMax + *) + + val norm : rand -> real + (* Map values in the range [randMin,randMax] to (0.0,1.0) *) + + val range : (int * int) -> rand -> int + (* Map v, randMin <= v <= randMax, to integer range [i,j] + * Exception - + * Fail if j < i + *) + + end (* RAND *) + +(* rand.sml + * + * COPYRIGHT (c) 1991 by AT&T Bell Laboratories. See COPYRIGHT file for details + * COPYRIGHT (c) 1998 by AT&T Laboratories. See COPYRIGHT file for details + * + * Random number generator taken from Paulson, pp. 170-171. + * Recommended by Stephen K. Park and Keith W. Miller, + * Random number generators: good ones are hard to find, + * CACM 31 (1988), 1192-1201 + * Updated to include the new preferred multiplier of 48271 + * CACM 36 (1993), 105-110 + * Updated to use on Word. + * + * Note: The Random structure provides a better generator. + *) + +structure Rand : RAND = + struct + + type rand = Word.word + type rand' = Int.int (* internal representation *) + + val a : rand' = 48271 + val m : rand' = valOf Int.maxInt (* 2^31 - 1 *) + val m_1 = m - 1 + val q = m div a + val r = m mod a + + val extToInt = Word.toInt + val intToExt = Word.fromInt + + val randMin : rand = 0w1 + val randMax : rand = intToExt m_1 + + fun chk 0w0 = 1 + | chk 0wx7fffffff = m_1 + | chk seed = extToInt seed + + fun random' seed = let + val hi = seed div q + val lo = seed mod q + val test = a * lo - r * hi + in + if test > 0 then test else test + m + end + + val random = intToExt o random' o chk + + fun mkRandom seed = let + val seed = ref (chk seed) + in + fn () => (seed := random' (!seed); intToExt (!seed)) + end + + val real_m = Real.fromInt m + fun norm s = (Real.fromInt (Word.toInt s)) / real_m + + fun range (i,j) = + if j < i + then raise Fail "Random.range: hi < lo" + else if j = i then fn _ => i + else let + val R = Int.fromInt j - Int.fromInt i + val cvt = Word.toIntX o Word.fromInt + in + if R = m then Word.toIntX + else fn s => i + cvt ((extToInt s) mod (R+1)) + end + + end (* Rand *) + +(* build.sml + * + * COPYRIGHT (c) 1994 AT&T Bell Laboratories. + * + * Build a two-dimensional tree for TSP. + *) + +structure BuildTree : sig + + datatype axis = X_AXIS | Y_AXIS + + val buildTree : { + n : int, dir : axis, + min_x : real, min_y : real, max_x : real, max_y : real + } -> Tree.tree + + end = struct + + structure T = Tree + + val m_e = 2.7182818284590452354 + val m_e2 = 7.3890560989306502274 + val m_e3 = 20.08553692318766774179 + val m_e6 = 403.42879349273512264299 + val m_e12 = 162754.79141900392083592475 + + datatype axis = X_AXIS | Y_AXIS + + (* builds a 2D tree of n nodes in specified range with dir as primary axis *) + fun buildTree arg = let + val rand = Rand.mkRandom 0w314 + fun drand48 () = Rand.norm (rand ()) + fun median {min, max, n} = let + val t = drand48(); (* in [0.0..1.0) *) + val retval = if (t > 0.5) + then Math.ln(1.0-(2.0*(m_e12-1.0)*(t-0.5)/m_e12))/12.0 + else ~(Math.ln(1.0-(2.0*(m_e12-1.0)*t/m_e12))/12.0) + in + min + ((retval + 1.0) * (max - min)/2.0) + end + fun uniform {min, max} = min + (drand48() * (max - min)) + fun build {n = 0, ...} = T.NULL + | build {n, dir=X_AXIS, min_x, min_y, max_x, max_y} = let + val med = median{min=min_y, max=max_y, n=n} + fun mkTree (min, max) = build{ + n=n div 2, dir=Y_AXIS, min_x=min_x, max_x=max_x, + min_y=min, max_y=max + } + in + T.mkNode( + mkTree(min_y, med), mkTree(med, max_y), + uniform{min=min_x, max=max_x}, med, n) + end + | build {n, dir=Y_AXIS, min_x, min_y, max_x, max_y} = let + val med = median{min=min_x, max=max_x, n=n} + fun mkTree (min, max) = build{ + n=n div 2, dir=X_AXIS, min_x=min, max_x=max, + min_y=min_y, max_y=max_y + } + in + T.mkNode( + mkTree(min_x, med), mkTree(med, max_x), + med, uniform{min=min_y, max=max_y}, n) + end + in + build arg + end + + end; (* Build *) + +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; +(* main.sml + * + * COPYRIGHT (c) 1994 AT&T Bell Laboratories. + * + *) + +structure Main : sig + + include BMARK + + val dumpPS : TextIO.outstream -> unit + + end = struct + + val name = "TSP" + + val problemSz = ref 32767 + val divideSz = ref 150 + + fun printLength (outS, Tree.NULL) = print "(* 0 points *)\n" + | printLength (outS, start as Tree.ND{next, x, y, ...}) = let + fun cycle (Tree.ND{next=next', ...}) = (next = next') + | cycle _ = false + fun distance (ax, ay, bx, by) = let + val dx = ax-bx and dy = ay-by + in + Math.sqrt (dx*dx + dy*dy) + end + fun length (Tree.NULL, px, py, n, len) = (n, len+distance(px, py, x, y)) + | length (t as Tree.ND{x, y, next, ...}, px, py, n, len) = + if (cycle t) + then (n, len+distance(px, py, x, y)) + else length(!next, x, y, n+1, len+distance(px, py, x, y)) + in + if (cycle(!next)) + then TextIO.output (outS, "(* 1 point *)\n") + else let + val (n, len) = length(!next, x, y, 1, 0.0) + in + TextIO.output (outS, concat[ + "(* ", Int.toString n, "points, cycle length = ", + Real.toString len, " *)\n" + ]) + end + end + + fun mkTree n = BuildTree.buildTree { + n=n, dir=BuildTree.X_AXIS, + min_x=0.0, max_x=1.0, + min_y=0.0, max_y=1.0 + } + + fun doit' n = TSP.tsp (mkTree n, !divideSz) + + fun dumpPS outS = ( + TextIO.output (outS, "newgraph\n"); + TextIO.output (outS, "newcurve pts\n"); + Tree.printList (outS, doit' (!problemSz)); + TextIO.output (outS, "linetype solid\n")) + + fun testit strm = printLength (strm, doit' (!problemSz)) + + val _ = problemSz := 2097151 + fun doit () = doit' (!problemSz) + + val doit = + fn n => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop n + end + + end diff --git a/benchmark/tests/tyan.sml b/benchmark/tests/tyan.sml new file mode 100644 index 0000000..4467e21 --- /dev/null +++ b/benchmark/tests/tyan.sml @@ -0,0 +1,1016 @@ +(* Modified by sweeks@sweeks.com 2001-10-03 to go in the MLton benchmark suite. + * Hardwired in the u6 list of polynomials and added a loop. + *) +(* tyan.sml + * A Grobner Basis calculation for polynomials over F17 + * Adapted from the TIL benchmark suite by Allyn Dimock: + * update to SML '97, Standard Basis Library, comment out unreachable code + * Original code from Thomas Yan, who has given his permission for this + * code be used as a benchmarking code for SML compilers + * (e-mail message Tue, 10 Apr 2001 13:07:44 -0400 (EDT)) + * + * The data structure for the intermediate results is described in + * @article{Yan:1998:GBSP, + * author = {Yan, Thomas}, + * title = {The Geobucked Data Structure For Polynomials}, + * journal = {Journal Of Symbolic Computation}, + * volume = 23, + * number = 3, + * pages = {285 -- 293}, + * year = 1998, + * } + *) + +val print : string -> unit = print +type 'a array1 = 'a Array.array +val sub1 = Array.sub +val update1 = Array.update +val array1 = Array.array +val length1 = Array.length +val op && = fn (i1, i2) => (Word.toInt (Word.andb (Word.fromInt (i1), Word.fromInt (i2)))) +val op || = fn (i1, i2) => (Word.toInt (Word.orb (Word.fromInt (i1), Word.fromInt (i2)))) +val op << = fn (i1, i2) => (Word.toInt (Word.<< (Word.fromInt (i1), Word.fromInt (i2)))) +val op >> = fn (i1, i2) => (Word.toInt (Word.>> (Word.fromInt (i1), Word.fromInt (i2)))) +infix && || << >> +fun fold f l b = List.foldl f b l +fun revfold f l b = List.foldr f b l + +val input_line = TextIO.inputLine +val end_of_stream = TextIO.endOfStream +val open_in = TextIO.openIn +val close_in = TextIO.closeIn + +nonfix smlnj_mod +nonfix smlnj_div +val smlnj_mod = op mod +val smlnj_div = op div +infix 7 smlnj_mod +infix 7 smlnj_div + +exception Tabulate +fun tabulate (i,f) = + if i <= 0 then raise Tabulate else + let val a = array1(i,f 0) + fun tabify j = if j < i then (update1(a,j,f j); tabify (j+1)) else a + in + tabify 1 + end + +exception ArrayofList +fun arrayoflist (hd::tl) = + let val a = array1((length tl) + 1,hd) + fun al([],_) = a + | al(hd::tl,i) = (update1(a,i,hd); al(tl,i+1)) + in + al(tl,1) + end + | arrayoflist ([]) = raise ArrayofList + + +structure Util = struct + datatype relation = Less | Equal | Greater + + exception NotImplemented of string + exception Impossible of string (* flag "impossible" condition *) + exception Illegal of string (* flag function use violating precondition *) + + fun error exn msg = raise (exn msg) + fun notImplemented msg = error NotImplemented msg + fun impossible msg = error Impossible msg + fun illegal msg = error Illegal msg + + (* arr[i] := obj :: arr[i]; extend non-empty arr if necessary *) + fun insert (obj,i,arr) = let + val len = length1 arr + val res = if i length l + n) ls 0,obj0) + fun ins (i,[]) = i | ins (i,x::l) = (update1(a,i,x); ins(i+1,l)) + fun insert (i,[]) = a | insert (i,l::ll) = insert(ins(i,l),ll) + in insert(0,ls) end +*) + + (* given compare and array a, return list of contents of a sorted in + * ascending order, with duplicates stripped out; which copy of a duplicate + * remains is random. NOTE that a is modified. + *) + fun stripSort compare = fn a => let + infix sub + + + val op sub = sub1 and update = update1 + fun swap (i,j) = let val ai = a sub i + in update(a,i,a sub j); update(a,j,ai) end + (* sort all a[k], 0<=i<=k (swap (lo,k); partition (lo+1,k+1,hi)) + | Equal => partition (lo,k+1,hi) + | Greater => (swap (k,hi-1); partition (lo,k,hi-1)) + val (lo,hi) = partition (i,i,j) + in s(i,lo,pivot::s(hi,j,acc)) end + val res = s(0,length1 a,[]) + + in + res + end +end + +structure F = struct + val p = 17 + + datatype field = F of int (* for (F n), always 0<=n

=p then F(k-p) else F k end + fun subtract (F n,F m) = if n>=m then F(n-m) else F(n-m+p) + fun negate (F 0) = F 0 | negate (F n) = F(p-n) + fun multiply (F n,F m) = F ((n*m) smlnj_mod p) + fun reciprocal (F 0) = raise Div + | reciprocal (F n) = let + (* consider euclid gcd alg on (a,b) starting with a=p, b=n. + * if maintain a = a1 n + a2 p, b = b1 n + b2 p, a>b, + * then when 1 = a = a1 n + a2 p, have a1 = inverse of n mod p + * note that it is not necessary to keep a2, b2 around. + *) + fun gcd ((a,a1),(b,b1)) = + if b=1 then (* by continued fraction expansion, 0<|b1|

> +*) + +(* unused code + fun power(n,k) = + if k<=3 then case k of + 0 => one + | 1 => n + | 2 => multiply(n,n) + | 3 => multiply(n,multiply(n,n)) + | _ => reciprocal (power (n,~k)) (* know k<0 *) + else if andb(k,1)=0 then power(multiply(n,n),rshift(k,1)) + else multiply(n,power(multiply(n,n),rshift(k,1))) +*) + + fun isZero (F n) = n=0 +(* unused codeunless P.display is used + fun equal (F n,F m) = n=m + + fun display (F n) = if n<=p smlnj_div 2 then Int.toString n + else "-" ^ Int.toString (p-n) +*) +end + +structure M = struct (* MONO *) + local + val andb = op && + infix sub << >> andb +(* val op << = Bits.lshift and op >> = Bits.rshift and op andb = Bits.andb +*) + in + +(* encode (var,pwr) as a long word: hi word is var, lo word is pwr + masks 0xffff for pwr, mask ~0x10000 for var, rshift 16 for var + note that encoded pairs u, v have same var if u>=v, u andb ~0x10000 (print (Int.toString i); print ",")) x; print">") +*) + exception DoesntDivide + +(* unused code + val numVars = 32 +*) + + val one = M [] + fun x_i v = M [(v<<16)+1] + fun explode (M l) = map (fn v => (v>>16,v andb 65535)) l + fun implode l = M (map (fn (v,p) => (v<<16)+p) l) + + val deg = let fun d([],n) = n | d(u::ul,n) = d(ul,(u andb 65535) + n) + in fn (M l) => d(l,0) end + + (* x^k > y^l if x>k or x=y and k>l *) + val compare = let + fun cmp ([],[]) = Util.Equal + | cmp (_::_,[]) = Util.Greater + | cmp ([],_::_) = Util.Less + | cmp ((u::us), (v::vs)) = if u=v then cmp (us,vs) + else if uv *) Util.Greater + in fn (M m,M m') => cmp(m,m') end + + fun display (M (l : int list)) : string = + let + fun dv v = if v<26 then chr (v+ord #"a") else chr (v-26+ord #"A") + fun d (vv,acc) = let val v = vv>>16 and p = vv andb 65535 + in if p=1 then dv v::acc + else + (dv v)::(String.explode (Int.toString p)) @ acc + end + in String.implode(fold d l []) end + + val multiply = let + fun mul ([],m) = m + | mul (m,[]) = m + | mul (u::us, v::vs) = let + val uu = u andb ~65536 + in if uu = (v andb ~65536) then let + val w = u + (v andb 65535) + in if uu = (w andb ~65536) then w::mul(us,vs) + else + (Util.illegal + (String.concat ["Mono.multiply overflow: ", + display (M(u::us)),", ", + display (M(v::vs))])) + end + else if u>v then u :: mul(us,v::vs) + else (* u M (mul (m,m')) end + + val lcm = let + fun lcm ([],m) = m + | lcm (m,[]) = m + | lcm (u::us, v::vs) = + if u>=v then if (u andb ~65536) M (lcm (m,m')) end + val tryDivide = let + fun rev([],l) = l | rev(x::xs,l)=rev(xs,x::l) + fun d (m,[],q) = SOME(M(rev(q,m))) + | d ([],_::_,_) = NONE + | d (u::us,v::vs,q) = + if u d (m,m',[]) end + fun divide (m,m') = + case tryDivide(m,m') of SOME q => q | NONE => raise DoesntDivide + +end end (* local, structure M *) + +structure MI = struct (* MONO_IDEAL *) + + (* trie: + * index first by increasing order of vars + * children listed in increasing degree order + *) + datatype 'a mono_trie = MT of 'a option * (int * 'a mono_trie) list + (* tag, encoded (var,pwr) and children *) + datatype 'a mono_ideal = MI of (int * 'a mono_trie) ref + (* int maxDegree = least degree > all elements *) + + fun rev ([],l) = l | rev (x::xs,l) = rev(xs,x::l) +(* unused code + fun tl (_::l) = l | tl [] = raise (Util.Impossible "MONO_IDEAL.tl") + fun hd (x::_) = x | hd [] = raise (Util.Impossible "MONO_IDEAL.hd") +*) + val emptyTrie = MT(NONE,[]) + fun mkEmpty () = MI(ref (0,emptyTrie)) + +(* unused code unless searchDeg is used + fun maxDeg (MI(x)) = #1(!x) +*) + + val lshift = op << +(* unused code unless decode is used + val rshift = op >> +*) + val andb = op && +(* unused code + val orb = op || +*) + fun encode (var,pwr) = lshift(var,16)+pwr +(* unused code + fun decode vp = (rshift(vp,16),andb(vp,65535)) +*) + fun grabVar vp = andb(vp,~65536) + fun grabPwr vp = andb(vp,65535) + fun smallerVar (vp,vp') = vp < andb(vp',~65536) + + exception Found + fun search (MI(x),M.M m') = let + val (d,mt) = !x + val result = ref NONE + (* exception Found of M.mono * '_a *) + (* s works on remaining input mono, current output mono, tag, trie *) + fun s (_,m,MT(SOME a,_)) = + raise(result := SOME (M.M m,a); Found) + | s (m',m,MT(NONE,trie)) = s'(m',m,trie) + and s'([],_,_) = NONE + | s'(_,_,[]) = NONE + | s'(vp'::m',m,trie as (vp,child)::children) = + if smallerVar(vp',vp) then s'(m',m,trie) + else if grabPwr vp = 0 then (s(vp'::m',m,child); + s'(vp'::m',m,children)) + else if smallerVar(vp,vp') then NONE + else if vp<=vp' then (s(m',vp::m,child); + s'(vp'::m',m,children)) + else NONE + in s(rev(m',[]),[],mt) + handle Found (* (m,a) => SOME(m,a) *) => !result + end + + (* assume m is a new generator, i.e. not a multiple of an existing one *) + fun insert (MI (mi),m,a) = let + val (d,mt) = !mi + fun i ([],MT (SOME _,_)) = Util.illegal "MONO_IDEAL.insert duplicate" + | i ([],MT (NONE,children)) = MT(SOME a,children) + | i (vp::m,MT(a',[])) = MT(a',[(vp,i(m,emptyTrie))]) + | i (vp::m,mt as MT(a',trie as (vp',_)::_)) = let + fun j [] = [(vp,i(m,emptyTrie))] + | j ((vp',child)::children) = + if vp M.compare (m,m')) msa + val buckets = revfold ins ms (array1(0,[])) + val n = length1 buckets + val mi = mkEmpty() + fun sort i = if i>=n then mi else let + fun redundant (m,_) = case search(mi,m) of NONE => false + | SOME _ => true + fun filter ([],l) = app (fn (m,a) => insert(mi,m,a)) l + | filter (x::xx,l) = if redundant x then filter(xx,l) + else filter(xx,x::l) + in filter(sub1(buckets,i),[]); + update1(buckets,i,[]); + sort(i+1) + end + in sort 0 end + + fun fold g (MI(x)) init = let + val (_,mt) = !x + fun f(acc,m,MT(NONE,children)) = f'(acc,m,children) + | f(acc,m,MT(SOME a,children)) = + f'(g((M.M m,a),acc),m,children) + and f'(acc,m,[]) = acc + | f'(acc,m,(vp,child)::children) = + if grabPwr vp=0 then f'(f(acc,m,child),m,children) + else f'(f(acc,vp::m,child),m,children) + in f(init,[],mt) end + +(* unused code + fun searchDeg (mi,d) = + if d>maxDeg mi then [] + else fold (fn ((m,a),l) => if M.deg m=d then (m,a)::l else l) mi [] +*) + +end (* structure MI *) + + +val log = let fun log(n,l) = if n<=1 then l else log((n >> 1),1+l) + in fn n => log(n,0) end +val maxLeft = ref 0 +val maxRight = ref 0 +val counts = tabulate(20,fn _ => array1(20,0)) +val indices = [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19] + +(* unused code +fun resetCounts() = app(fn i => app (fn j => update1(sub1(counts,i),j,0)) indices) indices +*) + +fun pair(l,r) = let + val l = log l and r = log r + val _ = maxLeft := Int.max(!maxLeft,l) and _ = maxRight := Int.max(!maxRight,r) + val a = sub1(counts,l) + in update1(a,r,sub1(a,r)+1) end +(* unused code unless printCounts is used +fun getCounts () = + map (fn i => map (fn j => sub1(sub1(counts,i),j)) indices) indices +*) + +structure P = struct + + datatype poly = P of (F.field*M.mono) list (* descending mono order *) +(* + fun show (P x) = (print "[ "; + app (fn (f, m) => + (print "("; F.show f; print ","; M.show m; print ") ")) x; + print " ]") +*) + val zero = P [] +(* unused code unless power is used + val one = P [(F.one,M.one)] +*) +(* unused code + fun coerceInt n = P [(F.coerceInt n,M.one)] + fun coerceField a = P [(a,M.one)] + fun coerceMono m = P [(F.one,m)] +*) + fun coerce (a,m) = P [(a,m)] + fun implode p = P p + fun cons (am,P p) = P (am::p) + +local + fun neg p = (map (fn (a,m) => (F.negate a,m)) p) + fun plus ([],p2) = p2 + | plus (p1,[]) = p1 + | plus ((a,m)::ms,(b,n)::ns) = case M.compare(m,n) of + Util.Less => (b,n) :: plus ((a,m)::ms,ns) + | Util.Greater => (a,m) :: plus (ms,(b,n)::ns) + | Util.Equal => let val c = F.add(a,b) + in if F.isZero c then plus(ms,ns) + else (c,m)::plus(ms,ns) + end + fun minus ([],p2) = neg p2 + | minus (p1,[]) = p1 + | minus ((a,m)::ms,(b,n)::ns) = case M.compare(m,n) of + Util.Less => (F.negate b,n) :: minus ((a,m)::ms,ns) + | Util.Greater => (a,m) :: minus (ms,(b,n)::ns) + | Util.Equal => let val c = F.subtract(a,b) + in if F.isZero c then minus(ms,ns) + else (c,m)::minus(ms,ns) + end + fun termMult (a,m,p) = + (map (fn (a',m') => (F.multiply(a,a'),M.multiply(m,m'))) p) +in +(* unused code + fun negate (P p) = P (neg p) +*) + fun add (P p1,P p2) = (pair(length p1,length p2); P (plus(p1,p2))) + fun subtract (P p1,P p2) = (pair(length p1,length p2); P (minus(p1,p2))) + +(* unused code unless power is used + val multiply = let + fun times (p1,p2) = + revfold (fn ((a,m),tot) => plus (termMult(a,m,p2),tot)) p1 [] + in fn (P p1,P p2) => if length p1 > length p2 then P(times (p2,p1)) + else P(times (p1,p2)) + end +*) + +(* unused code + fun singleReduce (P y,a,m,P x) = + (pair(length y,length x); P(minus(y,termMult(a,m,x)))) +*) + + fun spair (a,m,P f,b,n,P g) = + (pair(length f,length g); P(minus(termMult(a,m,f),termMult(b,n,g)))) + val termMult = fn (a,m,P f) => P(termMult(a,m,f)) +end + +(* unused code unless power is used + val rshift = op >> + val lshift = op << +*) + +(* unused code + val andb = op && + val orb = op || +*) + + fun scalarMult (a,P p) = P (map (fn (b,m) => (F.multiply(a,b),m)) p) + + +(* unused code + fun power(p,k) = + if k<=3 then case k of + 0 => one + | 1 => p + | 2 => multiply(p,p) + | 3 => multiply(p,multiply(p,p)) + | _ => Util.illegal "POLY.power with k<0" + else if andb(k,1)=0 then power(multiply(p,p),rshift(k,1)) + else multiply(p,power(multiply(p,p),rshift(k,1))) +*) + + fun isZero (P []) = true | isZero (P (_::_)) = false + +(* unused code + val equal = let + fun eq ([],[]) = true + | eq (_::_,[]) = false + | eq ([],_::_) = false + | eq ((a,m)::p,(b,n)::q) = + F.equal(a,b) andalso M.compare(m,n)=Util.Equal + andalso eq (p,q) + in fn (P p,P q) => eq (p,q) end +*) + + (* these should only be called if there is a leading term, i.e. poly<>0 *) +(* unused code + fun leadTerm (P(am::_)) = am + | leadTerm (P []) = Util.illegal "POLY.leadTerm" +*) + fun leadMono (P((_,m)::_)) = m + | leadMono (P []) = Util.illegal "POLY.leadMono" + fun leadCoeff (P((a,_)::_)) = a + | leadCoeff (P []) = Util.illegal "POLY.leadCoeff" + fun rest (P (_::p)) = P p + | rest (P []) = Util.illegal "POLY.rest" + fun leadAndRest (P (lead::rest)) = (lead,P rest) + | leadAndRest (P []) = Util.illegal "POLY.leadAndRest" + + fun deg (P []) = Util.illegal "POLY.deg on zero poly" + | deg (P ((_,m)::_)) = M.deg m (* homogeneous poly *) + fun numTerms (P p) = length p + +(* only used if r is used + fun display (P []) = F.display F.zero + | display (P p) = let + fun dsp (a,m) = let + val s = + if M.deg m = 0 then F.display a + else if F.equal(F.one,F.negate a) then "-" ^ M.display m + else if F.equal(F.one,a) then M.display m + else F.display a ^ M.display m + in if substring(s,0,1)="-" then s else "+" ^ s end + in String.concat(map dsp p) end +*) +end + +structure HP = struct + datatype hpoly = HP of P.poly array1 + val log = let + fun log(n,l) = if n<8 then l else log((n >> 2),1+l) + in fn n => log(n,0) end + fun mkHPoly p = let + val l = log(P.numTerms p) + in HP(tabulate(l+1,fn i => if i=l then p else P.zero)) end + fun add(p,HP ps) = let + val l = log(P.numTerms p) + in if l>=length1 ps then let + val n = length1 ps + in HP(tabulate(n+n, + fn i => if i=n then lar'(m,indices) else let + val p = sub1(ps,i) + in if P.isZero p then lar(m,indices,i+1) + else if null indices then lar(P.leadMono p,[i],i+1) + else case M.compare(m,P.leadMono p) of + Util.Less => lar(P.leadMono p,[i],i+1) + | Util.Equal => lar(m,i::indices,i+1) + | Util.Greater => lar(m,indices,i+1) + end + and lar' (_,[]) = NONE + | lar' (m,i::is) = let + fun extract i = case P.leadAndRest(sub1(ps,i)) of + ((a,_),rest) => (update1(ps,i,rest); a) + val a = revfold (fn (j,b) => F.add(extract j,b)) + is (extract i) + in if F.isZero a then lar(M.one,[],0) else SOME(a,m,HP ps) + end + in lar(M.one,[],0) end +end + +structure G = struct + val autoReduce = ref true + val maxDeg = ref 10000 + val maybePairs = ref 0 + val primePairs = ref 0 + val usedPairs = ref 0 + val newGens = ref 0 + + fun reset () = (maybePairs:=0; primePairs:=0; usedPairs:=0; newGens:=0) + + fun inc r = r := !r + 1 + + fun reduce (f,mi) = if P.isZero f then f else let + (* use accumulator and reverse at end? *) + fun r hp = case HP.leadAndRest hp of + NONE => [] + | (SOME(a,m,hp)) => case MI.search(mi,m) of + NONE => (a,m)::(r hp) + | SOME (m',p) => r (HP.add(P.termMult(F.negate a,M.divide(m,m'),!p),hp)) + in P.implode(r (HP.mkHPoly f)) end + + (* assume f<>0 *) + fun mkMonic f = P.scalarMult(F.reciprocal(P.leadCoeff f),f) + + (* given monic h, a monomial ideal mi of m's tagged with g's representing + * an ideal (g1,...,gn): a poly g is represented as (lead mono m,rest of g). + * update pairs to include new s-pairs induced by h on g's: + * 1) compute minimal gi1...gik so that generate , i.e. + * compute monomial ideal for gi:h's tagged with gi + * 2) toss out gij's whose lead mono is rel. prime to h's lead mono (why?) + * 3) put (h,gij) pairs into degree buckets: for h,gij with lead mono's m,m' + * deg(h,gij) = deg lcm(m,m') = deg (lcm/m) + deg m = deg (m':m) + deg m + * 4) store list of pairs (h,g1),...,(h,gn) as vector (h,g1,...,gn) + *) + fun addPairs (h,mi,pairs) = let + val m = P.leadMono h + val d = M.deg m + fun tag ((m' : M.mono,g' : P.poly ref),quots) = (inc maybePairs; + (M.divide(M.lcm(m,m'),m),(m',!g'))::quots) + fun insert ((mm,(m',g')),arr) = (* recall mm = m':m *) + if M.compare(m',mm)=Util.Equal then (* rel. prime *) + (inc primePairs; arr) + else (inc usedPairs; + Util.insert(P.cons((F.one,m'),g'),M.deg mm+d,arr)) + val buckets = MI.fold insert (MI.mkIdeal (MI.fold tag mi [])) + (array1(0,[])) + fun ins (~1,pairs) = pairs + | ins (i,pairs) = case sub1(buckets,i) of + [] => ins(i-1,pairs) + | gs => ins(i-1,Util.insert(arrayoflist(h::gs),i,pairs)) + in ins(length1 buckets - 1,pairs) end + + fun grobner fs = let + fun pr l = print (String.concat (l@["\n"])) + val fs = revfold (fn (f,fs) => Util.insert(f,P.deg f,fs)) + fs (array1(0,[])) + (* pairs at least as long as fs, so done when done w/ all pairs *) + val pairs = ref(array1(length1 fs,[])) + val mi = MI.mkEmpty() + val newDegGens = ref [] + val addGen = (* add and maybe auto-reduce new monic generator h *) + if not(!autoReduce) then + fn h => MI.insert (mi,P.leadMono h,ref (P.rest h)) + else fn h => let + val ((_,m),rh) = P.leadAndRest h + fun autoReduce f = + if P.isZero f then f + else let val ((a,m'),rf) = P.leadAndRest f + in case M.compare(m,m') of + Util.Less => P.cons((a,m'),autoReduce rf) + | Util.Equal => P.subtract(rf,P.scalarMult(a,rh)) + | Util.Greater => f + end + val rrh = ref rh + in + MI.insert (mi,P.leadMono h,rrh); + app (fn f => f:=autoReduce(!f)) (!newDegGens); + newDegGens := rrh :: !newDegGens + end + val tasksleft = ref 0 + fun feedback () = let + val n = !tasksleft + in + if (n && 15)=0 then print (Int.toString n) else (); + print "."; + TextIO.flushOut TextIO.stdOut; + tasksleft := n-1 + end + + fun try h = + let + val _ = feedback () + val h = reduce(h,mi) + in if P.isZero h + then () + else let val h = mkMonic h + val _ = (print "#"; TextIO.flushOut TextIO.stdOut) + in pairs := addPairs(h,mi,!pairs); + addGen h; + inc newGens + end + end + + fun tryPairs fgs = let + val ((a,m),f) = P.leadAndRest (sub1(fgs,0)) + fun tryPair i = if i=0 then () else let + val ((b,n),g) = P.leadAndRest (sub1(fgs,i)) + val k = M.lcm(m,n) + in + try (P.spair(b,M.divide(k,m),f,a,M.divide(k,n),g)); + tryPair (i-1) + end + in tryPair (length1 fgs -1) end + + fun numPairs ([],n) = n + | numPairs (p::ps,n) = numPairs(ps,n-1+length1 p) + + fun gb d = if d>=length1(!pairs) then mi else + (* note: i nullify entries to reclaim space *) + ( +pr ["DEGREE ",Int.toString d," with ", + Int.toString(numPairs(sub1(!pairs,d),0))," pairs ", + if d>=length1 fs then "0" else Int.toString(length(sub1(fs,d))), + " generators to do"]; + tasksleft := numPairs(sub1(!pairs,d),0); + if d>=length1 fs then () + else tasksleft := !tasksleft + length (sub1(fs,d)); + if d>(!maxDeg) then () + else ( + reset(); + newDegGens := []; + app tryPairs (sub1(!pairs,d)); + update1(!pairs,d,[]); + if d>=length1 fs then () + else (app try (sub1(fs,d)); update1(fs,d,[])); + pr ["maybe ",Int.toString(!maybePairs)," prime ", + Int.toString (!primePairs), + " using ",Int.toString (!usedPairs), + "; found ",Int.toString (!newGens)] + ); + gb(d+1) + ) + in gb 0 end + +local + (* grammar: + dig ::= 0 | ... | 9 + var ::= a | ... | z | A | ... | Z + sign ::= + | - + nat ::= dig | nat dig + mono ::= | var mono | var num mono + term ::= nat mono | mono + poly ::= term | sign term | poly sign term + *) + datatype char = Dig of int | Var of int | Sign of int + fun char ch = + let val och = ord ch in + if ord #"0"<=och andalso och<=ord #"9" then Dig (och - ord #"0") + else if ord #"a"<=och andalso och<=ord #"z" then Var (och - ord #"a") + else if ord #"A"<=och andalso och<=ord #"Z" then Var (och - ord #"A" + 26) + else if och = ord #"+" then Sign 1 + else if och = ord #"-" then Sign ~1 + else Util.illegal ("bad ch in poly: " ^ (Char.toString(ch))) + end + + fun nat (n,Dig d::l) = nat(n*10+d,l) | nat (n,l) = (n,l) + fun mono (m,Var v::Dig d::l) = + let val (n,l) = nat(d,l) + in mono(M.multiply(M.implode[(v,n)],m),l) end + | mono (m,Var v::l) = mono(M.multiply(M.x_i v,m),l) + | mono (m,l) = (m,l) + + fun term l = let + val (n,l) = case l of (Dig d::l) => nat(d,l) | _ => (1,l) + val (m,l) = mono(M.one,l) + in ((F.coerceInt n,m),l) end + fun poly (p,[]) = p + | poly (p,l) = let + val (s,l) = case l of Sign s::l => (F.coerceInt s,l) | _ => (F.one,l) + val ((a,m),l) = term l + in poly(P.add(P.coerce(F.multiply(s,a),m),p),l) end + +in + fun parsePoly s = poly (P.zero,map char(String.explode s)) + +(* unused code + fun readIdeal stream = let + fun readLine () = let + val s = input_line stream + val n = size s + val n = if n>0 andalso substring(s,n-1,1)="\n" then n-1 else n + fun r i = if i>=n then [] + else case substring(s,i,1) of + ";" => r(i+1) + | " " => r(i+1) + | _ => map char (String.explode(substring(s,i,n-i))) + in r 0 end + fun r () = if end_of_stream stream then [] + else poly(P.zero,readLine()) :: r() + fun num() = if end_of_stream stream then Util.illegal "missing #" + else case nat(0,readLine()) of + (_,_::_) => Util.illegal "junk after #" + | (n,_) => n + val _ = 1=num() orelse Util.illegal "stream doesn't start w/ `1'" + val n = num() + val i = r() + val _ = length i = n orelse Util.illegal "wrong # poly's" + in i end +*) + +(* unused code +fun read filename = let + val stream = open_in filename + val i = readIdeal stream + val _ = close_in stream + in i end +*) +end (* local *) + +end (* structure G *) + + + +val _ = G.maxDeg:=1000000 + +fun grab mi = MI.fold (fn ((m,g),l) => P.cons((F.one,m),!g)::l) mi [] + +(* unused code +fun r mi s = let + val p = G.parsePoly s + in print (P.display p); print "\n"; + print (P.display(G.reduce(p,mi))); print "\n" + end +*) + +(* unused code unless printCounts is used +fun p6 i= let val s= Int.toString (i:int) + val n= size s + in print(substring(" ",0,6-n)); print s end +*) + +(* unused code +fun hex n = let + fun h n = if n=0 then "" + else h(n smlnj_div 16) ^ substring("0123456789ABCDEF",n smlnj_mod 16,1) + in if n=0 then "0" else h n end +fun printCounts () = map (fn l => (map p6 l; print "\n")) (getCounts()) +fun totalCount () = revfold (fn (l,c) => revfold op + l c) (getCounts()) 0 +*) + +(* unused code +fun maxCount () = revfold (fn (l,m) => revfold Int.max l m) (getCounts()) 0 +*) + +(* unused code unless analyze is used +fun terms (p,tt) = if P.isZero p then tt else terms(P.rest p,P.leadMono p::tt) +fun tails ([],tt) = tt + | tails (t as _::t',tt) = tails (t',t::tt) +*) + +(* Unused code unless sort (analyze) is used +local + val a = 16807.0 and m = 2147483647.0 +in + val seed = ref 1.0 + fun random n = let val t = a*(!seed) + in seed := t - m * real(floor(t/m)); + floor(real n * !seed/m) + end +end +*) + +(* Unused code unless analyze is used +fun sort [] = [] + | sort a = +let + val a = arrayoflist a + val b = tabulate(length1 a,fn i => i) + val sub = sub1 and update = update1 + infix sub + fun swap (i,j) = let val ai = a sub i in update(a,i,a sub j); update(a,j,ai) end + (* sort all k, 0<=i<=k (swap (lo,k); partition (dup,lo+1,k+1,hi)) + | Util.Equal => partition (dup+1,lo,k+1,hi) + | Util.Greater => (swap (k,hi-1); partition (dup,lo,k,hi-1))) + val (dup,lo,hi) = partition (0,i,i,j) + in s(i,lo,(dup,pivot)::s(hi,j,acc)) end + in s(0,length1 a,[]) end +*) + +(* Unused code unless analyze is used +fun sum f l = revfold op + (map f l) 0 +*) + +(* Unused code included in the benchmark +fun analyze gb = let + val aa = revfold terms gb [] + val bb = map M.explode aa + val aa = sort aa + fun len m = length (M.explode m) + fun prt (s:string) (i:int) = (print s; print(Int.toString i); print "\n"; i) + val m= sum #1 aa + val u= length aa + val cm =sum (fn (d,l) => d*len l) aa + val cu =sum (len o #2) aa + val for=length(sort(map M.implode (revfold tails bb []))) + val bak=length(sort(map (M.implode o rev) (revfold tails (map rev bb) []))) + in + {m=prt "m = " m, u=prt "u = " u, cm =prt "cm = " cm, cu =prt "cu = " cu, for=prt "for= " for, bak=prt "bak= " bak} + end +*) + +fun gb fs = + let + val g = G.grobner fs handle (Util.Illegal s) => (print s; raise Div) + val fs = grab g + fun info f = app print + [M.display(P.leadMono f), + " + ", Int.toString(P.numTerms f - 1), " terms\n"] + in app info fs end + + +fun report (e as Tabulate) = (print "exn: Tabulate\n"; raise e) + | report (e as ArrayofList) = (print "exn: ArrayofList\n"; raise e) + | report (e as (Util.NotImplemented s)) = + (print ("exn: NotImplemented " ^ s ^ "\n"); raise e) + | report (e as (Util.Impossible s)) = + (print ("exn: Impossible " ^ s ^ "\n"); raise e) + | report (e as (Util.Illegal s)) = + (print ("exn: Illegal " ^ s ^ "\n"); raise e) + | report (e as (M.DoesntDivide)) = (print ("exn: DoesntDivide\n"); raise e) + | report (e as (MI.Found)) = (print ("exn: Found\n"); raise e) + + +(* rather long running test case *) +(* val fs = map G.parsePoly + * ["-El-Dh-Cd+Bo+xn+tm","-Fo+Ep-Ek-Dg-Cc+Ao+wn+sm","-Fn-Ej+Dp-Df-Cb+zo+vn+rm", + * "-Fm-Ei-De+Cp-Ca+yo+un+qm","Fl-Bp+Bk-Al-zh-yd+xj+ti","El-Bo-zg-yc+wj+si", + * "Dl-Bn-Aj+zk-zf-yb+vj+ri","Cl-Bm-Ai-ze+yk-ya+uj+qi", + * "Fh+Bg-xp+xf-wl-vh-ud+te","Eh+Ag-xo-wk+wf-vg-uc+se","Dh+zg-xn-wj-ub+re", + * "Ch+yg-xm-wi-ve+uf-ua+qe","Fd+Bc+xb-tp+ta-sl-rh-qd", + * "Ed+Ac+wb-to-sk+sa-rg-qc","Dd+zc+vb-tn-sj-rf+ra-qb","Cd+yc+ub-tm-si-re"] + *) + +(* rather long running test case *) +(* val u7 = map G.parsePoly + * ["abcdefg-h7","a+b+c+d+e+f+g","ab+bc+cd+de+ef+fg+ga", + * "abc+bcd+cde+def+efg+fga+gab","abcd+bcde+cdef+defg+efga+fgab+gabc", + * "abcde+bcdef+cdefg+defga+efgab+fgabc+gabcd", + * "abcdef+bcdefg+cdefga+defgab+efgabc+fgabcd+gabcde"] + *) + + +(* val u5 = map G.parsePoly ["abcde-f5","a+b+c+d+e","ab+bc+cd+de+ea", + * "abc+bcd+cde+dea+eab","abcd+bcde+cdea+deab+eabc"] + * + * val u4 = map G.parsePoly ["abcd-e4","a+b+c+d","ab+bc+cd+da","abc+bcd+cda+dab"] + * + *) + +(* fun runit () = + * let + * val _ = (print "Enter fs, u7, u6, u5, or u4: "; + * TextIO.flushOut TextIO.stdOut) + * val s = TextIO.inputN(TextIO.stdIn,2) + * val data = + * if (s = "fs") then fs else if (s = "u7") then u7 + * else if (s = "u6") then u6 else if (s = "u5") then u5 + * else if (s = "u4") then u4 else + * (print "no such data\n"; raise (Util.Impossible "no such data")) + * in + * gb data handle e => report e + * end + *) + +structure Main = + struct + fun doit n = + let + val u6 = + map G.parsePoly + ["abcdef-g6","a+b+c+d+e+f","ab+bc+cd+de+ef+fa", + "abc+bcd+cde+def+efa+fab", + "abcd+bcde+cdef+defa+efab+fabc", + "abcde+bcdef+cdefa+defab+efabc+fabcd"] + fun loop n = + if n = 0 + then () + else (gb u6; loop (n - 1)) + in + loop n + end + end diff --git a/benchmark/tests/vector-rev.sml b/benchmark/tests/vector-rev.sml new file mode 100644 index 0000000..1f7af60 --- /dev/null +++ b/benchmark/tests/vector-rev.sml @@ -0,0 +1,26 @@ +(* Written by Stephen Weeks (sweeks@sweeks.com). *) + +structure Main = + struct + open Vector + + fun rev v = + let + val n = length v + in + tabulate (n, fn i => sub (v, n - 1 - i)) + end + + fun doit n = + let + val v = tabulate (200000, fn i => i) + fun loop n = + if n < 0 + then () + else + if 0 = sub (rev (rev v), 0) + then loop (n - 1) + else raise Fail "bug" + in loop (n * 1000) + end + end diff --git a/benchmark/tests/vector32-concat.sml b/benchmark/tests/vector32-concat.sml new file mode 100644 index 0000000..04ca4d2 --- /dev/null +++ b/benchmark/tests/vector32-concat.sml @@ -0,0 +1,19 @@ +(* Written by Stephen Weeks (sweeks@sweeks.com). *) + +structure Main = + struct + fun doit n = + let + val len = 20000 + val sum = Int32.fromInt (len * (len - 1)) + val v = Vector.tabulate (len, fn i => Int32.fromInt i) + fun loop n = + if n < 0 + then () + else + if sum = Vector.foldl (op +) 0 (Vector.concat [v, v]) + then loop (n - 1) + else raise Fail "bug" + in loop (n * 10000) + end + end diff --git a/benchmark/tests/vector64-concat.sml b/benchmark/tests/vector64-concat.sml new file mode 100644 index 0000000..40c7707 --- /dev/null +++ b/benchmark/tests/vector64-concat.sml @@ -0,0 +1,19 @@ +(* Written by Stephen Weeks (sweeks@sweeks.com). *) + +structure Main = + struct + fun doit n = + let + val len = 20000 + val sum = Int64.fromInt (len * (len - 1)) + val v = Vector.tabulate (len, fn i => Int64.fromInt i) + fun loop n = + if n < 0 + then () + else + if sum = Vector.foldl (op +) 0 (Vector.concat [v, v]) + then loop (n - 1) + else raise Fail "bug" + in loop (n * 10000) + end + end diff --git a/benchmark/tests/vliw.sml b/benchmark/tests/vliw.sml new file mode 100644 index 0000000..068f942 --- /dev/null +++ b/benchmark/tests/vliw.sml @@ -0,0 +1,3699 @@ +(* From the SML/NJ benchmark suite. *) + +fun print _ = () + +signature BMARK = + sig + val doit : int -> unit + val testit : TextIO.outstream -> unit + end; + +open Array (* List *) +infix 9 sub + +fun fold f x y = List.foldr f y x +fun revfold f x y = List.foldl f y x +val makestring = Int.toString + +local +open Real +in +val realEq = == +val realNe = != +end + +exception NotAChar +fun fromStr x = + (case Char.fromString x + of SOME c => c + | NONE => raise NotAChar) + +fun ordof(s, i) = Char.ord(String.sub(s, i)) + + +val explode = (fn x => map Char.toString (explode x)) +val implode = (fn x => implode (map fromStr x)) +fun ord s = Char.ord (fromStr s) + +val output = TextIO.output +val std_out = TextIO.stdOut +val open_in = TextIO.openIn +val open_out = TextIO.openOut +val close_in = TextIO.closeIn +val close_out = TextIO.closeOut +val input_line = + fn ins => + case TextIO.inputLine ins of + NONE => "" + | SOME s => s +type instream = TextIO.instream +type outstream = TextIO.outstream +fun outputc f x = TextIO.output(f, x) + +exception NotAReal + +fun strToReal s = + (case Real.fromString s + of SOME r => r + | _ => raise NotAReal) + +fun intToReal x = + (strToReal ((Int.toString x) ^ ".0")) + +structure Bits = +struct + +fun wrap (f : Word.word * Word.word -> Word.word) + = (fn (x : int, y : int) => + Word.toInt(f(Word.fromInt x, Word.fromInt y))) + +val orb = wrap Word.orb +val andb = wrap Word.andb +val xorb = wrap Word.xorb +val lshift = wrap Word.<< +val rshift = wrap Word.>> + +end +structure Ref = +struct + val inc = fn x => (x := !x + 1) + val dec = fn x => (x := !x - 1) +end + +(* stringmap.sml *) + +signature STRINGMAP = + sig type 'a stringmap + exception Stringmap + val new : unit -> 'a stringmap + val add : 'a stringmap -> string * 'a -> unit + val rm : 'a stringmap -> string -> unit + val map : 'a stringmap -> string -> 'a + val app : (string * 'a -> unit) -> 'a stringmap -> unit + val isin : 'a stringmap -> string -> bool + val extract : 'a stringmap -> 'a list + end + +structure Stringmap : STRINGMAP = +struct + type 'a stringmap = (string * 'a) list array + exception Stringmap + val hashFactor = 32 + and tableSize = 2357 + + (* a string hashing function + returns a number between 0 and tableSize-1 *) + fun hash(str: string) : int = + let val nchars = String.size str + + fun loop(i,n,r) = + if i < n then + loop(i+1,n,(hashFactor * r + ordof(str,i)) mod tableSize) + else r + + in loop(0,nchars,0) +(* while !i < nchars do + (n := (hashFactor * !n + ordof(str, !i)) mod tableSize; + i := !i + 1); + !n +*) + end + + (* create a new stringmap *) + fun new (): 'a stringmap = array(tableSize,nil) + + (* add a mapping pair s +-> x to the stringmap a *) + fun add a (s,x) = + let val index = hash s + in update(a,index,(s,x)::(a sub index)) + end + + (* apply the stringmap a to the index string s *) + fun map a s = + let fun find ((s',x)::r) = if s=s' then x else find r + | find nil = raise Stringmap + in find (a sub (hash s)) + end + + (* return true if the string is in the map, false otherwise *) + fun isin a s = + ((map a s; true) + handle Stringmap => false) + + (* remove all pairs mapping string s from stringmap a *) + fun rm a s = let fun f ((b as (s',j))::r) = + if s=s' then f r else b :: f r + | f nil = nil + val index = hash s + in update(a,index, f(a sub index)) + end + + (* apply a function f to all mapping pairs in stringmap a *) + fun app (f: string * 'a -> unit) a = + let fun zap 0 = () + | zap n = let val m = n-1 in List.app f (a sub m); zap m end + in zap tableSize + end + + (* extract the stringmap items as a list *) + fun extract a = + let fun atol n = + if n < Array.length a then (a sub n) :: atol (n + 1) + else nil + val al = atol 0 + fun flatten (a, b) = a @ b + val fal = fold flatten al nil + fun strip (s, v) = v + val answer = List.map strip fal + in + answer + end + +end (* Stringmap *) + + + +structure StrPak : + sig + val stringListString : string list -> string + end = + +struct + +fun sl nil = "]" + | sl (h::nil) = h ^ "]" + | sl (h::n::t) = h ^ "," ^ sl (n::t) + +fun stringListString l = "[" ^ sl l + +end +signature SortObjSig = + sig + type obj + val gt : obj * obj -> bool + end + +functor Sort ( objfun : SortObjSig ) : + sig + type obj + val sort : obj list -> obj list + end = + +struct + +open objfun + +type obj = objfun.obj + +fun sort l = + let fun m2 (nil, b) = b + | m2 (a, nil) = a + | m2 (ha::ta, hb::tb) = + if gt(ha, hb) then hb::(m2(ha::ta, tb)) + else ha::(m2(ta, hb::tb)) + fun ml (nil) = nil + | ml (h::nil) = h + | ml (h1::h2::nil) = m2(h1, h2) + | ml (h1::h2::l) = ml [m2(h1, h2), (ml l)] + in + ml (map (fn x => [x]) l) + end + +end + +structure IntImp = + struct + type obj = int + fun gt(a:obj, b:obj) = a > b + end + + +structure INTSort = Sort ( IntImp ) + +structure Set : + sig + exception SET + exception LISTUNION + type 'a set + val make : ''a set + val makeEQ : ('a * 'a -> bool) -> 'a set + val listToSet : ''a list -> ''a set + val listToSetEQ : ('a * 'a -> bool) * 'a list -> 'a set + val add : 'a set * 'a -> 'a set + val union : 'a set * 'a set -> 'a set + val listUnion : 'a set list -> 'a set + val listUnionEQ : ('a * 'a -> bool) * 'a set list -> 'a set + val rm : 'a set * 'a -> 'a set + val intersect : 'a set * 'a set -> 'a set + val diff : 'a set * 'a set -> 'a set + val member : 'a set * 'a -> bool + val set : 'a set -> 'a list + val mag : 'a set -> int + val empty : 'a set -> bool + end = +struct +datatype 'a set = S of ('a*'a->bool) * 'a list + +exception SET +exception LISTUNION + +fun eqf (x, y) = x = y + +val make = S (eqf, nil) + +fun makeEQ eqf = S (eqf, nil) + +fun set (S (eqf, a)) = a + +fun member (S (eqf, nil), e) = false + | member (S (eqf, (s::t)), e) = eqf(e, s) orelse member(S (eqf, t), e) + +fun add(st as (S (eqf, s)), e) = if member(st, e) then st else S(eqf, e::s) + +fun listToSetEQ (eqf, l) = + let fun f (nil, s) = s + | f (h::t, s) = f(t, add(s, h)) + in + f(l, makeEQ eqf) + end + +fun listToSet l = listToSetEQ (eqf, l) + + +fun union (a, S (eqf, nil)) = a + | union (S (eqf, nil), b) = b + | union (S (eqf, e::a), b) = union(S (eqf, a), add(b, e)) + +fun listUnion (h::t) = fold union t h + | listUnion _ = raise LISTUNION + +fun listUnionEQ (eqf, l) = fold union l (makeEQ eqf) + + +fun rm (S (eqf, nil), x) = raise SET + | rm (S (eqf, s::t), x) = + if eqf(s, x) then S (eqf, t) else S(eqf, s :: set(rm(S (eqf, t), x))) + +fun intersect1 (a, S (eqf, nil), c) = S (eqf, c) + | intersect1 (S (eqf, nil), b, c) = S (eqf, c) + | intersect1 (S (eqf, a::t), b, c) = + if member(b, a) then intersect1(S (eqf, t), b, a::c) + else intersect1(S (eqf, t), b, c) + +fun intersect (a, b) = intersect1 (a, b, nil) + +fun diff (S (eqf, nil), b) = S (eqf, nil) + | diff (S (eqf, a::t), b) = if member(b, a) then diff(S (eqf, t), b) + else S (eqf, a :: set(diff(S (eqf, t), b))) + + +fun mag s = List.length (set s) + +(* fun empty s = set s = nil *) + +fun empty (S(eqf, nil)) = true + | empty (S(eqf, _)) = false + +end +(* Copyright 1989 by AT&T Bell Laboratories *) +(* updated by John Danskin at Princeton *) +structure AbsMach = +struct + type reg = (int*string) + type label = (int*string) + datatype values = + INT of int + | REAL of real + | LABVAL of int * int + + datatype arithop = imul | iadd | isub | idiv + | orb | andb | xorb | rshift | lshift + | fadd | fdiv | fmul | fsub + | real | floor | logb + + datatype comparison = ilt | ieq | igt | ile | ige | ine + | flt | feq | fgt | fle | fge | fne + | inrange | outofrange + datatype opcode = + FETCH of {immutable: bool, offset: int, ptr: reg, dst: reg} + (* dst := M[ptr+offset] + if immutable then unaffected by any STORE + other than through the allocptr *) + | STORE of {offset: int, src: reg, ptr: reg} + (* M[ptr+offset] := src *) + | GETLAB of {lab: label, dst: reg} + | GETREAL of {value: string, dst: reg} + | ARITH of {oper: arithop, src1: reg, src2: reg, dst: reg} + | ARITHI of {oper: arithop, src1: reg, src2: int, dst: reg} + | MOVE of {src: reg, dst: reg} + | BRANCH of {test: comparison, src1: reg, src2: reg, dst: label, + live: reg list} + | JUMP of {dst: reg, live: reg list} + | LABEL of {lab:label, live: reg list} + | WORD of {value: int} + | LABWORD of {lab: label} + | NOP + | BOGUS of {reads: reg list, writes: reg list} + + val opcodeEq : opcode * opcode -> bool = (op =) + +end + +structure AbsMachImp : + sig + type reg + type operation + val oeq : operation * operation -> bool + type comparison + val ceq : comparison * comparison -> bool + val write_o : operation -> reg Set.set + val read_o : operation -> reg Set.set + val write_c : comparison -> reg Set.set + val read_c : comparison -> reg Set.set + val resources_ok : operation list * comparison list -> bool + datatype codetypes = + ASSIGNMENT of operation + | LABELREF of int * operation + | COMPARISON of int * operation + | FLOW of int * operation + | TARGET of int * operation + | EXIT of operation + | JUNK of operation + | NERGLE + val classify : operation -> codetypes + val maxreg : AbsMach.opcode list -> int + end = +struct + +type reg = int (* register strings will gum up set operations etc *) +type operation = AbsMach.opcode +type comparison = AbsMach.opcode + +fun oeq (a, b) = AbsMach.opcodeEq(a, b) +fun ceq (a, b) = AbsMach.opcodeEq(a, b) + +fun reg(i, s) = i +fun label(i, s) = i + + +fun srl rl = Set.listToSet((map reg) rl) +fun sr r = srl [r] + +val immutableMem = ~1 +val mutableMem = ~2 +val flowControl = ~3 + +(* comparisons are limited to one because of difficulty writing larger trees *) +fun resources_ok(ops, c) = (List.length ops) <= 4 andalso (List.length c) <= 1 + +fun allocptr r = reg r = 1 + +fun write_o i = + let open Set + open AbsMach + val f = + fn FETCH{dst, ...} => sr dst + | STORE{ptr, ...} => + if allocptr ptr then listToSet [immutableMem, mutableMem] + else listToSet [mutableMem] + | GETLAB {dst, ...} => sr dst + | GETREAL {dst, ...} => sr dst + | ARITH {dst, ...} => sr dst + | ARITHI {dst, ...} => sr dst + | MOVE {dst, ...} => sr dst + | JUMP _ => listToSet [flowControl] + | BOGUS {writes, ...} => srl writes + | _ => make + in + f i + end + +fun write_c c = Set.listToSet [flowControl] + +val std_reg_list = [(1, ""), (2, ""), (3, ""), (4, ""), (5, "")] + +fun read i = + let open Set + open AbsMach + val f = + fn FETCH {immutable, ptr, ...} => + let val mem = if immutable then immutableMem else mutableMem + in + add(sr ptr, mem) + end + | STORE {src, ptr, ...} => srl [src, ptr] + | ARITH {src1, src2, ...} => srl [src1, src2] + | ARITHI {src1, ...} => sr src1 + | MOVE {src, ...} => sr src + | BRANCH {src1, src2, ...} => srl [src1, src2] + | JUMP {dst, ...} => srl (dst :: std_reg_list) + | BOGUS {reads, ...} => srl reads + | _ => make + in + f i + end + +fun read_o i = read i +fun read_c i = read i + +datatype codetypes = + ASSIGNMENT of operation + | LABELREF of int * operation + | COMPARISON of int * operation + | FLOW of int * operation + | TARGET of int * operation + | EXIT of operation + | JUNK of operation + | NERGLE + +fun maxreg li = + let fun f (a, b) = Int.max(a, b) + val r = + (Set.set (Set.listUnion((map write_o li) @ + (map read li)))) + in + fold f r 0 + end + + +fun classify i = + let open AbsMach + val f = + fn FETCH _ => ASSIGNMENT i + | STORE _ => ASSIGNMENT i + | GETLAB{lab, dst} => LABELREF(label lab, i) + | GETREAL _ => ASSIGNMENT i + | ARITH _ => ASSIGNMENT i + | ARITHI _ => ASSIGNMENT i + | MOVE{src, dst} => + if reg src = reg dst then NERGLE + else ASSIGNMENT i + | BRANCH{test,src1,src2,dst,live} => + if test = ieq andalso (reg src1) = (reg src2) + then FLOW (label dst, i) + else COMPARISON (label dst, i) + | JUMP _ => EXIT i + | LABEL {lab, ...} => TARGET(label lab, i) + | WORD _ => JUNK i + | LABWORD _ => JUNK i + | NOP => JUNK i + | BOGUS _ => ASSIGNMENT i + in + f i + end +end +structure ReadAbs : sig val read: instream -> AbsMach.opcode list end = +struct + +open AbsMach + +exception ReadError + +fun readline(i,f) = +let + + fun error s = (print("Error in line "^makestring i^": "^s^"\n"); + raise ReadError) + +fun b(" "::rest) = b rest | b rest = rest + +val aop = + fn "i"::"m"::"u"::"l"::l => (imul,l) + | "i"::"a"::"d"::"d"::l => (iadd,l) + | "i"::"s"::"u"::"b"::l => (isub,l) + | "i"::"d"::"i"::"v"::l => (idiv,l) + | "o"::"r"::"b"::" "::l=> (orb,l) + | "a"::"n"::"d"::"b"::l => (andb,l) + | "x"::"o"::"r"::"b"::l => (xorb,l) + | "r"::"s"::"h"::"i"::"f"::"t"::l => (rshift,l) + | "l"::"s"::"h"::"i"::"f"::"t"::l => (lshift,l) + | "f"::"a"::"d"::"d"::l => (fadd,l) + | "f"::"d"::"i"::"v"::l => (fdiv,l) + | "f"::"m"::"u"::"l"::l => (fmul,l) + | "f"::"s"::"u"::"b"::l => (fsub,l) + | "r"::"e"::"a"::"l"::l => (real,l) + | "f"::"l"::"o"::"o"::"r"::l => (floor,l) + | "l"::"o"::"g"::"b"::l => (logb,l) + | _ => error "illegal arithmetic operator" + +val com = + fn "i"::"l"::"t"::l => (ilt,l) + | "i"::"e"::"q"::l => (ieq,l) + | "i"::"g"::"t"::l => (igt,l) + | "i"::"l"::"e"::l => (ile,l) + | "i"::"g"::"e"::l => (ige,l) + | "i"::"n"::"e"::l => (ine,l) + | "f"::"l"::"t"::l => (flt,l) + | "f"::"e"::"q"::l => (feq,l) + | "f"::"g"::"t"::l => (fgt,l) + | "f"::"l"::"e"::l => (fle,l) + | "f"::"g"::"e"::l => (fge,l) + | "f"::"n"::"e"::l => (fne,l) + | "i"::"n"::"r"::"a"::"n"::"g"::"e"::l => (inrange,l) + | "o"::"u"::"t"::"o"::"f"::"r"::"a"::"n"::"g"::"e"::l => (outofrange,l) + | _ => error "illegal comparison operator" + +fun immut("i"::l) = (true,l) | immut("m"::l) = (false,l) + | immut _ = error "i or m required" + +fun int l = + let val z = ord "0" + fun f(n,l0 as d::l) = if d>="0" andalso d<="9" + then f(n*10+ord(d)-z, l) + else (n,l0) + | f _ = error "in readabs.int" + in f(0,l) + end + +fun string l = + let fun f("/"::l) = (nil,l) + | f(a::l) = let val (s,l') = f l + in (a::s, l') + end + | f _ = error "name not terminated by \"/\"" + val (s,l') = f l + in (implode s, l') + end + + fun realc s = + let val (sign,s) = case explode s of "~"::rest => (~1.0,rest) + | s => (1.0,s) + fun j(exp,d::dl,mant) = j(exp,dl,mant * 0.1 + intToReal(d)) + | j(0,nil,mant) = mant*sign + | j(exp,nil,mant) = if exp>0 then j(exp-1,nil,mant*10.0) + else j(exp+1,nil,mant*0.1) + fun h(esign,wholedigits,diglist,exp,nil) = + j(esign*exp+wholedigits-1,diglist,0.0) + | h(es,fd,dl,exp,d::s) = h(es,fd,dl,exp*10+(ord d - ord "0"),s) + fun g(i,r,"E"::"~"::s)=h(~1,i,r,0,s) + | g(i,r,"E"::s)=h(1,i,r,0,s) + | g(i,r,d::s) = if d>="0" andalso d<="9" then + g(i, (ord d - ord "0")::r, s) + else h(1,i,r,0,nil) + | g(i,r,nil) = h(1,i,r,0,nil) + fun f(i,r,"."::s)=g(i,r,s) + | f(i,r,s as "E"::_)=g(i,r,s) + | f(i,r,d::s) = f(i+1,(ord(d)-ord("0"))::r,s) + | f _ = error "bad in readdabs" + in f(0,nil,s) + end handle Overflow => error ("real constant "^s^" out of range") + +fun require((a:string)::ar, b::br) = if a=b then require(ar,br) + else error(a^" required") + | require(nil, br) = br + | require(a::_,_) = error(a^" required") + +fun reg l = let val (s,l) = string l + val l = require(["R"],l) + val (i,l) = int l + in ((i,s),l) + end +fun lab l = let val (s,l) = string l + val l = require(["L"],l) + val (i,l) = int l + in ((i,s),l) + end + +fun live l = + let fun f(")"::_) = nil + | f l = let val (r,l) = reg l + in r::f(b l) + end + in f(b(require(["("],l))) + end + +val opcode = + fn "F"::"E"::"T"::"C"::"H"::l => + let val (imm,l) = immut(b l) + val (dst,l) = reg(b l) + val (ptr,l) = reg(b(require(["M","["],b(require([":","="],b l))))) + val (offset,l) = int(b(require(["+"],b l))) + in require(["]"], b l); + FETCH{immutable=imm,dst=dst,ptr=ptr,offset=offset} + end + | "S"::"T"::"O"::"R"::"E"::l => + let val (ptr,l) = reg(b(require(["M","["],b l))) + val (offset,l) = int(b(require(["+"],b l))) + val (src,l) = reg(b(require([":","="],b(require(["]"], b l))))) + in STORE{src=src,ptr=ptr,offset=offset} + end + | "G"::"E"::"T"::"L"::"A"::"B"::l => + let val (dst,l) = reg(b l) + val (lab,l) = lab(b(require([":","="],b l))) + in GETLAB{dst=dst,lab=lab} + end + | "G"::"E"::"T"::"R"::"E"::"A"::"L"::l => + let val (dst,l) = reg(b l) + val r = realc(implode(b(require([":","="],b l)))) + in GETREAL{dst=dst,value=Real.toString r} + end + | "A"::"R"::"I"::"T"::"H"::"I"::l => + let val (dst,l) = reg(b l) + val (s1,l) = reg(b(require([":","="],b l))) + val (oper,l) = aop(b l) + val (s2,l) = int(b l) + in ARITHI{oper=oper,src1=s1,src2=s2,dst=dst} + end + | "A"::"R"::"I"::"T"::"H"::l => + let val (dst,l) = reg(b l) + val (s1,l) = reg(b(require([":","="],b l))) + val (oper,l) = aop(b l) + val (s2,l) = reg(b l) + in ARITH{oper=oper,src1=s1,src2=s2,dst=dst} + end + | "M"::"O"::"V"::"E"::l => + let val (dst,l) = reg(b l) + val (s1,l) = reg(b(require([":","="],b l))) + in MOVE{src=s1,dst=dst} + end + | "B"::"R"::"A"::"N"::"C"::"H"::l => + let val (s1,l) = reg(b(require(["I","F"],b l))) + val (test,l) = com(b l) + val (s2,l) = reg(b l) + val (dst,l) = lab(b(require(["G","O","T","O"],b l))) + val liv = live(b l) + in BRANCH{test=test,src1=s1,src2=s2,dst=dst,live=liv} + end + | "J"::"U"::"M"::"P"::l => + let val (dst,l) = reg(b l) + val live = live(b l) + in JUMP{dst=dst,live=live} + end + | "L"::"A"::"B"::"E"::"L"::l => + let val (lab,l) = lab(b l) + val live = live(b(require([":"],l))) + in LABEL{lab=lab,live=live} + end + | "W"::"O"::"R"::"D"::l => + let val (i,l) = int(b l) + in WORD{value=i} + end + | "L"::"A"::"B"::"W"::"O"::"R"::"D"::l => + let val (i,l) = lab(b l) + in LABWORD{lab=i} + end + | "N"::"O"::"P"::_ => NOP + | _ => error "illegal opcode name" +in + case explode(input_line f) + of nil => nil + | l => opcode(b l)::readline(i+1,f) +end + +fun read f = readline(0,f) + +end + +structure PrintAbs : + sig + val show: outstream -> AbsMach.opcode list -> unit + val str: AbsMach.opcode list -> string + end = +struct + +open AbsMach + +fun xstr prog = + +let + +val outstr = ref "" +fun pr s = outstr := !outstr ^ s + +val aop = + fn imul => "imul" + | iadd => "iadd" + | isub => "isub" + | idiv => "idiv" + | orb => "orb" + | andb => "andb" + | xorb => "xorb" + | rshift => "rshift" + | lshift => "lshift" + | fadd => "fadd" + | fdiv => "fdiv" + | fmul => "fmul" + | fsub => "fsub" + | real => "real" + | floor => "floor" + | logb => "logb" + +val com = + fn ilt => "ilt" + | ieq => "ieq" + | igt => "igt" + | ile => "ile" + | ige => "ige" + | ine => "ine" + | flt => "flt" + | feq => "feq" + | fgt => "fgt" + | fle => "fle" + | fge => "fge" + | fne => "fne" + | inrange => "inrange" + | outofrange => "outofrange" + +fun bo true = "t" | bo false = "f" + +fun reg(i,s) = (pr(s); pr "/R"; pr(makestring i)) +fun label(i,s) = (pr(s); pr "/L"; pr(makestring i)) + +val p = + fn FETCH{immutable,offset,ptr,dst} => + (pr "FETCH"; + if immutable then pr "i " else pr "m "; + reg dst; pr " := M[ "; reg ptr; + pr " + "; pr (makestring offset); pr(" ]\n")) + | STORE{offset,ptr,src} => + (pr "STORE "; + pr "M[ "; reg ptr; + pr " + "; pr (makestring offset); pr(" ] := "); + reg src; + pr "\n") + | GETLAB{lab, dst} => + (pr "GETLAB "; reg dst; + pr " := "; label lab; + pr "\n") + | GETREAL{value,dst} => + (pr "GETREAL "; reg dst; + pr " := "; + pr value; + pr "\n") + | ARITH{oper,src1,src2,dst} => + (pr "ARITH "; reg dst; + pr " := "; reg src1; + pr " "; pr(aop oper); pr " "; + reg src2; + pr "\n") + | ARITHI{oper,src1,src2,dst} => + (pr "ARITHI "; reg dst; + pr " := "; reg src1; + pr " "; pr(aop oper); pr " "; + pr(makestring src2); + pr "\n") + | MOVE{src,dst} => + (pr "MOVE "; reg dst; + pr " := "; reg src; + pr "\n") + | BRANCH{test,src1,src2,dst,live} => + (pr "BRANCH "; + pr "IF "; reg src1; + pr " "; pr(com test); pr " "; + reg src2; + pr " GOTO "; + label dst; + pr " ( "; + List.app (fn r => (reg r; pr " ")) live; + pr ")\n") + | JUMP{dst,live} => + (pr "JUMP "; reg dst; + pr " ( "; + List.app (fn r => (reg r; pr " ")) live; + pr ")\n") + | LABEL{lab, live} => + (pr "LABEL "; label lab; + pr ": ( "; + List.app (fn r => (reg r; pr " ")) live; + pr ")\n") + | WORD{value} => + (pr "WORD "; + pr (makestring value); + pr "\n") + | LABWORD{lab} => + (pr "LABWORD "; label lab; + pr "\n") + | NOP => pr "NOP\n" + | BOGUS{reads, writes} => + (pr "BOGUS"; + pr " ( "; + List.app (fn r => (reg r; pr " ")) writes; + pr ") := ("; + List.app (fn r => (reg r; pr " ")) reads; + pr ")\n") + + +in (List.app p prog; !outstr) +end + +fun str prog = + let fun cat (a, b) = (xstr [a]) ^ b + in + fold cat prog "" + end + +fun show out prog = + let fun f nil = () + | f (h::t) = (outputc out (xstr [h]); + f t) + in + f prog + end + +end + + +structure HM = AbsMachImp +structure BreakInst : + sig + val breaki : AbsMach.opcode list -> AbsMach.opcode list + end = +struct + +open AbsMach +open HM + +val maxreg = AbsMachImp.maxreg + +fun reg(i:int, s:string) = i +fun rstr(i:int, s:string) = s + +val new_reg_val = ref 0 +val new_reg_pairs:(AbsMach.reg * AbsMach.reg) list ref = ref nil + +fun new_reg_init li = (new_reg_val := maxreg li; + new_reg_pairs := nil) + +fun new_reg (r:AbsMach.reg) = + let fun f nil = + let val nr = (new_reg_val := !new_reg_val + 1; (!new_reg_val, rstr r)) + in + (new_reg_pairs := (r, nr) :: !new_reg_pairs; + nr) + end + | f ((a, b)::t) = if r = a then b else f t + in + f (!new_reg_pairs) + end + +fun breaki l = + let fun f i = + let val g = + fn ARITH{oper, src1, src2, dst} => + if reg dst = reg src1 orelse reg dst = reg src2 then + let val nr = new_reg(dst) + in + [ARITH{oper=oper, src1=src2, src2=src2, dst=nr}, + MOVE{src=nr, dst=dst}] + end + else [i] + | ARITHI{oper, src1, src2, dst} => + if reg dst = reg src1 then + let val nr = new_reg(dst) + in + [ARITHI{oper=oper, src1=src1, src2=src2, dst=nr}, + MOVE{src=nr, dst=dst}] + end + else [i] + | FETCH{immutable, offset, ptr, dst} => + if reg ptr = reg dst then + let val nr = new_reg(dst) + in + [FETCH{immutable=immutable, offset=offset, + ptr=ptr, dst=nr}, + MOVE{src=nr, dst=dst}] + end + else [i] + | MOVE{src, dst} => + if reg src = reg dst then nil + else [i] + | _ => [i] + in + g i + end + fun h (a, b) = f a @ b + val foo = new_reg_init l + in + fold h l nil + end + +end +structure OutFilter : + sig + val remnops : AbsMach.opcode list -> AbsMach.opcode list + end = +struct + +open AbsMach + +fun remnops ol = + let fun f (NOP, NOP::b) = NOP::b + | f (a, b) = a::b + in + fold f ol nil + end + +end +structure Delay : + sig + val init: AbsMach.opcode list -> unit + val add_delay: AbsMach.opcode list -> AbsMach.opcode list + val rm_bogus: AbsMach.opcode list -> AbsMach.opcode list + val is_bogus_i : AbsMach.opcode -> bool + val is_bogus_reg : AbsMach.reg -> bool + val idempotency : int ref + end = +struct + +open AbsMach + +val maxreg = ref 0 +val maxdelay = 12 + +val idempotency = ref 0 + +fun is_bogus_i (BOGUS _ ) = true + | is_bogus_i _ = false + +fun bogus_reg ((i, s), which) = (!maxreg + maxdelay * i + which, s) + +fun is_bogus_reg (i, s) = i > !maxreg + +fun unbogus_reg (i, s) = if is_bogus_reg (i, s) then (i div maxdelay, s) + else (i, s) + +val max_bog_reg = ref 0 +val curr_idem_reg = ref 0 + +fun idem_reg() = + (curr_idem_reg := !curr_idem_reg + 1; + (!curr_idem_reg, "idem")) + +fun init il = ( + maxreg := AbsMachImp.maxreg il; + max_bog_reg := (!maxreg + 1) * maxdelay; + curr_idem_reg := !max_bog_reg + 1 + ) + +exception DELAY + +fun delay i = + let fun opdelay oper = + let val f = + fn imul => 5 + | iadd => 2 + | isub => 2 + | idiv => 12 + | orb => 2 + | andb => 2 + | xorb => 2 + | rshift => 2 + | lshift => 2 + | fadd => 2 + | fdiv => 12 + | fmul => 4 + | fsub => 2 + | real => 2 + | floor => 2 + | logb => 2 + in + f oper + end + val id = + fn FETCH{immutable,offset,ptr,dst} => 2 + | STORE{offset,ptr,src} => 2 + | GETLAB{lab, dst} => 2 + | GETREAL{value,dst} => 2 + | ARITH{oper,src1,src2,dst} => opdelay oper + | ARITHI{oper,src1,src2,dst} => opdelay oper + | MOVE{src,dst} => 1 + | BRANCH{test,src1,src2,dst,live} => 5 + | JUMP{dst,live} => 1 + | LABEL{lab, live} => 0 + | NOP => 1 + | _ => raise DELAY + in + id i + end + +fun b_idemx (0, r, w) = nil + | b_idemx (1, r, w) = BOGUS{reads=r @ w, writes = [idem_reg()]} :: nil + | b_idemx (n, r, w) = + let val ir = idem_reg() + in + BOGUS{reads=r @ w, writes = [ir]} :: b_idemx(n-1, r, [ir]) + end + +fun b_idem (n, r, w) = + let fun fil ((i, s), b) = if i = 0 then b else (i, s) :: b + val nr = fold fil r nil + in + if null nr then nil + else b_idemx(n, nr, w) + end + +fun b_assx (0, r) = nil + | b_assx (1, r) = BOGUS{reads=[bogus_reg(r, 1)], writes=[r]} :: nil + | b_assx (n, r) = + BOGUS{reads=[bogus_reg(r, n)], writes=[bogus_reg(r, n-1)]} :: + b_assx(n-1, r) + +fun b_ass(n, r) = BOGUS{reads=[r], writes=[bogus_reg(r, n-1)]} :: + b_assx(n-1, r) + +fun b_brxx (0, rl) = nil + | b_brxx (1, rl) = + let fun b r = bogus_reg(r, 1) + in + BOGUS{reads=rl, writes=map b rl} :: nil + end + | b_brxx (n, rl) = + let fun br r = bogus_reg(r, n - 1) + fun bw r = bogus_reg(r, n) + in + BOGUS{reads=map br rl, writes=map bw rl} :: b_brxx (n - 1, rl) + end + +fun b_brx (n, rl) = + let fun br r = bogus_reg(r, n-1) + in + BOGUS{reads=map br rl, writes=rl} :: b_brxx(n-1, rl) + end + +fun b_br (b, n, rl) = rev (b :: b_brx(n, rl)) + +fun is_flow i = + let open AbsMachImp + fun f (FLOW _) = true + | f _ = false + in + f (classify i) + end + +fun add_delay il = + let fun idem (r, w) = b_idem (!idempotency, r, w) + fun g i = + let val d = delay i + val f = + fn FETCH{immutable,offset,ptr,dst} => + i :: (idem([ptr], [dst]) @ b_ass(d, dst)) + | STORE{offset,ptr,src} => [i] + | GETLAB{lab, dst} => i :: b_ass(d, dst) + | GETREAL{value,dst} => i :: b_ass(d, dst) + | ARITH{oper,src1,src2,dst} => + i :: (idem([src1, src2], [dst]) @ b_ass(d, dst)) + | ARITHI{oper,src1,src2,dst} => + i :: (idem([src1], [dst]) @ b_ass(d, dst)) + | MOVE{src,dst} => i :: idem([src], [dst]) + | BRANCH{test,src1,src2,dst,live} => + if is_flow i then [i] + else + b_br (BRANCH{test=test, + src1=src1,src2=src2,dst=dst, + live=live}, + d, [src1, src2]) + | _ => [i] + in + f i + end + fun apnd (nil, b) = b + | apnd (a::t, b) = a :: apnd(t, b) + fun fld(a, b) = apnd(g a, b) + in + fold fld il nil + end + +fun rm_bogus il = + let fun g nil = nil + | g (i::t) = + let val f = + fn FETCH{immutable,offset,ptr,dst} => + FETCH{immutable=immutable, offset=offset, ptr=ptr, + dst= unbogus_reg dst} :: + g t + | STORE{offset,ptr,src} => i :: g t + | GETLAB{lab, dst} => + GETLAB{lab=lab, dst= unbogus_reg dst} :: g t + | GETREAL{value,dst} => + GETREAL{value=value, dst=unbogus_reg dst} :: g t + | ARITH{oper,src1,src2,dst} => + ARITH{oper=oper,src1=src1,src2=src2,dst=unbogus_reg dst} :: + g t + | ARITHI{oper,src1,src2,dst} => + ARITHI{oper=oper,src1=src1,src2=src2,dst=unbogus_reg dst} :: + g t + | MOVE{src,dst} => i :: g t + | BRANCH{test,src1,src2,dst,live} => + BRANCH{test=test, + src1=unbogus_reg src1, + src2=unbogus_reg src2, + dst=dst, live=live + } :: g t + | BOGUS _ => g t + | _ => i :: g t + in + f i + end + in + g il + end +end +structure Ntypes : + sig + type name + val init_names : unit -> unit + val new_name : name -> name + val prime_name : name -> name + val name_prefix_eq : (name * name) -> bool + type test + val teq : test * test -> bool + type reg + type assignment + val aeq : assignment * assignment -> bool + + datatype test_or_name = + TEST of test + | NAME of name + | NEITHER + + val toneq : test_or_name * test_or_name -> bool + + datatype test_or_assign = + TST of test + | ASS of assignment + + val toaeq : test_or_assign * test_or_assign -> bool + + end = + +struct + + +type test = HM.comparison +val teq = HM.ceq + +type reg = int*string + +type assignment = HM.operation +val aeq = HM.oeq + +type name = string + +val ct = ref 0 + +fun init_names () = ct := 0 + +fun nn() = (ct := !ct + 1; !ct - 1) + +fun pref nil = nil + | pref ("_" :: t) = nil + | pref (h :: t) = h :: pref t + +val name_prefix = implode o pref o explode +fun name_prefix_eq(a, b) = (name_prefix a) = (name_prefix b) +(* +fun new_name n = n ^ "_" ^ (makestring (nn())) +*) +fun new_name n = name_prefix n ^ "_" ^ (makestring (nn())) +fun prime_name n = (new_name n) ^ "'" + +datatype test_or_name = + TEST of test + | NAME of name + | NEITHER + +fun toneq (TEST a, TEST b) = teq (a, b) + | toneq (NAME a, NAME b) = a = b + | toneq _ = false + +datatype test_or_assign = + TST of test + | ASS of assignment + +fun toaeq (TST a, TST b) = teq (a, b) + | toaeq (ASS a, ASS b) = aeq (a, b) + | toaeq _ = false + +end +structure Dag : + sig + exception DAG + exception DAGnotfound + type dag + val make : dag + val tests_of : dag -> Ntypes.test Set.set + val sel_of : dag -> ((Ntypes.test * bool) -> Ntypes.test_or_name) + val root_of : dag -> Ntypes.test_or_name + val succ_of : dag -> Ntypes.name Set.set + val attach : Ntypes.test * dag * dag -> dag + val reach : dag * Ntypes.test_or_name -> dag + val replace_edge : dag * Ntypes.name list -> dag + val newdag : (Ntypes.test Set.set * + ((Ntypes.test * bool) -> Ntypes.test_or_name) * + Ntypes.test_or_name * + Ntypes.name Set.set) + -> dag + val dagToString : dag -> string + end = +struct + +open Ntypes; + + +exception DAGnotfound +exception DAG + +datatype dag = + D of + test Set.set * + ((test * bool) -> test_or_name) * + test_or_name * + name Set.set + +fun tonToString (TEST t) = "TEST t" + | tonToString (NAME n) = "NAME " ^ n + | tonToString NEITHER = "NEITHER" + +fun sep (a, b) = a ^ ", " ^ b + +fun dagToString (D(t, sel, rt, s)) = + "D([" ^ PrintAbs.str (Set.set t) ^ "]" ^ + "fn, " ^ (tonToString rt) ^ ", " ^ (fold sep (Set.set s) ")") + +val make = D(Set.makeEQ teq, fn x => raise DAGnotfound, NEITHER, Set.make) + +fun newdag x = D x + +fun tests_of(D (b, sel, r, h)) = b +fun sel_of(D (b, sel, r, h)) = sel +fun root_of(D (b, sel, r, h)) = r +fun succ_of(D (b, sel, r, h)) = h + +fun attach (t, D dt, D df) = + let open Set + val (b1, sel1, r1, h1) = dt + val (b2, sel2, r2, h2) = df + in + D(add(union(b1, b2), t), + (fn(x, y) => + if teq(x, t) then if y then r1 else r2 + else sel1(x, y) handle DAGnotfound => sel2(x, y)), + TEST t, + union(h1,h2) + ) + end + +fun reach (D d, tn) = + let open Set + val (b, sel, r, h) = d + fun f (TEST t) = + if not (member(b, t)) then raise DAGnotfound + else attach(t, reach(D d, sel(t, true)), reach(D d, sel(t, false))) + | f (NAME n) = + D(makeEQ teq, fn x => raise DAGnotfound, NAME n, listToSet [n]) + | f (_) = raise DAGnotfound + in + f tn + end + +fun replace_edge (D d, nil) = D d + | replace_edge (D d, old::new::tl) = + let open Set + val (b, sel, r, h) = d + val nh = if member(h, old) then add(rm(h, old), new) else h + val nr = if toneq(r, NAME old) then NAME new else r + val nsel = fn(x, y) => + let val v = sel(x, y) + in + if toneq(v, NAME old) then NAME new else v + end + in + D (b, nsel, nr, nh) + end + | replace_edge _ = raise DAG + +end + + + + + + + + + + + + + + + + +structure Node : + sig + type node + type program + val delete_debug : bool ref + val move_op_debug : bool ref + val move_test_debug : bool ref + val rw_debug : bool ref + val ntn_debug : bool ref + val prog_node_debug : bool ref + val prog_node_debug_verbose : bool ref + val closure_progs_debug : bool ref + val cpsiCheck : bool ref + val makeProg : unit -> program + val make : + Ntypes.name * Ntypes.assignment Set.set * + Dag.dag * Ntypes.name Set.set-> node + val name_of : node -> Ntypes.name + val assignment_of : node -> Ntypes.assignment Set.set + val dag_of : node -> Dag.dag + val succ : program * node -> Ntypes.name Set.set + val prednm : program * Ntypes.name -> Ntypes.name Set.set + val pred : program * node -> Ntypes.name Set.set + val succNodes : program * node -> node Set.set + val predNodes : program * node -> node Set.set + val readNode : node -> int Set.set + val writeNode : node -> int Set.set + val unreachable : program * node -> bool + val num_ops_node : node -> int + val num_tests_node : node -> int + val num_things_node : node -> int + val replace_edge_node : node * string list -> node + exception NAMETONODE + val nameToNode : program * Ntypes.name -> node + val nameSetToNodeSet : program * Ntypes.name Set.set -> node Set.set + val eqn : node * node -> bool + val n00 : node + val fin : node + val delete : program * node -> program + val move_op : + program * Ntypes.assignment * node Set.set * node -> program + val move_test : program * Ntypes.test * node * node -> program + val nodeToString : node -> string + val progToString : program -> string + val entries : program -> node list + val programs : program -> program list + val addPredInfo : program -> program + val closure : program * node -> program + val sortNodes : node list -> node list + val updateNode : program * node -> program + val addNode : program * node -> program + val rmNode : program * node -> program + end = +struct + +open Ntypes +open Dag +open StrPak +datatype node = N of name * assignment Set.set * dag * name Set.set +type program = node Stringmap.stringmap * node * node + +type debug_fun = unit -> string +val delete_debug = ref false +val move_op_debug = ref false +val dead_set_debug = ref false +val move_test_debug = ref false +val rw_debug = ref false +val prog_node_debug = ref false +val prog_node_debug_verbose = ref false +val closure_progs_debug = ref false + +fun name_of(N(n, a, d, prd)) = n +fun assignment_of(N(n, a, d, prd)) = a +fun dag_of(N(n, a, d, prd)) = d +fun pred_of(N(n, a, d, prd)) = prd + +fun eqn(n1, n2) = name_of n1 = name_of n2 + +val start:name = "START" +val finish:name = "FINISH" + +fun printstringlist sl = stringListString sl +val psl = printstringlist + +fun nodeToString (N(n, a, d, prd)) = + "\nN(" ^ n ^ ", [" ^ PrintAbs.str (Set.set a) ^ "], " ^ + Dag.dagToString d ^ + "pred(" ^ psl (Set.set prd) ^ "))" + +fun progToString (ns, n0, F) = + "P (" ^ (psl o (map nodeToString) o Stringmap.extract) ns ^ ",\n" ^ + nodeToString n0 ^ ",\n" ^ + nodeToString F ^ ")\n" + +fun make (n, a, t, prd) = N(n, a, t, prd) + +val n00 = make(start, Set.makeEQ aeq, Dag.make, Set.make) +val fin = make(finish, Set.makeEQ aeq, Dag.make, Set.make) + +fun makeProg() = (Stringmap.new():node Stringmap.stringmap, n00, fin) + +fun addPredNode (N(n, a, t, prd), p) = (N(n, a, t, Set.add(prd, p))) +fun unionPredNode (N(n, a, t, prd), ps) = (N(n, a, t, Set.union(prd, ps))) +fun setPredNode (N(n, a, t, prd), p) = (N(n, a, t, p)) +fun rmPredNode (N(n, a, t, prd), p) = (N(n, a, t, Set.rm(prd, p))) + +fun p_n_debug (f:debug_fun) = + if !prog_node_debug then print ("p_n:" ^ f() ^ "\n") + else () + + +fun updateNode(P as (ns, n0, F), new_node) = + let val answer = + (Stringmap.rm (ns:node Stringmap.stringmap) + ((name_of new_node):string); + Stringmap.add ns ((name_of new_node), new_node); + if name_of new_node = name_of n0 then (ns, new_node, F) + else if name_of new_node = name_of F then (ns, n0, new_node) + else P) + val foo = p_n_debug + (fn () => + ("updateNode n=" ^ nodeToString new_node ^ + "=>" ^ + (if !prog_node_debug_verbose then progToString answer + else "(program)"))) + in + answer + end + +fun addNode(P as (ns, n0, F), new_node) = + let val answer = + if Stringmap.isin ns (name_of new_node) then updateNode(P, new_node) + else (Stringmap.add ns ((name_of new_node), new_node); + P) + val foo = p_n_debug + (fn () => + ("addNode n=" ^ nodeToString new_node ^ + "=>" ^ + (if !prog_node_debug_verbose then progToString answer + else "(program)"))) + in + answer + end + + +fun rmNode(P as (ns, n0, F), node) = + let val answer = (Stringmap.rm ns (name_of node); + P) + val foo = p_n_debug + (fn () => + ("rmNode n=" ^ nodeToString node ^ + "=>" ^ + (if !prog_node_debug_verbose then progToString answer + else "(program)"))) + in + answer + end + + +fun succ(p, n) = (succ_of o dag_of) n +fun pred(p, n) = pred_of n + +val ntn_debug = ref true +fun ntnPrint (f:debug_fun) = if !ntn_debug then print ("ntn:" ^ f() ^ "\n") else () + +exception NAMETONODE +fun nameToNode(P as (ns, n0, F), nm) = + Stringmap.map ns nm + handle Stringmap => + (ntnPrint (fn () => ("nameToNode " ^ nm ^ "not found")); + raise NAMETONODE) + +exception NAMESETTONODESET +fun nameSetToNodeSet(P, ns) = + Set.listToSetEQ(eqn, map (fn x => nameToNode(P, x)) (Set.set ns)) + handle NAMETONODE => raise NAMESETTONODESET + +fun prednm(p, nm) = pred(p, nameToNode(p, nm)) + +fun succNodes (p, n) = nameSetToNodeSet(p, succ(p, n)) +fun predNodes (p, n) = nameSetToNodeSet(p, pred(p, n)) + + +(* a correctness assertion *) +exception CPSI +val cpsiCheck = ref false +fun checkPredSuccInfo(from, P as (ns, n0, F)) = + let val nl = Stringmap.extract ns + val badnode = ref n0 + fun fail s = (print ("CPSI:" ^ s ^ " failed\nfrom " ^ from ^ + "\nbadnode=" ^ nodeToString (!badnode) ^ + "\nprogram=" ^ progToString P ^ "\n"); + raise CPSI) + fun chk (xpred, xsuccN, n) = + let val foo = badnode := n + val s = Set.set(xsuccN(P, n)) + handle NAMESETTONODESET => + fail "NAMESETTONODESET" + fun cs x = Set.member(xpred x, name_of n) + fun fs (x, b) = b andalso cs x + in + fold fs s true + end + fun cp (x, b) = b andalso chk(pred_of, succNodes, x) + fun cs (x, b) = b andalso chk((succ_of o dag_of), predNodes, x) + in + if not (fold cp nl true) then fail "cp" + else if not (fold cs nl true) then fail "cs" + else () + end +fun cpsi x = if !cpsiCheck then checkPredSuccInfo x else () + + +fun empty n = + let open Set in + empty (assignment_of n) andalso empty ((tests_of o dag_of) n) + end + +fun unreachable(P as (ns, n0, F), n) = + not (eqn (n0, n)) andalso Set.empty (pred(P, n)) + +fun read (TST(t)) = HM.read_c t + | read (ASS(a)) = HM.read_o a + +fun write (TST(t)) = HM.write_c t + | write (ASS(a)) = HM.write_o a + +fun read_write_debug (f:debug_fun) = + if !rw_debug then print (f() ^ "\n") + else () + +fun readNode n = + let open Set + val answer = + union + (listUnion (make::(map (read o ASS) ((set o assignment_of) n))), + listUnion (make::(map + (read o TST) ((set o tests_of o dag_of) n)))) + val foo = read_write_debug + (fn () => + ("readNode " ^ nodeToString n ^ "=>" ^ + stringListString (map makestring (set answer)))) + in + answer + end + +fun writeNode n = + let open Set + val answer = + union + (listUnion (make::(map (write o ASS) ((set o assignment_of) n))), + listUnion (make::(map + (write o TST) ((set o tests_of o dag_of) n)))) + val foo = read_write_debug + (fn () => + ("writeNode " ^ nodeToString n ^ "=>" ^ + stringListString (map makestring (set answer)))) + in + answer + end + +fun no_write_conflict (ta, n) = + let open Set in + empty (intersect(writeNode n, (union(read ta, write ta)))) + end + +fun no_read_conflict (ta, n) = + let open Set in + empty (intersect (write ta, readNode n)) + end + +fun empty n = + let open Set in + (empty o assignment_of) n andalso (empty o tests_of o dag_of) n + end + +fun replace_edge_node(N (n, a, d, p), nl) = N(n, a, replace_edge(d, nl), p) + +fun except_bogus nil = nil + | except_bogus (h::t) = + if Delay.is_bogus_i h then except_bogus t else h :: except_bogus t + +val num_ops_node = List.length o except_bogus o Set.set o assignment_of +val num_tests_node = List.length o Set.set o tests_of o dag_of +fun num_things_node n = (num_ops_node n) + (num_tests_node n) + +fun dead_debug (f:debug_fun) = + if !dead_set_debug then print ("dead" ^ f() ^ "\n") else () + +exception DEAD +fun dead(P:program, r:HM.reg, n:node, done: name Set.set) = + let val foo = + dead_debug (fn () => "(P, " ^ makestring r ^ ", " ^ nodeToString n ^ ")") + val new_done = Set.add(done, name_of n) + fun nfil(a, b) = if Set.member(new_done, a) then b + else a::b + fun drl nil = true + | drl (h::t) = dead(P, r, h, new_done) andalso drl t + fun ntn n = nameToNode (P, n) handle NAMETONODE => raise DEAD + val next = fold nfil (Set.set (succ(P, n))) nil + val answer = ( + not (Set.member(readNode n, r)) andalso + (Set.member(writeNode n, r) orelse + drl (map ntn next)) + ) + val foo = dead_debug(fn () => "=>" ^ Bool.toString answer) + in + answer + end + +fun deadset(P, rs, n) = + let val foo = dead_debug (fn () => "deadset(" ^ + stringListString + (map makestring (Set.set rs)) ^ ",\n" ^ + nodeToString n ^ ")") + fun f nil = true + | f (r::t) = dead(P, r, n, Set.make) andalso f t + val answer = f (Set.set rs) + val foo = dead_debug(fn () => "deadset=>" ^ Bool.toString answer ^ "\n") + in + answer + end + +fun del_debug (f:debug_fun) = + if !delete_debug then print ("delete:" ^ f() ^ "\n") + else () + +exception DELETE +exception DELETE_HD +exception DELETE_WIERDSUCC +fun delete (P as (ns, n0, F), n) = + let val foo = cpsi("delete enter", P) + val em = empty n + val un = unreachable(P, n) + fun ntn n = nameToNode(P, n) handle NAMETONODE => raise DELETE + val p = Set.listToSetEQ(eqn, (map ntn (Set.set (pred(P, n))))) + open Set + + val foo = del_debug + (fn () => + "delete( n=" ^ (name_of n) ^ "\n" ^ + "em=" ^ (Bool.toString em) ^ "\n" ^ + "un=" ^ (Bool.toString un) ^ "\n" ^ + "p =" ^ (psl (map name_of (Set.set p))) ^ "\n" ^ + ")") + in + if (em orelse un) andalso not (eqn(n, F)) then + if not un then + let + val foo = del_debug (fn () => "complex deletion") + val s0 = Set.set (succ(P, n)) + val nprime = if List.length s0 = 1 then hd s0 + else (print (Int.toString (List.length s0)); + raise DELETE_WIERDSUCC) + val new_nprime = + rmPredNode(unionPredNode(ntn nprime, pred_of n), + name_of n) + fun ren x = + replace_edge_node(x, [name_of n, name_of new_nprime]) + val pprime = map ren (set p) + fun updt(n, p) = updateNode(p, n) + val Nprime = fold updt (new_nprime :: pprime) P + + val foo = del_debug (fn () => "nprime=" ^ nprime) + val foo = del_debug + (fn () => + "pprime=" ^ (psl (map nodeToString pprime))) + val answer = rmNode(Nprime, n) + val foo = cpsi("delete leave cd", answer) + in + answer + end + else (del_debug (fn () => "simple_deletion"); + let val s = Set.set(nameSetToNodeSet(P, (succ(P, n)))) + fun updt(s, p) = updateNode(p, rmPredNode(s, name_of n)) + val np = rmNode(fold updt s P, n) + val foo = cpsi("delete leave sd", np) + in + np + end) + else (del_debug (fn () => "No deletion"); + P) + end handle Hd => raise DELETE_HD + +fun mop_debug (f:debug_fun) = + if !move_op_debug then + (dead_set_debug := true; + print ("mop:" ^ f() ^ "\n")) + else dead_set_debug := false + + +fun can_move_op1(P as (ns, n0, F), x, move_set, m) = + let open Set + val foo = mop_debug (fn () => "can_move_op") + val rok = HM.resources_ok(set (add(assignment_of m, x)), + set ((tests_of o dag_of) m)) + val foo = mop_debug(fn () => "1") + val p = diff(nameSetToNodeSet(P, succ(P, m)), move_set) + val foo = mop_debug(fn () => "2") + val l = (write o ASS) x + val foo = mop_debug(fn () => "3") + fun dlpf nil = true + | dlpf (pj::t) = deadset(P, l, pj) andalso dlpf t + fun cond nil = true + | cond (nj::t) = + (not o eqn)(nj, F) andalso + (* no_read_conflict(ASS x, nj) andalso *) + (* change ex model so it can run on a sequential machine *) + no_read_conflict(ASS x, m) andalso + no_write_conflict(ASS x, m) andalso + cond t + val foo = mop_debug(fn () => "4") + val answer = rok andalso cond (set move_set) andalso dlpf (set p) + val foo = mop_debug (fn () => "can_move_op=>" ^ Bool.toString answer) + in + answer + end + +fun can_move_op(P, x, move_set, m) = + let open Set + val ms = set move_set + fun pf n = pred(P, n) + val ps = set(listUnion (map pf ms)) + fun all (x, b) = b andalso can_move_op1(P, x, move_set, m) + in + if List.length ps > 1 then + if List.length ms > 1 then false + else fold all ((set o assignment_of o hd) ms) true + else can_move_op1(P, x, move_set, m) + end + +fun move_op (P as (ns, n0, F), x, move_set, m) = + let val foo = cpsi("move_op enter", P) + val foo = + mop_debug (fn () => + "move_op(x=" ^ + PrintAbs.str [x] ^ + "move_set\n" ^ + (stringListString (map nodeToString + (Set.set move_set))) ^ + "\nm=" ^ nodeToString m ^"\n)\n") + in + if not (can_move_op(P, x, move_set, m)) then P + else + let open Set + exception NOTFOUND + val primed_pairs = ref nil + fun pnf nm = + let fun f nil = + let val nn = prime_name nm + in + (primed_pairs := (nm, nn) :: !primed_pairs; + nn) + end + | f ((a, b)::t) = if nm = a then b else f t + val answer = f (!primed_pairs) + val foo = mop_debug (fn () => "pnf " ^ nm ^ "=>" ^ answer) + in + answer + end + val foo = mop_debug(fn () => "1") + fun njp nil = nil + | njp ((N(n, a, d, prd))::t) = + N(pnf n, rm(a, x), d, listToSet [name_of m]) :: njp t + fun ojp l = map (fn x => rmPredNode(x, name_of m)) l + fun replist nil = nil + | replist (h::t) = h :: pnf h :: replist t + val rlist = replist (map name_of (set move_set)) + val foo = mop_debug(fn () => "2") + val mprime = + let val aprime = add(assignment_of m, x) + val dprime = replace_edge(dag_of m, rlist) + in + N(name_of m, aprime, dprime, pred_of m) + end + val foo = mop_debug(fn () => "3") + val nj = njp(set move_set) + val foo = mop_debug(fn () => + "nj=" ^ + stringListString (map name_of nj)) + fun uptd(n, p) = updateNode(p, n) + val np = fold uptd (mprime :: (ojp (set move_set))) P + fun addnpi(n, p) = + let val s = set (succNodes(p, n)) + fun ap x = addPredNode(x, name_of n) + fun updt(x, p) = updateNode(p, ap x) + in + fold updt s p + end + fun addn(n, p) = addnpi(n, addNode(p, n)) + val nnp = fold addn nj np + val foo = mop_debug(fn () => "4") + val answer = nnp + val foo = mop_debug(fn () => "5") + val foo = cpsi("move_op leave", answer) + in + mop_debug(fn () => "6"); + answer + end + end + +fun updt_sel (d, nsel) = + let val tst = tests_of d + val rt = root_of d + val s = succ_of d + in + newdag(tst, nsel, rt, s) + end + +fun mt_debug (f:debug_fun) = + if !move_test_debug then print ("move_test" ^ f() ^ "\n") + else () + +fun can_move_test(P as (ns, n0, F):program, x:test, n:node, m:node) = + let val foo = cpsi("move_test enter", P) + val foo = mt_debug (fn () => "can_move_test") + val answer = + no_write_conflict(TST x, m) andalso + + (* hack because sel can't distinguish xj *) + not (Set.member(tests_of(dag_of m), x)) andalso + + HM.resources_ok(Set.set (assignment_of m), + Set.set (Set.add((tests_of o dag_of) m, x))) + val foo = mt_debug (fn () => "can_move_test=>" ^ Bool.toString answer) + in + answer + end + +fun move_test (P as (ns, n0, F):program, x:test, n:node, m:node) = + if not (can_move_test(P, x, n, m)) then P + else + let val foo = + mt_debug (fn () => "move_test" ^ name_of n ^ " " ^ name_of m) + open Set + val d_n = dag_of n + val sel_n = sel_of d_n + val rt_n = root_of d_n + val nt = + let val newname = (new_name o name_of) n ^ "tt" + fun nsel (z, b) = + let val v = sel_n(z, b) in + if toneq(v, TEST x) then sel_n(x, true) + else v + end + val nC = + if TEST x = rt_n then + reach(updt_sel(d_n, nsel), sel_n(x, true)) + else + reach(updt_sel(d_n, nsel), rt_n) + in + N(newname, assignment_of n, nC, listToSet [name_of m]) + end + val foo = mt_debug (fn () => "got nt") + val nf = + let val newname = ((new_name o name_of) n) ^ "ff" + fun nsel (z, b) = + let val v = sel_n(z, b) in + if toneq(v, TEST x) then sel_n(x, false) + else v + end + val nC = + if TEST x = rt_n then + reach(updt_sel(d_n, nsel), sel_n(x, false)) + else + reach(updt_sel(d_n, nsel), rt_n) + in + N(newname, assignment_of n, nC, listToSet [name_of m]) + end + val foo = mt_debug (fn () => "got nf") + val d_m = dag_of m + val sel_m = sel_of d_m + fun nton n = NAME( name_of n) + fun nsel (z, b) = + if teq(z, x) then if b then nton nt else nton nf + else + let val v = sel_m(z, b) in + if toneq(v, NAME(name_of n)) then TEST x else v + end + val nb = add(tests_of d_m, x) + val nh = + add(add(rm(succ_of d_m, name_of n), name_of nt), name_of nf) + fun new_rt (NAME rt) = TEST x + | new_rt t = t + val nc = newdag(nb, nsel, (new_rt o root_of) d_m, nh) + val new_m = N(name_of m, assignment_of m, nc, pred_of m) + fun updt_t s = addPredNode(s, name_of nt) + fun updt_f s = addPredNode(s, name_of nf) + val upt = map updt_t (set (nameSetToNodeSet(P, succ(P, nt)))) + val upf = map updt_f (set (nameSetToNodeSet(P, succ(P, nf)))) + fun updtl(n, p) = updateNode(p, n) + val np = + fold updtl ([rmPredNode(n, name_of m), new_m] @ upt @ upf) P + val answer = np + val foo = mt_debug (fn () => "mtst done") + val foo = cpsi("move_test leave", answer) + in + answer + end + + +fun entries (P as (ns, n0, F)) = + let val nl = Stringmap.extract ns + fun f (a, b) = if unreachable(P, a) then a::b else b + in + n0 :: (fold f nl nil) + end + +fun addPredInfo(P as (ns, n0, F)) = + let fun rmpi n = setPredNode (n, Set.make) + val nl = map rmpi (Stringmap.extract ns) + fun updt(n, p) = updateNode(p, n) + val np = fold updt nl P + fun addpi (n, p) = + let val s = Set.set (succNodes(p, n)) + fun api(s, p) = updateNode(p, addPredNode(s, name_of n)) + in + fold api s p + end + in + fold addpi nl np + end + +fun cp_debug (f:debug_fun) = + if !closure_progs_debug then print ("cp:" ^ f() ^ "\n") + else () + +fun closure (P as (ns, n0, F), entry) = + let open Set + val foo = cp_debug + (fn () => + "closure:entry=" ^ name_of entry ^ "\nprogram=" ^ progToString P) + val isin = Stringmap.isin + fun dfs(p, parent, nil) = p + | dfs(p as (ns, n0, F), parent, cur::todo) = + if not (isin ns (name_of cur)) then + let val np = dfs(addNode(p, cur), cur, set(succNodes(P, cur))) + in + dfs(np, parent, todo) + end + else dfs(p, parent, todo) + val prog:program = (Stringmap.new(), entry, F) + val answer = dfs(addNode(prog, entry), + entry, + set(succNodes(P, entry))) + val foo = cp_debug + (fn () => + "\nclosure=>" ^ progToString answer) + in + answer + end + +fun programs(P as (ns, n0, F):program) = + let val foo = cp_debug (fn () => "programs") + val l = entries (addPredInfo P) + (* make sure preds are in closure*) + fun cf e = addPredInfo(closure(P, e)) + val answer = map cf l + val foo = cp_debug (fn () => "programs done") + in + answer + end + +structure ns = + struct + type obj = node + + fun int l = + let val z = ord "0" + fun f(n, nil) = n + | f (n, d::l) = + if d>="0" andalso d<="9" then f(n*10+ord(d)-z, l) + else n + in + f(0,l) + end + + fun gt (a, b) = + let val a = explode(name_of a) + val b = explode(name_of b) + in + (int a) > (int b) + end + end + +structure sortN = Sort(ns) + +val sortNodes = sortN.sort + +end + +structure Compress : + sig + val compress_debug : bool ref + val compress : (int * Node.program) -> Node.program + val move_things_node : + Node.program * Ntypes.name * Ntypes.name Set.set -> Node.program + val do_move_tests : bool ref + val do_move_ops : bool ref + + val dbg_p : Node.program ref + + end = + +struct + +open Ntypes +open Dag +open Node + +val do_move_tests = ref false +val do_move_ops = ref true + +exception COMPRESS + +fun error (s:string) = + (print (s ^ "\n"); + raise COMPRESS) + +val compress_debug = ref false + +val dbg_p = ref (makeProg()) + +type debug_fun = unit -> string +fun debug (f:debug_fun) = + if !compress_debug then print (f() ^ "\n") + else () + +exception FILTERSUCC + +fun filterSucc(P, nm, fence_set) = + let open Set + val s = set(succ(P, nameToNode(P, nm))) + handle NAMETONODE => raise FILTERSUCC + fun f (nm, l) = if member(fence_set, nm) then l else nm::l + in + fold f s nil + end + +(* +val inP = ref false +val finP = ref makeProg +val foutP = ref makeProg + +fun chinP (p, from) = + let val nm = "11_100'_110tt_119'" + val prd = prednm(p, nm) + val pe = Set.empty(prd) + in + if !inP then + if pe then (foutP := p; error ("chinP gone -" ^ from)) else () + else if pe then () + else (inP := true; + print ("chinP found it -" ^ from ^ "\n"); + finP := p; + nameToNode(p, nm); + ()) + end +*) + +exception MOVETHINGSNODE +fun move_things_node(P, nm, fence_set) = + let open Set + (* + val foo = debug + (fn () => + "move_things_node(\n" ^ + progToString P ^ ",\n" ^ + nm ^ ", [" ^ + fold (fn (a, b) => a ^ ", " ^ b) (set fence_set) "]" ^ + ")") + *) + fun ntn (p, nm) = ((* chinP (p, "ntn");*) nameToNode (p, nm)) + handle NAMETONODE => (dbg_p := P; raise MOVETHINGSNODE) + fun s_nm_list p = filterSucc(p, nm, fence_set) + fun nd nm = ntn(P, nm) handle MOVETHINGSNODE => error "nd nm" + val au = listUnionEQ(aeq, map (assignment_of o nd) (s_nm_list P)) + val tu = listUnionEQ(teq, map (tests_of o dag_of o nd) (s_nm_list P)) + fun ms (p, a) = + let fun f(nm, l) = + ((*chinP (p, "ms"); *) + if member(assignment_of(ntn(p, nm)), a) then nm::l + else l + ) + handle MOVETHINGSNODE => (dbg_p := p; error "ms") + in + fold f (s_nm_list p) nil + end + fun move_a1(a, p) = + let val msl = ms (p, a) + val ms_set = nameSetToNodeSet(p, listToSet msl) + fun dms(a, p) = delete(p, ntn(p, a)) + fun mop() = + let val foo = debug (fn () => "mop start " ^ nm) + val new_p = move_op(p, a, ms_set, ntn(p, nm)) + handle MOVETHINGSNODE => error "move_a move_op" + val foo = debug (fn () => "mop end") + in + new_p + end + val mpa = mop() + (* + val foo = chinP(mpa, + "a_move_a amop " ^ nm ^ + StrPak.stringListString + (map name_of (set ms_set))) + *) + val answer = fold dms msl mpa + (* + val foo = chinP(answer, "a_move_a adel") + *) + in + answer + end + fun move_a(a, p) = if !do_move_ops then move_a1(a, p) else p + fun tset (p, t) = + let fun f(nm, l) = + ((*chinP (p, "tset");*) + if member(tests_of(dag_of(ntn(p, nm))), t) then nm::l + else l + ) + handle MOVETHINGSNODE => error "tset" + in + fold f (s_nm_list p) nil + end + fun move_t1(t, p) = + let val ts = tset (p, t) + val answer = + if List.length ts > 0 then + move_test(p, t, + (ntn(p, hd ts) + handle MOVETHINGSNODE => error "move_t 1"), + (ntn(p, nm) + handle MOVETHINGSNODE => error "move_t 2")) + + else p + (*val foo = chinP(answer, "a_move_t")*) + in + answer + end + fun move_t(t, p) = if !do_move_tests then move_t1(t, p) else p + in + debug (fn () => "movethingsnode " ^ nm ^ "\n"); + fold move_t (set tu) (fold move_a (set au) P) + end + +exception MOVETHINGSWINDOW +fun move_things_window(P, w, nm, fence_set) = + let open Set + (* + val foo = debug (fn () => + "move_things_window(\n" ^ + progToString P ^ ",\n" ^ + (makestring w) ^ ", " ^ + nm ^ ", [" ^ + fold (fn (a, b) => a ^ ", " ^ b) (set fence_set) "]" ^ + ")\n") + *) + fun ntn (P, nm) = (nameToNode (P, nm)) + handle NAMETONODE => raise MOVETHINGSWINDOW + val node = ntn(P, nm) + val things = num_things_node node + val s_nm_list = filterSucc(P, nm, fence_set) + fun nxt(nm, p) = + move_things_window(p, w - things, nm, fence_set) + val child_p = if w > things then fold nxt s_nm_list P else P + in + debug (fn () => "movethingswindow " ^ nm ^ "\n"); + move_things_node(child_p, nm, fence_set) + end + + +exception CPRESS +exception CPRESS1 +exception CPRESS2 +exception CPRESS3 +exception CPRESS4 +exception CPRESS5 +fun cpress(window, P, fence_set, everin_fence_set) = + let open Set + fun nxt(nm, p:program) = + ((* dbg_p := p; *) + move_things_window(p, window, nm, fence_set)) + handle MOVETHINGSWINDOW => raise CPRESS1 + val filled = fold nxt (set fence_set) P + handle CPRESS1 => raise CPRESS2 + fun succf nm = succ(filled, nameToNode(filled, nm)) + handle NAMETONODE => raise CPRESS + val nfence_set = listUnion(make::(map succf (set fence_set))) + fun filt(a, l) = if member(everin_fence_set, a) then l else a::l + val f_fence_set = listToSet(fold filt (set nfence_set) nil) + val n_everin_fc = + fold (fn (a, s) => add(s, a)) (set f_fence_set) everin_fence_set + in + debug (fn () => "cpress: fence_set=" ^ + StrPak.stringListString (set fence_set) ^ + "\n f_fence_set =" ^ StrPak.stringListString (set f_fence_set)); + if not (empty f_fence_set) + then cpress(window, filled, f_fence_set, n_everin_fc) + handle CPRESS => raise CPRESS3 + handle CPRESS1 => raise CPRESS4 + handle CPRESS2 => raise CPRESS5 + else filled + end + +fun clean_up (P as (ns, n0, F):program) = + let val foo = debug (fn () => "cleanup") + val clos = closure(P, n0) + val (ns, n0, F) = clos + val l = (map name_of (Stringmap.extract ns)) + fun f (n, p) = + (debug (fn () => "cleanup deleting " ^ n); + delete(p, nameToNode(p, n))) + val answer = fold f l clos + val foo = debug (fn () => "exiting cleanup") + in + answer + end + +fun compress(window, P as (ns, n0, F)) = + let open Set + val fence = n0 + val fence_set = add(make, name_of n0) + val everin_fence_set = add(makeEQ(name_prefix_eq), name_of n0) + val uc = cpress(window, P, fence_set, everin_fence_set) + val cu = clean_up uc + in + debug (fn () => "compress"); + cu + end + + + +end +structure ReadI : + sig + val readI : + HM.operation list -> (HM.operation list * Node.program list) + + val writeI : + (HM.operation list * Node.program list) -> HM.operation list + + val progMap : Node.program -> string + + val read_debug : bool ref + val write_debug : bool ref + val live_debug : bool ref + end = + +struct + +val read_debug = ref false +val write_debug = ref false +val live_debug = ref false + +fun read_dbg f = + if !read_debug then print ("readI.read:" ^ f() ^ "\n") + else () + +fun write_dbg f = + if !write_debug then print ("writeI.read:" ^ f() ^ "\n") + else () + +fun write_dbg_s s = write_dbg (fn () => s) + +exception BTARGET + +fun btarget (nil, n) = (fn x => raise BTARGET) + | btarget (h::t, n) = + let open HM + val rf = btarget(t, n + 1) + fun g lbl x = if lbl = x then n else rf x + fun f (TARGET(lbl, inst)) = (g lbl) + | f _ = rf + in + f h + end + + +val programs = Node.programs + +exception BNODES + +fun buildNodes l = + let open HM + open Ntypes + val t = btarget(l, 0) + fun f (nil, n) = nil + | f (ci::rest, n) = + let open Dag + open AbsMach + val nm = makestring n + val nxtnm = makestring (n + 1) + fun asn i = Set.listToSetEQ(aeq, i) + val edag = reach(Dag.make, NAME nxtnm) + fun tgtnm tgt = makestring (t tgt) + fun edagt tgt = reach(Dag.make, NAME (tgtnm tgt)) + val finDag = reach(Dag.make, NAME (Node.name_of Node.fin)) + fun cdag (tgt,tst) = attach(tst, edagt tgt, edag) + val g = + fn ASSIGNMENT i => Node.make(nm, asn [i], edag, Set.make) + | NERGLE => Node.make(nm, asn [], edag, Set.make) + | LABELREF (tgt, i as GETLAB{lab, dst}) => + Node.make(nm, + asn [GETLAB{lab=(t tgt, tgtnm tgt), + dst=dst}], + edag, Set.make) + | COMPARISON (tgt, tst) => + Node.make(nm, asn nil, cdag(tgt, tst), Set.make) + | FLOW (tgt, i) => + Node.make(nm, asn nil, edagt tgt, Set.make) + | EXIT i => Node.make(nm, asn [i], finDag, Set.make) + | TARGET (lbl, i) => + Node.make(nm, asn nil, edag, Set.make) + | _ => raise BNODES + in + (g ci)::Node.fin::(f (rest, n + 1)) + end + fun addn(n, p) = Node.addNode(p, n) + val prog = fold addn (Node.fin :: f(l, 0)) (Node.makeProg()) + in + prog + end + +exception READI +exception READI_NTN +fun readI ol = + let open HM + fun junkfil (JUNK a, (junk, other)) = (JUNK a :: junk, other) + | junkfil (x, (junk, other)) = (junk, x::other) + val cl = map HM.classify ol + val (junk, other) = fold junkfil cl (nil, nil) + fun ntn x = (Node.nameToNode x ) + handle NAMETONODE => raise READI_NTN + val (ns, foo, fin) = buildNodes other + val nn = (ns, ntn((ns, foo, fin), "0"), fin) + fun unjunk (JUNK i) = i + | unjunk _ = raise READI + val progs = programs nn + val foo = read_dbg + (fn () => ("progs =>" ^ + (StrPak.stringListString + (map Node.progToString progs)))) + in + (map unjunk junk, progs) + end + +structure ps = + struct + open Ntypes + type obj = Node.program + + fun int l = + let val z = ord "0" + fun f(n, nil) = n + | f (n, d::l) = + if d>="0" andalso d<="9" then f(n*10+ord(d)-z, l) + else n + in + f(0,l) + end + + fun gt((nsa, n0a, Fa), (nsb, n0b, Fb)) = + let val a = explode (Node.name_of n0a) + val b = explode (Node.name_of n0b) + in + (int a) > (int b) + end + end + +structure sortP = Sort (ps) + +fun live_dbg f = if !live_debug then print ("live:" ^ f() ^ "\n") + else () + +fun build_live_tab(P as (ns, n0, F): Node.program) = + let open Ntypes + open Node + open Set + fun fil (a, b) = if a < 0 orelse Delay.is_bogus_reg (a, "") then b + else add(b, a) + fun fil_lset s = fold fil (set s) make + val lt:(int set) Stringmap.stringmap = Stringmap.new() + val finset = listToSet [0, 1, 2, 3, 4, 5] + fun flive f n = + if Stringmap.isin lt (name_of n) then Stringmap.map lt (name_of n) + else f n + fun dfs cur = + let fun fl n = flive dfs n + val nm = name_of cur + val gen = (fil_lset o readNode) cur + val kill = writeNode cur + val foo = Stringmap.add lt (nm, gen) + val children = succNodes(P, cur) + val ch_live = if empty children then finset + else listUnion (map fl (set children)) + val live = union(diff(ch_live, kill), gen) + val foo = Stringmap.rm lt nm + val foo = Stringmap.add lt (nm, live) + in + live + end + in + dfs n0; + (fn nm => + let val ans = Stringmap.map lt nm + val foo = live_dbg (fn () => nm ^ "=>" ^ + StrPak.stringListString + (map makestring (set ans))) + in + ans + end) + end + +(* live is the union of live in successors *) +fun branch_live (P, tab, nm) = + let open Node + val s = Set.set (succ(P, nameToNode(P, nm))) + val l:int Set.set = Set.listUnion (map tab s) + val foo = live_dbg + (fn()=>("branch_live " ^ nm ^ " s=" ^ + StrPak.stringListString s ^ " -> " ^ + StrPak.stringListString (map makestring (Set.set l)))) + in + l + end + +exception WRITEP +exception WRITEP1 +exception WRITEP_NTN + +fun writeP (entry_map, lbl_fun, P as (ns, n0, F):Node.program) = + let open Ntypes + open Node + open Set + open HM + open AbsMach + val foo = write_dbg(fn () => "program:" ^ progToString P) + fun blblmap nil = (fn x => (print ("blblmap_" ^ x); raise WRITEP)) + | blblmap (nm::t) = + let val mp = blblmap t + val mylab = lbl_fun() + in + (fn x => if x = nm then mylab else mp x) + end + val lblmap = blblmap(map name_of (Stringmap.extract ns)) + val live_tab = build_live_tab P + fun label_list nm = map (fn r => (r, "")) (set (live_tab nm)) + fun br_list nm = + map (fn r => (r, "")) (set (branch_live(P, live_tab, nm))) + fun getlab (GETLAB{lab=(i,s), dst}) = + GETLAB{lab=(entry_map s, "node" ^ s), dst=dst} + | getlab _ = raise WRITEP1 + fun dogetlabs (i as GETLAB _, l) = (getlab i) :: l + | dogetlabs (i, l) = i :: l + fun ubranch (frm, nm) = + BRANCH{test=ieq, src1=(0, "zero"), src2=(0, "zero"), + dst=(lblmap nm, "node" ^ nm), live=br_list frm} + fun cbranch (BRANCH{test, src1, src2, dst, live}, frm, nm) = + BRANCH{test=test, src1=src1, src2=src2, + dst=(lblmap nm, "node" ^ nm), live=br_list frm} + | cbranch _ = (print "cbranch"; raise Match) + fun label nm = LABEL{lab=(lblmap nm, "node" ^ nm), live=label_list nm} + fun entry_label nm = + LABEL{lab=(entry_map nm, "entry"), live=label_list nm} + + fun f (done, lastnm, nm) = + let val foo = write_dbg + (fn () => + "f (" ^ + StrPak.stringListString (set done) ^ "," ^ + nm ^ ")") + in + if nm = name_of F then (write_dbg_s "fin"; (done, [NOP])) + else if member(done, nm) then (write_dbg_s "already"; + (done, [NOP, ubranch(lastnm, nm)])) + else + let open Dag + val foo = write_dbg_s "doing" + val node = nameToNode(P, nm) + handle NAMETONODE => raise WRITEP_NTN + val needlabel = + let val pd = set (pred (P, node)) + val foo = write_dbg + (fn () => ("needlabel pd=" ^ + StrPak.stringListString pd)) + fun f nil = false + | f ((p::nil):Ntypes.name list) = + let val pn = nameToNode(P, p:Ntypes.name) + val foo = write_dbg + (fn () => ("ndlbl: pn=" ^ + nodeToString pn)) + val d = dag_of pn + val sel = sel_of d + val rt = root_of d + fun istst (TEST t) = + (write_dbg_s "ist true\n"; + true) + | istst (NAME n) = + (write_dbg_s "ist false\n"; + false) + | istst NEITHER = + (write_dbg_s "ist false\n"; + false) + fun untst (TEST t) = t + | untst _ = (print "needlabel1"; + raise Match) + fun unnm (NAME nm) = nm + | unnm _ = (print "needlabel2"; + raise Match) + val foo = + if istst rt then + write_dbg + (fn () => + ("sel=" ^ + unnm(sel(untst rt, true)) ^ + "\n")) + else () + in + istst rt andalso + (sel(untst rt, true) = NAME nm) + end + | f (a::b::c) = true + val answer = f pd + val foo = write_dbg + (fn () => ("needlabel=>" ^ + Bool.toString answer)) + in + answer + end + val nodelabel = if needlabel then [label nm] else nil + val nodeNOP = [NOP] + val a = fold dogetlabs (set (assignment_of node)) nil + val d = dag_of node + val sel = sel_of d + val rt = root_of d + (* only works for <= 1 test *) + fun dag_code NEITHER = (nil, nil) + | dag_code (NAME n) = ([n], nil) + | dag_code (TEST t) = + let fun unnm (NAME x) = x + | unnm _ = (print "dag_code"; raise Match) + val t_n = unnm(sel(t, true)) + val f_n = unnm(sel(t, false)) + in + ([f_n, t_n], [cbranch(t, nm, t_n)]) + end + val (nl, cd) = dag_code rt + exception DFS_SURPRISE + fun dfs (done, nil) = (write_dbg_s "dfs nil"; + (done, nil)) + | dfs (done, h::nil) = (write_dbg_s "dfs 1"; + f(done, nm, h)) + | dfs (done, h::nxt::nil) = + let val foo = write_dbg_s "dfs 2" + val (dn1, cd1) = f(done, nm, h) + val (dn2, cd2) = + if member(dn1, nxt) then (dn1, nil) + else dfs(dn1, nxt::nil) + val lbl = + if nxt = name_of F orelse + member(dn2, nxt) then [NOP] + else [NOP, label nxt] + in + (dn2, cd1 @ lbl @ cd2) + end + | dfs _ = raise DFS_SURPRISE + val (dn, dcd) = dfs(add(done, nm), nl) + in + (dn, NOP :: nodelabel @ a @ cd @ dcd) + end + end + val (done, code) = f (Set.make, "badname", name_of n0) + in + (entry_label (name_of n0)) :: (label (name_of n0)) :: code + end + +exception WRITEI + +fun progMap(p as (ns, n0, F)) = + let val l = Node.sortNodes (Stringmap.extract ns) + val outstr = ref "" + fun pr s = outstr := !outstr ^ s + fun ntn n = Node.nameToNode(p, n) + val n0nm = Node.name_of n0 + val nFnm = Node.name_of F + fun f n = + let val s = Set.set (Node.succ(p, n)) + val nm = Node.name_of n + val pre = if nm = n0nm then "->\t" + else "\t" + val post = if nm = nFnm then "\t->\n" + else "\n" + in + pr (pre ^ + Node.name_of n ^ "\t->\t" ^ StrPak.stringListString s ^ + post) + end + in + List.app f l; + !outstr + end + +fun writeI(j:AbsMach.opcode list, p:Node.program list) = + let val labelid = ref 0 + fun newlabel () = (labelid := !labelid + 1; !labelid - 1) + fun bentrymap nil = (fn x => (print ("bentrymap_" ^ x); raise WRITEI)) + | bentrymap ((ns, n0, F)::t) = + let val mp = bentrymap t + val mylab = newlabel() + in + (fn x => if x = Node.name_of n0 then mylab else mp x) + end + val entry_map = bentrymap p + val sp = sortP.sort p + fun wp p = writeP (entry_map, newlabel, p) + fun f(a, b) = (wp a) @ b + val i = fold f sp nil + in + i @ j + end + + +end + + + +signature SIMLABS = + sig + exception Data_dependency_checked + exception End_of_Program + exception Simulator_error_1 + exception Simulator_error_2 + exception illegal_branch_within_branchdelay + exception illegal_jump_within_branchdelay + exception illegal_operator_or_operand + exception negative_label_offset + exception no_address_in_register + exception no_label_in_register + exception no_memory_address_in_register + exception runtime_error_in_labwords + exception runtime_error_in_words_or_labwords + exception type_mismatch_in_comparison + exception wrong_label + val breakptr : int -> unit + val clock : int ref + val d_m : int * int -> unit + val d_ms : int list -> unit + val d_pc : unit -> unit + val d_r : unit -> unit + val d_regs : int list -> unit + val init : AbsMach.opcode list -> unit + val mcell : int -> AbsMach.values + val pc : unit -> AbsMach.opcode list + val pinit : int * (AbsMach.arithop -> int) * int * AbsMach.opcode list + -> unit + val pptr : unit -> int + val prun : unit -> unit + val pstep : unit -> unit + val regc : int -> AbsMach.values + val run : unit -> unit + val runcount : int ref + val step : unit -> unit + val vinit : int * AbsMach.opcode list -> unit + val vpc : unit -> unit + val vrun1 : unit -> unit + val vrun2 : unit -> unit + val vrun3 : unit -> unit + val vstep1 : unit -> unit + val vstep2 : unit -> unit + val vstep3 : unit -> unit + + val Memory : (AbsMach.values array) ref + end; + + +structure SetEnv : SIMLABS= +struct + + open AbsMach; + + val codes : (opcode list ref)=ref nil; + + val RegN=ref 0 and LabN=ref 0 and memorysize=ref 10000; + (*RegN = (pointer to) number of registers needed; + LabN = (pointer to) number of labels; + memorysize=(pointer to) memory space size. + *) + val IP: (opcode list) ref =ref nil; + val inivalue=(INT 0); + (*IP = Program Pointer; + inivalue = zero- initial value of memory and registers. + *) + val Reg=ref (array(0,inivalue)) and Memory=ref (array(0,inivalue)) + and Lab_Array=ref (array(0, (0,IP) )); + (*Reg = register array; + Memory = memory cell array; + Lab_Array = label-opcode list array. + *) + + fun max(n1:int,n2:int)=if (n1>n2) then n1 else n2; + + (* hvnop tests whether the instruction is not a real machine instruction, + but only useful in simulation. + *) + fun hvnop(LABEL{...})=true | + hvnop(LABWORD{...})=true | + hvnop(WORD{...})=true | + hvnop(_)=false; + + (*count_number is used to take into account register references and label + declarations, and change RegN or LabN. + *) + fun count_number(FETCH {ptr=(n1,_),dst=(n2,_),...})= + (RegN:=max((!RegN),max(n1,n2)) ) | + count_number(STORE {src=(n1,_),ptr=(n2,_),...})= + (RegN:=max((!RegN),max(n1,n2)) ) | + count_number(ARITHI {src1=(n1,_),dst=(n2,_),...})= + (RegN:=max((!RegN),max(n1,n2)) ) | + count_number(MOVE {src=(n1,_),dst=(n2,_)})= + (RegN:=max((!RegN),max(n1,n2)) ) | + count_number(BRANCH {src1=(n1,_),src2=(n2,_),...})= + (RegN:=max((!RegN),max(n1,n2)) ) | + count_number(GETLAB {dst=(n,_),...})= + (RegN:=max((!RegN),n) ) | + count_number(GETREAL {dst=(n,_),...})= + (RegN:=max((!RegN),n) ) | + count_number(ARITH{src1=(n1,_),src2=(n2,_),dst=(n3,_),...})= + (RegN:=max((!RegN),max(n1,max(n2,n3)) ) ) | + count_number(LABEL{...})= + ( Ref.inc(LabN) ) | + count_number(_)=(); + + (* scan is used to scan the opcode list for the first time, to determine + the size of Reg and Lab_Array, i.e. number of registers and labels. + *) + fun scan(nil)=() | + scan(h::t)=(count_number(h);scan(t)); + + (* setlabels is used to set the label array, of which each item is a + pair (label, codep), codep points to the codes containing the LABEL + statement and afterwards codes. + *) + fun setlabels(nil,_)= () | + setlabels(codel as ((LABEL {lab=(l,_),...})::t),k)= + (update((!Lab_Array),k,(l,ref codel)); setlabels(t,k+1) ) | + setlabels(h::t,k)=setlabels(t,k) ; + + (* initializing the enviroment of the simulation. + *) + fun init(l)=(RegN:=0; LabN:=0; IP:=l; codes:=l; + scan(!IP); Ref.inc(RegN); + Reg:=array( (!RegN), inivalue ) ; + Memory:=array( (!memorysize), inivalue ) ; + Lab_Array:=array( (!LabN), (0,IP)); + setlabels(!IP,0) + ); + + + + exception wrong_label; + exception runtime_error_in_labwords; + exception runtime_error_in_words_or_labwords; + exception negative_label_offset; + exception no_label_in_register; + exception illegal_operator_or_operand; + exception type_mismatch_in_comparison ; + exception no_address_in_register; + exception no_memory_address_in_register; + + (* getresult gives the results of arithmtic operations + *) + fun getresult(iadd,INT (n1:int),INT (n2:int))=INT (n1+n2) | + getresult(isub,INT (n1:int),INT (n2:int))=INT (n1-n2) | + getresult(imul,INT (n1:int),INT (n2:int))=INT (n1*n2) | + getresult(idiv,INT (n1:int),INT (n2:int))=INT (n1 div n2) | + getresult(fadd,REAL (r1:real),REAL (r2:real))=REAL (r1+r2) | + getresult(fsub,REAL (r1:real),REAL (r2:real))=REAL (r1-r2) | + getresult(fmul,REAL (r1:real),REAL (r2:real))=REAL (r1*r2) | + getresult(fdiv,REAL (r1:real),REAL (r2:real))=REAL (r1/r2) | + getresult(iadd,INT (n1:int),LABVAL (l,k))=LABVAL (l,k+n1) | + getresult(iadd,LABVAL (l,k),INT (n1:int))=LABVAL (l,k+n1) | + getresult(isub,LABVAL (l,k),INT (n1:int))=LABVAL (l,k-n1) | + getresult(orb,INT n1,INT n2)=INT (Bits.orb(n1,n2)) | + getresult(andb,INT n1,INT n2)=INT (Bits.andb(n1,n2)) | + getresult(xorb,INT n1,INT n2)=INT (Bits.xorb(n1,n2)) | + getresult(rshift,INT n1,INT n2)=INT (Bits.rshift(n1,n2)) | + getresult(lshift,INT n1,INT n2)=INT (Bits.lshift(n1,n2)) | + getresult(real,INT n,_)=REAL (intToReal(n)) | + getresult(floor,REAL r,_)=INT (Real.floor(r)) | +(* getresult(logb,REAL r,_)=INT (System.Unsafe.Assembly.A.logb(r))| *) + getresult(_)=raise illegal_operator_or_operand; + + (* compare gives the results of comparisons in BRANCH statement. + *) + fun compare(ilt,INT n1,INT n2)= (n1n2) | + compare(ile,INT n1,INT n2)= (n1<=n2) | + compare(ige,INT n1,INT n2)= (n1>=n2) | + compare(ine,INT n1,INT n2)= (n1<>n2) | + compare(flt,REAL r1,REAL r2)= (r1r2) | + compare(fle,REAL r1,REAL r2)= (r1<=r2) | + compare(fge,REAL r1,REAL r2)= (r1>=r2) | + compare(fne,REAL r1,REAL r2)= (realNe(r1,r2)) | + compare(inrange,INT a,INT b)= (a>=0) andalso (ab) | + compare(inrange,REAL a,REAL b)= (a>=0.0) andalso (ab) | + compare(_)=raise type_mismatch_in_comparison ; + + (* findjmp_place returns the pointer to the codes corresponding to the + given label (the codes containing the LABEL statement itself). + *) + fun findjmp_place lab = + let val ipp=ref (ref nil) and i=ref 0 and flag=ref true; + val none=(while ( (!i < !LabN) andalso (!flag) ) do + ( let val (l,p)=((!Lab_Array) sub (!i)) in + if (l=lab) then (ipp:=p;flag:=false) + else Ref.inc(i) + end + ) + ) + in if (!flag) then raise wrong_label + else (!ipp) + end; + + (* findjmp_word returns the content of the k th labword in a code stream. + *) + fun findjmp_word(k,ip)=if (k<0) then raise negative_label_offset + else let fun f2(1,LABWORD{lab=(herepos,_)}::t) + =herepos | + f2(k,LABWORD{...}::t)=f2(k-1,t) | + f2(_)=raise runtime_error_in_labwords ; + in f2(k, (!ip) ) + end; + + (* inst_word returns the content of the k'th word or labword in a code + stream. + *) + fun inst_word(k,ip)=if (k<0) then raise negative_label_offset + else let fun f(1,LABWORD{lab=(herepos,_)}::t) + =LABVAL (herepos,0) | + f(1,WORD{value=n}::t)=INT n | + f(k,LABWORD{...}::t)=f(k-1,t) | + f(k,WORD{...}::t)=f(k-1,t) | + f(_)=raise + runtime_error_in_words_or_labwords + in f(k,(!ip)) + end; + + + (* execjmp changes IP, makes it point to the codes of the given label. + *) + fun execjmp(LABVAL (l,0))= (IP:= !(findjmp_place l) ) | + execjmp(LABVAL (l,k))= (IP:= + ! (findjmp_place + (findjmp_word(k,findjmp_place(l) ) ) ) + ) | + execjmp(_) = raise no_label_in_register; + + (* addrplus returns the result of address+offset. + *) + fun addrplus(INT n,ofst)= n+ofst | + addrplus(_,_)=raise no_memory_address_in_register; + + (* content gives the content of the fetched word. + *) + fun content(INT n,ofst)= (!Memory) sub (n+ofst) | + content(LABVAL (l,k),ofst)=inst_word(k+ofst,findjmp_place(l)) | + content(_,_)=raise no_address_in_register; + + (* exec executes the given instruction. + *) + fun exec(FETCH{immutable=_,offset=ofst,ptr=(p,_),dst=(d,_)})= + update((!Reg),d,content((!Reg) sub p,ofst) ) | + exec(STORE{offset=ofst,src=(s,_),ptr=(p,_)})= + update((!Memory),addrplus((!Reg) sub p,ofst),(!Reg) sub s) | + exec(GETLAB {lab=(l,_),dst=(d,_)})= + update((!Reg),d,(LABVAL (l,0)) ) | + exec(GETREAL {value=v,dst=(d,_)})= + update((!Reg),d,(REAL (strToReal v))) | + exec(MOVE{src=(s,_),dst=(d,_)})= + update((!Reg),d, (!Reg) sub s ) | + exec(LABEL {...})= + () | + exec(LABWORD {...}) = + () | + exec(WORD{...})= + () | + exec(JUMP {dst=(d,_),...})= + execjmp((!Reg) sub d) | + exec(ARITH {oper=opn,src1=(s1,_),src2=(s2,_),dst=(d,_)})= + update((!Reg),d,getresult(opn,(!Reg) sub s1,(!Reg) sub s2) ) | + exec(ARITHI {oper=opn,src1=(s1,_),src2=n1,dst=(d,_)})= + update((!Reg),d,getresult(opn,(!Reg) sub s1,(INT n1) ) ) | + exec(BRANCH{test=comp,src1=(s1,_),src2=(s2,_),dst=(labnum,_),...})= + if compare(comp,(!Reg) sub s1,(!Reg) sub s2) + then (IP:= !(findjmp_place(labnum) ) ) + else () | + exec(NOP)= () | + exec(BOGUS _)= raise Match + + ; + + + + exception End_of_Program; + + fun step () =let + val Instruction=(hd(!IP) handle Hd=> raise End_of_Program) + in + (IP:=tl(!IP) handle Tl=>raise End_of_Program; + exec(Instruction) ) + end; + fun run () =(step();run() ) + handle End_of_Program =>output(std_out,"End of program\n"); + + (* bms, ims, rms are simply abbreviations. + *) + val bms : bool -> string = Bool.toString + and ims : int -> string = Int.toString + and rms : real -> string = Real.toString + + (* dispv shows the content of a register, dispm shows the content of a + memory word. + *) + fun dispv(n,INT k)=output(std_out,"Register "^ims(n)^": "^ + "INT "^ims(k)^"\n") | + dispv(n,REAL r)=output(std_out,"Register "^ims(n)^": "^ + "REAL "^rms(r)^"\n") | + dispv(n,LABVAL (l,0))=output(std_out, + "Register "^ims(n)^": "^ + "LABEL "^ims(l)^"\n") | + dispv(n,LABVAL (l,k))=output(std_out, + "Register "^ims(n)^": "^ + "LABWORD "^ims(k)^" after"^ + "LABEL "^ims(l)^"\n") ; + + fun dispm(n,INT k)=output(std_out,"Memory "^ims(n)^": "^ + "INT "^ims(k)^"\n") | + dispm(n,REAL r)=output(std_out,"Memory "^ims(n)^": "^ + "REAL "^rms(r)^"\n") | + dispm(n,LABVAL (l,0))=output(std_out, + "Memory "^ims(n)^": "^ + "LABEL "^ims(l)^"\n") | + dispm(n,LABVAL (l,k))=output(std_out, + "Memory "^ims(n)^": "^ + "LABWORD "^ims(k)^" after"^ + "LABEL "^ims(l)^"\n") ; + + (* oms and cms give the strings of the functions and comparisions. + *) + fun oms(iadd)="iadd" | oms(isub)="isub" | + oms(imul)="imul" | oms(idiv)="idiv" | + oms(fadd)="fadd" | oms(fsub)="fsub" | + oms(fmul)="fmul" | oms(fdiv)="fdiv" | + oms(real)="real" | oms(floor)="floor" | oms(logb)="logb" | + oms(orb)="orb" | oms(andb)="andb" | oms(xorb)="xorb" | + oms(rshift)="rshift" | oms(lshift)="lshift" ; + + fun cms(ilt)="ilt" | cms(igt)="igt" | cms(ieq)="ieq" | + cms(ile)="ile" | cms(ige)="ige" | cms(ine)="ine" | + cms(flt)="flt" | cms(fgt)="fgt" | cms(feq)="feq" | + cms(fle)="fle" | cms(fge)="fge" | cms(fne)="fne" | + cms(outofrange)="outofrange" | cms(inrange)="inrange" ; + + (* lms gives the string of the live register list. + *) + fun lms(nil)="" | + lms((h,s)::nil)="("^ims(h)^","^s^")" | + lms((h,s)::t)="("^ims(h)^","^s^"),"^lms(t); + + (* disp gives the string for the instruction. + *) + fun disp(FETCH{immutable=b,offset=ofst,ptr=(p,s1),dst=(d,s2)}) = + "FETCH{immutable="^bms(b)^",offset="^ims(ofst) ^",ptr=("^ims(p)^","^s1 + ^"),dst=("^ims(d)^","^s2^")}\n" | + + disp(STORE{offset=ofst,src=(s,s1),ptr=(p,s2)}) = + "STORE{offset="^ims(ofst)^",src=("^ims(s)^","^s1^"),ptr=(" + ^ims(p)^","^s2^")}\n" | + + disp(GETLAB{lab=(l,ls),dst=(d,ds)}) = + "GETLAB{lab=("^ims(l)^","^ls^"),dst=("^ims(d)^","^ds^")}\n" | + + disp(GETREAL{value=r,dst=(d,ds)}) = + "GETREAL{value="^r^",dst=("^ims(d)^","^ds^")}\n" | + + disp(ARITH{oper=opn,src1=(s1,ss1),src2=(s2,ss2),dst=(d,ds)})= + "ARITH{oper="^oms(opn)^",src1=("^ims(s1)^","^ss1^"),src2=("^ims(s2) + ^","^ss2^"),dst=("^ims(d)^","^ds^")}\n" | + + disp(ARITHI{oper=opn,src1=(s1,ss1),src2=n,dst=(d,ds)})= + "ARITH{oper="^oms(opn)^",src1=("^ims(s1)^","^ss1^"),src2="^ims(n)^ + ",dst=("^ims(d)^","^ds^")}\n" | + + disp(MOVE{src=(s,ss),dst=(d,ds)})= + "MOVE{src=("^ims(s)^","^ss^"),dst=("^ims(d)^","^ds^")}\n" | + + disp(BRANCH{test=comp,src1=(s1,ss1),src2=(s2,ss2),dst=(labnum,ss3), + live=lt})= + "BRANCH{test="^cms(comp)^",src1=("^ims(s1)^","^ss1^"),src2=("^ims(s2) + ^","^ss2^"),dst=("^ims(labnum)^","^ss3^"),live=["^lms(lt)^"]}\n" | + + disp(JUMP{dst=(d,ds),live=lt}) = + "JUMP{dst=("^ims(d)^","^ds^"),live=["^lms(lt)^"]}\n" | + + disp(LABWORD{lab=(l,s)})="LABWORD{lab=("^ims(l)^","^s^")}\n" | + + disp(LABEL{lab=(l,s),live=lt})= + "LABEL{lab=("^ims(l)^","^s^"),live=["^lms(lt)^"]}\n" | + + disp(WORD{value=n})="WORD{value="^ims(n)^"}\n" | + + disp(NOP)="NOP" | + disp(BOGUS _) = raise Match + + ; + + fun d_pc () =output(std_out,disp(hd(!IP)) handle Hd=>"No More Instruction\n"); + fun pc () = (!IP); + fun pptr () =(List.length(!codes)-List.length(!IP))+1; + fun breakptr k=let fun goon (LABEL {lab=(l,_),...})=(l<>k) | + goon (_)=true + in while goon(hd(!IP)) do step() + end; + fun regc n=((!Reg) sub n); + fun d_r () =let val i=ref 0 in + (while ( !i < !RegN) do + (dispv((!i),(!Reg) sub (!i)); Ref.inc(i) ) + ) + end; + fun d_regs (nil)=() | + d_regs (h::t)=(dispv(h,(!Reg) sub h);d_regs(t)); + + fun mcell n=((!Memory) sub n); + fun d_m (n,m)=let val i=ref n in + while ( !i <=m) do (dispm(!i,(!Memory) sub !i); Ref.inc(i) ) + end; + fun d_ms nil =() | + d_ms (h::t)=(dispm(h,(!Memory) sub h); d_ms(t) ); + + +(* This part for the VLIW mode execution. *) + + + val runcount=ref 0 and sizen=ref 0 and flag=ref true; + exception Simulator_error_1; + exception Simulator_error_2; + exception Data_dependency_checked; + + (* member tests whether element a is in a list. + *) + fun member(a,nil)=false | + member(a,h::t)=if (a=h) then true else member(a,t); + (* hvcom tests whether the intersection of two list isnot nil. + *) + fun hvcom(nil,l)=false | + hvcom(h::t,l)=member(h,l) orelse hvcom(t,l); + + (* gset returns the list of registers refered in a instruction. + gwset returns the list of the register being written in a instruction. + *) + fun gset(FETCH{ptr=(p,_),dst=(d,_),...})=[p,d] | + gset(STORE{src=(s,_),ptr=(p,_),...})=[s,p] | + gset(GETLAB{dst=(d,_),...})=[d] | + gset(GETREAL{dst=(d,_),...})=[d] | + gset(ARITH{src1=(s1,_),src2=(s2,_),dst=(d,_),...})=[s1,s2,d] | + gset(ARITHI{src1=(s1,_),dst=(d,_),...})=[s1,d] | + gset(MOVE{src=(s,_),dst=(d,_)})=[s,d] | + gset(BRANCH{src1=(s1,_),src2=(s2,_),...})=[s1,s2] | + gset(JUMP{dst=(d,_),...})=[d] | + gset(_)=nil ; + fun gwset(FETCH{dst=(d,_),...})=[d] | + gwset(GETLAB{dst=(d,_),...})=[d] | + gwset(GETREAL{dst=(d,_),...})=[d] | + gwset(ARITH{dst=(d,_),...})=[d] | + gwset(ARITHI{dst=(d,_),...})=[d] | + gwset(MOVE{dst=(d,_),...})=[d] | + gwset(_)=nil ; + + (* fetchcode returns the instruction word which contains the next k + instruction. fetchcode3 is used in version 3 of VLIW mode, in which case + labels within instruction words are OK. + *) + fun fetchcode(0)=nil | + fetchcode(k)=let val h=hd(!IP) in + (IP:=tl(!IP); + if hvnop(h) + then (output(std_out, + "Warning: labels within the instruction word\n"); + fetchcode(k) + ) + else h::fetchcode(k-1) ) + end handle Hd=>nil; + fun fetchcode3(0)=nil | + fetchcode3(k)=let val h=hd(!IP) in + (IP:=tl(!IP); + if hvnop(h) then fetchcode3(k) + else h::fetchcode3(k-1) ) + end handle Hd=>nil; + + (* allnop tests if all instructions left mean no operation. + *) + fun allnop(nil)=true | + allnop(NOP::t)=allnop(t) | + allnop(_)=false; + + (* nopcut cut the instruction stream in a way that the first half are all + NOP instruction. + *) + fun nopcut(nil)=(nil,nil) | + nopcut(NOP::t)=let val (l1,l2)=nopcut(t) in (NOP::l1,l2) end | + nopcut(l)=(nil,l); + + (* cmdd tests the data dependency on memory cells and IP. + *) + fun cmdd(_,nil)=false | + cmdd(wset,STORE{ptr=(p,_),offset=ofst,...}::t)= + cmdd(addrplus((!Reg) sub p,ofst)::wset,t) | + cmdd(wset,FETCH{ptr=(p,_),offset=ofst,...}::t)= + member(addrplus((!Reg) sub p,ofst),wset) orelse cmdd(wset,t) | + cmdd(wset,BRANCH{...}::t)=if allnop(t) then false else true | + cmdd(wset,JUMP{...}::t)=if allnop(t) then false else true | + cmdd(wset,h::t)=cmdd(wset,t); + + (* crdd test the data dependency on registers. + *) + fun crdd(_,nil)=false | + crdd(wset,h::t)=if hvcom(gset(h),wset) then true + else crdd(gwset(h)@wset,t) ; + + (* check_dd checks whether there is data dependency in instruction stream l. + *) + fun check_dd(l)= crdd(nil,l) orelse cmdd(nil,l); + + (* rddcut seperate the longest part of the instruction stream that have no + data dependency on registers , from the left. + *) + fun rddcut(_,nil)= (nil,nil) | + rddcut(wset,l as (h::t))= + if hvcom(gset(h),wset) then (nil,l) + else let val (l1,l2)=rddcut(gwset(h)@wset,t) + in (h::l1,l2) end + ; + (* mddcut seperate the longest part of the instruction stream that have no data + dependency on memory cells and IP, from the left. + *) + fun mddcut(_,nil)= (nil,nil) | + mddcut(wset,(h as STORE{ptr=(p,_),offset=ofst,...})::t)= + let val (l1,l2)=mddcut(addrplus((!Reg) sub p,ofst)::wset,t) + in (h::l1,l2) end | + mddcut(wset,(h as FETCH{ptr=(p,_),offset=ofst,...})::t)= + if member(addrplus((!Reg) sub p,ofst),wset) + then (nil,h::t) + else let val (l1,l2)=mddcut(wset,t) in (h::l1,l2) end | + mddcut(wset,(h as BRANCH{...})::t)= + let val (l1,l2)=nopcut(t) in (h::l1,l2) end | + mddcut(wset,(h as JUMP{...})::t)= + let val (l1,l2)=nopcut(t) in (h::l1,l2) end | + mddcut(wset,h::t)= + let val (l1,l2)=mddcut(wset,t) in (h::l1,l2) end + ; + + (* calcult returns the necessary value list corresponding to a instruction + stream. And change the IP when necessary. + *) + fun calcult(nil)=nil | + calcult(FETCH{ptr=(p,_),offset=ofst,...}::t)= + content((!Reg) sub p,ofst)::calcult(t) | + calcult(STORE{src=(s,_),...}::t)=((!Reg) sub s )::calcult(t) | + calcult(MOVE{src=(s,_),...}::t)=((!Reg) sub s)::calcult(t) | + calcult(ARITH{oper=opn,src1=(s1,_),src2=(s2,_),...}::t)= + getresult(opn,(!Reg) sub s1,(!Reg) sub s2)::calcult(t) | + calcult(ARITHI{oper=opn,src1=(s1,_),src2=n1,...}::t)= + getresult(opn,(!Reg) sub s1,(INT n1))::calcult(t) | + calcult(JUMP{dst=(d,_),...}::t)=((!Reg) sub d)::calcult(t) | + calcult(h::t)=calcult(t); + + (* dowr does the actual writing operations. + *) + fun dowr(nil,nil)=() | + dowr(nil,h::t)=raise Simulator_error_1 | + dowr(FETCH{...}::t,nil)=raise Simulator_error_2 | + dowr(STORE{...}::t,nil)=raise Simulator_error_2 | + dowr(MOVE{...}::t,nil)=raise Simulator_error_2 | + dowr(ARITH{...}::t,nil)=raise Simulator_error_2 | + dowr(ARITHI{...}::t,nil)=raise Simulator_error_2 | + dowr(JUMP{...}::t,nil)=raise Simulator_error_2 | + dowr(FETCH{dst=(d,_),...}::t,vh::vt)=(update((!Reg),d,vh); + dowr(t,vt) ) | + dowr(STORE{ptr=(p,_),offset=ofst,...}::t,vh::vt)= + (update((!Memory),addrplus((!Reg) sub p,ofst),vh); dowr(t,vt) ) | + dowr(GETLAB{lab=(l,_),dst=(d,_)}::t,vt)= + (update((!Reg),d,(LABVAL (l,0)) ); dowr(t,vt) ) | + dowr(GETREAL{value=v,dst=(d,_)}::t,vt)= + (update((!Reg),d,(REAL (strToReal v)) ); dowr(t,vt) ) | + dowr(MOVE{dst=(d,_),...}::t,vh::vt)= + (update((!Reg),d,vh); dowr(t,vt) ) | + dowr(ARITH{dst=(d,_),...}::t,vh::vt)= + (update((!Reg),d,vh); dowr(t,vt) ) | + dowr(ARITHI{dst=(d,_),...}::t,vh::vt)= + (update((!Reg),d,vh); dowr(t,vt) ) | + dowr(JUMP{...}::t,vh::vt)= + (execjmp(vh); flag:=false; dowr(t,vt) ) | + dowr(BRANCH{test=comp,src1=(s1,_),src2=(s2,_), + dst=(labnum,_),...}::t,vt)= + if compare(comp,(!Reg) sub s1,(!Reg) sub s2) + then (IP:= !(findjmp_place(labnum)); flag:=false; dowr(t,vt) ) + else dowr(t,vt) | + dowr(h::t,vt)=dowr(t,vt) + ; + + (* vv3 executes an instruction word in version 3 mode. + *) + fun vv3(nil)= () | + vv3(l)=let val (l1,l2)=rddcut(nil,l); + val (l3,l4)=mddcut(nil,l1) + in (flag:=true; dowr(l3,calcult(l3)); Ref.inc(runcount); + if (!flag) then vv3(l4@l2) else () ) + end; + + fun vinit(k,l)=(init(l); sizen:=k; runcount:=0 ) ; + + fun vstep1()=let val f=(while hvnop(hd(!IP)) do IP:=tl(!IP)) + handle Hd=>raise End_of_Program; + val codel=fetchcode(!sizen) + in + (dowr(codel,calcult(codel)); Ref.inc(runcount) ) + end; + + fun vstep2()=let val f=(while hvnop(hd(!IP)) do IP:=tl(!IP)) + handle Hd=>raise End_of_Program; + val codel=fetchcode(!sizen) + in + if check_dd(codel) + then (output(std_out,"Data dependency checked in:\n"); + let fun f(nil)=() | + f(h::t)=(output(std_out,":"^disp(h)); f(t)) + in f(codel) end; + raise Data_dependency_checked + ) + else (dowr(codel,calcult(codel)); Ref.inc(runcount) ) + end; + + fun vstep3()=let val f=if (!IP)=nil then raise End_of_Program else (); + val codel=fetchcode3(!sizen) + in vv3(codel) end; + + fun vrun1()=(vstep1();vrun1()) + handle End_of_Program => + output(std_out,"End of program.\nTotal runtime: " + ^ims(!runcount)^" steps.\n"); + fun vrun2()=(vstep2(); vrun2()) + handle End_of_Program => + output(std_out,"End of program.\nTotal runtime: " + ^ims(!runcount)^" steps.\n")| + Data_dependency_checked=> + output(std_out,"Program halted.\n") ; + fun vrun3()=(vstep3(); vrun3()) + handle End_of_Program => + output(std_out,"End of program.\nTotal runtime: " + ^ims(!runcount)^" substeps.\n"); + + fun vpc()=let val codel=(!IP) ; + fun f (_,nil)=() | + f (0,_)= () | + f (k,h::l)=if k<=0 then () + else (output(std_out,disp(h) ); + if hvnop(h) then f(k,l) + else f(k-1,l) ) + in f((!sizen),codel) end; + + +(* This part for Pipeline mode *) + + + exception illegal_jump_within_branchdelay; + exception illegal_branch_within_branchdelay; + exception illegal_label_within_branchdelay; + exception illegal_labword_within_branchdelay; + exception illegal_word_within_branchdelay; + (* Rdelay points to the timing array of registers. + *) + val Rdelay=ref ( array(0,0) ); + (* clock records run time. withindelay is a flag used in BRANCH and JUMP delays. + *) + val clock=ref 0 and withindelay=ref false; + val fdelay=ref 1 and ardelay: ((arithop->int) ref)=ref (fn k=>1) + and jdelay=ref 1; + + (* pexec executes one instruction, increasing the clock when necessary, which + corresponding to the holding down of instruction streams. + *) + fun pexec(FETCH{immutable=_,offset=ofst,ptr=(p,_),dst=(d,_)})= + (let val t=(!Rdelay) sub p in + if (!clock) (i:=(!jdelay) ) ; + (IP:=tl(!IP)) handle Tl=>() + ) + end; + execjmp((!Reg) sub d) + ) | + pexec(BRANCH{test=comp,src1=(s1,_),src2=(s2,_),dst=(labnum,_),...})= + if (!withindelay) then raise illegal_branch_within_branchdelay + else + (let val t1=((!Rdelay) sub s1) and t2=((!Rdelay) sub s2); + val t=Int.max(t1,t2) in + if (!clock) (i:=(!jdelay) ) ; + (IP:=tl(!IP)) handle Tl=>() + ) + end; + if compare(comp,(!Reg) sub s1,(!Reg) sub s2) + then (IP:= !(findjmp_place(labnum) ) ) + else () + ) | + pexec(NOP)=Ref.inc(clock) | + pexec(LABEL{...})=if (!withindelay) + then raise illegal_label_within_branchdelay + else () | + pexec(LABWORD{...})=if (!withindelay) + then raise illegal_labword_within_branchdelay + else () | + pexec(WORD{...})=if (!withindelay) + then raise illegal_word_within_branchdelay + else () + ; + + fun pinit(fetchdelay,arithdelay,jumpdelay,l)= + (init(l); + Rdelay:=array((!RegN),0); + clock:=0; fdelay:=fetchdelay; + ardelay:=arithdelay; jdelay:=jumpdelay ); + + fun pstep()= + let + val Instruction=(hd(!IP) handle Hd=>raise End_of_Program) + in (IP:=tl(!IP) handle Tl=>raise End_of_Program; + withindelay:=false; pexec(Instruction) ) + end; + + fun prun()=(pstep(); prun() ) handle End_of_Program=> + (output(std_out,"End of program.\n"); + output(std_out,"Total time used: "^ims(!clock)^" cycles.\n") ); + +end; +structure SimStuff = +struct + +fun read file = + let val if1 = (open_in "simprelude.s") + val if2 = (open_in file) + val if3 = (open_in "simpostlude.s") + val prelude = ReadAbs.read if1 + val prog = ReadAbs.read if2 + val postlude = ReadAbs.read if3 + in + close_in if1; + close_in if2; + close_in if3; + prelude @ prog @ postlude + end + +fun init file = SetEnv.init (read file) + +val runcount = ref 0 + +fun run ()= + let open AbsMach + val foo = runcount := 0 + fun updc NOP = runcount := !runcount + 1 + | updc _ = () + open SetEnv + fun f () = (step(); (updc o hd o pc)(); f()) + in + f() + end + +fun srun () = let open SetEnv in d_pc(); step(); srun() end; + +fun memsave () = !SetEnv.Memory + + +fun memcmp(a:AbsMach.values array, b:AbsMach.values array) = + let open AbsMach + fun cmp (INT a, INT b) = a = b + | cmp (REAL a, REAL b) = realEq(a, b) + | cmp (LABVAL _, LABVAL _) = true + | cmp _ = false + fun f 0 = ~1 + | f n = if cmp((a sub n), (b sub n)) then f (n - 1) else n + val al = Array.length a + val bl = Array.length b + in + if al = bl then f (al - 1) else (print "size\n"; 0) + end + + +fun copyarray a = + let val la = Array.length a + val na = array(la, a sub 0) + fun f n = if n > 0 then (update(na, n, a sub n) ; f (n - 1)) else () + val foo = f (la - 1) + in + na + end + + +exception PROG_NO_END + +local open AbsMach +in + fun vstring (INT i) = "INT " ^ makestring i + | vstring (REAL i) = "REAL " ^ Real.toString i + | vstring (LABVAL(i, j)) = + "LABVAL(" ^ makestring i ^ ", " ^ makestring j ^ ")" +end + +fun runf f = + ((init f; + run (); + raise PROG_NO_END)) + handle End_of_Program => (print "eop\n"; + SetEnv.regc 4) + + +fun cmprog(f1, f2) = + let open AbsMach + fun intof (INT i) = i + fun ptsat p = SetEnv.mcell (intof p) + val p1 = runf f1 + (* val foo = print ("cmprog1:" ^ vstring p1 ^ "\n") *) + val v1 = ptsat p1 + val r1 = !runcount + val p2 = runf f2 + (* val foo = print ("cmprog2:" ^ vstring p2 ^ "\n") *) + val v2 = ptsat p2 + val r2 = !runcount + + in + (f1 ^ " ct " ^ makestring r1 ^ " ptr " ^ vstring p1 ^ + " val " ^ vstring v1 ^ + f2 ^ " ct " ^ makestring r2 ^ " ptr " ^ vstring p2 ^ + " val " ^ vstring v2 ^ "\n") + end + +end + +fun time str f = + let (* open System.Timer + val s = start_timer() *) + val v = f() + (* + val e = check_timer s + val foo = print (str ^ " took " ^ makestring e ^ "sec.usec\n") + *) + in + v + end + + +fun writeprog(file, j, p) = + let val ot = (open_out file) + val prog = ReadI.writeI(j, p) + val filp = (Delay.rm_bogus o OutFilter.remnops) prog + val xxx = PrintAbs.show ot filp + in + close_out ot + end; + +fun wp(file, prog) = + let val ot = (open_out file) + val filp = Delay.rm_bogus prog + val xxx = PrintAbs.show ot filp + in + close_out ot + end; + +fun dodelay i = (Delay.init i; Delay.add_delay i); + +val _ = ( +Node.move_test_debug := false; +Node.move_op_debug := false; +Node.rw_debug := false; +Node.delete_debug := false; +Node.ntn_debug := true; +Node.prog_node_debug := false; +Node.prog_node_debug_verbose := false; +Node.closure_progs_debug := false; +Node.cpsiCheck := false; +Compress.compress_debug := false; +ReadI.read_debug := false; +ReadI.write_debug := false; +ReadI.live_debug := false +) + +fun pm pl = print (StrPak.stringListString (map ReadI.progMap pl)); +fun pp pl = print (StrPak.stringListString (map PrintAbs.str pl)); + +fun ndnm nil = raise Node.NAMETONODE +| ndnm(h::t) = (fn (nm) => Node.nameToNode(h, nm) + handle Node.NAMETONODE => ndnm t nm); + +exception ERROR; + +fun err (s:string) = (print s; raise ERROR); + +fun pmem nil = (err "oh well") + | pmem ((ns, n0, f)::t) = + fn n => if Set.member(ns, n) then (ns, n0, f) + else pmem t n; + +structure Main = struct + +fun doitx (ifile:string, ofile:string, c_ofile:string, ws:int) = +let val foo = Ntypes.init_names() + val ins = open_in ifile + val i = (dodelay o BreakInst.breaki o ReadAbs.read) ins + val _ = close_in ins + val (j, p) = time "Building Nodes" (fn () => ReadI.readI i) + val x = time "writing unopt" (fn () => writeprog(ofile, j, p)) + fun cwin p = Compress.compress(ws, p) + val cp = time "compressing program" (fn () => map cwin p) + val xx = time "writing opt program" (fn () => writeprog(c_ofile, j, cp)) + val answer = "" (* SimStuff.cmprog(ofile, c_ofile) *) + val code_motions = Ntypes.new_name "0" +in + print (answer ^ "code_motions " ^ code_motions ^ " \n") +end + +fun main(s:string list, env:string list) = + let val idemp = ref 0 + val ws = ref 0 + val ifile = ref "/dev/null" + val ofile = ref "/dev/null" + val c_ofile = ref "/dev/null" + val gotifile = ref false + val gotofile = ref false + fun digit d = + if ord d >= ord "0" andalso ord d <= ord "9" then ord d - ord "0" + else err ("expected digit. got " ^ d) + val parse = + fn ("-" :: "i" :: "d" :: "e" :: "m" :: d :: nil) => + idemp := digit d + | ("-" :: "w" :: "s" :: d :: nil) => + ws := digit d + | ("-" :: t) => + (print ("usage: comp [-ws#] [-idem#]" ^ + "input_file temp_file compressed_file\n"); + print ("ws is the window size\nidem is the idempotency\n"); + err "exiting") + | s => if !gotofile then c_ofile := implode s + else if !gotifile then (gotofile := true; + ofile := implode s) + else (gotifile := true; + ifile := implode s) + val foo = List.app (parse o explode) (tl s) + val foo = print ("compressing " ^ !ifile ^ " into (uncompressed)" ^ + !ofile ^ + " and (compressed)" ^ !c_ofile ^ + " with idempotency " ^ makestring (!idemp) ^ + " and window size " ^ makestring (!ws) ^ "\n") + in + Delay.idempotency := !idemp; + doitx(!ifile, !ofile, !c_ofile, !ws) + end + +val s = OS.FileSys.getDir() + +fun doit() = main(["foobar", "-ws9", + s^"/DATA/ndotprod.s", + s^"/DATA/tmp.s", + s^"/DATA/cmp.s"], + nil) +fun testit _ = () +end + +structure Main : BMARK = + struct + open Main + + val doit = + fn n => + let + fun loop n = + if n = 0 + then () + else (doit(); + loop(n-1)) + in loop n + end + end diff --git a/benchmark/tests/wc-input1.sml b/benchmark/tests/wc-input1.sml new file mode 100644 index 0000000..d02eef8 --- /dev/null +++ b/benchmark/tests/wc-input1.sml @@ -0,0 +1,35 @@ +(* Written by Stephen Weeks (sweeks@sweeks.com). *) + +structure Main = + struct + fun doit n = + let + open TextIO + val f = OS.FileSys.tmpName () + val out = openOut f + val _ = + output (out, + String.implode + (List.tabulate (1000000, fn i => + if i mod 10 = 0 then #"\n" else #"a"))) + val _ = closeOut out + fun wc f = + let + val ins = openIn f + fun loop (i: int): int = + case input1 ins of + NONE => i + | SOME c => loop (if c = #"\n" then i + 1 else i) + val n = loop 0 + val _ = if n <> 100000 then raise Fail "bug" else () + val _ = closeIn ins + in n + end + val rec loop = + fn 0 => () + | n => (wc f; loop (n - 1)) + val _ = loop n + val _ = OS.FileSys.remove f + in () + end + end diff --git a/benchmark/tests/wc-scanStream.sml b/benchmark/tests/wc-scanStream.sml new file mode 100644 index 0000000..57d37af --- /dev/null +++ b/benchmark/tests/wc-scanStream.sml @@ -0,0 +1,42 @@ +(* Written by Stephen Weeks (sweeks@sweeks.com). *) + +structure Main = + struct + fun doit n = + let + open TextIO + val f = OS.FileSys.tmpName () + val out = openOut f + val _ = + output (out, + String.implode + (List.tabulate (1000000, fn i => + if i mod 10 = 0 then #"\n" else #"a"))) + val _ = closeOut out + fun wc f = + let + val ins = openIn f + in TextIO.scanStream + (fn reader => fn s => + let + fun loop (s, ns) = + case reader s of + NONE => (closeIn ins + ; if ns <> 100000 + then raise Fail "bug" + else () + ; NONE) + | SOME (c, s') => + loop (s', if c = #"\n" then ns + 1 else ns) + in loop (s, 0) + end) + ins + end + val rec loop = + fn 0 => () + | n => (wc f; loop (n - 1)) + val _ = loop n + val _ = OS.FileSys.remove f + in () + end + end diff --git a/benchmark/tests/zebra.sml b/benchmark/tests/zebra.sml new file mode 100644 index 0000000..5249751 --- /dev/null +++ b/benchmark/tests/zebra.sml @@ -0,0 +1,298 @@ +(* Copyright Stephen Weeks (sweeks@sweeks.com). 1999-6-21. + * + * This code solves the following "zebra" puzzle, and prints the solution. + * There are 120^5 ~= 24 billion possibilities, so exhaustive search should + * work fine, but I decided to write something that was a bit more clever. + * It took me longer to write (2.5 hours) than to write exhaustive search, but + * it runs fast (0.06 seconds on my 400MhZ P6). The code only needs to explore + * 3342 posibilites to solve the puzzle. + * + * Here is the puzzle. + * + * This word problem has 25 variables and 24 are given values. You must + * solve + * the 25th. + * + * The trick is HOW? + * + * If you look at the problem mathematically, no sweat. If you get lost + * in the + * English, you are dead. + * + * You will know you are right by checking the answer with all the + * conditions. + * + * Less than 1 percent of the population can solve this problem. + * + * The question is: Based on the following clues, who owns the zebra? + * + * **There are five houses. + * + * **Each house has its own unique color. + * + * **All house owners are of different nationalities. + * + * **They all have different pets. + * + * **They all drink different drinks. + * + * **They all smoke different cigarettes. + * + * **The Englishman lives in the red house. + * + * **The Swede has a dog. + * + * **The Dane drinks tea. + * + * **The green house is adjacent to the white house on the left. + * + * **In the green house they drink coffee. + * + * **The man who smokes Pall Malls has birds. + * + * **In the yellow house they smoke Dunhills. + * + * **In the middle house they drink milk. + * + * **The Norwegian lives in the first house. + * + * **The man who smokes Blends lives in a house next to the house with + * cats. + * + * **In a house next to the house where they have a horse, they smoke + * Dunhills. + * + * **The man who smokes Blue Masters drinks beer. + * + * **The German smokes Princes. + * + * **The Norwegian lives next to the blue house. + * + * **They drink water in a house next to the house where they smoke + * Blends. + * + * Who owns the zebra? + *) + +fun peek (l, p) = List.find p l +fun map (l, f) = List.map f l +fun fold (l, b, f) = List.foldl f b l + +datatype cigarette = Blend | BlueMaster | Dunhill | PallMall | Prince +val cigaretteToString = + fn Blend => "Blend" + | BlueMaster => "BlueMaster" + | Dunhill => "Dunhill" + | PallMall => "PallMall" + | Prince => "Prince" +datatype color = Blue | Green | Red | White | Yellow +val colorToString = + fn Blue => "Blue" + | Green => "Green" + | Red => "Red" + | White => "White" + | Yellow => "Yellow" +datatype drink = Beer | Coffee | Milk | Tea | Water +val drinkToString = + fn Beer => "Beer" + | Coffee => "Coffee" + | Milk => "Milk" + | Tea => "Tea" + | Water => "Water" +datatype nationality = Dane | English | German | Norwegian | Swede +val nationalityToString = + fn Dane => "Dane" + | English => "English" + | German => "German" + | Norwegian => "Norwegian" + | Swede => "Swede" +datatype pet = Bird | Cat | Dog | Horse | Zebra +val petToString = + fn Bird => "Bird" + | Cat => "Cat" + | Dog => "Dog" + | Horse => "Horse" + | Zebra => "Zebra" + +type pos = int +val poss = [1, 2, 3, 4, 5] +val first = SOME 1 +val middle = SOME 3 + +type 'a attribute = {poss: pos list, + unknown: 'a list, + known: (pos * 'a) list} + +exception Done +fun 'a fluidLet (r: 'a ref, x: 'a, f: unit -> 'b): 'b = + let val old = !r + in r := x + ; (f () before r := old) + handle Done => raise Done + | e => (r := old; raise e) + end + +fun search () = + let + fun init (unknown: 'a list): 'a attribute ref = + ref {poss = poss, unknown = unknown, known = []} + val cigarettes = init [Blend, BlueMaster, Dunhill, PallMall, Prince] + val colors = init [Blue, Green, Red, White, Yellow] + val drinks = init [Beer, Coffee, Milk, Tea, Water] + val nationalities = init [Dane, English, German, Norwegian, Swede] + val pets = init [Bird, Cat, Dog, Horse, Zebra] + + fun ''a find (r: ''a attribute ref) (x: ''a): pos option = + Option.map #1 (peek (#known (!r), fn (_, y) => x = y)) + val smoke = find cigarettes + val color = find colors + val drink = find drinks + val nat = find nationalities + val pet = find pets + + fun display () = + let + fun loop (r: 'a attribute ref, toString) = + (List.app (fn i => + let + val x = #2 (valOf (peek (#known (!r), + fn (j, _) => i = j))) + val s = toString x + in print s + ; print (CharVector.tabulate (12 - size s, + fn _ => #" ")) + end) poss + ; print "\n") + in + loop (cigarettes, cigaretteToString) + ; loop (colors, colorToString) + ; loop (drinks, drinkToString) + ; loop (nationalities, nationalityToString) + ; loop (pets, petToString) + end + + fun make f = + fn (SOME x, SOME y) => f (x, y) + | _ => true + val same = make (op =) + val adjacent = make (fn (x, y) => x = y - 1 orelse y = x - 1) + val left = make (fn (x, y) => x = y - 1) + + val num = ref 0 + fun isConsistent (): bool = + (num := !num + 1 + ; + same (nat English, color Red) + andalso same (nat Swede, pet Dog) + andalso same (nat Dane, drink Tea) + andalso left (color Green, color White) + andalso same (color Green, drink Coffee) + andalso same (smoke PallMall, pet Bird) + andalso same (color Yellow, smoke Dunhill) + andalso same (middle, drink Milk) + andalso same (nat Norwegian, first) + andalso adjacent (smoke Blend, pet Cat) + andalso adjacent (pet Horse, smoke Dunhill) + andalso same (drink Beer, smoke BlueMaster) + andalso same (nat German, smoke Prince) + andalso adjacent (nat Norwegian, color Blue) + andalso adjacent (drink Water, smoke Blend) + ) + + fun tryEach (l, f) = + let + fun loop (l, ac) = + case l of + [] => () + | x :: l => (f (x, l @ ac); loop (l, x :: ac)) + in loop (l, []) + end + + fun try (r: 'a attribute ref, + f: unit -> (('a attribute -> unit) + * ( unit -> unit))) = + let val {poss, unknown, known} = !r + in case unknown of + [] => () + | _ => + tryEach (unknown, fn (x, unknown) => + let val (each, done) = f () + in tryEach (poss, fn (p, poss) => + let val attr = {known = (p, x) :: known, + unknown = unknown, + poss = poss} + in fluidLet + (r, attr, fn () => + if isConsistent () then each attr else ()) + end) + ; done () + end) + end + + (* loop takes the current state and either + * - terminates in the same state if there is no consistent extension + * - raises Done with the state set at the consistent extension + *) + exception Inconsistent + exception Continue of unit -> unit + fun loop (): unit = + let + fun test r = + try + (r, fn () => + let + datatype 'a attrs = None | One of 'a | Many + val attrs = ref None + fun each a = + case !attrs of + None => attrs := One a + | One _ => attrs := Many + | Many => () + fun done () = + case !attrs of + None => raise Inconsistent + | One a => raise (Continue (fn () => fluidLet (r, a, loop))) + | Many => () + in (each, done) + end) + fun explore r = + try (r, fn () => + let + fun each _ = loop () + fun done () = raise Inconsistent + in (each, done) + end) + in (test cigarettes + ; test colors + ; test drinks + ; test nationalities + ; test pets + ; explore cigarettes + ; explore colors + ; explore drinks + ; explore nationalities + ; explore pets + ; raise Done) + handle Inconsistent => () + | Continue f => f () + end + val _ = loop () handle Done => () + val _ = if 3342 = !num + then () + else raise Fail "bug" +(* val _ = display () *) + in () + end + +structure Main = + struct + fun doit n = + let + fun loop n = + if n < 0 + then () + else (search () + ; loop (n - 1)) + in loop (n * 1000) + end + end diff --git a/benchmark/tests/zern.sml b/benchmark/tests/zern.sml new file mode 100644 index 0000000..5a16049 --- /dev/null +++ b/benchmark/tests/zern.sml @@ -0,0 +1,604 @@ +(* + * From David McClain's language study. + * http://www.azstarnet.com/~dmcclain/LanguageStudy.html + * + * Stephen Weeks replaced Unsafe.Real64Array with Real64Array. + *) + +fun print _ = () + +(* array2.sml + * + * COPYRIGHT (c) 1998 D.McClain/MCFA + * COPYRIGHT (c) 1997 AT&T Research. + *) + +structure FastRealArray2 : + sig + type array + + type region + = {base : array, + row : int, + col : int, + nrows : int option, + ncols : int option} + + datatype traversal = RowMajor | ColMajor + + val array : int * int * real -> array + val fromList : real list list -> array + val tabulate : traversal -> (int * int * (int * int -> real)) -> array + val sub : array * int * int -> real + val update : array * int * int * real -> unit + val dimensions : array -> int * int + val size : array -> int + val nCols : array -> int + val nRows : array -> int + val row : array * int -> real Vector.vector + val column : array * int -> real Vector.vector + + val copy : region * array * int * int -> unit + val appi : traversal -> (int * int * real -> unit) -> region -> unit + val app : traversal -> (real -> unit) -> array -> unit + val modifyi : traversal -> (int * int * real -> real) -> region -> unit + val modify : traversal -> (real -> real) -> array -> unit + val foldi : traversal -> (int*int*real*'a -> 'a) -> 'a -> region -> 'a + val fold : traversal -> (real * 'a -> 'a) -> 'a -> array -> 'a + + val rmSub : array * int -> real + val rmUpdate : array * int * real -> unit + + val unop : array * array * (real -> real) -> unit + val unopi : array * array * (real * int -> real) -> unit + val binop : array * array * array * (real * real -> real) -> unit + val binopi : array * array * array * (real * real * int -> real) -> unit + val fill : array * real -> unit + val fillf : array * (int -> real) -> unit + + val transpose : array -> array + val extract : region -> array + + (* + val shift : array * int * int -> array + *) + end = + struct + + structure A = (*Unsafe.*)Real64Array + + type rawArray = A.array + + val unsafeUpdate = A.update + val unsafeSub = A.sub + fun mkRawArray n = A.array (n, 0.0) + + + type array = {data : rawArray, + nrows : int, + ncols : int, + nelts : int} + + type region = {base : array, + row : int, + col : int, + nrows : int option, + ncols : int option} + + datatype traversal = RowMajor | ColMajor + + + fun dotimes n f = + let (* going forward is twice as fast as backward! *) + fun iter k = if k >= n then () + else (f(k); iter(k+1)) + in + iter 0 + end + + + fun mkArray(n,v) = + let + val arr = mkRawArray n + in + dotimes n (fn ix => unsafeUpdate(arr,ix,v)); + arr + end + + (* compute the index of an array element *) + fun ltu(i,limit) = (i >= 0) andalso (i < limit) + fun unsafeIndex ({nrows, ncols, ...} : array, i, j) = (i*ncols + j) + fun index (arr, i, j) = + if (ltu(i, #nrows arr) andalso ltu(j, #ncols arr)) + then unsafeIndex (arr, i, j) + else raise General.Subscript + (* row major index checking *) + fun rmIndex ({nelts,...}: array, ix) = + if ltu(ix, nelts) then ix + else raise General.Subscript + + val max_length = 4096 * 4096; (* arbitrary - but this is 128 MB *) + + fun chkSize (nrows, ncols) = + if (nrows <= 0) orelse (ncols <= 0) + then raise General.Size + else let + val n = nrows*ncols handle Overflow => raise General.Size + in + if (max_length < n) then raise General.Size else n + end + + fun array (nrows, ncols, v) = + let + val nelts = chkSize (nrows, ncols) + in + {data = mkArray (nelts, v), + nrows = nrows, ncols = ncols, nelts = nelts} + end + + fun fromList [] = raise General.Size + | fromList (row1 :: rest) = let + val ncols = List.length row1 + fun chk ([], nrows, l) = (nrows, l) + | chk (row::rest, nrows, l) = let + fun chkRow ([], n, revCol) = ( + if (n <> ncols) then raise General.Size else (); + List.revAppend (revCol, l)) + | chkRow (x::r, n, revCol) = chkRow (r, n+1, x::revCol) + in + chk (rest, nrows+1, chkRow(row, 0, [])) + end + val (nrows, flatList) = chk (rest, 1, []) + val nelts = chkSize(nrows, ncols) + val arr = mkRawArray nelts + fun upd(_,nil) = arr + | upd(k,v::vs) = (unsafeUpdate(arr,k,v); upd(k+1,vs)) + in + { data = upd(0,List.@(row1, flatList)), + nrows = nrows, + ncols = ncols, + nelts = nelts } + end + + fun tabulateRM (nrows, ncols, f) = + let + val nelts = chkSize(nrows, ncols) + val arr = mkRawArray nelts + fun lp1 (i, j, k) = if (i < nrows) + then lp2 (i, 0, k) + else () + and lp2 (i, j, k) = if (j < ncols) + then ( + unsafeUpdate(arr, k, f(i, j)); + lp2 (i, j+1, k+1)) + else lp1 (i+1, 0, k) + in + lp2 (0, 0, 0); + {data = arr, nrows = nrows, ncols = ncols, nelts = nelts} + end + + fun tabulateCM (nrows, ncols, f) = + let + val nelts = chkSize(nrows,ncols) + val arr = mkRawArray nelts + val delta = nelts - 1 + fun lp1 (i, j, k) = if (j < ncols) + then lp2 (0, j, k) + else () + and lp2 (i, j, k) = if (i < nrows) + then ( + unsafeUpdate(arr, k, f(i, j)); + lp2 (i+1, j, k+ncols)) + else lp1 (0, j+1, k-delta) + in + lp2 (0, 0, 0); + {data = arr, nrows = nrows, ncols = ncols, nelts = nelts} + end + + fun tabulate RowMajor = tabulateRM + | tabulate ColMajor = tabulateCM + + fun sub (a, i, j) = unsafeSub(#data a, index(a, i, j)) + fun update (a, i, j, v) = unsafeUpdate(#data a, index(a, i, j), v) + fun dimensions ({nrows, ncols, ...}: array) = (nrows, ncols) + fun size ({nelts,...}: array) = nelts + fun nCols (arr : array) = #ncols arr + fun nRows (arr : array) = #nrows arr + fun row ({data, nrows, ncols, ...}: array, i) = + if ltu(i, nrows) then + let + val stop = i*ncols + fun mkVec (j, l) = + if (j < stop) + then Vector.fromList l + else mkVec(j-1, unsafeSub(data, j)::l) + in + if ltu(nrows, i) + then raise General.Subscript + else mkVec (stop+ncols-1, []) + end + else raise General.Subscript + fun column ({data, ncols, nelts, ...}: array, j) = + if ltu(j, ncols) then + let + fun mkVec (i, l) = + if (i < 0) + then Vector.fromList l + else mkVec(i-ncols, unsafeSub(data, i)::l) + in + if ltu(ncols, j) + then raise General.Subscript + else mkVec ((nelts - ncols) + j, []) + end + else raise General.Subscript + + datatype index = DONE | INDX of {i:int, r:int, c:int} + + fun chkRegion {base={data, nrows, ncols, ...}: array, + row, col, nrows=nr, ncols=nc} + = let + fun chk (start, n, NONE) = + if ((start < 0) orelse (n < start)) + then raise General.Subscript + else n-start + | chk (start, n, SOME len) = + if ((start < 0) orelse (len < 0) orelse (n < start+len)) + then raise General.Subscript + else len + val nr = chk (row, nrows, nr) + val nc = chk (col, ncols, nc) + in + {data = data, i = (row*ncols + col), r=row, c=col, nr=nr, nc=nc} + end + + fun copy (region, dst, dst_row, dst_col) = + raise Fail "Array2.copy unimplemented" + + + (* this function generates a stream of indices for the given region in + * row-major order. + *) + fun iterateRM arg = let + val {data, i, r, c, nr, nc} = chkRegion arg + val ii = ref i and ri = ref r and ci = ref c + fun mkIndx (r, c) = let val i = !ii + in + ii := i+1; + INDX{i=i, c=c, r=r} + end + fun iter () = let + val r = !ri and c = !ci + in + if (c < nc) + then (ci := c+1; mkIndx(r, c)) + else if (r+1 < nr) + then (ci := 0; ri := r+1; iter()) + else DONE + end + in + (data, iter) + end + + (* this function generates a stream of indices for the given region in + * col-major order. + *) + fun iterateCM (arg as {base={ncols, ...}, ...}) = let + val {data, i, r, c, nr, nc} = chkRegion arg + val delta = nr * ncols - 1 + val ii = ref i and ri = ref r and ci = ref c + fun mkIndx (r, c) = let val i = !ii + in + ii := i+ncols; + INDX{i=i, c=c, r=r} + end + fun iter () = let + val r = !ri and c = !ci + in + if (r < nr) + then (ri := r+1; mkIndx(r, c)) + else if (c+1 < nc) + then (ii := !ii-delta; ri := 0; ci := c+1; iter()) + else DONE + end + in + (data, iter) + end + + fun appi order f region = let + val (data, iter) = (case order + of RowMajor => iterateRM region + | ColMajor => iterateCM region + (* end case *)) + fun app () = (case iter() + of DONE => () + | INDX{i, r, c} => (f(r, c, unsafeSub(data, i)); app()) + (* end case *)) + in + app () + end + + fun appRM f ({data, nelts, ...}: array) = + let + fun appf k = + if k < nelts then (f(unsafeSub(data,k)); + appf(k+1)) + else () + in + appf 0 + end + + fun appCM f {data, ncols, nrows, nelts} = let + val delta = nelts - 1 + fun appf (i, k) = if (i < nrows) + then (f(unsafeSub(data, k)); appf(i+1, k+ncols)) + else let + val k = k-delta + in + if (k < ncols) then appf (0, k) else () + end + in + appf (0, 0) + end + fun app RowMajor = appRM + | app ColMajor = appCM + + fun modifyi order f region = let + val (data, iter) = (case order + of RowMajor => iterateRM region + | ColMajor => iterateCM region + (* end case *)) + fun modify () = (case iter() + of DONE => () + | INDX{i, r, c} => ( + unsafeUpdate (data, i, f(r, c, unsafeSub(data, i))); + modify()) + (* end case *)) + in + modify () + end + + fun modifyRM f ({data, nelts, ...}: array) = + let + fun modf k = + if k < nelts then (unsafeUpdate(data,k,f(unsafeSub(data,k))); + modf (k+1)) + else () + in + modf 0 + end + + fun modifyCM f {data, ncols, nrows, nelts} = let + val delta = nelts - 1 + fun modf (i, k) = if (i < nrows) + then (unsafeUpdate(data, k, f(unsafeSub(data, k))); modf(i+1, k+ncols)) + else let + val k = k-delta + in + if (k < ncols) then modf (0, k) else () + end + in + modf (0, 0) + end + fun modify RowMajor = modifyRM + | modify ColMajor = modifyCM + + fun foldi order f init region = let + val (data, iter) = (case order + of RowMajor => iterateRM region + | ColMajor => iterateCM region + (* end case *)) + fun fold accum = (case iter() + of DONE => accum + | INDX{i, r, c} => fold(f(r, c, unsafeSub(data, i), accum)) + (* end case *)) + in + fold init + end + + fun foldRM f init ({data, nelts, ...}: array) = + let + fun foldf (k, accum) = + if k < nelts then foldf(k+1,f(unsafeSub(data,k),accum)) + else accum + in + foldf (0,init) + end + + fun foldCM f init {data, ncols, nrows, nelts} = let + val delta = nelts - 1 + fun foldf (i, k, accum) = if (i < nrows) + then foldf (i+1, k+ncols, f(unsafeSub(data, k), accum)) + else let + val k = k-delta + in + if (k < ncols) then foldf (0, k, accum) else accum + end + in + foldf (0, 0, init) + end + fun fold RowMajor = foldRM + | fold ColMajor = foldCM + + + fun transpose {data, nrows, ncols, nelts} = + let + val dst = mkRawArray nelts + val delta = nelts - 1 + fun iter (k,k') = + if k >= nelts then {data = dst, + nrows = ncols, + ncols = nrows, + nelts = nelts} + else (if k' >= nelts then iter(k,k' - delta) + else (unsafeUpdate(dst,k',unsafeSub(data,k)); + iter(k+1,k'+nrows))) + in + iter(0,0) + end + + fun extract (region as {base,row,col,nrows,ncols}) = + let + fun chk (start,limit,NONE) = + if ltu(start,limit) then limit - start + else raise General.Subscript + + | chk (start, limit, SOME len) = + if ltu(start + len - 1, limit) then len + else raise General.Subscript + + val nr = chk(row, nRows(base), nrows) + val nc = chk(col, nCols(base), ncols) + val n = nr * nc + val dst = mkRawArray n + val (data, iter) = iterateRM region + fun app (k) = (case iter() of + DONE => {data = dst, + nrows = nr, + ncols = nc, + nelts = n} + | INDX{i,...} => + (unsafeUpdate(dst,k,unsafeSub(data,i)); + app(k+1))) + in + app (0) + end + + fun rmSub (arr as {data,...}: array,ix) = + unsafeSub(data,rmIndex(arr, ix)) + + fun rmUpdate(arr as {data,...}: array,ix,v) = + unsafeUpdate(data,rmIndex(arr, ix),v) + + fun binop ({data=dst,nelts=nelts,...}: array, + {data=src1,...}: array, + {data=src2,...}: array, + f) = + dotimes nelts + (fn (ix) => unsafeUpdate(dst,ix,f(unsafeSub(src1,ix), + unsafeSub(src2,ix)))) + + fun unop ({data=dst,nelts=nelts,...}: array, + {data=src,...}: array, + f) = + dotimes nelts + (fn (ix) => unsafeUpdate(dst,ix,f(unsafeSub(src,ix)))) + + fun binopi ({data=dst,nelts=nelts,...}: array, + {data=src1,...}: array, + {data=src2,...}: array, + f) = + dotimes nelts + (fn ix => unsafeUpdate(dst,ix,f(unsafeSub(src1,ix), + unsafeSub(src2,ix), + ix))) + + fun unopi ({data=dst,nelts=nelts,...}: array, + {data=src,...}: array, + f) = + dotimes nelts + (fn ix => unsafeUpdate(dst,ix,f(unsafeSub(src,ix),ix))) + + fun fill ({data=dst,nelts=nelts,...}: array,v) = + dotimes nelts + (fn ix => unsafeUpdate(dst,ix,v)) + + fun fillf ({data=dst,nelts=nelts,...}: array,f) = + dotimes nelts + (fn ix => unsafeUpdate(dst,ix,f(ix))) + + end + +(* test of Zernick phase screen E-field generation *) +(* This is 1.9 times faster than IDL!!!! *) +structure MSpeed = + struct + structure F = FastRealArray2 + + val sin = Math.sin + val cos = Math.cos + + val fromInt = LargeReal.fromInt + + (* setup working vectors and arrays *) + fun collect n f = + let + fun g 0 l = l + | g n l = g (n-1) ((f n) :: l) + in + g n nil + end + + val ncoefs = 15 + val nx = 128 + val ny = nx + val nel = nx * ny + + (* generate an array from a scaled vector *) + fun mulsv (dst, sf, a) = + F.unop(dst,a,fn(vsrc) => sf * vsrc) + + + (* compute the complex exponential of an array *) + fun cisv (a, rpart, ipart) = + (F.unop(rpart,a,cos); + F.unop(ipart,a,sin); + (rpart,ipart)) + + (* accumulate scaled vectors into an array *) + fun mpadd dst (sf, src) = + F.binop(dst,dst,src,fn(vdst,vsrc) => vdst + sf * vsrc) + + + (* compute an E-field from a set of Zernike screens *) + fun zern (dst, rpart, ipart, coefs, zerns) = + (mulsv (dst, hd coefs, hd zerns); + ListPair.app (mpadd dst) (tl coefs, tl zerns); + cisv (dst, rpart, ipart)) + + (* timing tests and reporting *) + fun report_times(niter, nel, (start, stop)) = + let + val secs = Time.-(stop,start) + val dur = Time.toReal(secs) * 1.0E6 + val ops_per_us = ((fromInt niter) * (fromInt nel)) / dur + val ns_per_op = 1000.0 / ops_per_us + in + print(Time.toString (Time.-(stop,start))); + print("\n"); + { ops_per_us = ops_per_us, ns_per_op = ns_per_op} + end + + fun time_iterations f niter = + let + fun iter 0 = Time.now() + | iter n = (ignore (f()); iter (n-1)) + in + (Time.now(), iter niter) + end + + fun ztest niter = + report_times(niter, nel, + time_iterations + (fn () => + let val sum = F.array(ny,nx, 0.0) + val rpart = F.array(ny,nx, 0.0) + val ipart = F.array(ny,nx, 0.0) + val coefs = collect ncoefs (fn(x) => real(1 + x)) + val zerns = + collect ncoefs + (fn(x) => F.tabulate F.RowMajor + (ny, nx, fn(r,c) => 0.01 * real(nx * r + c))) + val (rpart, _) = + zern (sum, rpart, ipart, coefs, zerns) + in if Real.abs(FastRealArray2.sub(rpart, 0, 1) - 0.219) + < 0.001 + then () + else raise Fail "compiler bug" + end) + niter) +end + +structure Main = + struct + fun doit n = MSpeed.ztest n + end diff --git a/benchmark/update-counts.sh b/benchmark/update-counts.sh new file mode 100755 index 0000000..9b99f06 --- /dev/null +++ b/benchmark/update-counts.sh @@ -0,0 +1,67 @@ +#!/usr/bin/env bash + +# set -e + +die () { + echo "$1" >&2 + exit 1 +} + +if $(which gtime) --version >/dev/null 2>&1; then + time=$(which gtime) +elif $(which gnutime) --version >/dev/null 2>&1; then + time=$(which gnutime) +elif $(which time) --version 2>&1 | grep -q GNU; then + time=$(which time) +else + die 'Can'\''t find GNU time' +fi + + +minTime="75.0" + +bench="string-concat vector-concat" + +cd tests +for prog in $bench; do + case "$prog" in + "fxp") + continue ;; + esac + + ( cat $prog.sml ; echo "val _ = Main.doit (valOf (Int.fromString (hd (CommandLine.arguments ()))))" ) > $prog.main.sml + mlton -output $prog $prog.main.sml 1>/dev/null 2>/dev/null + + n=0 + t=0 + + while [ "$(echo "$t < $minTime" | bc)" = "1" ]; do + if [ $n -eq 0 ]; then + n=1 + m=1 + k=1 + elif [ $n -lt $m ]; then + n=$(($n+$k)) + else + m=$((2*$m)) + if [ $m -lt 8 ]; then + n=$m + else + k=$(( ($m-$n) / 2 )) + n=$(($n+$k)) + fi + fi + $time -o $prog.time --format "%U + %S" ./$prog $n 1>/dev/null 2>/dev/null + t=$(cat $prog.time | grep -v "Command exited" | bc) + s=$(grep "Command exited" $prog.time) + if [ ! -z "$s" ]; then + s="; $s " + break + fi + done + + echo "(\"$prog\", $n):: (* $t sec $s*)" + + rm $prog $prog.main.sml $prog.time + +done diff --git a/bin/Makefile b/bin/Makefile new file mode 100644 index 0000000..8c0dc27 --- /dev/null +++ b/bin/Makefile @@ -0,0 +1,13 @@ +## Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # Copyright (C) 1997-2000 NEC Research Institute. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +all: + +.PHONY: clean +clean: + ../bin/clean diff --git a/bin/add-cross b/bin/add-cross new file mode 100755 index 0000000..b3bbcc2 --- /dev/null +++ b/bin/add-cross @@ -0,0 +1,168 @@ +#!/usr/bin/env bash + +set -e + +# This script adds a new crosscompiler target for MLton. +# +# It takes four arguments. +# +# 1. , which is what MLton would pass via the -b flag to the GCC +# cross-compiler tools. You don't need to have installed these tools in order +# to run this script, since it uses ssh and the native gcc on the target. +# Examples of $crossTarget are i386-pc-cygwin and sparc-sun-solaris. +# +# 2. specifies the target architecture. +# +# 3. specifies the target OS. +# +# 4. specifies a remote machine of the target type. This script +# will ssh to $machine to compile the runtime and to compile and run the +# program that will print the values of all the constants that the MLton +# basis library needs. +# +# Here are some example uses of this script. +# +# add-cross i386-pc-cygwin x86 cygwin cygwin +# add-cross sparc-sun-solaris sparc solaris blade +# +# (Here cygwin happens to be the name of my Cygwin machine and blade +# happens to be the name of my Sparc machine.) +# +# You also may need to set $libDir, which determines where the +# cross-compiler target will be installed. + +die () { + echo >&2 "$1" + exit 1 +} + +usage () { + die "usage: $name " +} + +case "$#" in +4) + crossTarget="$1" + crossArch="$2" + crossOS="$3" + machine="$4" + ;; +*) + usage + ;; +esac + +name=`basename "$0"` +original=`pwd` +dir=`dirname "$0"` +src=`cd "$dir/.." && pwd` + +PATH="$src"/bin:$PATH + +# libDir is the mlton lib directory where you would like the +# cross-compiler information to be installed. If you have installed +# from the rpms, this will usually be /usr/lib/mlton. You must have +# write permission there. + +lib="$src/build/lib/mlton" + +# You shouldn't need to change anything below this line. + +rm -rf "$lib/targets/$crossTarget" +mkdir -p "$lib/targets/$crossTarget" || die "Cannot write to $lib." + +tmp='/tmp/mlton-add-cross' + +( cd "$src" && + mmake TARGET=$crossTarget TARGET_ARCH=$crossArch TARGET_OS=$crossOS \ + dirs ) + +ssh $machine "rm -rf $tmp && mkdir $tmp" + +echo "Copying files." +( cd "$src" && tar cf - --exclude '*.o' --exclude '*.a' Makefile basis-library bin include runtime ) | + ssh $machine "cd $tmp && tar xf - && + if [ ! $crossArch == \`./bin/host-arch\` ]; then echo $machine is \`./bin/host-arch\`, not $crossArch; exit 1; fi && + if [ ! $crossOS == \`./bin/host-os\` ]; then echo $machine is \`./bin/host-os\`, not $crossOS; exit 1; fi" + +echo "Making runtime on $machine." +ssh $machine "cd $tmp && ./bin/mmake CPPFLAGS=\"$CPPFLAGS\" LDFLAGS=\"$LDFLAGS\" COMPILE_FAST=yes OMIT_BYTECODE=yes clean dirs runtime" + +ssh $machine "cd $tmp/build/lib/targets/self && tar cf - ." | + ( cd "$lib/targets/$crossTarget" && tar xf - ) +( cd "$src" && + mmake TARGET=$crossTarget TARGET_ARCH=$crossArch TARGET_OS=$crossOS \ + mlbpathmap ) + +case "$crossOS" in +mingw) + suf='.exe' +;; +*) + suf='' +;; +esac + +# Copied from mlton-script +case "$crossArch" in +amd64) + archOpts='-m64' +;; +hppa) + archOpts='' +;; +ia64) + archOpts='-mlp64' +;; +sparc) + archOpts='-m32' +;; +x86) + archOpts='' +;; +esac + +case "$crossOS" in +aix) + osOpts='-maix64' +;; +cygwin) + osOpts='' +;; +darwin) + osOpts='-I/usr/local/include -I/opt/local/include -I/sw/include -L/usr/local/lib -L/opt/local/lib -L/sw/lib' +;; +freebsd) + osOpts='-I/usr/local/include -L/usr/local/lib/' +;; +hurd) + osOpts='' +;; +hpux) + osOpts='' +;; +linux) + osOpts='' +;; +mingw) + libs='-lws2_32 -lkernel32 -lpsapi -lnetapi32 -lwinmm' +;; +netbsd) + osOpts='-I/usr/pkg/include -Wl,-R/usr/pkg/lib -L/usr/pkg/lib/' +;; +openbsd) + osOpts='-I/usr/local/include -L/usr/local/lib/' +;; +solaris) + osOpts='-lnsl -lsocket -lrt' +;; +esac + +exe='print-constants' +echo "Compiling and running print-constants on $machine." +"$src/build/bin/mlton" -target $crossTarget -build-constants true | + ssh $machine "cd $tmp/runtime && + cat >$exe.c && + gcc $archOpts $osOpts $CPPFLAGS -I. -o $exe $exe.c libmlton.a libgdtoa.a $LDFLAGS -lgmp -lm" +ssh $machine "$tmp/runtime/$exe$suf" >"$lib/targets/$crossTarget/constants" +ssh $machine "rm -rf $tmp" diff --git a/bin/build-cross-gcc b/bin/build-cross-gcc new file mode 100755 index 0000000..4158ad8 --- /dev/null +++ b/bin/build-cross-gcc @@ -0,0 +1,177 @@ +#!/usr/bin/env bash + +# This script builds and installs a gcc cross compiler. + +# It has been used to build cross compilers from Linux to Cygwin, +# MinGW, and Solaris. It is unlikely that this script will work +# out-of-the-box. It is only intended as a template. You should read +# through it and understand what it does, and make changes as +# necessary. Feel free to add another targetType if you modify this +# script for another target. + +# Notes from Anoq about the mingw target: +# I downloaded the following files from www.mingw.org: +# *) binutils-2.13.90-20030111-1-src.tar.gz which I unpacked to +# binutils-2.13.90-20030111-1-src.tar +# This script unpacks the .tar to binutils-2.13.90-20030111-1-src +# *) gcc-3.2.3-20030504-1-src.tar.gz which I unpacked to +# gcc-3.2.3-20030504-1-src.tar +# This script unpacks the .tar to gcc-3.2.3-20030504-1 +# However when running make on gcc it complains about missing files +# stdlib.h and unistd.h + +set -e + +die () { + echo >&2 "$1" + exit 1 +} + +root=`pwd` +name=`basename "$0"` + +usage () { + die "usage: $name {cygwin|mingw|sun}" +} + +case "$#" in +1) + case "$1" in + cygwin|mingw|sun) + targetType="$1" + ;; + *) + usage + ;; + esac +;; +*) + usage +esac + +# You may want to change the installation prefix, which is where the +# script will install the cross-compiler tools. +prefix='/usr' + +# You must have have the sources to binutils and gcc, and place the +# tarfiles in the current directory. You can find ftp sites to +# download binutils and gcc-core at gnu.org. You may need to change +# the version numbers below to match what you download. +binutils='binutils-2.12' +gccVers='2.95.3' +gccTar="gcc-core-$gccVers.tar" + +# You may want to set the target. +case "$targetType" in +cygwin) + target='i386-pc-cygwin' + configureGCCFlags='' + makeGCCFlags='' + # For Cygwin, we also need the cygwin and w32api packages, + # which contain necessary header files and libraries. I got + # them by installing cygwin in a Windows machine (using # + # Cygwin's setup.exe program) and then getting the bzip'ed tar + # files out of their Cygwin packages dir. I had problems with + # cygwin-1.3.18-1, since its libcygwin.a contained a file, + # pseudo-reloc.o, with some strangeness that binutils didn't + # correctly handle. + cygwin='cygwin-1.3.17-1' + w32api='w32api-2.1-1' +;; +mingw) + target='i386-pc-mingw32' + # target='mingw32' + # These flags are from build-cross.sh from www.libsdl.org except: + # I added --disable-nls because of undefined references to dcgettext__ + configureGCCFlags='--with-headers=$prefix/$target/include --with-gnu-as --with-gnu-ld --without-newlib --disable-multilib --disable-nls' + makeGCCFlags='LANGUAGES=c' + # For MinGW, we also need the mingw-runtime and w32api packages, + # which contain necessary header files and libraries. I got + # them from www.mingw.org. + mingw='mingw-runtime-3.2' + w32api='w32api-2.4' +;; +sun) + target='sparc-sun-solaris' + configureGCCFlags='' + makeGCCFlags='' + # For sun, we assume that you have already copied the includes + # and libraries from a Solaris machine to the host machine. + if ! [ -d "$prefix/$target/include" -a -d "$prefix/$target/lib" ]; then + die "Must create $prefix/$target/{include,lib}." + fi + # The GCC tools expect limits.h to be in sys-include, not include. + ( cd "$prefix/$target" && + mkdir -p sys-include && + mv include/limits.h sys-include ) +;; +esac + +exists () { + if [ ! -r "$1" ]; then + die "$1 does not exist" + fi +} + +echo 'Checking that needed files exist.' +exists $binutils.tar +exists $gccTar +case "$targetType" in +cygwin) + exists $cygwin.tar + exists $w32api.tar + echo 'Copying include files and libraries needed by cross compiler.' + cd "$root" + mkdir -p cygwin + cd cygwin + tar x <../$cygwin.tar + tar x <../$w32api.tar + mkdir -p "$prefix/$target" || + die "Cannot create $prefix/$target." + (cd usr && tar c include lib) | (cd "$prefix/$target/" && tar x) +;; +mingw) + exists $mingw.tar + exists $w32api.tar + echo 'Copying include files and libraries needed by cross compiler.' + cd "$root" + mkdir -p mingw + cd mingw + tar x <../$mingw.tar + tar x <../$w32api.tar + mkdir -p "$prefix/$target" || + die "Cannot create $prefix/$target." + (tar c include lib) | (cd "$prefix/$target/" && tar x) +;; +*) +;; +esac + +echo 'Building binutils.' +cd "$root" +if [ ! -d "$binutils" ]; then + tar x <$binutils.tar +fi +mkdir -p build-binutils +cd build-binutils +"../$binutils/configure" "--prefix=$prefix" "--target=$target" \ + >"$root/configure-binutils-log" 2>&1 || + die "Configure of binutils failed." +make all install >"$root/build-binutils-log" 2>&1 || + die "Build of binutils failed." + +echo 'Building gcc.' +cd "$root" +tar x <"$gccTar" +mkdir -p build-gcc +cd build-gcc +eval "../gcc-$gccVers/configure" -v $configureGCCFlags \ + --enable-languages=c \ + "--prefix=$prefix" \ + "--target=$target" \ + >"$root/configure-gcc-log" 2>&1 || + die "Configure of gcc failed." +eval make $makeGCCFlags all install >"$root/build-gcc-log" 2>&1 || + die "Build of gcc failed." + +echo 'Success.' diff --git a/bin/clean b/bin/clean new file mode 100755 index 0000000..054e5f7 --- /dev/null +++ b/bin/clean @@ -0,0 +1,56 @@ +#!/usr/bin/env bash + +set -e + +die () { + echo >&2 "$1" + exit 1 +} + +usage () { + die "usage: $name [--exclude ...]" +} + + +name=$(basename "$0") +dir=$(dirname "$0") +root=$(cd "$dir/.." && pwd) +bin="$root/bin" + +declare -a exclude +while [ "$#" -gt 0 ]; do + case "$1" in + "--exclude") + shift + if [ "$#" -gt 0 ]; then + exclude+=("$1"); + shift + fi + ;; + *) usage + ;; + esac +done + +doit () { + # rm -rf '.#'* .*~ *~ *.a *.o .cm core mlmon.out svn-commit.* + "$bin/ls-ignore" | xargs rm -rf + for f in *; do + if [ -d "$f" ]; then + for ((i=0; i < ${#exclude[*]}; i++)); do + if [ "$f" == "${exclude[$i]}" ]; then + continue 2 + fi + done + cd "$f" + if [ -r Makefile ]; then + "$bin/mmake" clean || doit + else + doit + fi + cd .. + fi + done +} + +doit diff --git a/bin/host-arch b/bin/host-arch new file mode 100755 index 0000000..5e3e1ed --- /dev/null +++ b/bin/host-arch @@ -0,0 +1,27 @@ +#!/usr/bin/env bash + +set -e +name=`basename "$0"` +dir=`dirname "$0"` +bin=`cd "$dir" && pwd` + +die () { + echo >&2 "$1" + exit 1 +} + +usage () { + die "usage: $name" +} + +case "$#" in +0) +;; +*) + usage +;; +esac + +eval `"$bin/platform"` + +echo $HOST_ARCH diff --git a/bin/host-os b/bin/host-os new file mode 100755 index 0000000..04c41ad --- /dev/null +++ b/bin/host-os @@ -0,0 +1,27 @@ +#!/usr/bin/env bash + +set -e +name=`basename "$0"` +dir=`dirname "$0"` +bin=`cd "$dir" && pwd` + +die () { + echo >&2 "$1" + exit 1 +} + +usage () { + die "usage: $name" +} + +case "$#" in +0) +;; +*) + usage +;; +esac + +eval `"$bin/platform"` + +echo $HOST_OS diff --git a/bin/ls-ignore b/bin/ls-ignore new file mode 100755 index 0000000..22cbe2d --- /dev/null +++ b/bin/ls-ignore @@ -0,0 +1,101 @@ +#!/usr/bin/env bash + +set -e + +# List ignored files of current directory by constructing a "find" +# expression that matches names of ignored files. +# +# This script supports a reasonable subset of "gitignore(5)" +# semantics. Notably, it does support: +# * Patterns read from .gitignore files in current and parent directories +# * Blank line separators +# * Leading "#" comments +# * Trailing "/" directory patterns +# * Leading "/" this-directory patterns +# and it does not support: +# * Patterns read from $GIT_DIR/info/exclude +# (b/c inappropriate for a source release) +# * Patterns read from file specified by configuration variable core.excludesfile +# (b/c inappropriate for a source release) +# * Leading "!" negation patterns +# (b/c complex semantics) +# * Internal "/" FNM_PATHNAME patterns +# (b/c complex semantics incompatible with '-path' primary) + +name=$(basename "$0") +dir=$(dirname "$0") +root=$(cd "$dir/.." && pwd) + +ignore='.gitignore' + +declare -a fargs +fargs+=("(") +fargs+=("-exec") +fargs+=("false") +fargs+=(";") +idir="." +while true; do + if [ -r "$idir/$ignore" ]; then + while IFS= read -r opat; do + pat="$opat" + ## Blank line: Separator -- supported + if [ -z "$pat" ]; then + continue + fi + ## Leading "#": Comment -- supported + if [ "${pat:0:1}" = "#" ]; then + continue + fi + ## Leading "\#": Pattern beginning with "#" -- supported + if [ "${pat:0:2}" = "\#" ]; then + pat="#${pat:2}" + fi + ## Leading "!": Negated pattern -- unsupported + if [ "${pat:0:1}" = "!" ]; then + echo "$name:: unsupported pattern: $opat" + exit 1 + fi + ## Leading "\!": Pattern beginning with "!" -- supported + if [ "${pat:0:2}" = "\!" ]; then + pat="!${pat:2}" + fi + ## Trailing "/": Directory pattern -- supported + if [ "${pat:$((${#pat}-1)):1}" = "/" ]; then + dirPat="yes" + pat="${pat:0:$((${#pat}-1))}" + else + dirPat="no" + fi + ## Leading "/": This-directory pattern -- supported + if [ "${pat:0:1}" = "/" ]; then + if [ "$idir" = "." ]; then + pat="${pat:1}" + else + continue + fi + fi + ## Internal "/": FNM_PATHNAME pattern -- unsupported + if [ -z "${pat##*/*}" ]; then + echo "$name:: unsupported pattern: $opat" + exit 1 + fi + fargs+=("-o") + fargs+=("(") + if [ "$dirPat" = "yes" ]; then + fargs+=("-type") + fargs+=("d") + fi + fargs+=("-name") + fargs+=("$pat") + fargs+=(")") + done < "$idir/$ignore" + fi + if [ "$(cd "$idir" && pwd)" != "$root" ]; then + idir="../$idir" + else + break + fi +done +fargs+=(")") + +find . -mindepth 1 -maxdepth 1 "${fargs[@]}" -print diff --git a/bin/mlton-script b/bin/mlton-script new file mode 100644 index 0000000..de5846f --- /dev/null +++ b/bin/mlton-script @@ -0,0 +1,114 @@ +#!/usr/bin/env bash + +# This script calls MLton. + +set -e + +dir=`dirname "$0"` +lib=`cd "$dir/../lib/mlton" && pwd` + +declare -a rargs +case "$1" in +@MLton) + shift + while [ "$#" -gt 0 -a "$1" != "--" ]; do + rargs[${#rargs[@]}]="$1" + shift + done + if [ "$#" -gt 0 -a "$1" == "--" ]; then + shift + else + echo '@MLton missing --' + exit 1 + fi + ;; +esac + +EXE= + +doitMLton () { + mlton_mlton="$lib/mlton-compile$EXE" + if [ -x "$mlton_mlton" ]; then + exec "$mlton_mlton" @MLton ram-slop 0.5 "${rargs[@]}" -- "$@" + fi +} +doitSMLNJ () { + smlnj='sml' + if $smlnj -h >/dev/null 2>&1; then + smlnj_heap_suffix=`echo 'TextIO.output (TextIO.stdErr, SMLofNJ.SysInfo.getHeapSuffix ());' | $smlnj 2>&1 1> /dev/null` + mlton_smlnj_heap="$lib/mlton-smlnj.$smlnj_heap_suffix" + if [ -s "$mlton_smlnj_heap" ]; then + exec "$smlnj" @SMLload="$mlton_smlnj_heap" "$@" + fi + fi +} +doitPolyML () { + mlton_polyml="$lib/mlton-polyml$EXE" + if [ -x "$mlton_polyml" ]; then + exec "$mlton_polyml" "$@" + fi +} + +doit () { + doitMLton "$@" + doitSMLNJ "$@" + doitPolyML "$@" + echo 'Unable to run MLton. Check that lib is set properly.' >&2 + exit 1 +} + +CC="gcc" + +# You may need to set 'GMP_INC_DIR' so the C compiler can find gmp.h. +GMP_INC_DIR= +if [ -n "$GMP_INC_DIR" ]; then +gmpCCOpts="-cc-opt -I$GMP_INC_DIR" +fi +# You may need to set 'GMP_LIB_DIR' so the C compiler can find libgmp. +GMP_LIB_DIR= +if [ -n "$GMP_LIB_DIR" ]; then +gmpLinkOpts="-link-opt -L$GMP_LIB_DIR -target-link-opt netbsd -Wl,-R$GMP_LIB_DIR" +fi + +doit "$lib" \ + -ar-script "$lib/static-library" \ + -cc "$CC" \ + -cc-opt '-std=gnu11 -fno-common' \ + -cc-opt '-O1 -fomit-frame-pointer -fno-strict-aliasing' \ + -cc-opt '-w' \ + -cc-opt-quote "-I$lib/include" \ + -link-opt '-lm -lgmp' \ + $gmpCCOpts $gmpLinkOpts \ + -llvm-llc-opt '-O2' \ + -llvm-opt-opt '-mem2reg -O2' \ + -mlb-path-var 'SML_LIB $(LIB_MLTON_DIR)/sml' \ + -target-as-opt amd64 '-m64' \ + -target-as-opt x86 '-m32' \ + -target-cc-opt alpha \ + '-mieee -mbwx -mtune=ev6 -mfp-rounding-mode=d' \ + -target-cc-opt amd64 '-m64' \ + -target-cc-opt aix '-maix64' \ + -target-cc-opt ia64-hpux "-mlp64" \ + -target-cc-opt ia64 "-mtune=itanium2" \ + -target-cc-opt sparc '-m32 -mcpu=v8 -Wa,-xarch=v8plusa' \ + -target-cc-opt x86 \ + '-m32 + -fno-strength-reduce + -fschedule-insns + -fschedule-insns2 + -falign-functions=5 + -falign-jumps=2 + -falign-loops=2' \ + -target-link-opt amd64 '-m64' \ + -target-link-opt alpha \ + '-mieee -mbwx -mtune=ev6 -mfp-rounding-mode=d' \ + -target-link-opt aix '-maix64' \ + -target-link-opt ia64-hpux "-mlp64" \ + -target-link-opt linux '-Wl,-znoexecstack' \ + -target-link-opt mingw \ + '-lws2_32 -lkernel32 -lpsapi -lnetapi32 -lwinmm' \ + -target-link-opt mingw '-Wl,--enable-stdcall-fixup' \ + -target-link-opt solaris '-lnsl -lsocket -lrt' \ + -target-link-opt x86 '-m32' \ + -profile-exclude '\$\(SML_LIB\)' \ + "$@" diff --git a/bin/mmake b/bin/mmake new file mode 100755 index 0000000..63c880b --- /dev/null +++ b/bin/mmake @@ -0,0 +1,20 @@ +#!/usr/bin/env bash + +set -e + +die () { + echo "$1" >&2 + exit 1 +} + +if gmake -v >/dev/null 2>&1; then + make='gmake' +elif gnumake -v >/dev/null 2>&1; then + make='gnumake' +elif make -v 2>&1 | grep -q GNU; then + make=`which make` +else + die 'Can'\''t find GNU make' +fi + +exec "$make" "$@" diff --git a/bin/patch-mingw b/bin/patch-mingw new file mode 100755 index 0000000..5c113af --- /dev/null +++ b/bin/patch-mingw @@ -0,0 +1,13 @@ +#!/usr/bin/env sh + +set -e + +dir=`dirname "$0"` + +for f in `find "$dir" -type f | grep -v '\.svn' | grep -v '~'`; do + if head -n 1 "$f" | grep -q '#!/usr/bin/env bash'; then + echo "Processing $f" + sed 's;#!/usr/bin/env bash;#!/usr/bin/env sh;' <"$f" >.tmp; + mv .tmp "$f"; + fi +done diff --git a/bin/platform b/bin/platform new file mode 100755 index 0000000..90725db --- /dev/null +++ b/bin/platform @@ -0,0 +1,147 @@ +#!/usr/bin/env bash + +set -e + +name=`basename "$0"` +dir=`dirname "$0"` +bin=`cd "$dir" && pwd` + +die () { + echo >&2 "$1" + exit 1 +} + +usage () { + die "usage: $name" +} + +case "$#" in +0) +;; +*) + usage +;; +esac + +uname=`uname` +arch= + +case "$uname" in +AIX) + HOST_OS='aix' + arch=`/usr/sbin/lsattr -a type -F deflt -l proc0` + case $arch in + POWER) arch=powerpc64 ;; + esac +;; +CYGWIN*) + HOST_OS='cygwin' +;; +Darwin) + HOST_OS='darwin' +;; +*FreeBSD*) + HOST_OS='freebsd' +;; +GNU) + HOST_OS='hurd' +;; +HP-UX) + HOST_OS='hpux' +;; +Linux) + HOST_OS='linux' +;; +MINGW*) + HOST_OS='mingw' +;; +NetBSD*) + HOST_OS='netbsd' +;; +OpenBSD*) + HOST_OS='openbsd' +;; +SunOS) + HOST_OS='solaris' + for arch in sparc amd64 i386 `uname -m`; do + optisa $arch > /dev/null && break + done +;; +*) + die "Unknown OS $uname." +;; +esac + +if [ -z "$arch" ]; then + arch=`uname -m` +fi + +case "$arch" in +alpha*) +# not certain about this one; no alpha access + HOST_ARCH=alpha +;; +x86_64*) + HOST_ARCH=amd64 +;; +i?86_64) + HOST_ARCH=amd64 +;; +amd64) + HOST_ARCH=amd64 +;; +arm*) + HOST_ARCH=arm +;; +aarch64) + HOST_ARCH=arm64 +;; +parisc*) + HOST_ARCH=hppa +;; +9000/*) + HOST_ARCH=hppa +;; +ia64*) + HOST_ARCH=ia64 +;; +m68k*) + HOST_ARCH=m68k +;; +mips*) +# big-endian and little-endian detect via headers + HOST_ARCH=mips +;; +powerpc64) + HOST_ARCH=powerpc64 +;; +ppc64) + HOST_ARCH=powerpc64 +;; +powerpc) + HOST_ARCH=powerpc +;; +ppc*) + HOST_ARCH=powerpc +;; +Power*) + HOST_ARCH=powerpc +;; +s390*) + HOST_ARCH=s390 +;; +sparc*) + HOST_ARCH=sparc +;; +sun*) + HOST_ARCH=sparc +;; +i?86*) + HOST_ARCH=x86 +;; +*) + die "Unknown arch $arch." +;; +esac + +echo "HOST_OS=$HOST_OS HOST_ARCH=$HOST_ARCH" diff --git a/bin/regression b/bin/regression new file mode 100755 index 0000000..a63d3b3 --- /dev/null +++ b/bin/regression @@ -0,0 +1,268 @@ +#!/usr/bin/env bash + +# This script runs the regression tests in src/regression. +# It also compiles the tests in benchmark/tests + +# set -e + +name=`basename "$0"` + +usage () { + echo >&2 "usage: $name [-fail] [-short] [-test-reg reg] [mlton flags ...]" + exit 1 +} + +fail='false' +short='false' +testReg='false' +exitFail=false +declare -a testRegs +declare -a flags +declare -a extraFlags +flags[${#flags[@]}]="-type-check" +flags[${#flags[@]}]="true" +while [ "$#" -gt 0 ]; do + case "$1" in + -fail) + fail='true' + shift + ;; + -short) + short='true' + shift + ;; + -test-reg) + testReg='true' + shift + if [ "$#" = 0 ]; then + usage + fi + testRegs[${#testRegs[@]}]="$1" + shift + ;; + *) + flags[${#flags[@]}]="$1" + shift + ;; + esac +done + + +dir=`dirname "$0"` +src=`cd "$dir/.." && pwd` +bin="$src/build/bin" +lib="$src/build/lib/mlton" +mlton="$bin/mlton" +cont='callcc.sml callcc2.sml callcc3.sml once.sml' +flatArray='finalize.sml flat-array.sml flat-array.2.sml' +intInf='conv.sml conv2.sml fixed-integer.sml harmonic.sml int-inf.*.sml slow.sml slower.sml smith-normal-form.sml' +signal='finalize.sml signals.sml signals2.sml signals3.sml signals4.sml suspend.sml weak.sml' +thread='thread0.sml thread1.sml thread2.sml mutex.sml prodcons.sml same-fringe.sml timeout.sml' +world='world1.sml world2.sml world3.sml world4.sml world5.sml world6.sml' +tmp=/tmp/z.regression.$$ +PATH="$bin:$PATH" + +# whitelist tests that are known to fail (will still run but exit cleanly) +declare -A whitelisted +if [ -a $src/regression/whitelist ] ; then + while read f ; do + echo "whitelisting $f..." + whitelisted["$f"]=1 + done <$src/regression/whitelist +fi + +isWhitelisted () { + local f=$1 + if [[ ${whitelisted["$f"]} ]] ; then + echo 1 + else + echo 0 + fi +} + +eval `"$src/bin/platform"` + +compFail () { + echo "compilation of $f failed with ${flags[*]}" +} + +"$mlton" -verbose 1 || (echo 'no mlton present' && exitFail=true) +echo "flags = ${flags[*]}" + +cd "$src/regression" + +if $fail; then + for f in fail/*.sml; do + echo "testing $f" + ( "$mlton" "${flags[@]}" -stop tc "$f" >/dev/null 2>&1 && + echo "compilation of $f should have failed but did not" && ignore=$(isWhitelisted $f) && if [ "$ignore" -eq 0 ] ; then exitFail=true ; fi ) || + true + done + + if [ "$exitFail" = true ] ; then + exit 1 + else + exit 0 + fi +fi + +forMinGW='false' +if [ $HOST_OS = mingw ]; then + forMinGW='true' +fi + +for f in *.sml; do + f=`basename "$f" .sml` + if ($testReg); then + skip='true' + for (( i = 0 ; $i < ${#testRegs[@]} ; i++ )); do + if [ "$f" = "${testRegs[$i]}" ]; then + skip='false' + fi + done + if ($skip); then + continue + fi + fi + case $HOST_OS in + cygwin) + case "$f" in + textio.2) + continue + ;; + esac + ;; + hurd) + # Work-around hurd bug (http://bugs.debian.org/551470) + case "$f" in + mutex|prodcons|signals|signals2|signals3|signals4|suspend|thread2|timeout|world5) + continue + ;; + esac + ;; + mingw) + case "$f" in + cmdline|command-line|echo|filesys|posix-exit|signals|signals2|signals3|signals4|socket|suspend|textio.2|unixpath|world*) + continue + ;; + esac + ;; + esac + case "$f" in + serialize) + continue + ;; + esac + echo "testing $f" + unset extraFlags + case "$f" in + exn-history*) + extraFlags[${#extraFlags[@]}]="-const" + extraFlags[${#extraFlags[@]}]="Exn.keepHistory true" + ;; + esac + + mlb="$f.mlb" + echo "\$(SML_LIB)/basis/basis.mlb + \$(SML_LIB)/basis/mlton.mlb + \$(SML_LIB)/basis/sml-nj.mlb + ann + \"allowFFI true\" + \"allowOverload true\" + \"allowExtendedTextConsts true\" + \"nonexhaustiveBind ignore\" + \"nonexhaustiveMatch ignore\" + \"redundantBind ignore\" + \"redundantMatch ignore\" + in $f.sml + end" >"$mlb" + "$mlton" "${flags[@]}" "${extraFlags[@]}" -output "$f" "$mlb" + if [ "$?" -ne '0' ] || [ ! -x "$f" ]; then + compFail "$f" + exitFail=true + fi + rm "$mlb" + + if [ ! -r "$f".nonterm -a -x "$f" ]; then + nonZeroMsg='Nonzero exit status.' + if $forMinGW; then + nonZeroMsg="$nonZeroMsg"'\r' + fi + ( "./$f" || echo -e "$nonZeroMsg" ) >$tmp 2>&1 + if [ -r "$f.ok" ]; then + compare="$f.$HOST_ARCH-$HOST_OS.ok" + if [ ! -r $compare ]; then + compare="$f.ok" + fi + if $forMinGW; then + newcompare="$f.sed.ok" + sed $'s/$/\r/' <"$compare" > "$newcompare" + compare="$newcompare" + fi + if ! diff "$compare" "$tmp"; then + echo "$f: difference with ${flags[*]} ${extraFlags[*]}" + ignore=$(isWhitelisted $f) + if [ "$ignore" -eq 0 ] ; then + exitFail=true + fi + fi + fi + fi +done + +if $short || $testReg ; then + if [ "$exitFail" = true ] ; then + exit 1 + else + exit 0 + fi +fi + +"$src/bin/mmake" clean >/dev/null +cd "$src/benchmark/tests" +for f in *.sml; do + f=`basename "$f" .sml` + tmpf="/tmp/$f.$$" + case "$f" in + fxp) + echo "skipping $f" + ;; + *) + echo "testing $f" + echo "val _ = Main.doit 0" | cat "$f.sml" - > "$tmpf.sml" + $mlton -output "$tmpf" "${flags[@]}" \ + -default-ann 'nonexhaustiveBind ignore'\ + -default-ann 'nonexhaustiveMatch ignore'\ + -default-ann 'redundantBind ignore' \ + -default-ann 'redundantMatch ignore' \ + "$tmpf.sml" + if [ $? -ne 0 ]; then + compFail "$f" + exitFail=true + fi + rm -f "$tmpf" "$tmpf.sml" + ;; + esac +done +"$src/bin/mmake" clean >/dev/null +cd "$src" +for f in mllex mlyacc mlprof; do + tmpf="/tmp/$f.$$" + cd "$src/$f" + echo "testing $f" + "$src/bin/mmake" -W "$f" >/dev/null + "$mlton" "${flags[@]}" -output "$tmpf" "$f.mlb" + if [ $? -ne 0 ]; then + compFail "$f" + exitFail=true + fi + rm -f "$tmpf" +done + +rm -f "$tmp" + +if [ "$exitFail" = true ] ; then + exit 1 +else + exit 0 +fi diff --git a/bin/run-docker b/bin/run-docker new file mode 100755 index 0000000..ba5d8d1 --- /dev/null +++ b/bin/run-docker @@ -0,0 +1,12 @@ +#!/bin/bash + +NAME="mlton-run-docker" + +# Remove any containers which already have $NAME. +docker image rm $NAME + +# build container, and assign it tag $NAME +docker build -t $NAME . + +# run container with the tag $NAME. +docker run --rm -it $NAME diff --git a/bin/static-library b/bin/static-library new file mode 100755 index 0000000..dc4faab --- /dev/null +++ b/bin/static-library @@ -0,0 +1,73 @@ +#! /usr/bin/env bash + +# This script creates a static library (archive). +# It is invoked as: static-library TARGET OS OUTPUT objects* libraries* +# eg: static-library self mingw foo.a /tmp/obj1.o /tmp/obj2.o /lib/libmlton.a + +# A safe fallback for unsupported platforms is: +# rm -f foo.a +# ar rc foo.a /tmp/obj1.o /tmp/obj2.o +# ranlib foo.a + +# However, this script tries to mimic the behaviour of shared libraries as +# closely as possible. It links in the required bits of dependent libraries, +# links together the given objects, and then hides all non-public symbols. +# +# The end result of this process is that two MLton produced static libraries +# can safely be used at the same time since their symbols don't overlap. It +# is even possible to use libraries produced using different versions of the +# runtime. + +set -e + +target="$1" +shift +os="$1" +shift +output="$1" +shift + +if [ "$target" = "self" ]; then target=""; else target="$target-"; fi + +# Change this to false is partial linking does not work on your platform +partialLink='true' + +rm -f "${output}" + +if "$partialLink"; then + # Localize all but export symbols. Platform dependent. + if [ "$os" = "darwin" ]; then + "${target}ld" -r -o "$output.o" "$@" + # The osx linker already makes hidden symbols local + elif [ "$os" = "mingw" -o "$os" = "cygwin" ]; then + # Link allowing _address of stdcall function fixups + # Preserve the export list (.drectve section) + "${target}ld" -r --unique=.drectve --enable-stdcall-fixup -o "$output.o" "$@" + # Extract the list of exports to make only them global + "${target}dlltool" --output-def "$output.def" "$output.o" + grep '@' "$output.def" \ + | sed 's/^[[:space:]]*\([^[:space:]]*\).*$/_\1/' \ + > "$output.globals" + "${target}objcopy" --keep-global-symbols "$output.globals" "$output.o" + rm "$output.def" "$output.globals" + else + "${target}ld" -r -o "$output.o" "$@" + # ELF systems are all the same... localize hidden symbols + # Be careful not to localize gcc PIC's common section thunks + "${target}objdump" -t "$output.o" \ + | grep ' \.hidden ' \ + | grep -v get_pc_thunk \ + | sed 's/^.* \.hidden //' \ + > "$output.locals" + "${target}objcopy" --localize-symbols "$output.locals" "$output.o" + rm "$output.locals" + fi + + # Create the final archive + "${target}ar" rc "$output" "$output.o" + "${target}ranlib" "$output" + rm "$output.o" +else + "${target}ar" rc "$output" "$@" + "${target}ranlib" "$output" +fi diff --git a/bin/static-library.bat b/bin/static-library.bat new file mode 100644 index 0000000..5ccde29 --- /dev/null +++ b/bin/static-library.bat @@ -0,0 +1 @@ +@bash %~dp0static-library %* diff --git a/bin/travis-ci b/bin/travis-ci new file mode 100755 index 0000000..e6a4c3d --- /dev/null +++ b/bin/travis-ci @@ -0,0 +1,25 @@ +#!/usr/bin/env bash + +set -e + +echo +mlton +echo +make -version +echo +$CC --version +echo +if [[ "$MLTON_COMPILE_ARGS" == *"llvm"* ]]; then +llvm-as -version +opt -version +llc -version +echo +fi + +echo "Building MLton..." +make CC="$CC" MLTON_COMPILE_ARGS="$MLTON_COMPILE_ARGS" all + +if [ "$REGRESSION" == "true" ]; then +echo "Running regression tests..." +./bin/regression $MLTON_COMPILE_ARGS +fi diff --git a/doc/CHANGELOG.adoc b/doc/CHANGELOG.adoc new file mode 120000 index 0000000..e59a806 --- /dev/null +++ b/doc/CHANGELOG.adoc @@ -0,0 +1 @@ +../CHANGELOG.adoc \ No newline at end of file diff --git a/doc/README.adoc b/doc/README.adoc new file mode 120000 index 0000000..a7ab0b1 --- /dev/null +++ b/doc/README.adoc @@ -0,0 +1 @@ +../README.adoc \ No newline at end of file diff --git a/doc/examples/Makefile b/doc/examples/Makefile new file mode 100644 index 0000000..0d636de --- /dev/null +++ b/doc/examples/Makefile @@ -0,0 +1,17 @@ +## Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # Copyright (C) 1997-2000 NEC Research Institute. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +all: + +%: %.sml + mlton $< + +.PHONY: +clean: + ../../bin/clean + rm -f *.sml diff --git a/doc/examples/ffi/.gitignore b/doc/examples/ffi/.gitignore new file mode 100644 index 0000000..39600ec --- /dev/null +++ b/doc/examples/ffi/.gitignore @@ -0,0 +1,10 @@ +/c_quot.o +/export +/export.h +/ffi-export.o +/ffi-import.o +/iimport +/import +/import2 +/test_quot +/test_quot.h diff --git a/doc/examples/ffi/Makefile b/doc/examples/ffi/Makefile new file mode 100644 index 0000000..38cd9f7 --- /dev/null +++ b/doc/examples/ffi/Makefile @@ -0,0 +1,44 @@ +## Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # Copyright (C) 1997-2000 NEC Research Institute. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +PATH := ../../../build/bin:$(shell echo $$PATH) +mlton := mlton -default-ann 'allowFFI true' + +.PHONY: all all-win32 +all-win32: import import2 export test_quot + ./import + ./import2 + ./export + ./test_quot +all: all-win32 iimport + ./iimport + +export: export.sml ffi-export.o +import: import.sml ffi-import.o +import2: import2.sml ffi-import.o +test_quot : test_quot.sml c_quot.o + +ffi-import.o: export.h +ffi-export.o: export.h +c_quot.o : test_quot.h + +iimport: iimport.sml + $(mlton) \ + -target-link-opt linux -ldl \ + -target-link-opt solaris -ldl \ + iimport.sml + +%.o: %.c + gcc -Wall -c -o $@ $< +%.h: %.sml + $(mlton) -export-header $@ -stop tc $< +%: + $(mlton) -output $@ $^ + +clean: + ../../../bin/clean diff --git a/doc/examples/ffi/c_quot.c b/doc/examples/ffi/c_quot.c new file mode 100644 index 0000000..9fc367f --- /dev/null +++ b/doc/examples/ffi/c_quot.c @@ -0,0 +1,14 @@ +#include "test_quot.h" +#include + +PRIVATE Int8 c_quot(Int8 x, Int8 y) { + Int8 z = x / y; + return z; +} + +PUBLIC void call_sml_quot() { + Int8 x = -1; + Int8 y = 10; + Int8 z = sml_quot(x, y); + printf(" sml_z = %i\n", z); +} diff --git a/doc/examples/ffi/export.sml b/doc/examples/ffi/export.sml new file mode 100644 index 0000000..4f285fa --- /dev/null +++ b/doc/examples/ffi/export.sml @@ -0,0 +1,33 @@ +val e = _export "f": (int * real * char -> char) -> unit; +val _ = e (fn (i, r, _) => + (print (concat ["i = ", Int.toString i, + " r = ", Real.toString r, "\n"]) + ; #"g")) +val g = _import "g" public reentrant: unit -> unit; +val _ = g () +val _ = g () + +val e = _export "f2": (Word8.word -> word array) -> unit; +val _ = e (fn w => + Array.tabulate (10, fn _ => Word.fromLargeWord (Word8.toLargeWord w))) +val g2 = _import "g2" public reentrant: unit -> word array; +val a = g2 () +val _ = print (concat ["0wx", Word.toString (Array.sub (a, 0)), "\n"]) + +val e = _export "f3": (unit -> unit) -> unit; +val _ = e (fn () => print "hello\n"); +val g3 = _import "g3" public reentrant: unit -> unit; +val _ = g3 () + +(* This example demonstrates mutual recursion between C and SML. *) +val e = _export "f4": (int -> unit) -> unit; +val g4 = _import "g4" public reentrant: int -> unit; +val _ = e (fn i => if i = 0 then () else g4 (i - 1)) +val _ = g4 13 + +val (_, zzzSet) = _symbol "zzz" alloc: (unit -> int) * (int -> unit); +val () = zzzSet 42 +val g5 = _import "g5" public: unit -> unit; +val _ = g5 () + +val _ = print "success\n" diff --git a/doc/examples/ffi/ffi-export.c b/doc/examples/ffi/ffi-export.c new file mode 100644 index 0000000..cc71fe5 --- /dev/null +++ b/doc/examples/ffi/ffi-export.c @@ -0,0 +1,36 @@ +#include +#include "export.h" + +/* Functions in C are by default PUBLIC symbols */ +void g () { + Char8 c; + + fprintf (stderr, "g starting\n"); + c = f (13, 17.15, 'a'); + fprintf (stderr, "g done char = %c\n", c); +} + +Pointer g2 () { + Pointer res; + fprintf (stderr, "g2 starting\n"); + res = f2 (0xFF); + fprintf (stderr, "g2 done\n"); + return res; +} + +void g3 () { + fprintf (stderr, "g3 starting\n"); + f3 (); + fprintf (stderr, "g3 done\n"); +} + +void g4 (Int32 i) { + fprintf (stderr, "g4 (%d)\n", i); + f4 (i); +} + +void g5 () { + fprintf (stderr, "g5 ()\n"); + fprintf (stderr, "zzz = %i\n", zzz); + fprintf (stderr, "g5 done\n"); +} diff --git a/doc/examples/ffi/ffi-import.c b/doc/examples/ffi/ffi-import.c new file mode 100644 index 0000000..a6ac4c0 --- /dev/null +++ b/doc/examples/ffi/ffi-import.c @@ -0,0 +1,23 @@ +#include "export.h" + +Int32 FFI_INT = 13; +Word32 FFI_WORD = 0xFF; +Bool FFI_BOOL = 1; +Real64 FFI_REAL = 3.14159; + +Char8 ffi (Pointer a1, Int32 a1len, Pointer a2, Pointer a3, Int32 n) { + double *ds = (double*)a1; + int *pi = (int*)a2; + char *pc = (char*)a3; + int i; + double sum; + + sum = 0.0; + for (i = 0; i < a1len; ++i) { + sum += ds[i]; + ds[i] += n; + } + *pi = (int)sum; + *pc = 'c'; + return 'c'; +} diff --git a/doc/examples/ffi/iimport.sml b/doc/examples/ffi/iimport.sml new file mode 100644 index 0000000..6ded0c1 --- /dev/null +++ b/doc/examples/ffi/iimport.sml @@ -0,0 +1,121 @@ +signature DYN_LINK = + sig + type hndl + type mode + type fptr + + val dlopen : string * mode -> hndl + val dlsym : hndl * string -> fptr + val dlclose : hndl -> unit + + val RTLD_LAZY : mode + val RTLD_NOW : mode + end + +structure DynLink :> DYN_LINK = + struct + type hndl = MLton.Pointer.t + type mode = Word32.word + type fptr = MLton.Pointer.t + + (* These symbols come from a system libray, so the default import scope + * of external is correct. + *) + val dlopen = + _import "dlopen" : string * mode -> hndl; + val dlerror = + _import "dlerror": unit -> MLton.Pointer.t; + val dlsym = + _import "dlsym" : hndl * string -> fptr; + val dlclose = + _import "dlclose" : hndl -> Int32.int; + + val RTLD_LAZY = 0wx00001 (* Lazy function call binding. *) + val RTLD_NOW = 0wx00002 (* Immediate function call binding. *) + + val dlerror = fn () => + let + val addr = dlerror () + in + if addr = MLton.Pointer.null + then NONE + else let + fun loop (index, cs) = + let + val w = MLton.Pointer.getWord8 (addr, index) + val c = Byte.byteToChar w + in + if c = #"\000" + then SOME (implode (rev cs)) + else loop (index + 1, c::cs) + end + in + loop (0, []) + end + end + + val dlopen = fn (filename, mode) => + let + val filename = filename ^ "\000" + val hndl = dlopen (filename, mode) + in + if hndl = MLton.Pointer.null + then raise Fail (case dlerror () of + NONE => "???" + | SOME s => s) + else hndl + end + + val dlsym = fn (hndl, symbol) => + let + val symbol = symbol ^ "\000" + val fptr = dlsym (hndl, symbol) + in + case dlerror () of + NONE => fptr + | SOME s => raise Fail s + end + + val dlclose = fn hndl => + if MLton.Platform.OS.host = MLton.Platform.OS.Darwin + then () (* Darwin reports the following error message if you + * try to close a dynamic library. + * "dynamic libraries cannot be closed" + * So, we disable dlclose on Darwin. + *) + else + let + val res = dlclose hndl + in + if res = 0 + then () + else raise Fail (case dlerror () of + NONE => "???" + | SOME s => s) + end + end + +val dll = + let + open MLton.Platform.OS + in + case host of + Cygwin => "cygwin1.dll" + | Darwin => "libm.dylib" + | _ => "libm.so" + end + +val hndl = DynLink.dlopen (dll, DynLink.RTLD_LAZY) + +local + val double_to_double = + _import * : DynLink.fptr -> real -> real; + val cos_fptr = DynLink.dlsym (hndl, "cos") +in + val cos = double_to_double cos_fptr +end + +val _ = print (concat [" Math.cos(2.0) = ", Real.toString (Math.cos 2.0), "\n", + "libm.so::cos(2.0) = ", Real.toString (cos 2.0), "\n"]) + +val _ = DynLink.dlclose hndl diff --git a/doc/examples/ffi/import.sml b/doc/examples/ffi/import.sml new file mode 100644 index 0000000..17c6345 --- /dev/null +++ b/doc/examples/ffi/import.sml @@ -0,0 +1,24 @@ +(* main.sml *) + +(* Declare ffi to be implemented by calling the C function ffi. *) +val ffi = _import "ffi" public: real array * int * int ref * char ref * int -> char; +open Array + +val size = 10 +val a = tabulate (size, fn i => real i) +val ri = ref 0 +val rc = ref #"0" +val n = 17 + +(* Call the C function *) +val c = ffi (a, Array.length a, ri, rc, n) + +(* FFI_INT is declared as public in ffi-import.c *) +val (nGet, nSet) = _symbol "FFI_INT" public: (unit -> int) * (int -> unit); + +val _ = print (concat [Int.toString (nGet ()), "\n"]) + +val _ = + print (if c = #"c" andalso !ri = 45 andalso !rc = c + then "success\n" + else "fail\n") diff --git a/doc/examples/ffi/import2.sml b/doc/examples/ffi/import2.sml new file mode 100644 index 0000000..c72f065 --- /dev/null +++ b/doc/examples/ffi/import2.sml @@ -0,0 +1,78 @@ +(* main.sml *) + +(* Declare ffi to be implemented by calling the C function ffi. *) +val ffi_addr = _address "ffi" public: MLton.Pointer.t; +val ffi_schema = _import * : MLton.Pointer.t -> real array * int * int ref * char ref * int -> char; +open Array + +val size = 10 +val a = tabulate (size, fn i => real i) +val ri = ref 0 +val rc = ref #"0" +val n = 17 + +(* Call the C function *) +val c = ffi_schema ffi_addr (a, Array.length a, ri, rc, n) + +val _ = + print (if c = #"c" andalso !ri = 45 andalso !rc = c + then "success\n" + else "fail\n") + +val n = #1 (_symbol "FFI_INT" public: (unit -> int) * (int -> unit);) () +val _ = print (concat [Int.toString n, "\n"]) +val w = #1 (_symbol "FFI_WORD" public: (unit -> word) * (word -> unit);) () +val _ = print (concat [Word.toString w, "\n"]) +val b = #1 (_symbol "FFI_BOOL" public: (unit -> bool) * (bool -> unit);) () +val _ = print (concat [Bool.toString b, "\n"]) +val r = #1 (_symbol "FFI_REAL" public: (unit -> real) * (real -> unit);) () +val _ = print (concat [Real.toString r, "\n"]) + +signature OPAQUE = + sig + type t + val toString : t -> string + end + +structure OpaqueInt :> OPAQUE = + struct + type t = Int.int + val toString = Int.toString + end +structure OpaqueWord :> OPAQUE = + struct + type t = Word.word + val toString = Word.toString + end +structure OpaqueBool :> OPAQUE = + struct + type t = Bool.bool + val toString = Bool.toString + end +structure OpaqueReal :> OPAQUE = + struct + type t = Real.real + val toString = Real.toString + end + +val (n, _) = _symbol "FFI_INT" public: (unit -> OpaqueInt.t) * (OpaqueInt.t -> unit); +val _ = print (concat [OpaqueInt.toString (n ()), "\n"]) +val (w, _) = _symbol "FFI_WORD" public: (unit -> OpaqueWord.t) * (OpaqueWord.t -> unit); +val _ = print (concat [OpaqueWord.toString (w ()), "\n"]) +val (b, _) = _symbol "FFI_BOOL" public: (unit -> OpaqueBool.t) * (OpaqueBool.t -> unit); +val _ = print (concat [OpaqueBool.toString (b ()), "\n"]) +val (r, _) = _symbol "FFI_REAL" public: (unit -> OpaqueReal.t) * (OpaqueReal.t -> unit); +val _ = print (concat [OpaqueReal.toString (r ()), "\n"]) + +val n_addr = _address "FFI_INT" public: MLton.Pointer.t; +val n = MLton.Pointer.getInt32 (n_addr, 0); +val _ = print (concat [Int.toString n, "\n"]) +val w_addr = _address "FFI_WORD" public: MLton.Pointer.t; +val w = MLton.Pointer.getWord32 (w_addr, 0); +val _ = print (concat [Word.toString w, "\n"]) +val b_addr = _address "FFI_BOOL" public: MLton.Pointer.t; +val b = (MLton.Pointer.getInt32 (n_addr, 0)) <> 0 +val _ = print (concat [Bool.toString b, "\n"]) +val r_addr = _address "FFI_REAL" public: MLton.Pointer.t; +val r = MLton.Pointer.getReal64 (r_addr, 0) +val _ = print (concat [Real.toString r, "\n"]) diff --git a/doc/examples/ffi/test_quot.sml b/doc/examples/ffi/test_quot.sml new file mode 100644 index 0000000..92578e5 --- /dev/null +++ b/doc/examples/ffi/test_quot.sml @@ -0,0 +1,34 @@ +(* By default _import is external *) +val c_quot = _import "c_quot" private pure: Int8.int * Int8.int -> Int8.int; + +(* By default _export is public *) +val sml_quot = _export "sml_quot": (Int8.int * Int8.int -> Int8.int) -> unit; +val _ = sml_quot Int8.quot + +val call_sml_quot = _import "call_sml_quot" public reentrant: unit -> unit; + +val x : Int8.int = ~1 +val y : Int8.int = 10 + +val z = Int8.quot (x, y) +val c_z = c_quot (x, y) + +val bad_z = + let + val x : Int8.int = ~1 + val x : Word8.word = 0wxFF + val x : Int32.int = Word8.toInt x + val y : Int8.int = 10 + val y : Word8.word = 0wx0A + val y : Int32.int = Word8.toInt y + val z : Int32.int = Int32.quot (x, y) + val z = Int8.fromInt z + in + z + end + +val () = + print (concat [" bad_z = ", Int8.toString bad_z, "\n", + " z = ", Int8.toString z, "\n", + " c_z = ", Int8.toString c_z, "\n"]) +val () = call_sml_quot () diff --git a/doc/examples/finalizable/.gitignore b/doc/examples/finalizable/.gitignore new file mode 100644 index 0000000..6f6ae53 --- /dev/null +++ b/doc/examples/finalizable/.gitignore @@ -0,0 +1 @@ +/finalizable diff --git a/doc/examples/finalizable/Makefile b/doc/examples/finalizable/Makefile new file mode 100644 index 0000000..b893924 --- /dev/null +++ b/doc/examples/finalizable/Makefile @@ -0,0 +1,18 @@ +## Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +PATH := ../../../build/bin:$(shell echo $$PATH) + +mlton := mlton -default-ann 'allowFFI true' + +all: + $(mlton) finalizable.sml cons.c + ./finalizable + +.PHONY: clean +clean: + ../../../bin/clean diff --git a/doc/examples/finalizable/cons.c b/doc/examples/finalizable/cons.c new file mode 100644 index 0000000..b10d6e6 --- /dev/null +++ b/doc/examples/finalizable/cons.c @@ -0,0 +1,43 @@ +#include + +typedef unsigned int uint; + +typedef struct Cons { + struct Cons *next; + int value; +} *Cons; + +Cons listCons (int n, Cons c) { + Cons res; + + res = (Cons) malloc (sizeof(*res)); + fprintf (stderr, "0x%08x = listCons (%d)\n", (uint)res, n); + res->next = c; + res->value = n; + return res; +} + +Cons listSing (int n) { + Cons res; + + res = (Cons) malloc (sizeof(*res)); + fprintf (stderr, "0x%08x = listSing (%d)\n", (uint)res, n); + res->next = NULL; + res->value = n; + return res; +} + +void listFree (Cons p) { + fprintf (stderr, "listFree (0x%08x)\n", (uint)p); + free (p); +} + +int listSum (Cons c) { + int res; + + fprintf (stderr, "listSum\n"); + res = 0; + for (; c != NULL; c = c->next) + res += c->value; + return res; +} diff --git a/doc/examples/finalizable/finalizable.sml b/doc/examples/finalizable/finalizable.sml new file mode 100644 index 0000000..5f2deba --- /dev/null +++ b/doc/examples/finalizable/finalizable.sml @@ -0,0 +1,91 @@ +signature CLIST = + sig + type t + + val cons: int * t -> t + val sing: int -> t + val sum: t -> int + end + +functor CList (structure F: MLTON_FINALIZABLE + structure P: MLTON_POINTER + structure Prim: + sig + val cons: int * P.t -> P.t + val free: P.t -> unit + val sing: int -> P.t + val sum: P.t -> int + end): CLIST = + struct + type t = P.t F.t + + fun cons (n: int, l: t) = + F.withValue + (l, fn w' => + let + val c = F.new (Prim.cons (n, w')) + val _ = F.addFinalizer (c, Prim.free) + val _ = F.finalizeBefore (c, l) + in + c + end) + + fun sing n = + let + val c = F.new (Prim.sing n) + val _ = F.addFinalizer (c, Prim.free) + in + c + end + + fun sum c = F.withValue (c, Prim.sum) + end + +functor Test (structure CList: CLIST + structure MLton: sig + structure GC: + sig + val collect: unit -> unit + end + end) = + struct + fun f n = + if n = 1 + then () + else + let + val a = Array.tabulate (n, fn i => i) + val _ = Array.sub (a, 0) + Array.sub (a, 1) + in + f (n - 1) + end + + val l = CList.sing 2 + val l = CList.cons (2,l) + val l = CList.cons (2,l) + val l = CList.cons (2,l) + val l = CList.cons (2,l) + val l = CList.cons (2,l) + val l = CList.cons (2,l) + val _ = MLton.GC.collect () + val _ = f 100 + val _ = print (concat ["listSum(l) = ", + Int.toString (CList.sum l), + "\n"]) + val _ = MLton.GC.collect () + val _ = f 100 + end + +structure CList = + CList (structure F = MLton.Finalizable + structure P = MLton.Pointer + structure Prim = + struct + val cons = _import "listCons": int * P.t -> P.t; + val free = _import "listFree": P.t -> unit; + val sing = _import "listSing": int -> P.t; + val sum = _import "listSum": P.t -> int; + end) + +structure S = Test (structure CList = CList + structure MLton = MLton) diff --git a/doc/examples/profiling/.gitignore b/doc/examples/profiling/.gitignore new file mode 100644 index 0000000..1e8627a --- /dev/null +++ b/doc/examples/profiling/.gitignore @@ -0,0 +1,11 @@ +/mlmon.out + +/list-rev +/list-rev.dot +/list-rev.ps + +/tak + +/fib-tak +/mlmon.fib.out +/mlmon.tak.out diff --git a/doc/examples/profiling/Makefile b/doc/examples/profiling/Makefile new file mode 100644 index 0000000..fc55db8 --- /dev/null +++ b/doc/examples/profiling/Makefile @@ -0,0 +1,59 @@ +## Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # Copyright (C) 1997-2000 NEC Research Institute. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +mlton := mlton +mlprof := mlprof +ALLOC_EX := list-rev +COUNT_EX := tak +MULT_EX := fib-tak +TIME_EX := tak + +PATH := ../../../build/bin:$(shell echo $$PATH) + +.PHONY: all +all: profile-time profile-alloc profile-count profile-stack profile-multiple + +.PHONY: clean +clean: + ../../../bin/clean + +.PHONY: profile-alloc +profile-alloc: + $(mlton) -profile alloc $(ALLOC_EX).sml + ./$(ALLOC_EX) + $(mlprof) -show-line true $(ALLOC_EX) mlmon.out + +.PHONY: profile-count +profile-count: + $(mlton) -profile count $(COUNT_EX).sml + ./$(COUNT_EX) + $(mlprof) -raw true -show-line true $(COUNT_EX) mlmon.out + +.PHONE: profile-multiple +profile-multiple: + $(mlton) -profile time $(MULT_EX).sml + ./$(MULT_EX) + $(mlprof) $(MULT_EX) mlmon.fib.out + $(mlprof) $(MULT_EX) mlmon.tak.out + $(mlprof) $(MULT_EX) mlmon.fib.out mlmon.tak.out mlmon.out + +.PHONY: profile-stack +profile-stack: + $(mlton) -profile alloc -profile-stack true $(ALLOC_EX).sml + ./$(ALLOC_EX) + $(mlprof) -call-graph $(ALLOC_EX).dot -show-line true \ + $(ALLOC_EX) mlmon.out + dot -Tps $(ALLOC_EX).dot >$(ALLOC_EX).ps || true + +.PHONY: profile-time +profile-time: + $(mlton) -profile time $(TIME_EX).sml + ./$(TIME_EX) + $(mlprof) $(TIME_EX) mlmon.out + $(mlprof) -raw true $(TIME_EX) mlmon.out + $(mlprof) -show-line true $(TIME_EX) mlmon.out diff --git a/doc/examples/profiling/fib-tak.sml b/doc/examples/profiling/fib-tak.sml new file mode 100644 index 0000000..19737fe --- /dev/null +++ b/doc/examples/profiling/fib-tak.sml @@ -0,0 +1,38 @@ +structure Profile = MLton.Profile + +val fibData = Profile.Data.malloc () +val takData = Profile.Data.malloc () + +fun wrap (f, d) x = + Profile.withData (d, fn () => f x) + +val rec fib = + fn 0 => 0 + | 1 => 1 + | n => fib (n - 1) + fib (n - 2) +val fib = wrap (fib, fibData) + +fun tak (x,y,z) = + if not (y < x) + then z + else tak (tak (x - 1, y, z), + tak (y - 1, z, x), + tak (z - 1, x, y)) +val tak = wrap (tak, takData) + +val rec f = + fn 0 => () + | n => (fib 38; f (n-1)) +val _ = f 2 + +val rec g = + fn 0 => () + | n => (tak (18,12,6); g (n-1)) +val _ = g 500 + +fun done (data, file) = + (Profile.Data.write (data, file) + ; Profile.Data.free data) + +val _ = done (fibData, "mlmon.fib.out") +val _ = done (takData, "mlmon.tak.out") diff --git a/doc/examples/profiling/list-rev.sml b/doc/examples/profiling/list-rev.sml new file mode 100644 index 0000000..85d48fb --- /dev/null +++ b/doc/examples/profiling/list-rev.sml @@ -0,0 +1,12 @@ +fun append (l1, l2) = + case l1 of + [] => l2 + | x :: l1 => x :: append (l1, l2) + +fun rev l = + case l of + [] => [] + | x :: l => append (rev l, [x]) + +val l = List.tabulate (1000, fn i => i) +val _ = 1 + hd (rev l) diff --git a/doc/examples/profiling/tak.sml b/doc/examples/profiling/tak.sml new file mode 100644 index 0000000..715a2bc --- /dev/null +++ b/doc/examples/profiling/tak.sml @@ -0,0 +1,29 @@ +structure Tak = + struct + fun tak1 (x, y, z) = + let + fun tak2 (x, y, z) = + if y >= x + then z + else + tak1 (tak2 (x - 1, y, z), + tak2 (y - 1, z, x), + tak2 (z - 1, x, y)) + in + if y >= x + then z + else + tak1 (tak2 (x - 1, y, z), + tak2 (y - 1, z, x), + tak2 (z - 1, x, y)) + end + end + +val rec f = + fn 0 => () + | ~1 => print "this branch is not taken\n" + | n => (Tak.tak1 (18, 12, 6) ; f (n-1)) + +val _ = f 5000 + +fun uncalled () = () diff --git a/doc/examples/save-world/.gitignore b/doc/examples/save-world/.gitignore new file mode 100644 index 0000000..435ea30 --- /dev/null +++ b/doc/examples/save-world/.gitignore @@ -0,0 +1,2 @@ +/save-world +/world diff --git a/doc/examples/save-world/Makefile b/doc/examples/save-world/Makefile new file mode 100644 index 0000000..ddc5e7c --- /dev/null +++ b/doc/examples/save-world/Makefile @@ -0,0 +1,27 @@ +## Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh + # Jagannathan, and Stephen Weeks. + # Copyright (C) 1997-2000 NEC Research Institute. + # + # MLton is released under a BSD-style license. + # See the file MLton-LICENSE for details. + ## + +PATH := ../../../build/bin:$(shell echo $$PATH) + +mlton := mlton + +all: test + +.PHONY: test +test: world + ./save-world @MLton load-world world -- + +world: save-world + ./save-world + +save-world: save-world.sml + $(mlton) save-world.sml + +.PHONY: clean +clean: + ../../../bin/clean diff --git a/doc/examples/save-world/save-world.sml b/doc/examples/save-world/save-world.sml new file mode 100644 index 0000000..23e3110 --- /dev/null +++ b/doc/examples/save-world/save-world.sml @@ -0,0 +1,6 @@ +open MLton.World + +val _ = + case save "world" of + Original => print "I am the original\n" + | Clone => print "I am the clone\n" diff --git a/doc/examples/size/size.sml b/doc/examples/size/size.sml new file mode 100644 index 0000000..fab765f --- /dev/null +++ b/doc/examples/size/size.sml @@ -0,0 +1,45 @@ +fun 'a printSize (name: string, value: 'a): unit= + (print "The size of " + ; print name + ; print " is " + ; print (Int.toString (MLton.size value)) + ; print " bytes.\n") + +val l = [1, 2, 3, 4] + +val _ = + ( + printSize ("an int list of length 4", l) + ; printSize ("a string of length 10", "0123456789") + ; printSize ("an int array of length 10", Array.tabulate (10, fn _ => 0)) + ; printSize ("a double array of length 10", + Array.tabulate (10, fn _ => 0.0)) + ; printSize ("an array of length 10 of 2-ples of ints", + Array.tabulate (10, fn i => (i, i + 1))) + ; printSize ("a useless function", fn _ => 13) + ) + +(* This is here so that the list is "useful". + * If it were removed, then the optimizer (remove-unused-constructors) + * would remove l entirely. + *) +val _ = if 10 = foldl (op +) 0 l + then () + else raise Fail "bug" + +local + open MLton.Cont +in + val rc: int option t option ref = ref NONE + val _ = + case callcc (fn k: int option t => (rc := SOME k; throw (k, NONE))) of + NONE => () + | SOME i => print (concat [Int.toString i, "\n"]) +end + +val _ = printSize ("a continuation option ref", rc) + +val _ = + case !rc of + NONE => () + | SOME k => (rc := NONE; MLton.Cont.throw (k, SOME 13)) diff --git a/doc/examples/thread/non-preemptive-threads.sml b/doc/examples/thread/non-preemptive-threads.sml new file mode 100644 index 0000000..033981d --- /dev/null +++ b/doc/examples/thread/non-preemptive-threads.sml @@ -0,0 +1,87 @@ +structure Queue: + sig + type 'a t + + val new: unit -> 'a t + val enque: 'a t * 'a -> unit + val deque: 'a t -> 'a option + end = + struct + datatype 'a t = T of {front: 'a list ref, back: 'a list ref} + + fun new () = T {front = ref [], back = ref []} + + fun enque (T {back, ...}, x) = back := x :: !back + + fun deque (T {front, back}) = + case !front of + [] => (case !back of + [] => NONE + | l => let val l = rev l + in case l of + [] => raise Fail "deque" + | x :: l => (back := []; front := l; SOME x) + end) + | x :: l => (front := l; SOME x) + end + +structure Thread: + sig + val exit: unit -> 'a + val run: unit -> unit + val spawn: (unit -> unit) -> unit + val yield: unit -> unit + end = + struct + open MLton + open Thread + + val topLevel: Thread.Runnable.t option ref = ref NONE + + local + val threads: Thread.Runnable.t Queue.t = Queue.new () + in + fun ready (t: Thread.Runnable.t) : unit = + Queue.enque(threads, t) + fun next () : Thread.Runnable.t = + case Queue.deque threads of + NONE => valOf (!topLevel) + | SOME t => t + end + + fun 'a exit (): 'a = switch (fn _ => next ()) + + fun new (f: unit -> unit): Thread.Runnable.t = + Thread.prepare + (Thread.new (fn () => ((f () handle _ => exit ()) + ; exit ())), + ()) + + fun schedule t = (ready t; next ()) + + fun yield (): unit = switch (fn t => schedule (Thread.prepare (t, ()))) + + val spawn = ready o new + + fun run(): unit = + (switch (fn t => + (topLevel := SOME (Thread.prepare (t, ())) + ; next())) + ; topLevel := NONE) + end + +val rec loop = + fn 0 => () + | n => (print(concat[Int.toString n, "\n"]) + ; Thread.yield() + ; loop(n - 1)) + +val rec loop' = + fn 0 => () + | n => (Thread.spawn (fn () => loop n); loop' (n - 2)) + +val _ = Thread.spawn (fn () => loop' 10) + +val _ = Thread.run () + +val _ = print "success\n" diff --git a/doc/examples/thread/preemptive-threads.sml b/doc/examples/thread/preemptive-threads.sml new file mode 100644 index 0000000..68d3af3 --- /dev/null +++ b/doc/examples/thread/preemptive-threads.sml @@ -0,0 +1,98 @@ +structure Queue: + sig + type 'a t + + val new: unit -> 'a t + val enque: 'a t * 'a -> unit + val deque: 'a t -> 'a option + end = + struct + datatype 'a t = T of {front: 'a list ref, back: 'a list ref} + + fun new () = T {front = ref [], back = ref []} + + fun enque (T {back, ...}, x) = back := x :: !back + + fun deque (T {front, back}) = + case !front of + [] => (case !back of + [] => NONE + | l => let val l = rev l + in case l of + [] => raise Fail "deque" + | x :: l => (back := []; front := l; SOME x) + end) + | x :: l => (front := l; SOME x) + end + +structure Thread: + sig + val exit: unit -> 'a + val run: unit -> unit + val spawn: (unit -> unit) -> unit + val yield: unit -> unit + end = + struct + open Posix.Signal + open MLton + open Itimer Signal Thread + + val topLevel: Thread.Runnable.t option ref = ref NONE + + local + val threads: Thread.Runnable.t Queue.t = Queue.new () + in + fun ready (t: Thread.Runnable.t) : unit = + Queue.enque(threads, t) + fun next () : Thread.Runnable.t = + case Queue.deque threads of + NONE => valOf (!topLevel) + | SOME t => t + end + + fun 'a exit (): 'a = switch (fn _ => next ()) + + fun new (f: unit -> unit): Thread.Runnable.t = + Thread.prepare + (Thread.new (fn () => ((f () handle _ => exit ()) + ; exit ())), + ()) + + fun schedule t = (ready t; next ()) + + fun yield (): unit = switch (fn t => schedule (Thread.prepare (t, ()))) + + val spawn = ready o new + + fun setItimer t = + Itimer.set (Itimer.Real, + {value = t, + interval = t}) + + fun run (): unit = + (switch (fn t => + (topLevel := SOME (Thread.prepare (t, ())) + ; new (fn () => (setHandler (alrm, Handler.handler schedule) + ; setItimer (Time.fromMilliseconds 20))))) + ; setItimer Time.zeroTime + ; ignore alrm + ; topLevel := NONE) + end + +val rec delay = + fn 0 => () + | n => delay (n - 1) + +val rec loop = + fn 0 => () + | n => (delay 500000; loop (n - 1)) + +val rec loop' = + fn 0 => () + | n => (Thread.spawn (fn () => loop n); loop' (n - 1)) + +val _ = Thread.spawn (fn () => loop' 10) + +val _ = Thread.run () + +val _ = print "success\n" diff --git a/doc/guide/.gitignore b/doc/guide/.gitignore new file mode 100644 index 0000000..1b1b1f9 --- /dev/null +++ b/doc/guide/.gitignore @@ -0,0 +1,3 @@ +/localhost/ +/mlton-guide.pdf +/www.mlton.org/ diff --git a/doc/guide/Makefile b/doc/guide/Makefile new file mode 100644 index 0000000..c299e34 --- /dev/null +++ b/doc/guide/Makefile @@ -0,0 +1,195 @@ +GIT := git +MLTON_VERSION := 20180207 + +export LC_ALL = C + +NULL := + +ASCIIDOC := asciidoc +ifneq ($(shell which $(ASCIIDOC) 2> /dev/null),) +ASCIIDOC_CONF_DIR := $(shell $(ASCIIDOC) -v /dev/null 2>&1 | head -n 1 | sed 's|.*reading: \(.*\)/asciidoc.conf|\1|') +else +ASCIIDOC_CONF_DIR := +endif +ASCIIDOC_MLTON_FLAGS := $(shell cat conf/asciidoc-mlton.flags | sed 's|^\#.*||' | sed "s|MLTON_VERSION|$(MLTON_VERSION)|") +ASCIIDOC_MLTON_DEPS := bin/InclGitFile.py conf/asciidoc-mlton.flags $(shell cat conf/asciidoc-mlton.flags | sed -n 's|^.*\(conf/.*\)$$|\1|p') +ASCIIDOC_HTML5_FLAGS := $(ASCIIDOC_MLTON_FLAGS) $(shell cat conf/asciidoc-html5.flags | sed 's|^\#.*||') +ASCIIDOC_HTML5_DEPS := $(ASCIIDOC_MLTON_DEPS) conf/asciidoc-html5.flags $(shell cat conf/asciidoc-html5.flags | sed -n 's|^.*\(conf/.*\)$$|\1|p') +ASCIIDOC_DOCBOOK45_FLAGS := $(ASCIIDOC_MLTON_FLAGS) $(shell cat conf/asciidoc-docbook45.flags | sed 's|^\#.*||') +ASCIIDOC_DOCBOOK45_DEPS := $(ASCIIDOC_MLTON_DEPS) conf/asciidoc-docbook45.flags $(shell cat conf/asciidoc-docbook45.flags | sed -n 's|^.*\(conf/.*\)$$|\1|p') + +DBLATEX := dblatex + +GEN_PAGES := Index mlton-guide +GEN_ATTACHMENTS := $(foreach size,16 32 64 128 256 512 1024,Logo.attachments/mlton-$(size).png Logo.attachments/mlton-$(size).pdf) + +SRC_PAGES := $(filter-out $(GEN_PAGES),$(patsubst ./%.adoc,%,$(shell cd src ; find . -type f -name '*.adoc'))) +SRC_ATTACHMENTS := $(filter-out $(GEN_ATTACHMENTS),$(patsubst ./%,%,$(foreach dir,$(shell cd src ; find . -type d -name '*.attachments'),$(shell cd src ; find $(dir) -type f ! -name '.gitignore' ! -name '.gitattributes')))) + +HTML5_XTRA := asciidoc.css asciidoc.js pygments.css mlton.css mlton-gcse.js index.html +HTML5_XTRA_PAGES := Index + +MLTON_ORG_XTRA := $(HTML5_XTRA) +MLTON_ORG_XTRA_PAGES := $(HTML5_XTRA_PAGES) +MLTON_ORG_XTRA_ATTACHMENTS := $(foreach size,16 32 64 128 256 512 1024,Logo.attachments/mlton-$(size).png) +MLTON_ORG := $(addprefix www.mlton.org/, $(SRC_PAGES) $(SRC_ATTACHMENTS) $(MLTON_ORG_XTRA) $(MLTON_ORG_XTRA_PAGES) $(MLTON_ORG_XTRA_ATTACHMENTS)) +MLTON_ORG_TORM := $(filter-out $(MLTON_ORG),$(shell if [ -d www.mlton.org ]; then find www.mlton.org -type f; fi)) + +LOCALHOST_XTRA := $(filter-out mlton-gcse.js,$(HTML5_XTRA)) +LOCALHOST_XTRA_PAGES := $(HTML5_XTRA_PAGES) +LOCALHOST_XTRA_ATTACHMENTS := $(foreach size,16 32 64 128 256 512 1024,Logo.attachments/mlton-$(size).png) +LOCALHOST := $(addprefix localhost/, $(SRC_PAGES) $(SRC_ATTACHMENTS) $(LOCALHOST_XTRA) $(LOCALHOST_XTRA_PAGES) $(LOCALHOST_XTRA_ATTACHMENTS)) +LOCALHOST_TORM := $(filter-out $(LOCALHOST),$(shell if [ -d localhost ]; then find localhost -type f; fi)) + + +ALL := +ifneq ($(shell which $(ASCIIDOC) 2> /dev/null),) +ifneq ($(shell which pygmentize 2> /dev/null),) +ALL += $(LOCALHOST) localhost-rm +endif +ifneq ($(shell which $(DBLATEX) 2> /dev/null),) +ALL += mlton-guide.pdf +endif +endif + + +all: $(ALL) + + +ifneq ($(shell which gm 2> /dev/null),) +CONVERT := gm convert +else +ifneq ($(shell which convert 2> /dev/null),) +CONVERT := convert +else +CONVERT := no-convert +endif +endif + +%-16.png : %.svg + $(CONVERT) $< -resize 16x16 $@ +%-32.png : %.svg + $(CONVERT) $< -resize 32x32 $@ +%-64.png : %.svg + $(CONVERT) $< -resize 64x64 $@ +%-128.png : %.svg + $(CONVERT) $< -resize 128x128 $@ +%-256.png : %.svg + $(CONVERT) $< -resize 256x256 $@ +%-512.png : %.svg + $(CONVERT) $< -resize 512x512 $@ +%-1024.png : %.svg + $(CONVERT) $< -resize 1024x1024 $@ + +%-16.pdf : %.svg + $(CONVERT) $< -resize 16x16 $@ +%-32.pdf : %.svg + $(CONVERT) $< -resize 32x32 $@ +%-64.pdf : %.svg + $(CONVERT) $< -resize 64x64 $@ +%-128.pdf : %.svg + $(CONVERT) $< -resize 128x128 $@ +%-256.pdf : %.svg + $(CONVERT) $< -resize 256x256 $@ +%-512.pdf : %.svg + $(CONVERT) $< -resize 512x512 $@ +%-1024.pdf : %.svg + $(CONVERT) $< -resize 1024x1024 $@ + + +conf/specialsections.conf : $(ASCIIDOC_CONF_DIR)/lang-en.conf bin/mk-specialsections-conf.sh + ./bin/mk-specialsections-conf.sh $< $@ + +conf/html5-header.conf : $(ASCIIDOC_CONF_DIR)/html5.conf bin/mk-html5-header-conf.sh + ./bin/mk-html5-header-conf.sh $< $@ + +conf/html5-footer.conf : $(ASCIIDOC_CONF_DIR)/html5.conf bin/mk-html5-footer-conf.sh + ./bin/mk-html5-footer-conf.sh $< $@ + + +src/Index.adoc : bin/mk-index.sh $(foreach page,$(SRC_PAGES),src/$(page).adoc) + ./bin/mk-index.sh $(SRC_PAGES) > $@ + +src/mlton-guide.adoc : bin/mk-mlton-guide.sh $(foreach page,$(SRC_PAGES),src/$(page).adoc) + ./bin/mk-mlton-guide.sh $(SRC_PAGES) > $@ + + +$(ASCIIDOC_CONF_DIR)/stylesheets/asciidoc.css: ; +%/asciidoc.css : $(ASCIIDOC_CONF_DIR)/stylesheets/asciidoc.css + mkdir -p $(dir $@) ; cp $< $@ + +$(ASCIIDOC_CONF_DIR)/javascripts/asciidoc.js: ; +%/asciidoc.js : $(ASCIIDOC_CONF_DIR)/javascripts/asciidoc.js + mkdir -p $(dir $@) ; cp $< $@ + +$(ASCIIDOC_CONF_DIR)/stylesheets/pygments.css: ; +%/pygments.css : $(ASCIIDOC_CONF_DIR)/stylesheets/pygments.css + mkdir -p $(dir $@) ; cp $< $@ + +conf/mlton.css: ; +%/mlton.css : conf/mlton.css + mkdir -p $(dir $@) ; cp $< $@ + +conf/mlton-gcse.js: ; +%/mlton-gcse.js : conf/mlton-gcse.js + mkdir -p $(dir $@) ; cp $< $@ + +%/index.html : %/Home + rm -f $@ ; mkdir -p $(dir $@) ; ln -s Home $@ ; touch $@ + + +www.mlton.org/% : src/%.adoc $(ASCIIDOC_HTML5_DEPS) bin/mk-git-attribute-entity-flags.sh + mkdir -p $(dir $@) ; $(ASCIIDOC) $(ASCIIDOC_HTML5_FLAGS) $(shell ./bin/mk-git-attribute-entity-flags.sh $<) -a mlton-guide-host=www.mlton.org -a mlton-guide-page=$(basename $(notdir $<)) -o $@ $< + +www.mlton.org/% : src/% + mkdir -p $(dir $@) ; cp -prf $< $@ + +.PHONY: www.mlton.org-rm +www.mlton.org-rm: $(MLTON_ORG) + @rm -rf $(MLTON_ORG_TORM) + +.PHONY: www.mlton.org +www.mlton.org: $(MLTON_ORG) + +.PHONY: upload_www.mlton.org +upload_www.mlton.org: $(MLTON_ORG) www.mlton.org-rm + rsync -avzP --delete -e ssh www.mlton.org/ fluet,mlton@web.sourceforge.net:htdocs/wiki + + +localhost/% : src/%.adoc $(ASCIIDOC_HTML5_DEPS) + mkdir -p $(dir $@) ; $(ASCIIDOC) $(ASCIIDOC_HTML5_FLAGS) -a mlton-guide-host=localhost -a mlton-guide-page=$(basename $(notdir $<)) -o $@ $< + +localhost/% : src/% + mkdir -p $(dir $@) ; cp -prf $< $@ + +.PHONY: localhost-rm +localhost-rm: $(LOCALHOST) + @rm -rf $(LOCALHOST_TORM) + +.PHONY: localhost +localhost: $(LOCALHOST) localhost-rm + +src/mlton-guide.xml : src/mlton-guide.adoc conf/asciidoc-docbook45.flags $(ASCIIDOC_DOCBOOK45_DEPS) + mkdir -p $(dir $@) ; $(ASCIIDOC) $(ASCIIDOC_DOCBOOK45_FLAGS) -o $@ $< + @true || xmllint --nonet --noout --valid $@ || true +mlton-guide.pdf : src/mlton-guide.xml src/Logo.attachments/mlton-128.pdf conf/mlton-dblatex.xsl conf/mlton-dblatex.sty + $(DBLATEX) -t pdf -p conf/mlton-dblatex.xsl -s conf/mlton-dblatex.sty -o $@ $< + + +.PHONY: check-git-links +check-git-links: + @./bin/check-git-links.sh $(SRC_PAGES) + +.PHONY: clean +clean: + ../../bin/clean + +.PHONY: vars +vars: + @echo ASCIIDOC_CONF_DIR=$(ASCIIDOC_CONF_DIR) + @echo ASCIIDOC_HTML5_FLAGS=$(ASCIIDOC_HTML5_FLAGS) + @echo ASCIIDOC_HTML5_DEPS=$(ASCIIDOC_HTML5_DEPS) + @echo GEN_PAGES=$(GEN_PAGES) + @echo GEN_ATTACHMENTS=$(GEN_ATTACHMENTS) + @echo SRC_PAGES=$(SRC_PAGES) + @echo SRC_ATTACHMENTS=$(SRC_ATTACHMENTS) diff --git a/doc/guide/bin/InclGitFile.py b/doc/guide/bin/InclGitFile.py new file mode 100755 index 0000000..5674361 --- /dev/null +++ b/doc/guide/bin/InclGitFile.py @@ -0,0 +1,34 @@ +#!/usr/bin/env python + +import sys +import urllib +import re + +i = 1 +repo = sys.argv[i] +i += 1 +branch = sys.argv[i] +i += 1 +src = sys.argv[i] +i += 1 +url = 'https://raw.github.com/MLton/' + repo + '/' + branch + '/' + src +response = urllib.urlopen(url) +buff = response.readlines() + +if len(sys.argv) > i: + newbuff = [] + while len(sys.argv) > i: + lines = sys.argv[i] + match = re.compile(r"^\s*(?P-?[0-9]+)?:(?P-?[0-9]+)?\s*$").match(lines) + start = match.group('start') + if start: + start = int(start) + end = match.group('end') + if end: + end = int(end) + newbuff.extend(buff[start:end]) + i += 1 + buff = newbuff + +sys.stdout.writelines(buff) +sys.stdout.flush() diff --git a/doc/guide/bin/check-git-links.sh b/doc/guide/bin/check-git-links.sh new file mode 100755 index 0000000..9ad8e45 --- /dev/null +++ b/doc/guide/bin/check-git-links.sh @@ -0,0 +1,36 @@ +#!/bin/sh + +dir=$(dirname "$0") +root=$(cd "$dir/../../.." && pwd) + +pages=$(echo $@ | sort -f) + +for page in ${pages}; do + for vgd in $(cat src/${page}.adoc | sed -E -n 's|.*().*|\1|p'); do + rev=$(echo "$vgd" | sed -E -n 's||\1|p') + path=$(echo "$vgd" | sed -E -n 's||\2|p') + if (cd ${root}; git ls-tree ${rev} ${path} | grep -E -q '^[0-9]+[[:space:]]tree[[:space:]][0-9a-f]+[[:space:]]'${path}'$'); then + : + else + echo "*** ${page}: ${vgd}" + fi + done + for vgf in $(cat src/${page}.adoc | sed -E -n 's|.*().*|\1|p'); do + rev=$(echo "$vgf" | sed -E -n 's||\1|p') + path=$(echo "$vgf" | sed -E -n 's||\2|p') + if (cd ${root}; git ls-tree ${rev} ${path} | grep -E -q '^[0-9]+[[:space:]]blob[[:space:]][0-9a-f]+[[:space:]]'${path}'$'); then + : + else + echo "*** ${page}: ${vgf}" + fi + done + for rgf in $(cat src/${page}.adoc | sed -E -n 's|.*().*|\1|p'); do + rev=$(echo "$rgf" | sed -E -n 's||\1|p') + path=$(echo "$rgf" | sed -E -n 's||\2|p') + if (cd ${root}; git ls-tree ${rev} ${path} | grep -E -q '^[0-9]+[[:space:]]blob[[:space:]][0-9a-f]+[[:space:]]'${path}'$'); then + : + else + echo "*** ${page}: ${rgf}" + fi + done +done diff --git a/doc/guide/bin/mk-git-attribute-entity-flags.sh b/doc/guide/bin/mk-git-attribute-entity-flags.sh new file mode 100755 index 0000000..331b25f --- /dev/null +++ b/doc/guide/bin/mk-git-attribute-entity-flags.sh @@ -0,0 +1,5 @@ +#!/bin/sh + +if [ -n "$(which git)" ]; then + git log -n 1 --format="-a git-commit-hash='%H' -a git-author-date='%ad' -a git-author-email='%ae' -a git-author-name='%an'" "$1" 2>/dev/null +fi diff --git a/doc/guide/bin/mk-html5-footer-conf.sh b/doc/guide/bin/mk-html5-footer-conf.sh new file mode 100755 index 0000000..093d5ac --- /dev/null +++ b/doc/guide/bin/mk-html5-footer-conf.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +prefix="$2" +csplit -f ${prefix} -n 2 -s $1 '%\[footer\]%' '/