Segmentation fault when trying to use mllex and mlyacc, sml sourc
e
Roland Olsson
rolsson@cs.chalmers.se
Tue, 14 Dec 1999 04:49:03 -0800
This message is in MIME format. Since your mail reader does not understand
this format, some or all of this message may not be legible.
------_=_NextPart_000_01BF4636.F6376BCE
Content-Type: text/plain;
charset="windows-1252"
------_=_NextPart_000_01BF4636.F6376BCE
Content-Type: TEXT/PLAIN;
name="main.sml"
Content-Transfer-Encoding: quoted-printable
Content-Disposition: attachment;
filename="main.sml"
Content-Description: SML source code
Content-ID: <Pine.SOL.4.10.9912141349030.24367@muppet1.cs.chalmers.se>
structure Word31 =3D Word structure Int31 =3D Int
(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi=20
*
* $Log: base.sig, v $
* Revision 1.1.1.1 1997/01/14 01:38:04 george
* Version 109.24
*
* Revision 1.1.1.1 1996/01/31 16:01:42 george
* Version 109
*=20
*)
(* 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 =3D
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 =3D
sig
datatype ('a, 'b) pairlist =3D EMPTY | PAIR of 'a * 'b * ('a, =
'b) pairlist
datatype state =3D STATE of int
datatype term =3D T of int
datatype nonterm =3D NT of int
datatype action =3D SHIFT of state
| REDUCE of int
| ACCEPT
| ERROR
type table
=09
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.
=20
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 =3D
sig
structure LrTable: LR_TABLE
datatype ('a, 'b) token =3D 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 =3D
sig
structure Stream: STREAM
structure LrTable: LR_TABLE
structure Token: TOKEN
sharing LrTable =3D 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 *=20
'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 =3D
sig
structure UserDeclarations :
sig
type ('a, 'b) token
type pos
type svalue
end
val makeLexer: (int -> string) -> unit ->=20
(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 =3D
sig
structure UserDeclarations :
sig
type ('a, 'b) token
type pos
type svalue
type arg
end
val makeLexer: (int -> string) -> UserDeclarations.arg -> unit ->=20
(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. =20
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 =3D
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
=20
(* 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 =3D 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:=20
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=20
SML-Yacc will match.
*)
signature PARSER =3D
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
=09
(* 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 =3D=20
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 Andrew W. Appel, David R. Tarditi=20
*
* $Log: lrtable.sml, v $
* Revision 1.1.1.1 1997/01/14 01:38:04 george
* Version 109.24
*
* Revision 1.1.1.1 1996/01/31 16:01:42 george
* Version 109
*=20
*)
structure LrTable: LR_TABLE =3D=20
struct
open Array List
infix 9 sub
datatype ('a, 'b) pairlist =3D EMPTY
| PAIR of 'a * 'b * ('a, 'b) pairlist
datatype term =3D T of int
datatype nonterm =3D NT of int
datatype state =3D STATE of int
datatype action =3D SHIFT of state
| REDUCE of int (* rulenum from grammar *)
| ACCEPT
| ERROR
exception Goto of state * nonterm
type table =3D {states: int, rules: int, initialState: state,
action: ((term, action) pairlist * action) array,
goto: (nonterm, state) pairlist array}
val numStates =3D fn ({states, ...}: table) =3D> states
val numRules =3D fn ({rules, ...}: table) =3D> rules
val describeActions =3D
fn ({action, ...}: table) =3D>=20
fn (STATE s) =3D> action sub s
val describeGoto =3D
fn ({goto, ...}: table) =3D>
fn (STATE s) =3D> goto sub s
fun findTerm (T term, row, default) =3D
let fun find (PAIR (T key, data, r)) =3D
if key < term then find r
else if key=3Dterm then data
else default
| find EMPTY =3D default
in find row
end
fun findNonterm (NT nt, row) =3D
let fun find (PAIR (NT key, data, r)) =3D
if key < nt then find r
else if key=3Dnt then SOME data
else NONE
| find EMPTY =3D NONE
in find row
end
val action =3D fn ({action, ...}: table) =3D>
fn (STATE state, term) =3D>
let val (row, default) =3D action sub state
in findTerm(term, row, default)
end
val goto =3D fn ({goto, ...}: table) =3D>
fn (a as (STATE state,nonterm)) =3D>
case findNonterm(nonterm, goto sub state)
of SOME state =3D> state
| NONE =3D> raise (Goto a)
val initialState =3D fn ({initialState, ...}: table) =3D> initialState
val mkLrTable =3D fn {actions, gotos, initialState,numStates,numRules} =
=3D>
({action=3Dactions, goto=3Dgotos,
states=3DnumStates,
rules=3DnumRules,
initialState=3DinitialState}: table)
end;
(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi=20
*
* $Log: stream.sml, v $
* Revision 1.2 1997/08/26 19:18:55 jhr
* Replaced used of "abstraction" with ":>".
*
# Revision 1.1.1.1 1997/01/14 01:38:04 george
# Version 109.24
#
* Revision 1.1.1.1 1996/01/31 16:01:43 george
* Version 109
*=20
*)
(* Stream: a structure implementing a lazy stream. The signature =
STREAM
is found in base.sig *)
structure Stream :> STREAM =3D
struct
datatype 'a str =3D EVAL of 'a * 'a str ref | UNEVAL of (unit->'a)
type 'a stream =3D 'a str ref
fun get(ref(EVAL t)) =3D t
| get(s as ref(UNEVAL f)) =3D=20
let val t =3D (f(), ref(UNEVAL f)) in s :=3D EVAL t; t end
fun streamify f =3D ref(UNEVAL f)
fun cons(a, s) =3D ref(EVAL(a, s))
end;
(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi=20
*
* $Log: parser2.sml, v $
* Revision 1.2 1997/08/26 19:18:54 jhr
* Replaced used of "abstraction" with ":>".
*
# Revision 1.1.1.1 1997/01/14 01:38:04 george
# Version 109.24
#
* 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
*=20
*)
(* 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. =20
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:
----------------
=09
* 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=20
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: =20
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 =3D=20
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 =3D
*)
structure LrParser :> LR_PARSER =3D
struct
structure LrTable =3D LrTable
structure Stream =3D Stream
structure Token: TOKEN =3D
struct
structure LrTable =3D LrTable
datatype ('a, 'b) token =3D TOKEN of LrTable.term * ('a * 'b * 'b)
val sameToken =3D fn (TOKEN(t, _), TOKEN(t', _)) =3D> t=3Dt'
end
open LrTable
open Token
val DEBUG1 =3D false
val DEBUG2 =3D false
exception ParseError
exception ParseImpossible of int
structure Fifo :> FIFO =3D
struct
type 'a queue =3D ('a list * 'a list)
val empty =3D (nil,nil)
exception Empty
fun get(a :: x, y) =3D (a, (x, y))
| get(nil, nil) =3D raise Empty
| get(nil, y) =3D get(rev y, nil)
fun put(a, (x, y)) =3D (x, a :: y)
end
type ('a, 'b) elem =3D (state * ('a * 'b * 'b))
type ('a, 'b) stack =3D ('a, 'b) elem list
type ('a, 'b) lexv =3D ('a, 'b) token
type ('a, 'b) lexpair =3D ('a, 'b) lexv * (('a, 'b) lexv =
Stream.stream)
type ('a, 'b) distanceParse =3D
('a, 'b) lexpair *
('a, 'b) stack *=20
(('a, 'b) stack * ('a, 'b) lexpair) Fifo.queue *
int ->
('a, 'b) lexpair *
('a, 'b) stack *=20
(('a, 'b) stack * ('a, 'b) lexpair) Fifo.queue *
int *
action option
type ('a, 'b) ecRecord =3D
{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=20
val print =3D fn s =3D> TextIO.output(TextIO.stdOut, s)
val println =3D fn s =3D> (print s; print "\n")
val showState =3D fn (STATE s) =3D> "STATE " ^ (Int.toString s)
in
fun printStack(stack: ('a, 'b) stack, n: int) =3D
case stack
of (state, _) :: rest =3D>
(print("\t" ^ Int.toString n ^ ": ");
println(showState state);
printStack(rest, n+1))
| nil =3D> ()
=20
fun prAction showTerminal
(stack as (state, _) :: _, next as (TOKEN (term, _), _), action) =3D
(println "Parse: state stack:";
printStack(stack, 0);
print(" state=3D"
^ showState state=09
^ " next=3D"
^ showTerminal term
^ " action=3D"
);
case action
of SHIFT state =3D> println ("SHIFT " ^ (showState =
state))
| REDUCE i =3D> println ("REDUCE " ^ (Int.toString i))
| ERROR =3D> println "ERROR"
| ACCEPT =3D> println "ACCEPT")
| prAction _ (_, _, action) =3D ()
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 *)
=09
val ssParse =3D
fn (table, showTerminal, saction, fixError, arg) =3D>
let val prAction =3D prAction showTerminal
val action =3D LrTable.action table
val goto =3D LrTable.goto table
fun parseStep(args as
(lexPair as (TOKEN (terminal, value as (_, leftPos, _)),
lexer
),
stack as (state, _) :: _,
queue)) =3D
let val nextAction =3D action (state, terminal)
val _ =3D if DEBUG1 then prAction(stack, lexPair,nextAction)
else ()
in case nextAction
of SHIFT s =3D>
let val newStack =3D (s, value) :: stack
val newLexPair =3D Stream.get lexer
val (_,newQueue) =3DFifo.get(Fifo.put((newStack,newLexPair),
queue))
in parseStep(newLexPair, (s, value) :: stack,newQueue)
end
| REDUCE i =3D>
(case saction(i, leftPos, stack, arg)
of (nonterm, value, stack as (state, _) :: _) =3D>
parseStep(lexPair, (goto(state,nonterm), value) :: stack,
queue)
| _ =3D> raise (ParseImpossible 197))
| ERROR =3D> parseStep(fixError args)
| ACCEPT =3D>=20
(case stack
of (_, (topvalue, _, _)) :: _ =3D>
let val (token, restLexer) =3D lexPair
in (topvalue, Stream.cons(token, restLexer))
end
| _ =3D> raise (ParseImpossible 202))
end
| parseStep _ =3D 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 =3D
fn (table, showTerminal, saction, arg) =3D>
let val prAction =3D prAction showTerminal
val action =3D LrTable.action table
val goto =3D LrTable.goto table
fun parseStep(lexPair, stack, queue, 0) =3D (lexPair, stack, =
queue, 0, NONE)
| parseStep(lexPair as (TOKEN (terminal, value as (_, leftPos, =
_)),
lexer
),
stack as (state, _) :: _,
queue, distance) =3D
let val nextAction =3D action(state, terminal)
val _ =3D if DEBUG1 then prAction(stack, lexPair,nextAction)
else ()
in case nextAction
of SHIFT s =3D>
let val newStack =3D (s, value) :: stack
val newLexPair =3D Stream.get lexer
in parseStep(newLexPair, (s, value) :: stack,
Fifo.put((newStack,newLexPair), queue), distance-1)
end
| REDUCE i =3D>
(case saction(i, leftPos, stack, arg)
of (nonterm, value, stack as (state, _) :: _) =3D>
parseStep(lexPair, (goto(state,nonterm), value) :: stack,
queue, distance)
| _ =3D> raise (ParseImpossible 240))
| ERROR =3D> (lexPair, stack, queue, distance, SOME nextAction)
| ACCEPT =3D> (lexPair, stack, queue, distance, SOME nextAction)
end
| parseStep _ =3D raise (ParseImpossible 242)
in parseStep: ('a, 'b) distanceParse=20
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)=20
(lexv as (TOKEN (term, value as (_, leftPos, _)), _), =
stack, queue) =3D
let val _ =3D if DEBUG2 then
error("syntax error found at " ^ (showTerminal term),
leftPos, leftPos)
else ()
fun tokAt(t, p) =3D TOKEN(t, (errtermvalue t, p, p))
val minDelta =3D 3
(* pull all the state * lexv elements from the queue *)
val stateList =3D=20
let fun f q =3D let val (elem,newQueue) =3D Fifo.get q
in elem :: (f newQueue)
end handle Fifo.Empty =3D> nil
in f queue
end
(* now number elements of stateList, giving distance from
error token *)
val (_, numStateList) =3D
List.foldr (fn (a, (num, r)) =3D> (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 =3D oper to be applied
pos =3D the # of the element in stateList that would be altered.
distance =3D the number of tokens beyond the error token which the
change allows us to parse.
new =3D new terminal * value pair at that point
orig =3D original terminal * value pair at the point being changed.
*)
datatype ('a, 'b) change =3D CHANGE of
{pos: int, distance: int, leftPos: 'b, rightPos: 'b,
new: ('a, 'b) lexv list, orig: ('a, 'b) lexv list}
val showTerms =3D concat o map (fn TOKEN(t, _) =3D> " " ^ =
showTerminal t)
val printChange =3D fn c =3D>
let val CHANGE {distance,new, orig, pos, ...} =3D c
in (print ("{distance=3D " ^ (Int.toString distance));
print (", orig =3D"); print(showTerms orig);
print (",new =3D"); print(showTerms new);
print (", pos=3D " ^ (Int.toString pos));
print "}\n")
end
val printChangeList =3D 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) =3D
case distanceParse(lexPair, stack, Fifo.empty, =
queuePos+maxAdvance+1)
of (_, _, _, distance, SOME ACCEPT) =3D>=20
if maxAdvance-distance-1 >=3D 0=20
then maxAdvance=20
else maxAdvance-distance-1
| (_, _, _, distance, _) =3D> maxAdvance - distance - 1
(* catList: concatenate results of scanning list *)
fun catList l f =3D List.foldr (fn(a, r)=3D> f a @ r) [] l
fun keywordsDelta new =3D if List.exists (fn(TOKEN(t, =
_))=3D>is_keyword t) new
then minDelta else 0
fun tryChange{lex, stack, pos, leftPos, rightPos, orig,new} =3D
let val lex' =3D List.foldr (fn (t', p)=3D>(t', Stream.cons p)) =
lex new
val distance =3D parse(lex', stack, pos+length new-length orig)
in if distance >=3D minAdvance + keywordsDelta new=20
then [CHANGE{pos=3Dpos, leftPos=3DleftPos, rightPos=3DrightPos,
distance=3Ddistance, orig=3Dorig,new=3Dnew}]=20
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) =3D
let fun del(0, accum, left, right, lexPair) =3D
tryChange{lex=3DlexPair, stack=3Dstack,
pos=3DqPos, leftPos=3Dleft, rightPos=3Dright,
orig=3Drev accum, new=3D[]}
| del(n, accum, left, right, (tok as TOKEN(term, (_, _, r)), =
lexer)) =3D
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) =3D
catList terms (fn t =3D>
tryChange{lex=3DlexPair, stack=3Dstack,
pos=3DqueuePos, orig=3D[],new=3D[tokAt(t, l)],
leftPos=3Dl, rightPos=3Dl})
=20
(* 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) =3D
if noShift term then []
else
catList terms (fn t =3D>
tryChange{lex=3DStream.get lexer, stack=3Dstack,
pos=3DqueuePos,
leftPos=3Dl, rightPos=3Dr, orig=3D[orig],
new=3D[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',=20
lp is what remains of the stream after deletion=20
*)
fun do_delete(nil, lp as (TOKEN(_, (_, l, _)), _)) =3D =
SOME(nil, l, l, lp)
| do_delete([t], (tok as TOKEN(t', (_, l, r)), lp')) =3D
if t=3Dt'
then SOME([tok], l, r, Stream.get lp')
else NONE
| do_delete(t :: rest, (tok as TOKEN(t', (_, l, r)), lp')) =
=3D
if t=3Dt'
then case do_delete(rest, Stream.get lp')
of SOME(deleted, l', r', lp'') =3D>
SOME(tok :: deleted, l, r', lp'')
| NONE =3D> NONE
else NONE
=20
fun tryPreferred((stack, lexPair), queuePos) =3D
catList preferred_change (fn (delete, insert) =3D>
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) =3D>=20
tryChange{lex=3Dlp, stack=3Dstack, pos=3DqueuePos,
leftPos=3Dl, rightPos=3Dr, orig=3Ddeleted,
new=3Dmap (fn t=3D>(tokAt(t, r))) insert}
| NONE =3D> [])
val changes =3D catList numStateList tryPreferred @
catList numStateList tryInsert @
catList numStateList trySubst @
catList numStateList (tryDelete 1) @
catList numStateList (tryDelete 2) @
catList numStateList (tryDelete 3)
val findMaxDist =3D fn l =3D>=20
foldr (fn (CHANGE {distance, ...}, high) =3D> Int.max(distance, =
high)) 0 l
(* maxDist: max distance past error taken that we could parse *)
val maxDist =3D findMaxDist changes
(* remove changes which did not parse maxDist tokens past the error =
token *)
val changes =3D catList changes=20
(fn(c as CHANGE{distance, ...}) =3D>=20
if distance=3DmaxDist then [c] else [])
in case changes=20
of (l as change :: _) =3D>
let fun print_msg (CHANGE {new, orig, leftPos, rightPos, ...}) =
=3D
let val s =3D=20
case (orig,new)
of (_ :: _, []) =3D> "deleting " ^ (showTerms orig)
| ([], _ :: _) =3D> "inserting " ^ (showTerms new)
| _ =3D> "replacing " ^ (showTerms orig) ^
" with " ^ (showTerms new)
in error ("syntax error: " ^ s, leftPos, rightPos)
end
=20
val _ =3D=20
(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 =3D a b c d e
findNth 0 =3D (e, a b c d)
findNth 1 =3D (d, a b c)
*)
val findNth =3D fn n =3D>
let fun f (h :: t, 0) =3D (h, rev t)
| f (h :: t,n) =3D f(t,n-1)
| f (nil, _) =3D let exception FindNth
in raise FindNth
end
in f (rev stateList,n)
end
=09
val CHANGE {pos, orig,new, ...} =3D change
val (last, queueFront) =3D findNth pos
val (stack, lexPair) =3D last
val lp1 =3D foldl(fn (_, (_, r)) =3D> Stream.get r) lexPair orig
val lp2 =3D foldr(fn(t, r)=3D>(t, Stream.cons r)) lp1 new
val restQueue =3D=20
Fifo.put((stack, lp2),
foldl Fifo.put Fifo.empty queueFront)
val (lexPair, stack, queue, _, _) =3D
distanceParse(lp2, stack, restQueue, pos)
in (lexPair, stack, queue)
end
| nil =3D> (error("syntax error found at " ^ (showTerminal term),
leftPos, leftPos); raise ParseError)
end
val parse =3D fn {arg, table, lexer, saction, void, lookahead,
ec=3Dec as {showTerminal, ...}: ('a, 'b) ecRecord} =3D>
let val distance =3D 15 (* defer distance tokens *)
val minAdvance =3D 1 (* must parse at least 1 token past error *)
val maxAdvance =3D Int.max(lookahead, 0)(* max distance for parse =
check *)
val lexPair =3D Stream.get lexer
val (TOKEN (_, (_, leftPos, _)), _) =3D lexPair
val startStack =3D [(initialState table, (void, leftPos, =
leftPos))]
val startQueue =3D Fifo.put((startStack, lexPair), Fifo.empty)
val distanceParse =3D distanceParse(table, showTerminal, saction, =
arg)
val fixError =3D mkFixError(ec, distanceParse, minAdvance, =
maxAdvance)
val ssParse =3D ssParse(table, showTerminal, saction, fixError, =
arg)
fun loop (lexPair, stack, queue, _, SOME ACCEPT) =3D
ssParse(lexPair, stack, queue)
| loop (lexPair, stack, queue, 0, _) =3D ssParse(lexPair, stack, =
queue)
| loop (lexPair, stack, queue, distance, SOME ERROR) =3D
let val (lexPair, stack, queue) =3D fixError(lexPair, stack, queue)
in loop (distanceParse(lexPair, stack, queue, distance))
end
| loop _ =3D 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 =3D ParserGen(structure LrTable=3DLrTable
structure Stream=3DStream);
*)
(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi=20
*
* $Log: join.sml, v $
* Revision 1.1.1.1 1997/01/14 01:38:04 george
* Version 109.24
*
* Revision 1.1.1.1 1996/01/31 16:01:42 george
* Version 109
*=20
*)
(* 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 =3D LrParser.LrTable
sharing ParserData.Token =3D LrParser.Token
sharing type Lex.UserDeclarations.svalue =3D ParserData.svalue
sharing type Lex.UserDeclarations.pos =3D ParserData.pos
sharing type Lex.UserDeclarations.token =3D =
ParserData.Token.token)
: PARSER =3D
struct
structure Token =3D ParserData.Token
structure Stream =3D LrParser.Stream
=20
exception ParseError =3D LrParser.ParseError
type arg =3D ParserData.arg
type pos =3D ParserData.pos
type result =3D ParserData.result
type svalue =3D ParserData.svalue
val makeLexer =3D LrParser.Stream.streamify o Lex.makeLexer
val parse =3D fn (lookahead, lexer, error, arg) =3D>
(fn (a, b) =3D> (ParserData.Actions.extract a, b))
(LrParser.parse {table =3D ParserData.table,
lexer=3Dlexer,
lookahead=3Dlookahead,
saction =3D ParserData.Actions.actions,
arg=3Darg,
void=3D ParserData.Actions.void,
ec =3D {is_keyword =3D ParserData.EC.is_keyword,
noShift =3D ParserData.EC.noShift,
preferred_change =3D ParserData.EC.preferred_change,
errtermvalue =3D ParserData.EC.errtermvalue,
error=3Derror,
showTerminal =3D ParserData.EC.showTerminal,
terms =3D ParserData.EC.terms}}
)
val sameToken =3D Token.sameToken
end
(* functor JoinWithArg creates a variant of the parser structure =
produced=20
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 =3D LrParser.LrTable
sharing ParserData.Token =3D LrParser.Token
sharing type Lex.UserDeclarations.svalue =3D ParserData.svalue
sharing type Lex.UserDeclarations.pos =3D ParserData.pos
sharing type Lex.UserDeclarations.token =3D =
ParserData.Token.token)
: ARG_PARSER =3D
struct
structure Token =3D ParserData.Token
structure Stream =3D LrParser.Stream
exception ParseError =3D LrParser.ParseError
type arg =3D ParserData.arg
type lexarg =3D Lex.UserDeclarations.arg
type pos =3D ParserData.pos
type result =3D ParserData.result
type svalue =3D ParserData.svalue
val makeLexer =3D fn s =3D> fn arg =3D>
LrParser.Stream.streamify (Lex.makeLexer s arg)
val parse =3D fn (lookahead, lexer, error, arg) =3D>
(fn (a, b) =3D> (ParserData.Actions.extract a, b))
(LrParser.parse {table =3D ParserData.table,
lexer=3Dlexer,
lookahead=3Dlookahead,
saction =3D ParserData.Actions.actions,
arg=3Darg,
void=3D ParserData.Actions.void,
ec =3D {is_keyword =3D ParserData.EC.is_keyword,
noShift =3D ParserData.EC.noShift,
preferred_change =3D ParserData.EC.preferred_change,
errtermvalue =3D ParserData.EC.errtermvalue,
error=3Derror,
showTerminal =3D ParserData.EC.showTerminal,
terms =3D ParserData.EC.terms}}
)
val sameToken =3D Token.sameToken
end;
(* hash-string.sml
*
* COPYRIGHT (c) 1992 by AT&T Bell Laboratories
*)
structure HashString : sig
val hashString : string -> word
end =3D struct
fun charToWord c =3D Word.fromInt(Char.ord c)
(* A function to hash a character. The computation is:
*
* h =3D 33 * h + 720 + c
*)
fun hashChar (c, h) =3D Word.<<(h, 0w5) + h + 0w720 + (charToWord =
c)
fun hashString s =3D CharVector.foldl hashChar 0w0 s
=20
end (* HashString *)
(* lib-base-sig.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file =
for details.
*)
signature LIB_BASE =3D
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 *)
(* lib-base.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file =
for details.
*)
structure LibBase : LIB_BASE =3D
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} =3D
raise (Fail(concat[module, ".", func, ": ", msg]))
val version =3D {
date =3D "June 1, 1996",=20
system =3D "SML/NJ Library",
version_id =3D [1, 0]
}
fun f ([], l) =3D l
| f ([x : int], l) =3D (Int.toString x)::l
| f (x::r, l) =3D (Int.toString x) :: "." :: f(r, l)
val banner =3D concat (
#system version :: ", Version " ::
f (#version_id version, [", ", #date version]))
end (* LibBase *)
(* random-sig.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file =
for details.
*)
signature RANDOM =3D
sig
type rand
(* the internal state of a random number generator *)
val rand : (int * int) -> rand
(* create rand from initial seed *)
val toString : rand -> string
val fromString : string -> rand
(* convert state to and from string
* fromString raises Fail if its argument
* does not have the proper form.
*)
val randInt : rand -> int
(* generate ints uniformly in [minInt,maxInt] *)
val randNat : rand -> int
(* generate ints uniformly in [0,maxInt] *)
val randReal : rand -> real
(* generate reals uniformly in [0.0,1.0) *)
val randRange : (int * int) -> rand -> int
(* randRange (lo,hi) generates integers uniformly [lo,hi].
* Raises Fail if hi < lo.
*)
end; (* RANDOM *)
(* random.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file =
for details.
*
* This package implements a random number generator using a =
subtract-with-borrow
* (SWB) generator as described in Marsaglia and Zaman, "A New Class of =
Random Number
* Generators," Ann. Applied Prob. 1(3), 1991, pp. 462-480.
*=20
* The SWB generator is a 31-bit generator with lags 48 and 8. It has =
period=20
* (2^1487 - 2^247)/105 or about 10^445. In general, these generators =
are
* excellent. However, they act locally like a lagged Fibonacci =
generator
* and thus have troubles with the birthday test. Thus, we combine this =
SWB
* generator with the linear congruential generator =
(48271*a)mod(2^31-1).
*
* Although the interface is fairly abstract, the implementation uses=20
* 31-bit ML words. At some point, it might be good to use 32-bit =
words.
*)
structure Random : RANDOM =3D
struct
structure A =3D Array
structure LW =3D LargeWord
structure W8A =3D Word8Array
structure W8V =3D Word8Vector
structure P =3D Pack32Big
val << =3D Word31.<<
val >> =3D Word31.>>
val & =3D Word31.andb
val ++ =3D Word31.orb
val xorb =3D Word31.xorb
infix << >> & ++
val nbits =3D 31 (* bits per =
word *)
val maxWord : Word31.word =3D 0wx7FFFFFFF (* largest =
word *)
val bit30 : Word31.word =3D 0wx40000000
val lo30 : Word31.word =3D 0wx3FFFFFFF
val N =3D 48
val lag =3D 8
val offset =3D N-lag
fun error (f,msg) =3D LibBase.failure {module=3D"Random",func=3Df, =
msg=3Dmsg}
val two2neg30 =3D 1.0/((real 0x8000)*(real 0x8000)) (* 2^~30 *)
fun minus(x,y,false) =3D (x - y, y > x)
| minus(x,y,true) =3D (x - y - 0w1, y >=3D x)
datatype rand =3D RND of {
vals : Word31.word A.array,(* seed array *)
borrow : bool ref, (* last borrow *)
congx : Word31.word ref, (* congruential seed *)
index : int ref (* index of next available value =
in vals *)
}
(* We represent state as a string, starting with an initial
* word acting as an magic cookie (with bit 0 determining the
* value of borrow), followed by a word containing index and a =
word
* containing congx, followed by the seed array.
*)
val numWords =3D 3 + N
val magic : LW.word =3D 0wx72646e64
fun toString (RND{vals, borrow, congx, index}) =3D let
val arr =3D W8A.array (4*numWords, 0w0)
val word0 =3D if !borrow then LW.orb (magic, 0w1) else magic
fun fill (src,dst) =3D
if src =3D N then ()
else (
P.update (arr, dst, Word31.toLargeWord (A.sub (vals, =
src)));
fill (src+1,dst+1)
)
in
P.update (arr, 0, word0);
P.update (arr, 1, LW.fromInt (!index));
P.update (arr, 2, Word31.toLargeWord (!congx));
fill (0,3);
Byte.bytesToString (W8A.extract (arr, 0, NONE))
end
fun fromString s =3D let
val bytes =3D Byte.stringToBytes s
val _ =3D if W8V.length bytes =3D 4 * numWords then ()
else error ("fromString","invalid state string")
val word0 =3D P.subVec (bytes, 0)
val _ =3D if LW.andb(word0, 0wxFFFFFFFE) =3D magic then ()
else error ("fromString","invalid state string")
fun subVec i =3D P.subVec (bytes, i)
val borrow =3D ref (LW.andb(word0,0w1) =3D 0w1)
val index =3D ref (LW.toInt (subVec 1))
val congx =3D ref (Word31.fromLargeWord (subVec 2))
val arr =3D A.array (N, 0w0 : Word31.word)
fun fill (src,dst) =3D
if dst =3D N then ()
else (
A.update (arr, dst, Word31.fromLargeWord (subVec =
src));
fill (src+1,dst+1)
)
in
fill (3, 0);
RND{vals =3D arr,
index =3D index,=20
congx =3D congx,=20
borrow =3D borrow}
end
(* linear congruential generator:
* multiplication by 48271 mod (2^31 - 1)=20
*)
val a : Word31.word =3D 0w48271
val m : Word31.word =3D 0w2147483647
val q =3D m div a
val r =3D m mod a
fun lcg seed =3D let
val left =3D a * (seed mod q)
val right =3D r * (seed div q)
in
if left > right then left - right
else (m - right) + left
end
(* Fill seed array using subtract-with-borrow generator:
* x[n] =3D x[n-lag] - x[n-N] - borrow
* Sets index to 1 and returns 0th value.
*)
fun fill (RND{vals,index,congx,borrow}) =3D let
fun update (ix,iy,b) =3D let
val (z,b') =3D minus(A.sub(vals,ix), A.sub(vals,iy),b)
in
A.update(vals,iy,z); b'
end
fun fillup (i,b) =3D
if i =3D lag then b
else fillup(i+1, update(i+offset,i,b))
fun fillup' (i,b) =3D
if i =3D N then b
else fillup'(i+1, update(i-lag,i,b))
in
borrow :=3D fillup' (lag, fillup (0,!borrow));
index :=3D 1;
A.sub(vals,0)
end
(* Create initial seed array and state of generator.
* Fills the seed array one bit at a time by taking the leading=20
* bit of the xor of a shift register and a congruential =
sequence.=20
* The congruential generator is (c*48271) mod (2^31 - 1).
* The shift register generator is c(I + L18)(I + R13).
* The same congruential generator continues to be used as a=20
* mixing generator with the SWB generator.
*)
fun rand (congy, shrgx) =3D let
fun mki (i,c,s) =3D let
val c' =3D lcg c
val s' =3D xorb(s, s << 0w18)
val s'' =3D xorb(s', s' >> 0w13)
val i' =3D (lo30 & (i >> 0w1)) ++ (bit30 & =
xorb(c',s''))
in (i',c',s'') end
fun iterate (0, v) =3D v
| iterate (n, v) =3D iterate(n-1, mki v)
fun mkseed (congx,shrgx) =3D iterate (nbits, =
(0w0,congx,shrgx))
fun genseed (0,seeds,congx,_) =3D (seeds,congx)
| genseed (n,seeds,congx,shrgx) =3D let
val (seed,congx',shrgx') =3D mkseed (congx,shrgx)
in genseed(n-1,seed::seeds,congx',shrgx') end
val congx =3D ((Word31.fromInt congy & maxWord) << 0w1)+0w1
val (seeds,congx) =3D genseed(N,[],congx, Word31.fromInt =
shrgx)
in
RND{vals =3D A.fromList seeds,=20
index =3D ref 0,=20
congx =3D ref congx,=20
borrow =3D ref false}
end
(* Get next random number. The tweak function combines
* the number from the SWB generator with a number from
* the linear congruential generator.
*)
fun randWord (r as RND{vals, index,congx,...}) =3D let
val idx =3D !index
fun tweak i =3D let
val c =3D lcg (!congx)
in
congx :=3D c;
xorb(i, c)
end
in
if idx =3D N then tweak(fill r)
else tweak(A.sub(vals,idx)) before index :=3D idx+1
end
fun randInt state =3D Word31.toIntX(randWord state)
fun randNat state =3D Word31.toIntX(randWord state & lo30)
fun randReal state =3D
(real(randNat state) + real(randNat state) * two2neg30) * =
two2neg30
fun randRange (i,j) =3D=20
if j < i=20
then error ("randRange", "hi < lo")
else let
val R =3D two2neg30*real(j - i + 1)
in
fn s =3D> i + trunc(R*real(randNat s))
end handle _ =3D> let
val ri =3D real i
val R =3D (real j)-ri+1.0
in
fn s =3D> trunc(ri + R*(randReal s))
end
end; (* Random *)
(* hash-key-sig.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file =
for details.
*
* Abstract hash table keys. This is the argument signature for the =
hash table
* functor (see hash-table-sig.sml and hash-table.sml).
*
* AUTHOR: John Reppy
* AT&T Bell Laboratories
* Murray Hill, NJ 07974
* jhr@research.att.com
*)
signature HASH_KEY =3D
sig
type hash_key
val hashVal : hash_key -> word
(* Compute an unsigned integer key from a hash key. *)
val sameKey : (hash_key * hash_key) -> bool
(* Return true if two keys are the same.
* NOTE: if sameKey(h1, h2), then it must be the
* case that (hashVal h1 =3D hashVal h2).
*)
end (* HASH_KEY *)
(* mono-hash-table-sig.sml
*
* COPYRIGHT (c) 1992 by AT&T Bell Laboratories.
*
* The result signature of the hash table functor (see hash-table.sml).
*
* AUTHOR: John Reppy
* AT&T Bell Laboratories
* Murray Hill, NJ 07974
* jhr@research.att.com
*)
signature MONO_HASH_TABLE =3D
sig
structure Key : HASH_KEY
type 'a hash_table
val mkTable : (int * exn) -> 'a hash_table
(* Create a new table; the int is a size hint and the exception
* is to be raised by find.
*)
val clear : 'a hash_table -> unit
(* remove all elements from the table *)
val insert : 'a hash_table -> (Key.hash_key * 'a) -> unit
(* Insert an item. If the key already has an item associated with it,
* then the old item is discarded.
*)
val lookup : 'a hash_table -> Key.hash_key -> 'a
(* Find an item, the table's exception is raised if the item doesn't =
exist *)
val find : 'a hash_table -> Key.hash_key -> 'a option
(* Look for an item, return NONE if the item doesn't exist *)
val remove : 'a hash_table -> Key.hash_key -> 'a
(* Remove an item, returning the item. The table's exception is =
raised if
* the item doesn't exist.
*)
val numItems : 'a hash_table -> int
(* Return the number of items in the table *)
val listItems : 'a hash_table -> 'a list
val listItemsi : 'a hash_table -> (Key.hash_key * 'a) list
(* Return a list of the items (and their keys) in the table *)
val app : ('a -> unit) -> 'a hash_table -> unit
val appi : ((Key.hash_key * 'a) -> unit) -> 'a hash_table -> unit
(* Apply a function to the entries of the table *)
val map : ('a -> 'b) -> 'a hash_table -> 'b hash_table
val mapi : ((Key.hash_key * 'a) -> 'b) -> 'a hash_table -> 'b =
hash_table
(* Map a table to a new table that has the same keys *)
val fold : (('a * 'b) -> 'b) -> 'b -> 'a hash_table -> 'b
val foldi : ((Key.hash_key * 'a * 'b) -> 'b) -> 'b -> 'a hash_table =
-> 'b
(** Also mapPartial?? *)
val filter : ('a -> bool) -> 'a hash_table -> unit
val filteri : ((Key.hash_key * 'a) -> bool) -> 'a hash_table -> =
unit
(* remove any hash table items that do not satisfy the given
* predicate.
*)
val copy : 'a hash_table -> 'a hash_table
(* Create a copy of a hash table *)
val bucketSizes : 'a hash_table -> int list
(* returns a list of the sizes of the various buckets. This is to
* allow users to gauge the quality of their hashing function.
*)
end (* MONO_HASH_TABLE *)
(* hash-table-rep.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories.
* COPYRIGHT (c) 1996 AT&T Research.
*
* This is the internal representation of hash tables, along with some
* utility functions. It is used in both the polymorphic and functor
* hash table implementations.
*
* AUTHOR: John Reppy
* AT&T Bell Laboratories
* Murray Hill, NJ 07974
* jhr@research.att.com
*)
structure HashTableRep : sig
datatype ('a, 'b) bucket
=3D NIL
| B of (word * 'a * 'b * ('a, 'b) bucket)
type ('a, 'b) table =3D ('a, 'b) bucket array
val alloc : int -> ('a, 'b) table
(* allocate a table of at least the given size *)
val growTable : (('a, 'b) table * int) -> ('a, 'b) table
(* grow a table to the specified size *)
val growTableIfNeeded : (('a, 'b) table ref * int) -> bool
(* conditionally grow a table; the second argument is the number
* of items currently in the table.
*)
val clear : ('a, 'b) table -> unit
(* remove all items *)
val listItems : (('a, 'b) table * int ref) -> 'b list
val listItemsi : (('a, 'b) table * int ref) -> ('a * 'b) list
val appi : ('a * 'b -> 'c) -> ('a, 'b) table -> unit
val app : ('a -> 'b) -> ('c, 'a) table -> unit
val mapi : ('a * 'b -> 'c) -> ('a, 'b) table -> ('a, 'c) table
val map : ('a -> 'b) -> ('c, 'a) table -> ('c, 'b) table
val foldi : ('a * 'b * 'c -> 'c) -> 'c -> ('a, 'b) table -> 'c
val fold : ('a * 'b -> 'b) -> 'b -> ('c, 'a) table -> 'b
val filteri : ('a * 'b -> bool) -> ('a, 'b) table -> unit
val filter : ('a -> bool) -> ('b,'a) table -> unit
val copy : ('a, 'b) table -> ('a, 'b) table
val bucketSizes : ('a, 'b) table -> int list
end =3D struct
datatype ('a, 'b) bucket
=3D NIL
| B of (word * 'a * 'b * ('a, 'b) bucket)
type ('a, 'b) table =3D ('a, 'b) bucket array
fun index (i, sz) =3D Word.toIntX(Word.andb(i, Word.fromInt sz - =
0w1))
(* find smallest power of 2 (>=3D 32) that is >=3D n *)
fun roundUp n =3D let
fun f i =3D if (i >=3D n) then i else f(i * 2)
in
f 32
end
(* Create a new table; the int is a size hint and the exception
* is to be raised by find.
*)
fun alloc sizeHint =3D Array.array(roundUp sizeHint, NIL)
(* grow a table to the specified size *)
fun growTable (table, newSz) =3D let
val newArr =3D Array.array (newSz, NIL)
fun copy NIL =3D ()
| copy (B(h, key, v, rest)) =3D let
val indx =3D index (h, newSz)
in
Array.update (newArr, indx,
B(h, key, v, Array.sub(newArr, indx)));
copy rest
end
in
Array.app copy table;
newArr
end
(* conditionally grow a table; return true if it grew. *)
fun growTableIfNeeded (table, nItems) =3D let
val arr =3D !table
val sz =3D Array.length arr
in
if (nItems >=3D sz)
then (table :=3D growTable (arr, sz+sz); true)
else false
end
(* remove all items *)
fun clear table =3D Array.modify (fn _ =3D> NIL) table
(* return a list of the items in the table *)
fun listItems (table, nItems) =3D let
fun f (_, l, 0) =3D l
| f (~1, l, _) =3D l
| f (i, l, n) =3D let
fun g (NIL, l, n) =3D f (i-1, l, n)
| g (B(_, k, v, r), l, n) =3D g(r, v::l, n-1)
in
g (Array.sub(table, i), l, n)
end
in
f ((Array.length table) - 1, [], !nItems)
end (* listItems *)
fun listItemsi (table, nItems) =3D let
fun f (_, l, 0) =3D l
| f (~1, l, _) =3D l
| f (i, l, n) =3D let
fun g (NIL, l, n) =3D f (i-1, l, n)
| g (B(_, k, v, r), l, n) =3D g(r, (k, v)::l, n-1)
in
g (Array.sub(table, i), l, n)
end
in
f ((Array.length table) - 1, [], !nItems)
end (* listItems *)
(* Apply a function to the entries of the table *)
fun appi f table =3D let
fun appF NIL =3D ()
| appF (B(_, key, item, rest)) =3D (f (key, item); appF rest)
in
Array.app appF table
end (* appi *)
fun app f table =3D let
fun appF NIL =3D ()
| appF (B(_, key, item, rest)) =3D (f item; appF rest)
in
Array.app appF table
end (* app *)
(* Map a table to a new table that has the same keys *)
fun mapi f table =3D let
fun mapF NIL =3D NIL
| mapF (B(hash, key, item, rest)) =3D
B(hash, key, f (key, item), mapF rest)
val newTbl =3D Array.tabulate (
Array.length table,
fn i =3D> mapF (Array.sub(table, i)))
in
newTbl
end (* transform *)
(* Map a table to a new table that has the same keys *)
fun map f table =3D let
fun mapF NIL =3D NIL
| mapF (B(hash, key, item, rest)) =3D B(hash, key, f item, mapF =
rest)
val newTbl =3D Array.tabulate (
Array.length table,
fn i =3D> mapF (Array.sub(table, i)))
in
newTbl
end (* map *)
fun foldi f init table =3D let
fun foldF (NIL, accum) =3D accum
| foldF (B(hash, key, item, rest), accum) =3D
foldF(rest, f(key, item, accum))
in
Array.foldl foldF init table
end
fun fold f init table =3D let
fun foldF (NIL, accum) =3D accum
| foldF (B(hash, key, item, rest), accum) =3D
foldF(rest, f(item, accum))
in
Array.foldl foldF init table
end
(* remove any hash table items that do not satisfy the given
* predicate.
*)
fun filteri pred table =3D let
fun filterP NIL =3D NIL
| filterP (B(hash, key, item, rest)) =3D if (pred(key, item))
then B(hash, key, item, filterP rest)
else filterP rest
in
Array.modify filterP table
end (* filteri *)
fun filter pred table =3D let
fun filterP NIL =3D NIL
| filterP (B(hash, key, item, rest)) =3D if (pred item)
then B(hash, key, item, filterP rest)
else filterP rest
in
Array.modify filterP table
end (* filter *)
(* Create a copy of a hash table *)
fun copy table =3D
Array.tabulate (Array.length table, fn i =3D> Array.sub(table, i));
(* returns a list of the sizes of the various buckets. This is to
* allow users to gauge the quality of their hashing function.
*)
fun bucketSizes table =3D let
fun len (NIL, n) =3D n
| len (B(_, _, _, r), n) =3D len(r, n+1)
in
Array.foldr (fn (b, l) =3D> len(b, 0) :: l) [] table
end
end (* HashTableRep *)
(* hash-table-fn.sml
*
* COPYRIGHT (c) 1992 by AT&T Bell Laboratories.
*
* A hash table functor. It takes a key type with two operations: =
sameKey and
* hashVal as arguments (see hash-key-sig.sml).
*
* AUTHOR: John Reppy
* AT&T Bell Laboratories
* Murray Hill, NJ 07974
* jhr@research.att.com
*)
functor HashTableFn (Key : HASH_KEY) : MONO_HASH_TABLE =3D
struct
structure Key =3D Key
open Key
structure HTRep =3D HashTableRep
datatype 'a hash_table =3D HT of {
not_found : exn,
table : (hash_key, 'a) HTRep.table ref,
n_items : int ref
}
fun index (i, sz) =3D Word.toIntX(Word.andb(i, Word.fromInt sz - =
0w1))
(* Create a new table; the int is a size hint and the exception
* is to be raised by find.
*)
fun mkTable (sizeHint, notFound) =3D HT{
not_found =3D notFound,
table =3D ref (HTRep.alloc sizeHint),
n_items =3D ref 0
}
(* remove all elements from the table *)
fun clear (HT{table, n_items, ...}) =3D (HTRep.clear(!table); =
n_items :=3D 0)
(* Insert an item. If the key already has an item associated with =
it,
* then the old item is discarded.
*)
fun insert (tbl as HT{table, n_items, ...}) (key, item) =3D let
val arr =3D !table
val sz =3D Array.length arr
val hash =3D hashVal key
val indx =3D index (hash, sz)
fun look HTRep.NIL =3D (
Array.update(arr, indx, HTRep.B(hash, key, item, Array.sub(arr, =
indx)));
n_items :=3D !n_items + 1;
HTRep.growTableIfNeeded (table, !n_items);
HTRep.NIL)
| look (HTRep.B(h, k, v, r)) =3D if ((hash =3D h) andalso =
sameKey(key, k))
then HTRep.B(hash, key, item, r)
else (case (look r)
of HTRep.NIL =3D> HTRep.NIL
| rest =3D> HTRep.B(h, k, v, rest)
(* end case *))
in
case (look (Array.sub (arr, indx)))
of HTRep.NIL =3D> ()
| b =3D> Array.update(arr, indx, b)
(* end case *)
end
(* find an item, the table's exception is raised if the item doesn't =
exist *)
fun lookup (HT{table, not_found, ...}) key =3D let
val arr =3D !table
val hash =3D hashVal key
val indx =3D index (hash, Array.length arr)
fun look HTRep.NIL =3D raise not_found
| look (HTRep.B(h, k, v, r)) =3D if ((hash =3D h) andalso =
sameKey(key, k))
then v
else look r
in
look (Array.sub (arr, indx))
end
(* look for an item, return NONE if the item doesn't exist *)
fun find (HT{table, ...}) key =3D let
val arr =3D !table
val sz =3D Array.length arr
val hash =3D hashVal key
val indx =3D index (hash, sz)
fun look HTRep.NIL =3D NONE
| look (HTRep.B(h, k, v, r)) =3D if ((hash =3D h) andalso =
sameKey(key, k))
then SOME v
else look r
in
look (Array.sub (arr, indx))
end
(* Remove an item. The table's exception is raised if
* the item doesn't exist.
*)
fun remove (HT{not_found, table, n_items}) key =3D let
val arr =3D !table
val sz =3D Array.length arr
val hash =3D hashVal key
val indx =3D index (hash, sz)
fun look HTRep.NIL =3D raise not_found
| look (HTRep.B(h, k, v, r)) =3D if ((hash =3D h) andalso =
sameKey(key, k))
then (v, r)
else let val (item, r') =3D look r in (item, HTRep.B(h, k, v, r')) =
end
val (item, bucket) =3D look (Array.sub (arr, indx))
in
Array.update (arr, indx, bucket);
n_items :=3D !n_items - 1;
item
end (* remove *)
(* Return the number of items in the table *)
fun numItems (HT{n_items, ...}) =3D !n_items
(* return a list of the items in the table *)
fun listItems (HT{table =3D ref arr, n_items, ...}) =3D
HTRep.listItems (arr, n_items)
fun listItemsi (HT{table =3D ref arr, n_items, ...}) =3D
HTRep.listItemsi (arr, n_items)
(* Apply a function to the entries of the table *)
fun appi f (HT{table, ...}) =3D HTRep.appi f (! table)
fun app f (HT{table, ...}) =3D HTRep.app f (! table)
(* Map a table to a new table that has the same keys and exception *)
fun mapi f (HT{table, n_items, not_found}) =3D HT{
table =3D ref(HTRep.mapi f (! table)),
n_items =3D ref(!n_items),
not_found =3D not_found
}
fun map f (HT{table, n_items, not_found}) =3D HT{
table =3D ref(HTRep.map f (! table)),
n_items =3D ref(!n_items),
not_found =3D not_found
}
(* Fold a function over the entries of the table *)
fun foldi f init (HT{table, ...}) =3D HTRep.foldi f init (! table)
fun fold f init (HT{table, ...}) =3D HTRep.fold f init (! table)
(* remove any hash table items that do not satisfy the given
* predicate.
*)
fun filteri pred (HT{table, ...}) =3D HTRep.filteri pred (! table)
fun filter pred (HT{table, ...}) =3D HTRep.filter pred (! table)
(* Create a copy of a hash table *)
fun copy (HT{table, n_items, not_found}) =3D HT{
table =3D ref(HTRep.copy(! table)),
n_items =3D ref(!n_items),
not_found =3D not_found
}
(* returns a list of the sizes of the various buckets. This is to
* allow users to gauge the quality of their hashing function.
*)
fun bucketSizes (HT{table, ...}) =3D HTRep.bucketSizes (! table)
end (* HashTableFn *)
(* mono-dynamic-array-sig.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file =
for details.
*
* Signature for unbounded arrays.
*
*)
signature MONO_DYNAMIC_ARRAY =3D
sig
type elem
type array
val array : (int * elem) -> array
(* array (sz, e) creates an unbounded array all of whose elements
* are initialized to e. sz (>=3D 0) is used as a
* hint of the potential range of indices. Raises Size if a
* negative hint is given.
*)
val subArray : array * int * int -> array
(* subArray (a,lo,hi) creates a new array with the same default
* as a, and whose values in the range [0,hi-lo] are equal to
* the values in b in the range [lo, hi].
* Raises Size if lo > hi
*)
val fromList : elem list * elem -> array
(* arrayoflist (l, v) creates an array using the list of values l
* plus the default value v.
*)
val tabulate: int * (int -> elem) * elem -> array
(* tabulate (sz,fill,dflt) acts like Array.tabulate, plus=20
* stores default value dflt. Raises Size if sz < 0.
*)
val default : array -> elem
(* default returns array's default value *)
val sub : array * int -> elem
(* sub (a,idx) returns value of the array at index idx.
* If that value has not been set by update, it returns the =
default value.
* Raises Subscript if idx < 0
*)
val update : array * int * elem -> unit
(* update (a,idx,v) sets the value at index idx of the array to =
v.=20
* Raises Subscript if idx < 0
*)
val bound : array -> int
(* bound returns an upper bound on the index of values that have =
been
* changed.
*)
val truncate : array * int -> unit
(* truncate (a,sz) makes every entry with index > sz the default =
value *)
(** what about iterators??? **)
end (* MONO_DYNAMIC_ARRAY *)
(* dynamic-array-fn.sml
*
* COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See COPYRIGHT file =
for details.
*
* Arrays of unbounded length
*
*)
functor DynamicArrayFn (A : MONO_ARRAY) : MONO_DYNAMIC_ARRAY =3D
struct
type elem =3D A.elem
datatype array =3D BLOCK of A.array ref * elem * int ref
=20
exception Subscript =3D General.Subscript
exception Size =3D General.Size
fun array (sz, dflt) =3D BLOCK(ref (A.array (sz, dflt)), dflt, ref =
(~1))
(* fromList (l, v) creates an array using the list of values l
* plus the default value v.
* NOTE: Once MONO_ARRAY includes arrayoflist, this will become =
trivial.
*)
fun fromList (initList, dflt) =3D let
val len =3D length initList
val arr =3D A.array(len, dflt)
fun upd ([], _) =3D ()
| upd (x::r, i) =3D (A.update(arr, i, x); upd(r, i+1))
in
upd (initList, 0);
BLOCK(ref arr, dflt, ref (len-1))
end
(* tabulate (sz,fill,dflt) acts like Array.tabulate, plus=20
* stores default value dflt. Raises Size if sz < 0.
*)
fun tabulate (sz, fillFn, dflt) =3D
BLOCK(ref(A.tabulate(sz, fillFn)), dflt, ref (sz-1))
fun subArray (BLOCK(arr,dflt,bnd),lo,hi) =3D let
val arrval =3D !arr
val bnd =3D !bnd
fun copy i =3D A.sub(arrval,i+lo)
in
if hi <=3D bnd
then BLOCK(ref(A.tabulate(hi-lo,copy)), dflt, ref =
(hi-lo))
else if lo <=3D bnd=20
then BLOCK(ref(A.tabulate(bnd-lo,copy)),dflt,ref(bnd-lo))
else
array(0,dflt)
end
fun default (BLOCK(_,dflt,_)) =3D dflt
fun sub (BLOCK(arr,dflt,_),idx) =3D (A.sub(!arr,idx))=20
handle Subscript =3D> if idx < 0 then raise Subscript else =
dflt
fun bound (BLOCK(_,_,bnd)) =3D (!bnd)
fun expand(arr,oldlen,newlen,dflt) =3D let
fun fillfn i =3D if i < oldlen then A.sub(arr,i) else dflt
in
A.tabulate(newlen, fillfn)
end
fun update (BLOCK(arr,dflt,bnd),idx,v) =3D let=20
val len =3D A.length (!arr)
in
if idx >=3D len=20
then arr :=3D expand(!arr,len, =
Int.max(len+len,idx+1),dflt)=20
else ();
A.update(!arr,idx,v);
if idx > !bnd then bnd :=3D idx else ()
end
fun truncate (a as BLOCK(arr,dflt,bndref),sz) =3D let
val bnd =3D !bndref
val newbnd =3D sz - 1
val arr_val =3D !arr
val array_sz =3D A.length arr_val
fun fillDflt (i,stop) =3D
if i =3D stop then ()
else (A.update(arr_val,i,dflt);fillDflt(i-1,stop))
in
if newbnd < 0 then (bndref :=3D ~1;arr :=3D =
A.array(0,dflt))
else if newbnd >=3D bnd then ()
else if 3 * sz < array_sz then let
val BLOCK(arr',_,bnd') =3D subArray(a,0,newbnd)
in
(bndref :=3D !bnd'; arr :=3D !arr')
end
else fillDflt(bnd,newbnd)
end
end (* DynamicArrayFn *)
(* File: lib40.sml
Created 1993-06-01
Modified 1998-09-14.
*)
structure Lib =3D
struct
open Math
exception My_mod_exn
fun op mod( N, K ) =3D=20
if N < 0 orelse K < 0 then raise My_mod_exn else N - K * ( N div K )
(* To avoid segmentation fault under gdb in SML/NJ 110.0.3 *)
val Max_int =3D case Int.maxInt of SOME X =3D> X - 3
val Max_word =3D Word.fromInt Max_int
val Max_real =3D 1.0E99
fun for( L, U, f ) =3D
if L>U then
()
else (
f L;
for( L+1, U, f )
)
fun real_for( L, U, f ) =3D
if L>U then
()
else (
f L;
real_for( L+1.0, U, f )
)
fun word32_to_bin_string( X : Word32.word ) : string =3D
let
fun g( N : int, X : Word32.word ) =3D
if N =3D 0 then
""
else
g( N-1, Word32.>>( X, 0w1 ) ) ^
Word32.toString( Word32.andb( X, 0w1 ) )=20
in
g(32,X)
end
fun bin_string_to_word32( Xs : string ) : Word32.word =3D
let
fun h( #"0" ) =3D 0w0
| h( #"1" ) =3D 0w1
fun g( Xs : char list ) : Word32.word =3D
case Xs of
[X1] =3D> h X1
| X1::Xs1 =3D> Word32.orb( h X1, Word32.<<( g Xs1, 0w1 ) )
in
g( rev( explode Xs ) )
end
fun is_NONE NONE =3D true
| is_NONE _ =3D false
fun is_SOME( SOME _ ) =3D true
| is_SOME _ =3D false
type outstream =3D TextIO.outstream
val std_err =3D ref TextIO.stdErr
val std_out =3D ref TextIO.stdOut
fun output( stream : outstream, S : string ) =3D=20
TextIO.output(stream, S)
fun flush_out( stream : outstream ) =3D TextIO.flushOut stream
fun flush_output( stream : outstream, S : string ) =3D (
flush_out stream;
output(stream, S)
)
fun p S =3D ( output( !std_out, S ); flush_out( !std_out ) )
fun print_int N =3D p(Int.toString N)
fun print_word32 N =3D p(Word32.toString N)
fun print_real N =3D p(Real.toString N)
fun print_bool N =3D p(Bool.toString N)
fun print_option(print : 'a -> unit, X : 'a option ) =3D
case X of NONE =3D> p"NONE" | SOME X =3D> ( p"SOME( "; print X; p" )" =
)
fun print_int_option X =3D print_option( print_int, X )
fun print_real_option X =3D print_option( print_real, X )
fun print_bool_option X =3D print_option( print_bool, X )
fun pack( Xs : string list ) : string =3D
let
fun g [] =3D []
| g( X :: Xs ) =3D Int.toString( String.size X ) ^ "\n" :: X :: g =
Xs
in
String.concat( g Xs )
end
fun unpack( S : string ) : string list =3D
let
val Len =3D String.size S
fun nl_pos Start =3D
if Start >=3D Len then
NONE
else
case String.sub( S, Start ) of=20
#"\n" =3D> SOME Start
| _ =3D> nl_pos( Start + 1 ) =20
fun read_len( Start : int ) : ( int * int ) option =3D
case nl_pos Start of
NONE =3D> NONE
| SOME Pos =3D>
case Int.fromString( String.substring( S, Start, Pos-Start ) ) of
SOME Len =3D> SOME( Len, Pos+1 )
fun g Start=3D
case read_len Start of
NONE =3D> []
| SOME( Len, Start ) =3D> String.substring( S, Start, Len ) :: =
g(Start+Len)
in
g 0
end
=20
exception Internal_error
fun re_raise(Ex:exn,S:string) =3D (
flush_out( !std_out );
output(!std_out,"\nre_raise: "^S^"\n");
flush_out( !std_out );
raise Ex
)
fun inc X =3D if !X < Max_int then X :=3D !X + 1 else ()
fun real_inc( X : real ref ) : unit =3D X :=3D !X + 1.0
fun word_inc( X : Word.word ref) =3D
( X :=3D Word.+( !X, Word.fromInt 1) )
local val Eps =3D 1.0E~6 in
fun real_eq(X:real,Y:real):bool =3D
if abs Y < Eps then
abs X < Eps
else
case X/Y of Ratio =3D>
1.0-Eps<Ratio andalso Ratio<1.0+Eps
end
fun real_rep_eq( X : real, Y : real ) =3D=20
case Real.compare( X, Y ) of EQUAL =3D> true | _ =3D> false
local
fun normalize X =3D=20
if X > 1.0 orelse X < ~1.0 then=20
normalize( X / 2.55343525364845 )
else
X
in
fun normrealhash( X : real ) =3D=20
normalize( case Real.toManExp X of { man, exp } =3D>=20
man * (real exp + 0.38197515646351) )
end
fun max2(less,X,Y) =3D if less(X,Y) then Y else X
fun min2(less,X,Y) =3D if less(X,Y) then X else Y
fun cmp_invert cmp =3D fn( X, Y ) =3D> cmp( Y, X )
fun real_pow(X,Y) =3D exp(Y*ln X)
fun real_factorial N =3D if N<=3D0.0 then 1.0 else =
N*real_factorial(N-1.0)
fun is_prime(N:int) : bool =3D
let val Max=3Dceil(sqrt(real N))
fun try I =3D
I>Max orelse not(N mod I=3D0) andalso try(I+1)
in
try 2
end
val Big_prime =3D
let fun try N =3D if is_prime N then N else try(N-1) in
try Max_int
end
exception Real_mod
fun real_mod(X:real,Y:real) =3D
X - real(trunc(X/Y))*Y
handle Div =3D> raise Real_mod
| Overflow =3D> raise Real_mod
local
val Max =3D real Max_int - 7.0
in
fun hash_real_to_int( X : real ) : int =3D Real.trunc( normrealhash X * =
Max )
handle Ex =3D> (
p"\nhash_real_to_int: X =3D "; p( Real.toString X );
re_raise( Ex, "hash_real_to_int" ) )
fun hash_real_to_word( X : real ) : word =3D=20
Word.fromInt( Real.trunc( normrealhash X * Max ) )
handle Ex =3D> (
p"\nhash_real_to_word: X =3D "; p( Real.toString X );
re_raise( Ex, "hash_real_to_word" ) )
end (* local *)
fun real_compare( X : real, Y ) =3D
if X < Y then
LESS
else if Y < X then
GREATER
else=20
EQUAL
structure Int_hash_key =3D
struct
type hash_key=3Dint
fun hashVal(X:int)=3D Word.fromInt X
fun sameKey(X,Y:int)=3D X=3DY
end
structure Int_HashTable =3D HashTableFn(Int_hash_key)
structure Int_dyn =3D DynamicArrayFn(
struct
open Array
type elem =3D int
type vector =3D elem Vector.vector
type array =3D int array
structure Vector =3D
struct
open Vector
type elem =3D int
type vector =3D elem Vector.vector
end
end=20
)
structure Real_hash_key =3D
struct
fun hashVal(X:real) =3D Word.fromInt( hash_real_to_int X )
fun sameKey(X:real,Y:real) =3D real_rep_eq( X, Y )
type hash_key=3Dreal
end
structure Real_HashTable =3D HashTableFn(Real_hash_key)
structure Word32_dyn =3D DynamicArrayFn(=20
struct
open Array
type elem =3D Word32.word
type vector =3D elem Vector.vector
type array =3D Word32.word array
structure Vector =3D
struct
open Vector
type elem =3D Word32.word
type vector =3D elem Vector.vector
end
end=20
)
structure Word8_dyn =3D DynamicArrayFn(
struct
open Array
type elem =3D Word8.word
type vector =3D elem Vector.vector
type array =3D Word8.word array
structure Vector =3D
struct
open Vector
type elem =3D Word8.word
type vector =3D elem Vector.vector
end
end=20
)
structure Word_hash_key =3D
struct
type hash_key=3Dword
fun hashVal(X:word)=3D X
fun sameKey(X,Y:word)=3D X=3DY
end
structure Word_HashTable =3D HashTableFn(Word_hash_key)
structure String_hash_key =3D
struct
type hash_key=3Dstring
val hashVal =3D HashString.hashString
fun sameKey(X,Y:string)=3D X=3DY
end
structure String_HashTable =3D HashTableFn(String_hash_key)
fun timeit( f : unit -> 'a ) =3D
let
val start =3D Timer.startCPUTimer ();
val result =3D f();
val non_gc_time =3D #usr(Timer.checkCPUTimer start);
in
print( Real.toString( Time.toReal non_gc_time ) );
print "\n";=20
result
end;
fun time_to_real X=3D Time.toReal X
handle Ex =3D> re_raise( Ex, "time_to_real" )
fun real_to_time X =3D Time.fromReal X
handle Ex =3D> (
output(!std_err, "\n\nreal_to_time: X =3D " ^ Real.toString X);
re_raise( Ex, "real_to_time" )
)
type timer =3D ( string * bool * real * Timer.cpu_timer ) ref
fun mk_timer( Id ) : timer =3D ref( Id, false, 0.0, =
Timer.startCPUTimer() )
handle Ex =3D> re_raise( Ex, "mk_timer" )
exception Start_timer
fun start_timer( T : timer ) =3D
T :=3D=20
let=20
val ( Id, Running, So_far, Timer ) =3D !T
in
if Running then (
p( "\n\nstart_timer: " ^ Id );
raise Start_timer )
else
( Id, true, So_far, Timer.startCPUTimer() )
end
handle Ex =3D> re_raise( Ex, "start_timer" )
fun timer_running( T : timer ) =3D #2(!T)
exception Stop_timer
fun stop_timer(T) =3D
(
T :=3D=20
let=20
val ( Id, Running, So_far, Timer ) =3D !T
in
if not(Running) then (
p( "\n\nstop_timer: " ^ Id );
raise Stop_timer )
else
( Id, false,=20
So_far+time_to_real(#usr(Timer.checkCPUTimer Timer)), Timer)
end)
(*
handle Time.Time =3D> (
output(!std_err,"\nstop_timer: Exn Time handled :" ^
Real.toString(#2(!T)) ^ "\n");
stop_timer T
)
| Ex =3D> re_raise( Ex, "stop_timer" )
*)
fun check_timer(T) : real =3D
let=20
val ( Id, Running, So_far, Timer ) =3D !T
in
if Running then
So_far+time_to_real(#usr(Timer.checkCPUTimer Timer))
(*
handle Time.Time =3D> (
output(!std_err,"\ncheck_timer: Exn Time handled :" ^
Real.toString So_far ^ "\n");
check_timer T
)
*)
else
So_far
end
handle Ex =3D> re_raise( Ex, "check_timer" )
fun set_timer(T,To:real) : unit =3D
(case !T of ( Id, Running, _, _ ) =3D>
T :=3D ( Id, Running, To, Timer.startCPUTimer() ) )
handle Ex =3D> re_raise( Ex, "set_timer" )
fun sort (op < : 'a * 'a -> bool) ls =3D let=20
fun merge([],ys) =3D ys
| merge(xs,[]) =3D xs
| merge(x::xs,y::ys) =3D
if y < x then y::merge(x::xs,ys) else =
x::merge(xs,y::ys)
fun mergepairs(ls as [l], k) =3D ls
| mergepairs(l1::l2::ls,k) =3D
if k mod 2 =3D 1 then l1::l2::ls
else mergepairs(merge(l1,l2)::ls, k div 2)
| mergepairs _ =3D raise Internal_error
fun nextrun(run,[]) =3D (rev run,[])
| nextrun(run,x::xs) =3D if hd run < x then =
nextrun(x::run,xs)
else (rev run,x::xs)
fun samsorting([], ls, k) =3D hd(mergepairs(ls,0))
| samsorting(x::xs, ls, k) =3D let=20
val (run,tail) =3D nextrun([x],xs)
in samsorting(tail, mergepairs(run::ls,k+1), k+1)
end
in=20
case ls of [] =3D> [] | _ =3D> samsorting(ls, [], 0)
end
fun stable_merge(less,[],Ys) =3D Ys
| stable_merge(less,Xs,[]) =3D Xs
| stable_merge(less,X::Xs,Y::Ys) =3D
if less(Y,X) then=20
Y::stable_merge(less,X::Xs,Ys)=20
else=20
X::stable_merge(less,Xs,Y::Ys)
fun cmpsort( cmp : 'a * 'a -> order, Xs : 'a list ) =3D
sort ( fn( X1, X2 ) =3D> case cmp( X1, X2 ) of LESS =3D> true | _ =
=3D> false ) Xs=20
fun nl() =3D output(!std_out,"\n");
local
val Rand =3D Random.rand( 6951246, ~215434691 )
in
val randInt =3D fn() =3D> Random.randInt Rand
val randNat =3D fn() =3D> Random.randNat Rand
val randReal =3D fn() =3D> Random.randReal Rand
val randRange =3D fn(Low,High) =3D> Random.randRange (Low,High) Rand
end
end (* structure Lib *)
structure List1 =3D
struct
open Lib;
fun list_less(less,_,[]) =3D false
| list_less(less,[],_) =3D true
| list_less(less,X::Xs,Y::Ys) =3D
less(X,Y) orelse ( not(less(Y,X)) andalso list_less(less,Xs,Ys) )
fun list_compare( cmp, [], [] ) =3D EQUAL
| list_compare( cmp, [], _ ) =3D LESS
| list_compare( cmp, _, [] ) =3D GREATER
| list_compare( cmp, X :: Xs, Y :: Ys ) =3D=20
case cmp( X, Y ) of
EQUAL =3D> list_compare( cmp, Xs, Ys )
| Z =3D> Z
fun snoc(Xs,X) =3D Xs@(X::nil)
fun dh(X::nil) =3D X
| dh(X::Xs) =3D dh(Xs)
fun lt(X::nil) =3D nil
| lt(X::Xs) =3D X::(lt Xs)
exception Nth;
fun nth( X::_, 0 ) =3D X
| nth( _::Xs, N ) =3D if N>0 then nth(Xs,N-1) else raise Nth
| nth(_,_) =3D raise Nth;
fun index(X,Y::Ys) =3D
if X=3DY then 0 else 1+index(X,Ys)
fun index_opt(X,[]) =3D NONE
| index_opt(X,Y::Ys) =3D if X=3DY then SOME 0 else
case index_opt(X,Ys) of NONE =3D> NONE | SOME N =3D> SOME(1+N)
fun index_opt'( _, [] ) =3D NONE
| index_opt'( found, Y::Ys) =3D if found Y then SOME 0 else
case index_opt'( found, Ys ) of NONE =3D> NONE | SOME N =3D> =
SOME(1+N)
fun take(N,[]) =3D []
| take(N,X::Xs) =3D if N>0 then X::take(N-1,Xs) else []
fun drop(_,[]) =3D []
| drop(N,X::Xs) =3D if N>0 then drop(N-1,Xs) else X::Xs
fun takewhile(p,[]) =3D []
| takewhile(p,X::Xs) =3D
if p X then X::takewhile(p,Xs) else nil
fun dropwhile(p,[]) =3D []
| dropwhile(p,X::Xs) =3D=20
if p X then dropwhile(p,Xs) else X::Xs
exception List_replace;
fun list_replace( X::Xs, 0, Y ) =3D Y::Xs
| list_replace( X::Xs, N, Y ) =3D
if N>0 then X::list_replace(Xs,N-1,Y) else raise List_replace
| list_replace(_,_,_) =3D raise List_replace;
exception Delete_nth
fun delete_nth(nil,_) =3D raise Delete_nth
| delete_nth(X::Xs,N) =3D if N=3D0 then Xs else X::delete_nth(Xs,N-1)
fun fromto(Lower,Upper) =3D
if Lower>Upper then nil else Lower::fromto(Lower+1,Upper)
fun real_sum( Xs : real list ) =3D
case Xs of nil =3D> 0.0
| X1::Xs1 =3D> X1+real_sum Xs1
fun real_prod( Xs : real list ) =3D
case Xs of nil =3D> 1.0
| X1::Xs1 =3D> X1*real_prod Xs1
fun int_sum( Xs : int list ) =3D
case Xs of nil =3D> 0
| X1::Xs1 =3D> X1+int_sum Xs1
fun combine( [], [] ) =3D []
| combine( X::Xs, Y::Ys ) =3D (X,Y)::combine(Xs,Ys)
fun split [] =3D ([],[])
| split( (X1,X2)::Xs ) =3D case split Xs of (Ys,Zs) =3D> =
(X1::Ys,X2::Zs)
val zip =3D combine
val unzip =3D split
fun indexize( Xs : 'a list, Start : int ) =3D
combine( Xs, fromto( Start, Start + length Xs - 1 ) )
fun assoc_opt( X : ''a, Xs : (''a * 'b ) list ) : 'b option =3D
case Xs of
nil =3D> NONE
| (X1,Y1)::Xs1 =3D> if X1=3DX then SOME Y1 else assoc_opt(X,Xs1)
fun assoc_opt'(eq : 'a*'a->bool, X : 'a, Xs : ('a * 'b ) list ) : 'b =
option =3D
case Xs of
nil =3D> NONE
| (X1,Y1)::Xs1 =3D> if eq(X1,X) then SOME Y1 else =
assoc_opt'(eq,X,Xs1)
fun assoc(X,Xs) =3D case assoc_opt(X,Xs) of SOME Y =3D> Y
fun foldright( A, f, Xs ) =3D
case Xs of nil =3D> A
| X1::Xs1 =3D> f( X1, foldright(A,f,Xs1) )
fun flat_map( f, Xs ) =3D
case Xs of nil =3D> nil | X1::Xs1 =3D> f(X1)@flat_map(f,Xs1)
fun flatten nil =3D nil
| flatten (Xs::Xss) =3D Xs@flatten Xss
fun map( f, Xs ) =3D
case Xs of nil =3D> nil | X1::Xs1 =3D> f(X1)::map(f,Xs1)
fun loop( f, Xs ) =3D
case Xs of nil =3D> () | X1::Xs1 =3D> ( f X1; loop(f,Xs1) )
fun filter(p,Xs) =3D
case Xs of
nil =3D> nil
| X1::Xs1 =3D>=20
if p X1 then
X1 :: filter( p, Xs1 )
else
filter( p, Xs1 )
fun pfilter( p, Xs ) =3D
case Xs of
nil =3D> ( nil, nil )
| X1::Xs1 =3D>=20
case pfilter( p, Xs1 ) of ( Ys, Zs ) =3D>
if p X1 then
( X1::Ys, Zs )
else
( Ys, X1::Zs )
fun forall(p,Xs) =3D null( filter( fn X =3D> not(p(X)), Xs ) )
fun exists(p,Xs) =3D=20
case Xs of nil =3D> false
| X1::Xs1 =3D> p X1 orelse exists(p,Xs1)
fun cart_prod(Xs,Ys) =3D flat_map( fn X =3D> map(fn Y=3D>(X,Y),Ys), Xs =
)
fun powset([],Base) =3D [Base]
| powset(X::Xs,Base) =3D powset(Xs,Base) @ powset(Xs,X::Base)
exception Choose
fun choose( Xs : 'a list, K : int ) : 'a list list =3D
if K > length Xs orelse K<0 then
raise Choose
else if K=3D0 then
[[]]
else if K=3Dlength Xs then
[Xs]
else case Xs of X1::Xs1 =3D>
map( fn Ys =3D> X1::Ys, choose(Xs1,K-1) ) @ choose(Xs1,K)
fun mk_eq_classes( eq : 'a * 'a -> bool, Xs : 'a list ) : 'a list list =
=3D
let
fun g [] =3D []
| g( X :: Xs ) =3D
case pfilter( fn Y :: _ =3D> eq( X, Y ), g Xs ) of
( [], Xss ) =3D> [X] :: Xss
| ( [Ys], Xss ) =3D> ( X :: Ys ) :: Xss
in
g Xs
end
fun count(X,Xs) =3D
case Xs of nil =3D> 0 | X1::Xs1 =3D>=20
if X=3DX1 then 1+count(X,Xs1) else count(X,Xs1)
fun member(X,Xs) =3D=20
case Xs of nil =3D> false | X1::Xs1 =3D> X=3DX1 orelse member(X,Xs1)
fun is_subset(Xs,Ys) =3D forall( fn X =3D> member(X,Ys), Xs )
fun member'(eq,X,Xs) =3D=20
case Xs of nil =3D> false | X1::Xs1 =3D> eq(X,X1) orelse =
member'(eq,X,Xs1)
fun is_set(Xs) =3D
case Xs of nil =3D> true | X1::Xs1 =3D> not(member(X1,Xs1)) andalso =
is_set(Xs1)
fun is_set'(eq,Xs) =3D
case Xs of=20
nil =3D> true=20
| X1::Xs1 =3D> not(member'(eq,X1,Xs1)) andalso is_set'(eq,Xs1)
fun make_set(Xs) =3D
case Xs of nil =3D> nil=20
| X1::Xs1 =3D> if member(X1,Xs1) then make_set(Xs1) else =
X1::make_set(Xs1)
fun make_set'(eq,Xs) =3D
case Xs of nil =3D> nil=20
| X1::Xs1 =3D>=20
if member'(eq,X1,Xs1) then make_set'(eq,Xs1) else =
X1::make_set'(eq,Xs1)
fun fast_make_set( less, Xs ) =3D
let fun ms(Xs) =3D
case Xs of=20
nil =3D> Xs
| X::nil =3D> Xs
| X1::(Xs1 as X2::Xs2) =3D> if less(X1,X2) then X1::ms(Xs1) else ms =
Xs1
in
ms(Lib.sort less Xs )
end
fun duplicates(Xs) =3D
case Xs of
nil =3D> nil
| X1::Xs1 =3D> if member(X1,Xs1) then X1::duplicates(Xs1) else =
duplicates(Xs1)
fun list_eq( eq : 'a * 'a -> bool, Xs : 'a list, Ys : 'a list ) =3D
let=20
fun g( [], [] ) =3D true
| g( [], _ ) =3D false
| g( _, [] ) =3D false
| g( X :: Xs, Y :: Ys ) =3D eq( X, Y ) andalso g( Xs, Ys )
in
g( Xs, Ys )
end
fun option_eq( eq : 'a * 'a -> bool, X : 'a option, Y : 'a option ) : =
bool =3D
case X of
NONE =3D> ( case Y of NONE =3D> true | SOME _ =3D> false )
| SOME X =3D>
case Y of
NONE =3D> false
| SOME Y =3D> eq( X, Y )
fun stable_sort (less : 'a * 'a -> bool) Xs =3D
map(#1, sort (fn((X1,N1),(X2,N2)) =3D>=20
less(X1,X2) orelse not(less(X2,X1)) andalso N1<N2)
(combine(Xs,fromto(1,length Xs))))
fun delete_one(X,Xs) =3D
case Xs of
nil =3D> nil
| X1::Xs1 =3D> if X=3DX1 then Xs1 else X1::delete_one(X,Xs1)
fun min( less, Xs ) =3D=20
case Xs of
X1::nil =3D> X1
| X1::Xs1 =3D> let val M =3D min(less,Xs1) in
if less(M,X1) then M else X1
end
fun max( less, Xs ) =3D
case Xs of
X1::nil =3D> X1
| X1::X2::Xs2 =3D> if less(X1,X2) then max(less,X2::Xs2) else =
max(less,X1::Xs2)
fun is_subsequence( [], _ ) =3D true
| is_subsequence( X1 :: Xs1, [] ) =3D false
| is_subsequence( Xs as X1 :: Xs1, Y1 :: Ys1 ) =3D=20
if X1 =3D Y1 then
is_subsequence( Xs1, Ys1 )
else
is_subsequence( Xs, Ys1 )
local
fun lcp( eq, So_far, Xss ) =3D
if exists( null, Xss ) then
rev So_far
else=20
case Xss of ( X :: _ ) :: Xss1 =3D>
if forall( fn Y::_ =3D> eq( X, Y ), Xss1 ) then
lcp( eq, X :: So_far, map( tl, Xss ) )
else
rev So_far
in=20
fun longest_common_prefix'( eq : 'a * 'a -> bool,=20
Xss : 'a list list ) : 'a list =3D
case Xss of
[] =3D> []
| [ Xs ] =3D> Xs
| _::_::_ =3D> lcp( eq, [], Xss )
end (* local *)
=20
fun longest_common_prefix( Xss : ''a list list ) : ''a list =3D
longest_common_prefix'( op=3D, Xss )
(*
See lcs.sml instead
local
open Array2
in
fun lcs(eq, Xs, Ys ) : int =3D
let
val Memomatrix : int option array =3D=20
array( length Xs, length Ys, NONE )
fun lcs'( _, _, [], _ ) =3D 0
| lcs'( _, _, _, [] ) =3D 0
| lcs'( I, J, Xs as X1::Xs1, Ys as Y1::Ys1 ) =3D
case sub( Memomatrix, I, J ) of
SOME N =3D> N
| NONE =3D>
let val N =3D
if eq(X1,Y1) then
1 + lcs'(I+1,J+1,Xs1,Ys1)
else
max2( op<, lcs'(I+1,J,Xs1,Ys), lcs'(I,J+1,Xs,Ys1) )
in
update(Memomatrix,I,J,SOME N);
N
end
in
lcs'(0,0,Xs,Ys)
end
end (* local *)
*)
(*
fun test1() =3D lcs(op=3D, [1,2,3,2,4,1,2], [2,4,3,1,2,1] )
fun test2() =3D timeit( fn () =3D> lcs( op=3D,
[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25],
[1,7,3,4,5,6,7,8,5,10,11,12,13,14,15,16,11,18,19,20,21,22,23,21,25]) =
)
*)
fun difference(Xs,Ys) =3D
case Xs of nil =3D> nil
| X1::Xs1 =3D>
if member(X1,Ys) then difference(Xs1,Ys) else =
X1::difference(Xs1,Ys)
fun difference'(eq,Xs,Ys) =3D
case Xs of nil =3D> nil
| X1::Xs1 =3D>
if member'(eq,X1,Ys) then difference'(eq,Xs1,Ys) else=20
X1::difference'(eq,Xs1,Ys)
fun is_sorted( less, Xs ) =3D
case Xs of
[] =3D> true
| [X] =3D> true
| X1::( Xs1 as X2::Xs2) =3D>=20
not(less(X2,X1)) andalso is_sorted(less,Xs1)
fun cmp_is_sorted( cmp, Xs ) =3D
is_sorted( fn( X, Y ) =3D> case cmp( X, Y ) of LESS =3D> true | _ =
=3D> false, Xs )
exception Sorted_difference
fun sorted_difference( less, Xs, Ys ) =3D
if not(is_sorted(less,Xs)) orelse not(is_sorted(less,Ys)) then
raise Sorted_difference
else
case Xs of nil =3D> nil
| X1::Xs1 =3D> case Ys of nil =3D> Xs
| Y1::Ys1 =3D>
if less(X1,Y1) then
X1::sorted_difference(less,Xs1,Ys)
else if less(Y1,X1) then
sorted_difference(less,Xs,Ys1)
else
sorted_difference(less,Xs1,Ys)
fun fast_difference( less, Xs, Ys ) =3D
sorted_difference( less, Lib.sort less Xs, Lib.sort less Ys )
fun intersection(Xs,Ys) =3D
case Xs of nil =3D> nil
| X1::Xs1 =3D>=20
if member(X1,Ys) then X1::intersection(Xs1,Ys) else =
intersection(Xs1,Ys)
exception Sorted_intersection
fun sorted_intersection( less, Xs, Ys ) =3D
if not(is_sorted(less,Xs)) orelse not(is_sorted(less,Ys)) then
raise Sorted_intersection
else
case Xs of nil =3D> nil
| X1::Xs1 =3D> case Ys of nil =3D> nil
| Y1::Ys1 =3D>
if less(X1,Y1) then
sorted_intersection(less,Xs1,Ys)
else if less(Y1,X1) then
sorted_intersection(less,Xs,Ys1)
else
X1::sorted_intersection(less,Xs1,Ys1)
fun fast_intersection( less, Xs, Ys ) =3D
sorted_intersection( less, Lib.sort less Xs, Lib.sort less Ys )
fun sorted_intersections( less : 'a*'a->bool, Xss : 'a list list ) =3D
case Xss of
[] =3D> []
| _ =3D>
let fun g Xss =3D
case Xss of
[Xs] =3D> Xs
| Xs::Xss =3D> sorted_intersection( less, Xs, g Xss )
in
g Xss
end
fun list_insert(less,X,Xs) =3D
case Xs of
nil =3D> X::nil
| X1::Xs1 =3D> if less(X,X1) then X::X1::Xs1 else =
X1::list_insert(less,X,Xs1)
fun list_out(out : outstream, print : outstream * 'a -> unit, Xs : 'a =
list ) =3D
let fun p S =3D output(out,S)
in
p "[ "; (
case Xs of
nil =3D> ()
| _::_ =3D> (
loop( fn X =3D> ( print(out,X); p", " ), lt Xs );
print( out, dh Xs ) )
);
p " ]"
end
fun real_list_out(out : outstream, Xs : real list ) =3D
list_out( out, fn(Stream,X) =3D> output(Stream,Real.toString X), Xs)
fun int_list_out(out : outstream, Xs : int list ) =3D
list_out( out, fn(Stream,X) =3D> output(Stream,Int.toString X), Xs)
fun bool_list_out(out : outstream, Xs : bool list ) =3D
list_out( out, fn(Stream,X) =3D> output(Stream,Bool.toString X), Xs)
fun print_list(print : 'a -> unit, Xs : 'a list ) =3D
list_out(!std_out, fn(Stream,X) =3D> print X, Xs)
fun print_int_list( Xs : int list ) =3D
print_list( fn X =3D> output(!std_out,Int.toString X), Xs )
fun print_word32_list( Xs : Word32.word list ) =3D
print_list( fn X =3D> output(!std_out,Word32.toString X), Xs )
fun print_real_list( Xs : real list ) =3D
print_list( fn X =3D> output(!std_out,Real.toString X), Xs )
fun print_bool_list( Xs : bool list ) =3D
print_list( fn X =3D> output(!std_out,Bool.toString X), Xs )
fun print_bool_list_list( Xss : bool list list ) =3D
print_list(fn Xs =3D> (print_bool_list Xs; output(!std_out,"\n")), =
Xss)
fun print_int_opt NONE =3D p "NONE "
| print_int_opt( SOME X ) =3D p( "SOME " ^ Int.toString X ^ " " )
fun print_real_opt NONE =3D p "NONE "
| print_real_opt( SOME X ) =3D p( "SOME " ^ Real.toString X ^ " " )
fun scramble( Xs : 'a list ) : 'a list =3D
map(#1,
sort (fn ((_,X),(_,Y)) =3D> X<Y)
(combine(Xs,map(fn _ =3D> randReal(),fromto(1,length Xs)))))
exception rand_choice_exn
fun rand_choice( Xs : 'a list ) : 'a =3D
case Xs of [] =3D> raise rand_choice_exn | _ =3D>
nth( Xs, randRange( 0, length Xs -1 ) ) =20
(* List hashing function: *)
local
val N_rands =3D 10000
val Rand =3D Random.rand( 8362696, ~279264173 )
val next =3D fn() =3D> Random.randReal Rand
val Rand_vector : real vector =3D
Vector.tabulate( N_rands, fn I =3D> next() - 0.5 )
fun next_random Rand_vector_index =3D (
Rand_vector_index :=3D !Rand_vector_index + 1;
Vector.sub( Rand_vector, !Rand_vector_index )
)
handle Subscript =3D> (
Rand_vector_index :=3D ~1;
next_random Rand_vector_index
)
fun hash( Hash_val : real ref, Rand_vector_index : int ref, X : real ) =
: unit =3D
Hash_val :=3D 0.45243233 + X * next_random Rand_vector_index + =
!Hash_val
=20
in (* local *)
fun list_hash( f : 'a -> real, Xs : 'a list ) : real =3D=20
let
val Hash_val =3D ref 0.0 =20
val Rand_vector_index =3D ref ~1
in
loop( fn X =3D> hash( Hash_val, Rand_vector_index, f X ), Xs );
!Hash_val + 0.325454325
end
end (* local *)
end (* List1 *)
functor Hash_make_set_functor( H : MONO_HASH_TABLE ) :=20
sig
val hash_make_set : H.Key.hash_key list -> H.Key.hash_key list
end =3D
struct
exception Hash_make_set_exn
fun hash_make_set Xs =3D
let
val Table : unit H.hash_table =3D=20
H.mkTable( length Xs, Hash_make_set_exn )
in
List1.filter( fn X =3D>=20
case H.find Table X of
NONE =3D> ( H.insert Table (X,()); true )
| SOME _ =3D> false,
Xs )
end
end=20
=20
signature HASH_SET =3D
sig
structure Key : HASH_KEY
type item =3D Key.hash_key
structure H : MONO_HASH_TABLE
type set =3D unit H.hash_table
val empty : unit -> set
val insert : item * set -> unit
val delete : item * set -> unit
val list_to_set : item list -> set
val set_to_list : set -> item list=20
val member : item * set -> bool
val loop : (item -> 'a) * set -> unit
val singleton : item -> set=20
val union : set * set -> set
val intersection : set * set -> set
val difference : set * set -> set
val union_map : ('a -> set) * 'a list -> set
end=20
functor HashSet( Key : HASH_KEY ) : HASH_SET =3D
struct
structure Key =3D Key
type item =3D Key.hash_key
structure H =3D HashTableFn( Key )
type set =3D unit H.hash_table
exception HashSet_exn
fun empty() : set =3D H.mkTable( 10, HashSet_exn )
fun insert( X : item, Xs : set ) : unit =3D H.insert Xs ( X, () )
fun delete( X : item, Xs : set ) : unit =3D H.remove Xs X
fun list_to_set( Xs : item list ) : set =3D
let
val Ys =3D H.mkTable( length Xs, HashSet_exn )
in
List1.loop( fn X =3D> insert( X, Ys ), Xs );
Ys
end =20
fun set_to_list( Xs : set ) : item list =3D List1.map( #1, H.listItemsi =
Xs )
fun member( X : item, Xs : set ) : bool =3D
case H.find Xs X of NONE =3D> false | SOME _ =3D> true
fun loop( f, Xs ) =3D H.appi ( fn( X, () ) =3D> (f X; ()) ) Xs
=20
fun singleton( X : item ) : set =3D
case empty() of Xs =3D> ( insert( X, Xs ); Xs )
fun union( Xs : set, Ys : set ) : set =3D
let
val Zs =3D H.copy Xs
in
loop( fn Y =3D> insert( Y, Zs ), Ys );
Zs
end
=20
=20
fun intersection( Xs : set, Ys : set ) : set =3D
let
val Zs =3D empty()
in
loop( fn X =3D> if member( X, Ys ) then insert( X, Zs ) else (), Xs =
);
Zs
end
=20
=20
fun difference( Xs : set, Ys : set ) : set =3D
let
val Zs =3D empty()
in
loop( fn X =3D> if member( X, Ys ) then () else insert( X, Zs ), Xs =
);
Zs
end
=20
fun union_map( f : 'a -> set, Xs : 'a list ) =3D
case Xs of
[] =3D> empty()
| X :: Xs =3D> union( f X, union_map( f, Xs ) )
end (* functor HashSet *)
structure Int_set =3D HashSet( Lib.Int_hash_key )
structure Real_set =3D HashSet( Lib.Real_hash_key )
structure Tree =3D
struct
open List1
datatype 'a tree =3D tree_cons of 'a * 'a tree list
datatype 'a bin_tree =3D bt_nil | bt_cons of 'a * 'a bin_tree * 'a =
bin_tree
fun bt_map( f : 'a -> 'b, Xs : 'a bin_tree ) : 'b bin_tree =3D
case Xs of
bt_nil =3D> bt_nil
| bt_cons(RoXs,LeXs,RiXs) =3D>=20
bt_cons( f RoXs, bt_map(f,LeXs), bt_map(f,RiXs) )
fun is_leaf( tree_cons(_,Subs) ) =3D null(Subs);
fun root( tree_cons(Root,_) ) =3D Root;
fun subs( tree_cons(_,Subs) ) =3D Subs;
fun preorder( tree_cons(X,Xs) : 'a tree ) : 'a list =3D
X::flat_map(preorder,Xs)
fun leaves( tree_cons(X,Xs) : 'a tree ) : 'a list =3D
case Xs of
nil =3D> X::nil
| _ =3D> flat_map(leaves,Xs)
fun positions( tree_cons(Root,Subs) : 'a tree ) : int list list =3D
[]::flat_map( fn (Order_no,Sub_pos_list) =3D>
map( fn Sub_pos =3D> Order_no::Sub_pos, Sub_pos_list =
),
combine( fromto(0,length(Subs)-1), map(positions,Subs) =
)
)
fun pos_to_sub( T as tree_cons(Root,Subs) : 'a tree, Pos : int list )
: 'a tree =3D
case Pos of
nil =3D> T
| P::Ps =3D> pos_to_sub(nth(Subs,P),Ps)
fun pos_replace( Old as tree_cons(Root,Subs), Pos : int list, New )
: 'a tree =3D
case Pos of
nil =3D> New
| P::Ps =3D>
tree_cons(
Root,
list_replace( Subs, P, pos_replace(nth(Subs,P),Ps,New) )
)
fun add_sub_right( T : 'a tree, Pos : int list, Sub : 'a tree)
: 'a tree =3D
let val tree_cons(X,Xs) =3D pos_to_sub(T,Pos)
in
pos_replace( T, Pos, tree_cons(X,snoc(Xs,Sub)) )
end
end (* structure Tree *)
(*
require "basis.__vector";
require "basis.__array";
require "basis.__list";
require "basis.__string";
require "basis.__int";
require "basis.__word";
require "hash-table-sig.sml";
require "hash-table.sml";
require "dynamic-array-sig.sml";
require "dynamic-array.sml";
require "lib.sml";
*)
(* File: ast.sml
Created: 1993-05-21
Modified: 1996-08-06
*)
signature AST =3D
sig
datatype symbol_category =3D=20
func_sym | var_sym | emb_sym | not_activated_sym | dont_know_sym=20
| ty_var_sym | ty_con_sym | int_sym
val symbol_category_to_string : symbol_category -> string
val string_to_symbol_category : string -> symbol_category=20
type symbol =3D symbol_category*Word.word*Word.word
val symbol_hash : symbol -> Word.word
val real_symbol_hash : symbol -> real
val string_to_symbol : symbol_category * string -> symbol
val string_to_symbol' : string -> symbol
val string_to_qsymbol : string -> symbol
val symbol_to_string : symbol -> string
val get_predefined_syms : unit -> symbol list
val symbol_less : symbol * symbol -> bool
val int_to_symbol : int -> symbol
val int_sym_to_int : symbol -> int
structure Symbol_hash_key : HASH_KEY
structure Symbol_HashTable : MONO_HASH_TABLE
structure Symbol_dyn : MONO_DYNAMIC_ARRAY
type ty_var =3D symbol
datatype ty_exp =3D
ty_var_exp of ty_var
| ty_con_exp of symbol * ty_exp list
type ty_schema =3D { schematic_vars : ty_var list, ty_exp : ty_exp }
(* See Peyton-Jones book for documentation of this type *)
type ty_env =3D (symbol * ty_schema) list
datatype ('a,'b)e =3D
app_exp of { func : symbol, args : ('a,'b)e list, exp_info : 'a }
| case_exp of {=20
exp : ('a,'b)e,=20
rules : {
pat:('a,'b)e,
exp:('a,'b)e,
act_index : int ref,
act_count : int ref,
activated : bool ref
} list,
exp_info : 'a=20
}
| let_exp of {=20
dec_list : {=20
func : symbol,=20
pat : ('a,'b)e,=20
exp:('a,'b)e,
dec_info : 'b
} list,
exp : ('a,'b)e,
exp_info : 'a=20
}
| as_exp of { var : symbol, pat : ('a,'b)e, exp_info : 'a }
type ('a,'b)rule_type =3D {
pat:('a,'b)e,
exp:('a,'b)e,
act_index : int ref,
act_count : int ref,
activated : bool ref
}=20
type ('a,'b)d =3D {=20
func : symbol,=20
pat : ('a,'b)e,=20
exp : ('a,'b)e,=20
dec_info : 'b=20
}
val set_exp : ('a,'b)d * ('a,'b)e -> ('a,'b)d
type exp_info_type =3D ty_exp
type dec_info_type =3D ty_schema
val no_exp_info : unit -> exp_info_type
val no_dec_info : unit -> ty_schema
val is_no_exp_info : exp_info_type -> bool
val is_no_dec_info : dec_info_type -> bool
val mk_exp_info : ty_exp -> exp_info_type
val get_ty_exp : exp_info_type -> ty_exp
val set_ty_exp : exp_info_type * ty_exp -> exp_info_type
val mk_rule : ('a,'b)rule_type * ('c,'d)e * ('c,'d)e -> =
('c,'d)rule_type
val mk_new_rule : ('a,'b)e * ('a,'b)e -> ('a,'b)rule_type
type exp =3D ( exp_info_type, dec_info_type )e
type pat=3Dexp
type dec =3D ( exp_info_type, dec_info_type )d
type datatype_dec =3D {
ty_con : symbol,
ty_pars : ty_var list,
alts : { constr : symbol, domain : ty_exp option } list
}
type type_dec =3D {
ty_con : symbol,
ty_pars : ty_var list,
ty_exp : ty_exp=20
}
datatype parse_result =3D
parsed_fun of dec list
| parsed_type of type_dec
| parsed_datatype of datatype_dec list
val TUPLE : symbol
val TUPLE_TY_CON : symbol
val INT : symbol
val BOOL : symbol
val INPUT_TYPE : symbol
val OUTPUT_TYPE : symbol
val THIN_ARROW : symbol
val PREDEFINED_NOT_ACTIVATED_SYMBOL : symbol
val EQ : symbol
val SEMICOLON : symbol
val LESS' : symbol
val PLUS : symbol
val MUL : symbol
val DIV : symbol
val MINUS : symbol
val UMINUS : symbol
val CONS : symbol
val APPEND : symbol
val FALSE : symbol
val TRUE : symbol
val F : symbol
val ANON : symbol
val DUMMY_FUNC : symbol
val DUMMY_TY_CON : symbol
val DUMMY_SYMBOL : symbol
val dummy_exp : 'a -> ('a,'b)e
val Dummy_exp : exp
val Dummy_dec : dec
val Dummy_ty_exp : ty_exp
val Dummy_ty_schema : ty_schema
val type_of_exp : exp -> ty_exp
val is_predefined_sym : symbol -> bool
val is_generated_sym : symbol -> bool
val is_int : symbol -> bool
val is_int_exp : ('a,'b)e -> bool
val is_variable : symbol -> bool
val is_ty_var : symbol -> bool
val is_variable_exp : ('a,'b)e -> bool
val is_function : symbol -> bool
val is_q : symbol -> bool
val is_q_exp : ('a,'b)e -> bool
val is_not_activated_sym : symbol -> bool
val is_not_activated_exp : ('a,'b)e -> bool
val is_not_activated_rule : ('a,'b)rule_type -> bool
val is_emb_exp : ('a,'b)e -> bool
val is_dont_know_exp : ('a,'b)e -> bool
val is_app_exp : ('a,'b)e -> bool
val is_case_exp : ('a,'b)e -> bool
val is_let_exp : ('a,'b)e -> bool
val is_leaf : ('a,'b)e -> bool
val is_tuple_exp : ('a,'b)e -> bool
val is_anon_sym : symbol -> bool
val is_anon_exp : ('a,'b)e -> bool
val is_fun_type : ty_exp -> bool
val is_tuple_type : ty_exp -> bool
val sym_no : unit -> word * word
val set_sym_no : word * word -> unit
val gen_func_sym : unit -> symbol
val gen_ty_var_sym : unit -> symbol
val gen_var_sym : unit -> symbol
val gen_var_exp : 'a -> ('a,'b) e
val gen_emb_sym : unit -> symbol
val gen_emb_exp : 'a -> ('a,'b) e
val gen_not_activated_sym : unit -> symbol
val gen_not_activated_exp : 'a -> ('a,'b) e
val gen_dont_know_sym : unit -> symbol
val gen_dont_know_exp : 'a -> ('a,'b) e
val mk_anon_exp : 'a -> ('a,'b)e
val vars_in_ty_exp : ty_exp -> ty_var list
val ty_cons_in_ty_exp : ty_exp -> symbol list
val vars_in_pure_tuple_pat : ('a,'b)e -> symbol list
val vars_in_pat : ('a,'b)e -> symbol list
val var_exps_in_pat : ('a,'b)e -> ('a,'b)e list=20
val get_exp_info : ('a,'b)e -> 'a
val set_exp_info : ('a,'b)e * 'a -> ('a,'b)e
val exp_size : ('a,'b)e -> int
val rename : ('a,'b)e * bool -> ('a,'b)e=20
val rename_decs : ('a,'b)d list * bool -> ('a,'b)d list
val Debug : bool ref
val print_syms : symbol list -> unit
end (* sig AST *)
structure Ast : AST =3D
struct
open Lib
open List1
datatype symbol_category =3D=20
func_sym | var_sym | emb_sym | not_activated_sym | dont_know_sym=20
| ty_var_sym | ty_con_sym | int_sym
fun symbol_category_to_string( X : symbol_category ) =3D
case X of
func_sym =3D> "func_sym"
| var_sym =3D> "var_sym"
| emb_sym =3D> "emb_sym"
| not_activated_sym =3D> "not_activated_sym"
| dont_know_sym =3D> "dont_know_sym"
| ty_var_sym =3D> "ty_var_sym"
| ty_con_sym =3D> "ty_con_sym"=20
| int_sym =3D> "int_sym"
fun string_to_symbol_category( X : string ) =3D
case X of
"func_sym" =3D> func_sym
| "var_sym" =3D> var_sym
| "emb_sym" =3D> emb_sym
| "not_activated_sym" =3D> not_activated_sym
| "dont_know_sym" =3D> dont_know_sym
| "ty_var_sym" =3D> ty_var_sym
| "ty_con_sym" =3D> ty_con_sym
| "int_sym" =3D> int_sym
type symbol =3D symbol_category*word*word
(*=20
A symbol (Cat,0,N) represents a predefined identifier.
A symbol of the form (Cat,1,N) is used for canonization.
A symbol (Cat,M,N) with M>=3D2 represents a generated identifier.
*)
fun is_predefined_sym(Cat,M,N) =3D M =3D Word.fromInt 0
fun is_generated_sym(Cat,M,N) =3D M >=3D Word.fromInt 2
exception Symbol_HashTable_exn
structure H =3D Lib.String_HashTable
val Symbol_table : symbol H.hash_table =3D=20
(*=20
Maps a string (predefined identifier) to the corresponding=20
symbol.=20
*)
H.mkTable(1000,Symbol_HashTable_exn)
fun get_predefined_syms() : symbol list =3D
map( #2, H.listItemsi Symbol_table )
structure String_dyn =3D DynamicArrayFn(
struct
open Array
type elem =3D string
type vector =3D elem Vector.vector
type array =3D string array
structure Vector =3D=20
struct
open Vector
type elem =3D string
type vector =3D elem Vector.vector
end
end=20
)
val String_table: String_dyn.array =3D=20
String_dyn.array(2,"UNDEFINED SYMBOL")
val Top : int ref =3D ref 0
fun string_to_symbol( Cat : symbol_category, S : string ) : symbol =3D
(*
Inserts S in the next free entry in array of predefined symbols
if S is an unseen symbol.
*)
case H.find Symbol_table S of
SOME Sym =3D> Sym
| NONE =3D> (
String_dyn.update( String_table, !Top, S );
let val Sym =3D ( Cat, Word.fromInt 0, Word.fromInt(!Top) ) in
H.insert Symbol_table (S,Sym);
inc Top;
Sym
end
)
fun string_to_symbol'( S : string ) : symbol =3D
case String.explode S of
#"?" :: #"_" :: #"E" :: #"M" :: #"B" :: _ =3D>
string_to_symbol( emb_sym, S )
| #"?" :: #"_" :: #"D" :: _ =3D>
string_to_symbol( dont_know_sym, S )
| #"?" :: #"_" :: #"N" :: #"A" :: _ =3D>
string_to_symbol( not_activated_sym, S )
| _ =3D> string_to_symbol( func_sym, S )
exception String_to_qsymbol_exn
fun string_to_qsymbol( S : string ) : symbol =3D
case String.explode S of
#"E" :: #"M" :: #"B" :: _ =3D>
string_to_symbol( emb_sym, S )
| #"D" :: _ =3D>
string_to_symbol( dont_know_sym, S )
| #"N" :: #"A" :: _ =3D>
string_to_symbol( not_activated_sym, S )
| #"?" :: #"_" :: #"E" :: #"M" :: #"B" :: _ =3D>
string_to_symbol( emb_sym, S )
| #"?" :: #"_" :: #"D" :: _ =3D>
string_to_symbol( dont_know_sym, S )
| #"?" :: #"_" :: #"N" :: #"A" :: _ =3D>
string_to_symbol( not_activated_sym, S )
| _ =3D> (
output( !std_err, "\nIllegal exception name:" ^ S ^
"\nExceptions must start with EMB, D or NA.\n\n");
raise String_to_qsymbol_exn
)
fun is_q(Cat,_,_) =3D
case Cat of=20
emb_sym =3D> true
| not_activated_sym =3D> true
| dont_know_sym =3D> true
| _ =3D> false=20
=20
fun symbol_to_string( Sym as (Cat,M,N) : symbol ) : string =3D
if is_predefined_sym Sym then
(if is_q Sym then "(raise " else "") ^
String_dyn.sub( String_table, Word.toInt N) ^
(if is_q Sym then ")" else "")
else
let val Suffix =3D Word.toString M ^ "_" ^ Word.toString N in
case Cat of
func_sym =3D> "g" ^ Suffix
| var_sym =3D> "V" ^ Suffix
| not_activated_sym =3D> "(raise NA_" ^ Suffix ^ ")"
| emb_sym =3D> "(raise EMB_" ^ Suffix ^ ")"
| dont_know_sym =3D> "(raise D_" ^ Suffix ^ ")"
| ty_var_sym =3D> "'" ^ Suffix
| ty_con_sym =3D> "c" ^ Suffix
| int_sym =3D> Int.toString( Word.toIntX N )
end
fun symbol_less( (_,M1,N1) : symbol, (_,M2,N2) : symbol ) : bool =3D
Word.<(M1,M2) orelse M1=3DM2 andalso Word.<(N1,N2)
fun int_to_symbol( N : int ) : symbol =3D
( int_sym, Word.fromInt(~1), Word.fromInt N )
fun int_sym_to_int( (int_sym,_,N) : symbol ) : int =3D
Word.toIntX N
=20
type ty_var =3D symbol
datatype ty_exp =3D
ty_var_exp of ty_var
| ty_con_exp of symbol * ty_exp list
type ty_schema =3D { schematic_vars : ty_var list, ty_exp : ty_exp }
(* See Peyton-Jones book for documentation of this type *)
type ty_env =3D (symbol * ty_schema) list
datatype ('a,'b)e =3D
app_exp of { func : symbol, args : ('a,'b)e list, exp_info : 'a }
| case_exp of {=20
exp : ('a,'b)e,=20
rules : {
pat:('a,'b)e,
exp:('a,'b)e,
act_index : int ref,
act_count : int ref,
activated : bool ref
} list,
exp_info : 'a=20
}
| let_exp of {=20
dec_list : {=20
func : symbol,=20
pat : ('a,'b)e,=20
exp:('a,'b)e,
dec_info : 'b
} list,
exp : ('a,'b)e,
exp_info : 'a=20
}
| as_exp of { var : symbol, pat : ('a,'b)e, exp_info : 'a }
type ('a,'b)rule_type =3D {
pat:('a,'b)e,
exp:('a,'b)e,
act_index : int ref,
act_count : int ref,
activated : bool ref
}=20
type ('a,'b)d =3D {=20
func : symbol,=20
pat : ('a,'b)e,=20
exp : ('a,'b)e,=20
dec_info : 'b=20
}
fun set_exp( { func, pat, exp, dec_info } : ('a,'b)d, E : ('a,'b)e )
: ('a,'b)d =3D
{ func =3D func, pat =3D pat, exp =3D E, dec_info =3D dec_info }
type exp_info_type =3D ty_exp
type dec_info_type =3D ty_schema
fun get_ty_exp TE =3D TE
fun set_ty_exp( _, TE ) =3D TE=20
fun mk_rule( { act_index, act_count, activated, ... } : =
('a,'b)rule_type,
Pat : ('c,'d)e, E : ('c,'d)e ) =3D {
pat =3D Pat,
exp =3D E,
act_index =3D ref( !act_index ),
act_count =3D ref( !act_count ),
activated =3D ref( !activated )
}
fun mk_new_rule( Pat : ('a,'b)e, E : ('a,'b)e ) =3D {
pat =3D Pat,
exp =3D E,
act_index =3D ref 0,
act_count =3D ref 0,
activated =3D ref false
}
type exp =3D ( exp_info_type, dec_info_type )e
type pat=3Dexp
type dec =3D ( exp_info_type, dec_info_type )d
type datatype_dec =3D {
ty_con : symbol,
ty_pars : ty_var list,
alts : { constr : symbol, domain : ty_exp option } list
}
type type_dec =3D {
ty_con : symbol,
ty_pars : ty_var list,
ty_exp : ty_exp=20
}
datatype parse_result =3D
parsed_fun of dec list
| parsed_type of type_dec
| parsed_datatype of datatype_dec list
val TUPLE =3D string_to_symbol( func_sym, "___tuple" )
val TUPLE_TY_CON =3D string_to_symbol( ty_con_sym, "___tuple" )
val INT =3D string_to_symbol( ty_con_sym, "int" )
val BOOL =3D string_to_symbol( ty_con_sym, "bool" )
val INPUT_TYPE =3D string_to_symbol( ty_con_sym, "input_type" )
val OUTPUT_TYPE =3D string_to_symbol( ty_con_sym, "output_type" )
val THIN_ARROW =3D string_to_symbol( ty_con_sym, "->" )
val PREDEFINED_NOT_ACTIVATED_SYMBOL =3D string_to_symbol( =
not_activated_sym, "?_NA_PREDEFINED" )
val EQ =3D string_to_symbol( func_sym, "=3D" )
val SEMICOLON =3D string_to_symbol( func_sym, ";" )
val LESS' =3D string_to_symbol( func_sym, "<" )
val PLUS =3D string_to_symbol( func_sym, "+" )
val MUL =3D string_to_symbol( func_sym, "*" )
val DIV =3D string_to_symbol( func_sym, "/" )
val MINUS =3D string_to_symbol( func_sym, "-" )
val UMINUS =3D string_to_symbol( func_sym, "~" )
val CONS =3D string_to_symbol( func_sym, "::" )
val APPEND =3D string_to_symbol( func_sym, "@" )
val FALSE =3D string_to_symbol( func_sym, "false" )
val TRUE =3D string_to_symbol( func_sym, "true" )
val ANON =3D string_to_symbol( func_sym, "_" )
val F =3D string_to_symbol( func_sym, "f" )
val DUMMY_FUNC =3D string_to_symbol( func_sym, "___dummy" )
val DUMMY_SYMBOL =3D DUMMY_FUNC
val DUMMY_TY_CON =3D string_to_symbol( ty_con_sym, "___dummy_ty_con" )
val Dummy_ty_exp =3D ty_con_exp( DUMMY_TY_CON, [] )
fun dummy_exp(Exp_info : 'a) : ('a,'b)e =3D=20
app_exp{
func=3DDUMMY_FUNC,
args=3Dnil,
exp_info=3DExp_info
}
val Dummy_exp : exp =3D dummy_exp Dummy_ty_exp
val Dummy_ty_schema =3D { schematic_vars =3D [], ty_exp =3D =
Dummy_ty_exp }
val Dummy_dec : dec =3D {
func=3DDUMMY_FUNC,
pat=3DDummy_exp,
exp=3DDummy_exp,
dec_info=3DDummy_ty_schema
}
fun no_exp_info() =3D Dummy_ty_exp
fun no_dec_info() =3D Dummy_ty_schema
fun is_no_exp_info TE =3D TE =3D no_exp_info()
fun is_no_dec_info Sch =3D Sch =3D no_dec_info()
fun mk_exp_info TE =3D TE
fun is_int(int_sym,_,_) =3D true
| is_int _ =3D false
fun is_int_exp( app_exp{ func, ... } : ('a,'b)e ) =3D is_int func
| is_int_exp _ =3D false
fun is_variable(var_sym,_,_) =3D true
| is_variable _ =3D false
fun is_ty_var(ty_var_sym,_,_) =3D true
| is_ty_var(_,_,_) =3D false
fun is_variable_exp( app_exp{ func, ... } ) =3D is_variable func
| is_variable_exp _ =3D false
fun is_function(func_sym,_,_) =3D true
| is_function _ =3D false
fun is_q_exp( app_exp{ func, ... } : ('a,'b)e ) =3D is_q func
| is_q_exp _ =3D false
fun is_emb_exp(=20
app_exp{ func=3D(emb_sym,_,_), ... } : ('a,'b)e ) =3D=20
true
| is_emb_exp _ =3D false
fun is_not_activated_sym( (not_activated_sym,_,_) ) =3D true
| is_not_activated_sym _ =3D false
fun is_not_activated_exp(=20
app_exp{ func=3D(not_activated_sym,_,_), ... } : ('a,'b)e ) =3D=20
true
| is_not_activated_exp _ =3D false
fun is_not_activated_rule( { exp, ... } : ('a,'b) rule_type ) =3D
is_not_activated_exp exp
fun is_dont_know_exp(=20
app_exp{ func=3D(dont_know_sym,_,_), ... } : ('a,'b)e ) =3D true
| is_dont_know_exp _ =3D false
fun is_app_exp( app_exp{...} ) =3D true
| is_app_exp _ =3D false
fun is_case_exp(case_exp{...}) =3D true
| is_case_exp _ =3D false
fun is_let_exp(let_exp{...}) =3D true
| is_let_exp _ =3D false
fun is_leaf( app_exp{args=3Dnil,...}:('a,'b)e ) =3D true
| is_leaf E =3D is_q_exp E
fun is_tuple_exp( app_exp{ func, ... } : ('a,'b)e ) =3D func=3DTUPLE
| is_tuple_exp _ =3D false
fun is_anon_sym S =3D S =3D ANON
exception Is_anon_exp_exn
fun is_anon_exp( app_exp{ func, args, ... } :('a,'b)e ) =3D=20
if null args then
is_anon_sym func
else
raise Is_anon_exp_exn
| is_anon_exp _ =3D false
fun is_fun_type( ty_con_exp( Ty_con, _ ) ) =3D Ty_con =3D THIN_ARROW
| is_fun_type _ =3D false
fun is_tuple_type( ty_con_exp( Ty_con, _ ) ) =3D Ty_con =3D =
TUPLE_TY_CON
| is_tuple_type _ =3D false
local
val Current_sym_no =3D ref( Word.fromInt 0 )=20
val Current_sym_no' =3D ref( Word.fromInt 2 )
in
exception Sym_no
fun sym_no() =3D (=20
word_inc Current_sym_no;
if Word.>=3D( !Current_sym_no, Lib.Max_word ) then (
Current_sym_no :=3D Word.fromInt 1;
word_inc Current_sym_no';
if Word.>=3D( !Current_sym_no', Lib.Max_word ) then=20
raise Sym_no=20
else=20
()
)
else
();
( !Current_sym_no', !Current_sym_no )
)
fun set_sym_no( No', No ) =3D (
Current_sym_no :=3D No;
Current_sym_no' :=3D No'
)
end (* local *)
fun gen_var_sym() =3D=20
case sym_no() of (M,N) =3D> (var_sym,M,N)
fun gen_ty_var_sym() =3D=20
case sym_no() of (M,N) =3D> (ty_var_sym,M,N)
fun gen_func_sym() =3D=20
case sym_no() of (M,N) =3D> (func_sym,M,N)
fun gen_emb_sym() =3D=20
case sym_no() of (M,N) =3D> (emb_sym,M,N)
fun gen_not_activated_sym() =3D=20
case sym_no() of (M,N) =3D> (not_activated_sym,M,N)
fun gen_dont_know_sym() =3D=20
case sym_no() of (M,N) =3D> (dont_know_sym,M,N)
fun gen_var_exp(Exp_info) =3D
app_exp{func=3Dgen_var_sym(),args=3Dnil,exp_info=3DExp_info }
fun mk_anon_exp(Exp_info) =3D
app_exp{func=3DANON,args=3Dnil,exp_info=3DExp_info }
fun gen_not_activated_exp(Exp_info) =3D
app_exp{func=3Dgen_not_activated_sym(),args=3Dnil,exp_info=3DExp_info =
}
fun gen_dont_know_exp(Exp_info) =3D
app_exp{func=3Dgen_dont_know_sym(),args=3Dnil,exp_info=3DExp_info }
fun gen_emb_exp(Exp_info) =3D
app_exp{func=3Dgen_emb_sym(),args=3Dnil,exp_info=3DExp_info }
fun vars_in_ty_exp TE =3D
let fun vars_in_ty_exp1 TE =3D
case TE of ty_var_exp N =3D> N::nil
| ty_con_exp(F,TEs) =3D> flat_map( vars_in_ty_exp1, TEs )
in
make_set(vars_in_ty_exp1 TE)
end
fun ty_cons_in_ty_exp TE =3D
let fun ty_cons_in_ty_exp1 TE =3D
case TE of =20
ty_var_exp _ =3D> nil
| ty_con_exp(F,TEs) =3D> F :: flat_map( ty_cons_in_ty_exp1, TEs )
in
make_set(ty_cons_in_ty_exp1 TE)
end
exception Vars_in_pure_tuple_pat_exn
fun vars_in_pure_tuple_pat P =3D (
case P of
app_exp{func,args=3Dnil,...} =3D>
if is_variable func then
func::nil
else
raise Vars_in_pure_tuple_pat_exn
| app_exp{func,args,...} =3D>=20
if func =3D TUPLE then (
loop( fn app_exp{ func =3D V, args=3D[], ... } =3D>
if is_variable V then () else raise =
Vars_in_pure_tuple_pat_exn
| _ =3D> raise Vars_in_pure_tuple_pat_exn,
args );
map( fn app_exp{ func, ... } =3D> func, args )
)
else
raise Vars_in_pure_tuple_pat_exn )
=20
fun vars_in_pat P =3D
case P of
app_exp{func,args=3Dnil,...} =3D>
if is_variable func then
func::nil
else
nil
| app_exp{func,args,...} =3D> flat_map(vars_in_pat,args)
| as_exp{var,pat,...} =3D> var::vars_in_pat(pat)
fun var_exps_in_pat P =3D
case P of
app_exp{func,args=3Dnil,...} =3D>
if is_variable func then
P::nil
else
nil
| app_exp{func,args,...} =3D> flat_map(var_exps_in_pat,args)
| as_exp{var,pat,exp_info} =3D>=20
app_exp{func=3Dvar,args=3Dnil,exp_info=3Dexp_info}::
var_exps_in_pat pat=20
fun symbol_hash( (Cat,M,N) : symbol ) =3D=20
Word.xorb(
case Cat of func_sym =3D> 0w1 | var_sym =3D> 0w2 | _ =3D> 0w4,
Word.xorb(M,N) )
fun real_symbol_hash( (Cat,M,N) : symbol ) : real =3D=20
( case Cat of=20
func_sym =3D> 0.456343233453663769848=20
| var_sym =3D> 0.8349187367352156128437628=20
| _ =3D> 0.92764352345272984378327
)=20
*=20
( normrealhash( real( Word.toIntX M ) ) +=20
normrealhash( real( Word.toIntX N ) ) )
structure Symbol_hash_key =3D
struct
type hash_key=3Dsymbol
val hashVal =3D symbol_hash
fun sameKey(X,Y:symbol)=3D X=3DY
end
structure Symbol_HashTable =3D HashTableFn(Symbol_hash_key)
structure Symbol_dyn =3D DynamicArrayFn(
struct
open Array
type elem =3D symbol
type vector =3D symbol Vector.vector
type array =3D symbol array
structure Vector =3D
struct
open Vector
type elem =3D symbol
type vector =3D symbol Vector.vector
end
end=20
)
fun get_exp_info E =3D
case E of
app_exp {exp_info,...} =3D> exp_info
| case_exp {exp_info,...} =3D> exp_info
| let_exp {exp_info,...} =3D> exp_info
| as_exp {exp_info,...} =3D> exp_info
fun set_exp_info( E, Info ) =3D
case E of
app_exp { func, args, ... } =3D>=20
app_exp{ func =3D func, args =3D args, exp_info =3D Info }
| case_exp { exp, rules, ... } =3D>
case_exp{ exp =3D exp, rules =3D rules, exp_info =3D Info }
| let_exp { dec_list, exp, ... } =3D>
let_exp{ dec_list =3D dec_list, exp =3D exp, exp_info =3D Info }
| as_exp { var, pat, ... } =3D>=20
as_exp{ var =3D var, pat =3D pat, exp_info =3D Info }
fun type_of_exp E =3D get_ty_exp(get_exp_info E)
fun exp_size( E : ('a,'b)e ) =3D=20
case E of
app_exp{ args, ... } =3D> 1 + int_sum(map(exp_size,args))
| case_exp{ exp, rules, ... } =3D>
1 + exp_size exp + int_sum(map(exp_size,map(#exp,rules)))
| let_exp { dec_list, exp, ... } =3D>
1 + exp_size exp + int_sum(map(exp_size,map(#exp,dec_list)))
| as_exp{ pat, ... } =3D> 1 + exp_size pat
local
exception Rename
exception Rename_hash
structure H =3D Symbol_HashTable
in
fun rename( E : ('a,'b)e, Canonize : bool ) : ('a,'b)e =3D
let
val Curr_no =3D ref(Word.fromInt 0)
fun sym_no() =3D (word_inc Curr_no; (Word.fromInt 1,!Curr_no) )
val gen_var_sym =3D=20
if Canonize then=20
fn() =3D> case sym_no() of (M,N) =3D> (var_sym,M,N)
else=20
gen_var_sym
val gen_func_sym =3D=20
if Canonize then=20
fn() =3D> case sym_no() of (M,N) =3D> (func_sym,M,N)
else=20
gen_func_sym
val gen_not_activated_sym =3D=20
if Canonize then=20
fn() =3D> case sym_no() of (M,N) =3D> (not_activated_sym,M,N)
else=20
gen_not_activated_sym
val gen_dont_know_sym =3D=20
if Canonize then=20
fn() =3D> case sym_no() of (M,N) =3D> (dont_know_sym,M,N)
else=20
gen_dont_know_sym
val gen_var_exp =3D
if Canonize then=20
fn Exp_info =3D>=20
app_exp{func=3Dgen_var_sym(),args=3Dnil,exp_info=3DExp_info }
else
gen_var_exp
val gen_not_activated_exp =3D=20
if Canonize then=20
fn Exp_info =3D>=20
app_exp{func=3Dgen_not_activated_sym(),
args=3Dnil,exp_info=3DExp_info }
else
gen_not_activated_exp
val gen_dont_know_exp =3D
if Canonize then=20
fn Exp_info =3D>=20
app_exp{func=3Dgen_dont_know_sym(),
args=3Dnil,exp_info=3DExp_info }
else
gen_dont_know_exp
=20
val Table : symbol list H.hash_table =3D=20
H.mkTable( 3 * exp_size E, Rename_hash )
fun insert S =3D=20
let=20
val Sym =3D
if is_variable S then gen_var_sym() else gen_func_sym()=20
in
case H.find Table S of
NONE =3D> H.insert Table ( S, [Sym] )
| SOME Xs =3D> H.insert Table ( S, Sym::Xs )
end
fun delete( S : symbol ) : unit =3D
let=20
val Sym::Xs =3D H.lookup Table S
in
case Xs of
[] =3D> ( H.remove Table S; () )
| _ =3D> H.insert Table ( S, Xs )
end
fun replace( S : symbol) : symbol =3D=20
case H.find Table S of NONE =3D> S | SOME( S :: _ ) =3D> S
=20
fun insert_pat Pat =3D ( map(insert,vars_in_pat Pat); () )
fun delete_pat Pat =3D ( map(delete,vars_in_pat Pat); () )
fun rename E =3D
case E of
app_exp{func,args,exp_info} =3D>
if is_q_exp E then
if is_dont_know_exp E then
gen_dont_know_exp exp_info
else if is_not_activated_exp E then
gen_not_activated_exp exp_info
else
raise Rename
else
app_exp{ func=3Dreplace func, args=3Dmap(rename,args), =
exp_info=3Dexp_info }
| case_exp{exp,rules,exp_info} =3D> case_exp{ exp=3Drename exp, =
rules=3D
map( fn Rule as {pat,exp,...} =3D>
let=20
val _ =3D insert_pat pat;
val X =3D mk_rule(Rule,rename pat,rename exp)
in
delete_pat pat;
X
end,
rules ),
exp_info=3Dexp_info }
| let_exp{ dec_list, exp, exp_info } =3D>=20
let
val _ =3D map( fn { func, ... } =3D> insert func, dec_list )
val Ds =3D map( fn { func, pat, exp, dec_info } =3D>=20
let
val _ =3D insert_pat pat
val D =3D {
func =3D replace func,
pat =3D rename pat,
exp =3D rename exp,
dec_info =3D dec_info
}
in
delete_pat pat;
D
end,
dec_list )
val LE =3D let_exp{ dec_list =3D Ds, exp =3D rename exp,
exp_info =3D exp_info }
in
map( fn { func, ... } =3D> delete func, dec_list );
LE
end
| as_exp{var,pat,exp_info} =3D>=20
as_exp{ var=3Dreplace var, pat=3Drename pat, exp_info=3Dexp_info =
}
in
rename E
end
end (* local *)
fun rename_decs( Ds : ('a,'b)d list, Canonize : bool )=20
: ('a,'b)d list =3D
case Ds of
[] =3D> []
| D::_ =3D>
let
val Dummy_e =3D #exp D
in
case rename(=20
let_exp{
dec_list =3D Ds,
exp =3D Dummy_e,
exp_info =3D get_exp_info Dummy_e=20
},
Canonize ) of
let_exp{ dec_list, ... } =3D> dec_list
end
val Debug =3D ref false
fun print_syms Syms =3D list_out(
!std_out,
fn (Str,Sym) =3D> output( Str, symbol_to_string Sym ),
Syms )
end (* structure Ast *)
signature ML_TOKENS =3D
sig
type ('a,'b) token
type svalue
val EOF: 'a * 'a -> (svalue,'a) token
val ID: (string) * 'a * 'a -> (svalue,'a) token
val INT: (int) * 'a * 'a -> (svalue,'a) token
val EXCEPTION: 'a * 'a -> (svalue,'a) token
val RAISE: 'a * 'a -> (svalue,'a) token
val APPEND: 'a * 'a -> (svalue,'a) token
val CONS: 'a * 'a -> (svalue,'a) token
val COLON: 'a * 'a -> (svalue,'a) token
val PRIME: 'a * 'a -> (svalue,'a) token
val MINUS: 'a * 'a -> (svalue,'a) token
val DIV: 'a * 'a -> (svalue,'a) token
val MUL: 'a * 'a -> (svalue,'a) token
val PLUS: 'a * 'a -> (svalue,'a) token
val LESS': 'a * 'a -> (svalue,'a) token
val EQ: 'a * 'a -> (svalue,'a) token
val SEMICOLON: 'a * 'a -> (svalue,'a) token
val COMMA: 'a * 'a -> (svalue,'a) token
val THIN_ARROW: 'a * 'a -> (svalue,'a) token
val ARROW: 'a * 'a -> (svalue,'a) token
val VBAR: 'a * 'a -> (svalue,'a) token
val RPAR: 'a * 'a -> (svalue,'a) token
val LPAR: 'a * 'a -> (svalue,'a) token
val AS: 'a * 'a -> (svalue,'a) token
val OF: 'a * 'a -> (svalue,'a) token
val CASE: 'a * 'a -> (svalue,'a) token
val END: 'a * 'a -> (svalue,'a) token
val IN: 'a * 'a -> (svalue,'a) token
val LET: 'a * 'a -> (svalue,'a) token
val AND: 'a * 'a -> (svalue,'a) token
val TYPE: 'a * 'a -> (svalue,'a) token
val DATATYPE: 'a * 'a -> (svalue,'a) token
val VAL: 'a * 'a -> (svalue,'a) token
val FUN: 'a * 'a -> (svalue,'a) token
end
signature ML_LRVALS=3D
sig
structure Tokens : ML_TOKENS
structure ParserData:PARSER_DATA
sharing type ParserData.Token.token =3D Tokens.token
sharing type ParserData.svalue =3D Tokens.svalue
end
functor MLLrValsFun (structure Token : TOKEN) : ML_LRVALS =3D=20
struct
structure ParserData=3D
struct
structure Header =3D=20
struct
(* File: ML.grm=20
Created: 1993-05-26
Modified: 1996-06-02
*)
end
structure LrTable =3D Token.LrTable
structure Token =3D Token
local open LrTable in=20
val table=3Dlet val actionRows =3D
"\
\\001\000\001\000\202\000\003\000\202\000\004\000\202\000\005\000\202\00=
0\
\\007\000\202\000\008\000\202\000\010\000\202\000\013\000\202\000\
\\014\000\202\000\017\000\202\000\018\000\202\000\021\000\084\000\
\\022\000\083\000\023\000\082\000\024\000\081\000\027\000\080\000\
\\028\000\079\000\030\000\202\000\033\000\202\000\000\000\
\\001\000\001\000\203\000\003\000\203\000\004\000\203\000\005\000\203\00=
0\
\\007\000\203\000\008\000\203\000\010\000\203\000\013\000\203\000\
\\014\000\203\000\017\000\203\000\018\000\203\000\021\000\084\000\
\\022\000\083\000\023\000\082\000\024\000\081\000\027\000\080\000\
\\028\000\079\000\030\000\203\000\033\000\203\000\000\000\
\\001\000\001\000\011\000\000\000\
\\001\000\001\000\011\000\003\000\010\000\004\000\009\000\030\000\008\00=
0\000\000\
\\001\000\006\000\064\000\009\000\063\000\012\000\062\000\029\000\061\00=
0\
\\031\000\060\000\032\000\059\000\000\000\
\\001\000\007\000\121\000\000\000\
\\001\000\008\000\138\000\018\000\087\000\019\000\086\000\020\000\085\00=
0\
\\021\000\084\000\022\000\083\000\023\000\082\000\024\000\081\000\
\\027\000\080\000\028\000\079\000\000\000\
\\001\000\010\000\120\000\018\000\087\000\019\000\086\000\020\000\085\00=
0\
\\021\000\084\000\022\000\083\000\023\000\082\000\024\000\081\000\
\\027\000\080\000\028\000\079\000\000\000\
\\001\000\012\000\034\000\032\000\033\000\000\000\
\\001\000\012\000\047\000\032\000\033\000\000\000\
\\001\000\012\000\053\000\025\000\016\000\032\000\052\000\000\000\
\\001\000\013\000\037\000\000\000\
\\001\000\013\000\070\000\017\000\069\000\026\000\068\000\027\000\041\00=
0\000\000\
\\001\000\013\000\070\000\017\000\069\000\027\000\041\000\000\000\
\\001\000\013\000\095\000\000\000\
\\001\000\013\000\102\000\000\000\
\\001\000\013\000\104\000\016\000\074\000\017\000\103\000\000\000\
\\001\000\013\000\119\000\017\000\118\000\018\000\087\000\019\000\086\00=
0\
\\020\000\085\000\021\000\084\000\022\000\083\000\023\000\082\000\
\\024\000\081\000\027\000\080\000\028\000\079\000\000\000\
\\001\000\013\000\123\000\016\000\074\000\000\000\
\\001\000\013\000\124\000\000\000\
\\001\000\013\000\128\000\000\000\
\\001\000\013\000\136\000\000\000\
\\001\000\015\000\137\000\027\000\041\000\000\000\
\\001\000\016\000\074\000\019\000\141\000\000\000\
\\001\000\019\000\035\000\000\000\
\\001\000\019\000\038\000\000\000\
\\001\000\019\000\042\000\027\000\041\000\000\000\
\\001\000\026\000\134\000\000\000\
\\001\000\032\000\013\000\000\000\
\\001\000\032\000\023\000\000\000\
\\001\000\032\000\025\000\000\000\
\\001\000\032\000\027\000\000\000\
\\001\000\032\000\029\000\000\000\
\\001\000\032\000\056\000\000\000\
\\001\000\032\000\091\000\000\000\
\\001\000\032\000\125\000\000\000\
\\001\000\033\000\000\000\000\000\
\\146\000\000\000\
\\147\000\000\000\
\\148\000\000\000\
\\149\000\000\000\
\\150\000\001\000\011\000\003\000\010\000\004\000\009\000\030\000\008\00=
0\000\000\
\\151\000\000\000\
\\152\000\000\000\
\\153\000\000\000\
\\154\000\005\000\030\000\000\000\
\\155\000\000\000\
\\156\000\000\000\
\\157\000\000\000\
\\158\000\000\000\
\\159\000\000\000\
\\160\000\017\000\026\000\000\000\
\\161\000\012\000\017\000\025\000\016\000\000\000\
\\162\000\000\000\
\\163\000\014\000\077\000\000\000\
\\164\000\016\000\074\000\000\000\
\\165\000\010\000\078\000\000\000\
\\166\000\016\000\074\000\000\000\
\\167\000\000\000\
\\168\000\000\000\
\\169\000\000\000\
\\170\000\000\000\
\\171\000\000\000\
\\172\000\016\000\074\000\017\000\103\000\000\000\
\\173\000\000\000\
\\174\000\022\000\073\000\032\000\072\000\000\000\
\\175\000\000\000\
\\176\000\022\000\073\000\032\000\072\000\000\000\
\\177\000\000\000\
\\178\000\016\000\074\000\000\000\
\\179\000\000\000\
\\180\000\018\000\087\000\019\000\086\000\020\000\085\000\021\000\084\00=
0\
\\022\000\083\000\023\000\082\000\024\000\081\000\027\000\080\000\
\\028\000\079\000\000\000\
\\181\000\018\000\087\000\019\000\086\000\020\000\085\000\021\000\084\00=
0\
\\022\000\083\000\023\000\082\000\024\000\081\000\027\000\080\000\
\\028\000\079\000\000\000\
\\182\000\005\000\031\000\000\000\
\\183\000\000\000\
\\184\000\000\000\
\\185\000\000\000\
\\186\000\027\000\041\000\000\000\
\\187\000\000\000\
\\188\000\027\000\041\000\000\000\
\\189\000\000\000\
\\190\000\011\000\045\000\012\000\044\000\032\000\043\000\000\000\
\\191\000\017\000\096\000\027\000\041\000\000\000\
\\192\000\000\000\
\\193\000\000\000\
\\194\000\000\000\
\\195\000\000\000\
\\196\000\000\000\
\\197\000\000\000\
\\198\000\000\000\
\\199\000\012\000\090\000\031\000\089\000\032\000\088\000\000\000\
\\200\000\000\000\
\\201\000\019\000\086\000\020\000\085\000\021\000\084\000\022\000\083\00=
0\
\\023\000\082\000\024\000\081\000\027\000\080\000\028\000\079\000\000\00=
0\
\\204\000\000\000\
\\205\000\000\000\
\\206\000\022\000\083\000\023\000\082\000\000\000\
\\207\000\022\000\083\000\023\000\082\000\000\000\
\\208\000\021\000\084\000\022\000\083\000\023\000\082\000\024\000\081\00=
0\
\\027\000\080\000\028\000\079\000\000\000\
\\209\000\021\000\084\000\022\000\083\000\023\000\082\000\024\000\081\00=
0\
\\027\000\080\000\028\000\079\000\000\000\
\\210\000\000\000\
\\211\000\000\000\
\\212\000\017\000\129\000\018\000\087\000\019\000\086\000\020\000\085\00=
0\
\\021\000\084\000\022\000\083\000\023\000\082\000\024\000\081\000\
\\027\000\080\000\028\000\079\000\000\000\
\\213\000\000\000\
\\214\000\014\000\142\000\019\000\086\000\020\000\085\000\021\000\084\00=
0\
\\022\000\083\000\023\000\082\000\024\000\081\000\027\000\080\000\
\\028\000\079\000\000\000\
\\215\000\000\000\
\"
val actionRowNumbers =3D
"\003\000\038\000\039\000\040\000\
\\041\000\037\000\028\000\052\000\
\\052\000\029\000\043\000\003\000\
\\030\000\051\000\031\000\052\000\
\\032\000\045\000\044\000\073\000\
\\070\000\008\000\042\000\024\000\
\\052\000\048\000\011\000\025\000\
\\052\000\029\000\026\000\081\000\
\\009\000\010\000\050\000\049\000\
\\033\000\046\000\074\000\009\000\
\\004\000\080\000\009\000\009\000\
\\012\000\009\000\068\000\067\000\
\\057\000\058\000\059\000\010\000\
\\054\000\047\000\056\000\077\000\
\\071\000\090\000\091\000\034\000\
\\004\000\004\000\002\000\014\000\
\\082\000\079\000\010\000\009\000\
\\075\000\013\000\062\000\010\000\
\\010\000\015\000\016\000\033\000\
\\010\000\004\000\004\000\004\000\
\\004\000\004\000\004\000\004\000\
\\004\000\004\000\088\000\089\000\
\\004\000\084\000\017\000\007\000\
\\005\000\078\000\009\000\018\000\
\\019\000\066\000\065\000\069\000\
\\035\000\010\000\060\000\053\000\
\\055\000\098\000\097\000\096\000\
\\094\000\093\000\095\000\001\000\
\\000\000\092\000\020\000\101\000\
\\004\000\085\000\009\000\004\000\
\\083\000\027\000\076\000\061\000\
\\064\000\063\000\087\000\004\000\
\\021\000\099\000\022\000\006\000\
\\010\000\102\000\086\000\004\000\
\\100\000\023\000\103\000\004\000\
\\009\000\072\000\104\000\036\000"
val gotoT =3D
"\
\\001\000\143\000\002\000\005\000\003\000\004\000\004\000\003\000\
\\011\000\002\000\016\000\001\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\002\000\010\000\003\000\004\000\004\000\003\000\011\000\002\000\
\\016\000\001\000\000\000\
\\000\000\
\\000\000\
\\007\000\013\000\008\000\012\000\000\000\
\\005\000\018\000\006\000\017\000\007\000\013\000\008\000\016\000\000\00=
0\
\\017\000\020\000\018\000\019\000\000\000\
\\000\000\
\\002\000\022\000\003\000\004\000\004\000\003\000\011\000\002\000\
\\016\000\001\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\007\000\013\000\008\000\026\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\014\000\030\000\000\000\
\\000\000\
\\000\000\
\\007\000\013\000\008\000\034\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\005\000\037\000\006\000\017\000\007\000\013\000\008\000\016\000\000\00=
0\
\\017\000\038\000\018\000\019\000\000\000\
\\000\000\
\\000\000\
\\014\000\044\000\000\000\
\\007\000\049\000\021\000\048\000\022\000\047\000\023\000\046\000\000\00=
0\
\\000\000\
\\000\000\
\\009\000\053\000\010\000\052\000\000\000\
\\000\000\
\\000\000\
\\014\000\055\000\000\000\
\\012\000\056\000\000\000\
\\000\000\
\\014\000\064\000\015\000\063\000\000\000\
\\014\000\065\000\000\000\
\\000\000\
\\014\000\069\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\007\000\049\000\021\000\074\000\022\000\047\000\023\000\046\000\
\\024\000\073\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\012\000\090\000\000\000\
\\012\000\091\000\000\000\
\\016\000\092\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\007\000\049\000\021\000\095\000\022\000\047\000\023\000\046\000\000\00=
0\
\\014\000\064\000\015\000\096\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\007\000\049\000\022\000\098\000\023\000\097\000\000\000\
\\007\000\049\000\021\000\099\000\022\000\047\000\023\000\046\000\000\00=
0\
\\000\000\
\\000\000\
\\009\000\103\000\010\000\052\000\000\000\
\\007\000\049\000\021\000\104\000\022\000\047\000\023\000\046\000\000\00=
0\
\\012\000\105\000\000\000\
\\012\000\106\000\000\000\
\\012\000\107\000\000\000\
\\012\000\108\000\000\000\
\\012\000\109\000\000\000\
\\012\000\110\000\000\000\
\\012\000\111\000\000\000\
\\012\000\112\000\000\000\
\\012\000\113\000\000\000\
\\000\000\
\\000\000\
\\012\000\115\000\013\000\114\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\014\000\064\000\015\000\120\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\007\000\049\000\021\000\125\000\022\000\047\000\023\000\046\000\
\\024\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\
\\012\000\115\000\013\000\128\000\000\000\
\\000\000\
\\014\000\130\000\020\000\129\000\000\000\
\\012\000\131\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\012\000\115\000\013\000\133\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\000\000\
\\007\000\049\000\021\000\137\000\022\000\047\000\023\000\046\000\000\00=
0\
\\000\000\
\\000\000\
\\012\000\138\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\\012\000\141\000\000\000\
\\014\000\130\000\020\000\142\000\000\000\
\\000\000\
\\000\000\
\\000\000\
\"
val numstates =3D 144
val numrules =3D 70
val s =3D ref "" and index =3D ref 0
val string_to_int =3D fn () =3D>=20
let val i =3D !index
in index :=3D i+2; Char.ord(String.sub(!s,i)) + =
Char.ord(String.sub(!s,i+1)) * 256
end
val string_to_list =3D fn s' =3D>
let val len =3D String.size s'
fun f () =3D
if !index < len then string_to_int() :: f()
else nil
in index :=3D 0; s :=3D s'; f ()
end
val string_to_pairlist =3D fn (conv_key,conv_entry) =3D>
let fun f () =3D
case string_to_int()
of 0 =3D> EMPTY
| n =3D> PAIR(conv_key (n-1),conv_entry =
(string_to_int()),f())
in f
end
val string_to_pairlist_default =3D fn (conv_key,conv_entry) =3D>
let val conv_row =3D string_to_pairlist(conv_key,conv_entry)
in fn () =3D>
let val default =3D conv_entry(string_to_int())
val row =3D conv_row()
in (row,default)
end
end
val string_to_table =3D fn (convert_row,s') =3D>
let val len =3D String.size s'
fun f ()=3D
if !index < len then convert_row() :: f()
else nil
in (s :=3D s'; index :=3D 0; f ())
end
local
val memo =3D Array.array(numstates+numrules,ERROR)
val _ =3Dlet fun g i=3D(Array.update(memo,i,REDUCE(i-numstates)); =
g(i+1))
fun f i =3D
if i=3Dnumstates then g i
else (Array.update(memo,i,SHIFT (STATE i)); f (i+1))
in f 0 handle Subscript =3D> ()
end
in
val entry_to_action =3D fn 0 =3D> ACCEPT | 1 =3D> ERROR | j =3D> =
Array.sub(memo,(j-2))
end
val =
gotoT=3DArray.fromList(string_to_table(string_to_pairlist(NT,STATE),goto=
T))
val =
actionRows=3Dstring_to_table(string_to_pairlist_default(T,entry_to_actio=
n),actionRows)
val actionRowNumbers =3D string_to_list actionRowNumbers
val actionT =3D let val actionRowLookUp=3D
let val a=3DArray.fromList(actionRows) in fn i=3D>Array.sub(a,i) end
in Array.fromList(map actionRowLookUp actionRowNumbers)
end
in LrTable.mkLrTable =
{actions=3DactionT,gotos=3DgotoT,numRules=3Dnumrules,
numStates=3Dnumstates,initialState=3DSTATE 0}
end
end
local open Header in
type pos =3D int
type arg =3D unit
structure MlyValue =3D=20
struct
datatype svalue =3D VOID | ntVOID of unit | ID of (string)
| INT of (int) | TY_EXP_LIST of (Ast.ty_exp list)
| CART_PROD of (Ast.ty_exp list) | BASIC_TY_EXP of (Ast.ty_exp)
| TY_EXP of (Ast.ty_exp)
| RULE_LIST of ( ( Ast.exp_info_type, Ast.dec_info_type ) =
Ast.rule_type list)
| RULE of ({ pat:Ast.pat,exp:Ast.exp } ) | FUN_DEC of (Ast.dec)
| FUN_DECS of (Ast.dec list) | FUN_DEC_LIST of (Ast.dec list)
| PAT_LIST of (Ast.pat list) | PAT of (Ast.pat)
| EXP_LIST of (Ast.exp list) | EXP of (Ast.exp)
| TYPE_DEC of ({ ty_con:Ast.symbol,ty_pars:Ast.ty_var =
list,ty_exp:Ast.ty_exp } )
| ALT of ({ constr:Ast.symbol,domain:Ast.ty_exp option } )
| ALT_LIST of ({ constr:Ast.symbol,domain:Ast.ty_exp option } list)
| TY_PAR_LIST of (Ast.symbol list) | TY_VAR of (Ast.symbol)
| DATATYPE_DEC of (Ast.datatype_dec)
| DATATYPE_DECS of (Ast.datatype_dec list)
| DATATYPE_DEC_LIST of (Ast.datatype_dec list)
| DEC of (Ast.parse_result) | DEC_LIST of (Ast.parse_result list)
| START of (Ast.parse_result list)
end
type svalue =3D MlyValue.svalue
type result =3D Ast.parse_result list
end
structure EC=3D
struct
open LrTable
val is_keyword =3D
fn _ =3D> false
val preferred_change =3D=20
nil
val noShift =3D=20
fn (T 32) =3D> true | _ =3D> false
val showTerminal =3D
fn (T 0) =3D> "FUN"
| (T 1) =3D> "VAL"
| (T 2) =3D> "DATATYPE"
| (T 3) =3D> "TYPE"
| (T 4) =3D> "AND"
| (T 5) =3D> "LET"
| (T 6) =3D> "IN"
| (T 7) =3D> "END"
| (T 8) =3D> "CASE"
| (T 9) =3D> "OF"
| (T 10) =3D> "AS"
| (T 11) =3D> "LPAR"
| (T 12) =3D> "RPAR"
| (T 13) =3D> "VBAR"
| (T 14) =3D> "ARROW"
| (T 15) =3D> "THIN_ARROW"
| (T 16) =3D> "COMMA"
| (T 17) =3D> "SEMICOLON"
| (T 18) =3D> "EQ"
| (T 19) =3D> "LESS'"
| (T 20) =3D> "PLUS"
| (T 21) =3D> "MUL"
| (T 22) =3D> "DIV"
| (T 23) =3D> "MINUS"
| (T 24) =3D> "PRIME"
| (T 25) =3D> "COLON"
| (T 26) =3D> "CONS"
| (T 27) =3D> "APPEND"
| (T 28) =3D> "RAISE"
| (T 29) =3D> "EXCEPTION"
| (T 30) =3D> "INT"
| (T 31) =3D> "ID"
| (T 32) =3D> "EOF"
| _ =3D> "bogus-term"
local open Header in
val errtermvalue=3D
fn _ =3D> MlyValue.VOID
end
val terms =3D (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 32) :: nil
end
structure Actions =3D
struct=20
exception mlyAction of int
local open Header in
val actions =3D=20
fn (i392,defaultPos,stack,
(()):arg) =3D>
case (i392,stack)
of (0,(_,(MlyValue.DEC_LIST DEC_LIST,DEC_LIST1left,DEC_LIST1right))::
rest671) =3D> let val result=3DMlyValue.START(( DEC_LIST ))
in (LrTable.NT 0,(result,DEC_LIST1left,DEC_LIST1right),rest671) end
| (1,(_,(MlyValue.FUN_DEC_LIST FUN_DEC_LIST,FUN_DEC_LIST1left,
FUN_DEC_LIST1right))::rest671) =3D> let val result=3DMlyValue.DEC((
Ast.parsed_fun FUN_DEC_LIST ))
in (LrTable.NT 2,(result,FUN_DEC_LIST1left,FUN_DEC_LIST1right),
rest671) end
| (2,(_,(MlyValue.TYPE_DEC TYPE_DEC,TYPE_DEC1left,TYPE_DEC1right))::
rest671) =3D> let val result=3DMlyValue.DEC(( Ast.parsed_type TYPE_DEC =
))
in (LrTable.NT 2,(result,TYPE_DEC1left,TYPE_DEC1right),rest671) end
| (3,(_,(MlyValue.DATATYPE_DEC_LIST DATATYPE_DEC_LIST,
DATATYPE_DEC_LIST1left,DATATYPE_DEC_LIST1right))::rest671) =3D> let val =
result=3DMlyValue.DEC(( Ast.parsed_datatype DATATYPE_DEC_LIST ))
in (LrTable.NT 2,(result,DATATYPE_DEC_LIST1left,
DATATYPE_DEC_LIST1right),rest671) end
| (4,(_,(MlyValue.DEC DEC,DEC1left,DEC1right))::rest671) =3D> let val=20
result=3DMlyValue.DEC_LIST(( DEC::nil ))
in (LrTable.NT 1,(result,DEC1left,DEC1right),rest671) end
| (5,(_,(MlyValue.DEC_LIST DEC_LIST,_,DEC_LIST1right))::_::(_,(_,
EXCEPTION1left,_))::rest671) =3D> let val result=3DMlyValue.DEC_LIST((
DEC_LIST ))
in (LrTable.NT 1,(result,EXCEPTION1left,DEC_LIST1right),rest671) end
| (6,(_,(MlyValue.DEC_LIST DEC_LIST,_,DEC_LIST1right))::(_,(
MlyValue.DEC DEC,DEC1left,_))::rest671) =3D> let val result=3D
MlyValue.DEC_LIST(( DEC::DEC_LIST ))
in (LrTable.NT 1,(result,DEC1left,DEC_LIST1right),rest671) end
| (7,(_,(MlyValue.DATATYPE_DECS DATATYPE_DECS,_,DATATYPE_DECS1right))
::(_,(_,DATATYPE1left,_))::rest671) =3D> let val result=3D
MlyValue.DATATYPE_DEC_LIST(( DATATYPE_DECS ))
in (LrTable.NT 3,(result,DATATYPE1left,DATATYPE_DECS1right),rest671)
end
| (8,(_,(MlyValue.DATATYPE_DEC DATATYPE_DEC,DATATYPE_DEC1left,
DATATYPE_DEC1right))::rest671) =3D> let val result=3D
MlyValue.DATATYPE_DECS(( DATATYPE_DEC :: nil ))
in (LrTable.NT 4,(result,DATATYPE_DEC1left,DATATYPE_DEC1right),
rest671) end
| (9,(_,(MlyValue.DATATYPE_DECS DATATYPE_DECS,_,DATATYPE_DECS1right))
::_::(_,(MlyValue.DATATYPE_DEC DATATYPE_DEC,DATATYPE_DEC1left,_))::
rest671) =3D> let val result=3DMlyValue.DATATYPE_DECS((
DATATYPE_DEC :: DATATYPE_DECS ))
in (LrTable.NT 4,(result,DATATYPE_DEC1left,DATATYPE_DECS1right),
rest671) end
| (10,(_,(MlyValue.ALT_LIST ALT_LIST,_,ALT_LIST1right))::_::(_,(
MlyValue.ID ID,_,_))::(_,(MlyValue.TY_PAR_LIST TY_PAR_LIST,
TY_PAR_LIST1left,_))::rest671) =3D> let val =
result=3DMlyValue.DATATYPE_DEC
((
{
ty_con =3D Ast.string_to_symbol(Ast.ty_con_sym,ID),
ty_pars =3D TY_PAR_LIST,
alts =3D ALT_LIST
}=20
))
in (LrTable.NT 5,(result,TY_PAR_LIST1left,ALT_LIST1right),rest671)
end
| (11,(_,(MlyValue.ID ID,_,ID1right))::(_,(_,PRIME1left,_))::rest671)
=3D> let val result=3DMlyValue.TY_VAR((
Ast.string_to_symbol( Ast.ty_var_sym, "'" ^ ID ) ))
in (LrTable.NT 6,(result,PRIME1left,ID1right),rest671) end
| (12,(_,(_,_,RPAR1right))::(_,(MlyValue.TY_PAR_LIST TY_PAR_LIST,_,_))
::(_,(_,LPAR1left,_))::rest671) =3D> let val =
result=3DMlyValue.TY_PAR_LIST
(( TY_PAR_LIST ))
in (LrTable.NT 7,(result,LPAR1left,RPAR1right),rest671) end
| (13,(_,(MlyValue.TY_PAR_LIST TY_PAR_LIST,_,TY_PAR_LIST1right))::_::(
_,(MlyValue.TY_VAR TY_VAR,TY_VAR1left,_))::rest671) =3D> let val =
result=3D
MlyValue.TY_PAR_LIST(( TY_VAR :: TY_PAR_LIST ))
in (LrTable.NT 7,(result,TY_VAR1left,TY_PAR_LIST1right),rest671) end
| (14,(_,(MlyValue.TY_VAR TY_VAR,TY_VAR1left,TY_VAR1right))::rest671)
=3D> let val result=3DMlyValue.TY_PAR_LIST(( TY_VAR :: nil ))
in (LrTable.NT 7,(result,TY_VAR1left,TY_VAR1right),rest671) end
| (15,rest671) =3D> let val result=3DMlyValue.TY_PAR_LIST(( nil ))
in (LrTable.NT 7,(result,defaultPos,defaultPos),rest671) end
| (16,(_,(MlyValue.ALT_LIST ALT_LIST,_,ALT_LIST1right))::_::(_,(
MlyValue.ALT ALT,ALT1left,_))::rest671) =3D> let val result=3D
MlyValue.ALT_LIST(( ALT :: ALT_LIST ))
in (LrTable.NT 8,(result,ALT1left,ALT_LIST1right),rest671) end
| (17,(_,(MlyValue.ALT ALT,ALT1left,ALT1right))::rest671) =3D> let val=20
result=3DMlyValue.ALT_LIST(( ALT :: nil ))
in (LrTable.NT 8,(result,ALT1left,ALT1right),rest671) end
| (18,(_,(MlyValue.TY_EXP TY_EXP,_,TY_EXP1right))::_::(_,(MlyValue.ID=20
ID,ID1left,_))::rest671) =3D> let val result=3DMlyValue.ALT((
{=20
constr =3D Ast.string_to_symbol( Ast.func_sym, ID ),
domain =3D SOME TY_EXP
}=20
))
in (LrTable.NT 9,(result,ID1left,TY_EXP1right),rest671) end
| (19,(_,(MlyValue.ID ID,ID1left,ID1right))::rest671) =3D> let val=20
result=3DMlyValue.ALT((
{=20
constr =3D Ast.string_to_symbol( Ast.func_sym, ID ),=20
domain =3D NONE=20
}=20
))
in (LrTable.NT 9,(result,ID1left,ID1right),rest671) end
| (20,(_,(MlyValue.TY_EXP TY_EXP,_,TY_EXP1right))::_::(_,(MlyValue.ID=20
ID,_,_))::(_,(MlyValue.TY_PAR_LIST TY_PAR_LIST,_,_))::(_,(_,TYPE1left,
_))::rest671) =3D> let val result=3DMlyValue.TYPE_DEC((
{
ty_con =3D Ast.string_to_symbol( Ast.ty_con_sym, ID ),
ty_pars =3D TY_PAR_LIST,
ty_exp =3D TY_EXP
}=20
))
in (LrTable.NT 10,(result,TYPE1left,TY_EXP1right),rest671) end
| (21,(_,(MlyValue.TY_VAR TY_VAR,TY_VAR1left,TY_VAR1right))::rest671)
=3D> let val result=3DMlyValue.BASIC_TY_EXP(( Ast.ty_var_exp TY_VAR ))
in (LrTable.NT 21,(result,TY_VAR1left,TY_VAR1right),rest671) end
| (22,(_,(MlyValue.ID ID,ID1left,ID1right))::rest671) =3D> let val=20
result=3DMlyValue.BASIC_TY_EXP((
=20
Ast.ty_con_exp(
Ast.string_to_symbol( Ast.ty_con_sym, ID ),
nil)=20
=20
))
in (LrTable.NT 21,(result,ID1left,ID1right),rest671) end
| (23,(_,(_,_,RPAR1right))::(_,(MlyValue.TY_EXP TY_EXP,_,_))::(_,(_,
LPAR1left,_))::rest671) =3D> let val result=3DMlyValue.BASIC_TY_EXP((
TY_EXP ))
in (LrTable.NT 21,(result,LPAR1left,RPAR1right),rest671) end
| (24,(_,(MlyValue.ID ID,_,ID1right))::_::(_,(MlyValue.TY_EXP_LIST=20
TY_EXP_LIST,_,_))::(_,(_,LPAR1left,_))::rest671) =3D> let val result=3D
MlyValue.BASIC_TY_EXP((
=20
Ast.ty_con_exp(=20
Ast.string_to_symbol( Ast.ty_con_sym, ID ),=20
TY_EXP_LIST )=20
=20
))
in (LrTable.NT 21,(result,LPAR1left,ID1right),rest671) end
| (25,(_,(MlyValue.ID ID,_,ID1right))::(_,(MlyValue.BASIC_TY_EXP=20
BASIC_TY_EXP,BASIC_TY_EXP1left,_))::rest671) =3D> let val result=3D
MlyValue.BASIC_TY_EXP((
=20
Ast.ty_con_exp(=20
Ast.string_to_symbol( Ast.ty_con_sym, ID ),=20
BASIC_TY_EXP::nil )=20
=20
))
in (LrTable.NT 21,(result,BASIC_TY_EXP1left,ID1right),rest671) end
| (26,(_,(MlyValue.TY_EXP TY_EXP2,_,TY_EXP2right))::_::(_,(
MlyValue.TY_EXP TY_EXP1,TY_EXP1left,_))::rest671) =3D> let val =
result=3D
MlyValue.TY_EXP_LIST(( TY_EXP1::TY_EXP2::nil ))
in (LrTable.NT 23,(result,TY_EXP1left,TY_EXP2right),rest671) end
| (27,(_,(MlyValue.TY_EXP_LIST TY_EXP_LIST,_,TY_EXP_LIST1right))::_::(
_,(MlyValue.TY_EXP TY_EXP,TY_EXP1left,_))::rest671) =3D> let val =
result=3D
MlyValue.TY_EXP_LIST(( TY_EXP::TY_EXP_LIST ))
in (LrTable.NT 23,(result,TY_EXP1left,TY_EXP_LIST1right),rest671) end
| (28,(_,(MlyValue.BASIC_TY_EXP BASIC_TY_EXP2,_,BASIC_TY_EXP2right))::
_::(_,(MlyValue.BASIC_TY_EXP BASIC_TY_EXP1,BASIC_TY_EXP1left,_))::
rest671) =3D> let val result=3DMlyValue.CART_PROD((
=20
BASIC_TY_EXP1::BASIC_TY_EXP2::nil=20
))
in (LrTable.NT 22,(result,BASIC_TY_EXP1left,BASIC_TY_EXP2right),
rest671) end
| (29,(_,(MlyValue.CART_PROD CART_PROD,_,CART_PROD1right))::_::(_,(
MlyValue.BASIC_TY_EXP BASIC_TY_EXP,BASIC_TY_EXP1left,_))::rest671) =3D> =
let val result=3DMlyValue.CART_PROD(( BASIC_TY_EXP::CART_PROD ))
in (LrTable.NT 22,(result,BASIC_TY_EXP1left,CART_PROD1right),rest671)
end
| (30,(_,(MlyValue.BASIC_TY_EXP BASIC_TY_EXP,BASIC_TY_EXP1left,
BASIC_TY_EXP1right))::rest671) =3D> let val result=3DMlyValue.TY_EXP((
BASIC_TY_EXP))
in (LrTable.NT 20,(result,BASIC_TY_EXP1left,BASIC_TY_EXP1right),
rest671) end
| (31,(_,(MlyValue.CART_PROD CART_PROD,CART_PROD1left,CART_PROD1right)
)::rest671) =3D> let val result=3DMlyValue.TY_EXP((
Ast.ty_con_exp(Ast.TUPLE_TY_CON,CART_PROD) ))
in (LrTable.NT 20,(result,CART_PROD1left,CART_PROD1right),rest671)
end
| (32,(_,(MlyValue.TY_EXP TY_EXP2,_,TY_EXP2right))::_::(_,(
MlyValue.TY_EXP TY_EXP1,TY_EXP1left,_))::rest671) =3D> let val =
result=3D
MlyValue.TY_EXP((
=20
Ast.ty_con_exp(Ast.THIN_ARROW, TY_EXP1::TY_EXP2::nil)=20
)
)
in (LrTable.NT 20,(result,TY_EXP1left,TY_EXP2right),rest671) end
| (33,(_,(MlyValue.FUN_DECS FUN_DECS,_,FUN_DECS1right))::(_,(_,
FUN1left,_))::rest671) =3D> let val result=3DMlyValue.FUN_DEC_LIST((
FUN_DECS ))
in (LrTable.NT 15,(result,FUN1left,FUN_DECS1right),rest671) end
| (34,(_,(MlyValue.EXP EXP,_,EXP1right))::_::(_,(MlyValue.PAT PAT,_,_)
)::(_,(MlyValue.ID ID,ID1left,_))::rest671) =3D> let val result=3D
MlyValue.FUN_DEC((
{
func=3DAst.string_to_symbol( Ast.func_sym, ID ),
pat=3DPAT,
exp=3DEXP,
dec_info=3DAst.no_dec_info()
}=20
))
in (LrTable.NT 17,(result,ID1left,EXP1right),rest671) end
| (35,(_,(MlyValue.EXP EXP,_,EXP1right))::_::(_,(MlyValue.TY_EXP=20
TY_EXP2,_,_))::_::_::(_,(MlyValue.TY_EXP TY_EXP1,_,_))::_::(_,(
MlyValue.PAT PAT,_,_))::_::(_,(MlyValue.ID ID,ID1left,_))::rest671)
=3D> let val result=3DMlyValue.FUN_DEC((
{
func=3DAst.string_to_symbol( Ast.func_sym, ID ),
pat=3DPAT,
exp=3DEXP,
dec_info=3D=20
let val TE =3D=20
Ast.ty_con_exp( Ast.THIN_ARROW, TY_EXP1::TY_EXP2::nil )
in
{
schematic_vars =3D Ast.vars_in_ty_exp TE,
ty_exp =3D TE
}
end
}=20
))
in (LrTable.NT 17,(result,ID1left,EXP1right),rest671) end
| (36,(_,(MlyValue.FUN_DEC FUN_DEC,FUN_DEC1left,FUN_DEC1right))::
rest671) =3D> let val result=3DMlyValue.FUN_DECS(( FUN_DEC :: nil ))
in (LrTable.NT 16,(result,FUN_DEC1left,FUN_DEC1right),rest671) end
| (37,(_,(MlyValue.FUN_DECS FUN_DECS,_,FUN_DECS1right))::_::(_,(
MlyValue.FUN_DEC FUN_DEC,FUN_DEC1left,_))::rest671) =3D> let val =
result=3D
MlyValue.FUN_DECS(( FUN_DEC :: FUN_DECS ))
in (LrTable.NT 16,(result,FUN_DEC1left,FUN_DECS1right),rest671) end
| (38,(_,(_,_,RPAR1right))::(_,(MlyValue.PAT PAT,_,_))::(_,(_,
LPAR1left,_))::rest671) =3D> let val result=3DMlyValue.PAT(( PAT ))
in (LrTable.NT 13,(result,LPAR1left,RPAR1right),rest671) end
| (39,(_,(_,_,RPAR1right))::(_,(MlyValue.PAT_LIST PAT_LIST,_,_))::_::(
_,(MlyValue.PAT PAT,_,_))::(_,(_,LPAR1left,_))::rest671) =3D> let val=20
result=3DMlyValue.PAT((
Ast.app_exp {
func=3DAst.TUPLE,
args=3DPAT::PAT_LIST,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 13,(result,LPAR1left,RPAR1right),rest671) end
| (40,(_,(MlyValue.PAT PAT2,_,PAT2right))::_::(_,(MlyValue.PAT PAT1,
PAT1left,_))::rest671) =3D> let val result=3DMlyValue.PAT((
Ast.app_exp {
func=3DAst.CONS,
args=3DPAT1::PAT2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 13,(result,PAT1left,PAT2right),rest671) end
| (41,(_,(_,_,RPAR1right))::(_,(MlyValue.PAT_LIST PAT_LIST,_,_))::_::(
_,(MlyValue.ID ID,ID1left,_))::rest671) =3D> let val =
result=3DMlyValue.PAT
((
Ast.app_exp {
func=3DAst.string_to_symbol( Ast.var_sym, ID ),
args=3DPAT_LIST,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 13,(result,ID1left,RPAR1right),rest671) end
| (42,(_,(MlyValue.PAT PAT,_,PAT1right))::_::(_,(MlyValue.ID ID,
ID1left,_))::rest671) =3D> let val result=3DMlyValue.PAT((
Ast.as_exp {
var=3DAst.string_to_symbol( Ast.var_sym, ID ),
pat=3DPAT,=20
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 13,(result,ID1left,PAT1right),rest671) end
| (43,(_,(MlyValue.ID ID2,_,ID2right))::(_,(MlyValue.ID ID1,ID1left,_)
)::rest671) =3D> let val result=3DMlyValue.PAT((
Ast.app_exp {
func=3DAst.string_to_symbol( Ast.var_sym, ID1 ),
args=3D[ Ast.app_exp{
func=3DAst.string_to_symbol( Ast.var_sym, ID2 ),
args=3Dnil,
exp_info=3DAst.no_exp_info() } ],
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 13,(result,ID1left,ID2right),rest671) end
| (44,(_,(MlyValue.ID ID,ID1left,ID1right))::rest671) =3D> let val=20
result=3DMlyValue.PAT((
Ast.app_exp {
func=3DAst.string_to_symbol( Ast.var_sym, ID ),
args=3Dnil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 13,(result,ID1left,ID1right),rest671) end
| (45,(_,(MlyValue.PAT PAT,PAT1left,PAT1right))::rest671) =3D> let val=20
result=3DMlyValue.PAT_LIST(( PAT::nil ))
in (LrTable.NT 14,(result,PAT1left,PAT1right),rest671) end
| (46,(_,(MlyValue.PAT_LIST PAT_LIST,_,PAT_LIST1right))::_::(_,(
MlyValue.PAT PAT,PAT1left,_))::rest671) =3D> let val result=3D
MlyValue.PAT_LIST(( PAT::PAT_LIST ))
in (LrTable.NT 14,(result,PAT1left,PAT_LIST1right),rest671) end
| (47,(_,(MlyValue.ID ID,_,ID1right))::(_,(_,RAISE1left,_))::rest671)
=3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func =3D Ast.string_to_qsymbol ID,
args =3D [],
exp_info =3D Ast.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,RAISE1left,ID1right),rest671) end
| (48,(_,(_,_,RPAR1right))::(_,(MlyValue.EXP EXP,_,_))::(_,(_,
LPAR1left,_))::rest671) =3D> let val result=3DMlyValue.EXP(( EXP ))
in (LrTable.NT 11,(result,LPAR1left,RPAR1right),rest671) end
| (49,(_,(_,_,RPAR1right))::(_,(MlyValue.EXP_LIST EXP_LIST,_,_))::_::(
_,(MlyValue.EXP EXP,_,_))::(_,(_,LPAR1left,_))::rest671) =3D> let val=20
result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.TUPLE,
args=3DEXP::EXP_LIST,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,LPAR1left,RPAR1right),rest671) end
| (50,(_,(_,_,RPAR1right))::(_,(MlyValue.EXP_LIST EXP_LIST,_,_))::_::(
_,(MlyValue.ID ID,ID1left,_))::rest671) =3D> let val =
result=3DMlyValue.EXP
((
Ast.app_exp {
func=3DAst.string_to_symbol( Ast.func_sym, ID ),
args=3DEXP_LIST,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,ID1left,RPAR1right),rest671) end
| (51,(_,(MlyValue.ID ID2,_,ID2right))::(_,(MlyValue.ID ID1,ID1left,_)
)::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func =3D Ast.string_to_symbol( Ast.func_sym, ID1 ),
args =3D Ast.app_exp {
func =3D Ast.string_to_symbol' ID2,
args =3D nil,
exp_info =3D Ast.no_exp_info()
}
::
nil,
exp_info =3D Ast.no_exp_info()=20
}=20
))
in (LrTable.NT 11,(result,ID1left,ID2right),rest671) end
| (52,(_,(MlyValue.INT INT,_,INT1right))::(_,(MlyValue.ID ID,ID1left,_
))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func =3D Ast.string_to_symbol( Ast.func_sym, ID ),
args =3D Ast.app_exp {
func =3D Ast.int_to_symbol INT,
args =3D nil,
exp_info =3D Ast.no_exp_info()
}
::
nil,
exp_info =3D Ast.no_exp_info()=20
}=20
))
in (LrTable.NT 11,(result,ID1left,INT1right),rest671) end
| (53,(_,(MlyValue.ID ID,ID1left,ID1right))::rest671) =3D> let val=20
result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.string_to_symbol' ID,
args=3Dnil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,ID1left,ID1right),rest671) end
| (54,(_,(MlyValue.INT INT,INT1left,INT1right))::rest671) =3D> let val=20
result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.int_to_symbol INT,
args=3Dnil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,INT1left,INT1right),rest671) end
| (55,(_,(MlyValue.EXP EXP2,_,EXP2right))::_::(_,(MlyValue.EXP EXP1,
EXP1left,_))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.SEMICOLON,
args=3DEXP1::EXP2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,EXP1left,EXP2right),rest671) end
| (56,(_,(MlyValue.EXP EXP2,_,EXP2right))::_::(_,(MlyValue.EXP EXP1,
EXP1left,_))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.EQ,
args=3DEXP1::EXP2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,EXP1left,EXP2right),rest671) end
| (57,(_,(MlyValue.EXP EXP2,_,EXP2right))::_::(_,(MlyValue.EXP EXP1,
EXP1left,_))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.LESS',
args=3DEXP1::EXP2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,EXP1left,EXP2right),rest671) end
| (58,(_,(MlyValue.EXP EXP2,_,EXP2right))::_::(_,(MlyValue.EXP EXP1,
EXP1left,_))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.MUL,
args=3DEXP1::EXP2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,EXP1left,EXP2right),rest671) end
| (59,(_,(MlyValue.EXP EXP2,_,EXP2right))::_::(_,(MlyValue.EXP EXP1,
EXP1left,_))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.DIV,
args=3DEXP1::EXP2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,EXP1left,EXP2right),rest671) end
| (60,(_,(MlyValue.EXP EXP2,_,EXP2right))::_::(_,(MlyValue.EXP EXP1,
EXP1left,_))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.PLUS,
args=3DEXP1::EXP2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,EXP1left,EXP2right),rest671) end
| (61,(_,(MlyValue.EXP EXP2,_,EXP2right))::_::(_,(MlyValue.EXP EXP1,
EXP1left,_))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.MINUS,
args=3DEXP1::EXP2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,EXP1left,EXP2right),rest671) end
| (62,(_,(MlyValue.EXP EXP2,_,EXP2right))::_::(_,(MlyValue.EXP EXP1,
EXP1left,_))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.CONS,
args=3DEXP1::EXP2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,EXP1left,EXP2right),rest671) end
| (63,(_,(MlyValue.EXP EXP2,_,EXP2right))::_::(_,(MlyValue.EXP EXP1,
EXP1left,_))::rest671) =3D> let val result=3DMlyValue.EXP((
Ast.app_exp {
func=3DAst.APPEND,
args=3DEXP1::EXP2::nil,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,EXP1left,EXP2right),rest671) end
| (64,(_,(MlyValue.RULE_LIST RULE_LIST,_,RULE_LIST1right))::_::(_,(
MlyValue.EXP EXP,_,_))::(_,(_,CASE1left,_))::rest671) =3D> let val=20
result=3DMlyValue.EXP((
Ast.case_exp {
exp=3DEXP,
rules=3DRULE_LIST,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,CASE1left,RULE_LIST1right),rest671) end
| (65,(_,(_,_,END1right))::(_,(MlyValue.EXP EXP,_,_))::_::(_,(
MlyValue.FUN_DEC_LIST FUN_DEC_LIST,_,_))::(_,(_,LET1left,_))::rest671)
=3D> let val result=3DMlyValue.EXP((
Ast.let_exp {
dec_list=3DFUN_DEC_LIST,
exp=3DEXP,
exp_info=3DAst.no_exp_info()
}=20
))
in (LrTable.NT 11,(result,LET1left,END1right),rest671) end
| (66,(_,(MlyValue.EXP EXP,EXP1left,EXP1right))::rest671) =3D> let val=20
result=3DMlyValue.EXP_LIST(( EXP::nil ))
in (LrTable.NT 12,(result,EXP1left,EXP1right),rest671) end
| (67,(_,(MlyValue.EXP_LIST EXP_LIST,_,EXP_LIST1right))::_::(_,(
MlyValue.EXP EXP,EXP1left,_))::rest671) =3D> let val result=3D
MlyValue.EXP_LIST(( EXP::EXP_LIST ))
in (LrTable.NT 12,(result,EXP1left,EXP_LIST1right),rest671) end
| (68,(_,(MlyValue.EXP EXP,_,EXP1right))::_::(_,(MlyValue.PAT PAT,
PAT1left,_))::rest671) =3D> let val result=3DMlyValue.RULE_LIST((
Ast.mk_new_rule(PAT,EXP) :: nil ))
in (LrTable.NT 19,(result,PAT1left,EXP1right),rest671) end
| (69,(_,(MlyValue.RULE_LIST RULE_LIST,_,RULE_LIST1right))::_::(_,(
MlyValue.EXP EXP,_,_))::_::(_,(MlyValue.PAT PAT,PAT1left,_))::rest671)
=3D> let val result=3DMlyValue.RULE_LIST((
=20
Ast.mk_new_rule(PAT,EXP) :: RULE_LIST=20
))
in (LrTable.NT 19,(result,PAT1left,RULE_LIST1right),rest671) end
| _ =3D> raise (mlyAction i392)
end
val void =3D MlyValue.VOID
val extract =3D fn a =3D> (fn MlyValue.START x =3D> x
| _ =3D> let exception ParseInternal
in raise ParseInternal end) a=20
end
end
structure Tokens : ML_TOKENS =3D
struct
type svalue =3D ParserData.svalue
type ('a,'b) token =3D ('a,'b) Token.token
fun FUN (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 0,(
ParserData.MlyValue.VOID,p1,p2))
fun VAL (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 1,(
ParserData.MlyValue.VOID,p1,p2))
fun DATATYPE (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 2,(
ParserData.MlyValue.VOID,p1,p2))
fun TYPE (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 3,(
ParserData.MlyValue.VOID,p1,p2))
fun AND (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 4,(
ParserData.MlyValue.VOID,p1,p2))
fun LET (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 5,(
ParserData.MlyValue.VOID,p1,p2))
fun IN (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 6,(
ParserData.MlyValue.VOID,p1,p2))
fun END (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 7,(
ParserData.MlyValue.VOID,p1,p2))
fun CASE (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 8,(
ParserData.MlyValue.VOID,p1,p2))
fun OF (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 9,(
ParserData.MlyValue.VOID,p1,p2))
fun AS (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 10,(
ParserData.MlyValue.VOID,p1,p2))
fun LPAR (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 11,(
ParserData.MlyValue.VOID,p1,p2))
fun RPAR (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 12,(
ParserData.MlyValue.VOID,p1,p2))
fun VBAR (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 13,(
ParserData.MlyValue.VOID,p1,p2))
fun ARROW (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 14,(
ParserData.MlyValue.VOID,p1,p2))
fun THIN_ARROW (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 15,(
ParserData.MlyValue.VOID,p1,p2))
fun COMMA (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 16,(
ParserData.MlyValue.VOID,p1,p2))
fun SEMICOLON (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 17,(
ParserData.MlyValue.VOID,p1,p2))
fun EQ (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 18,(
ParserData.MlyValue.VOID,p1,p2))
fun LESS' (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 19,(
ParserData.MlyValue.VOID,p1,p2))
fun PLUS (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 20,(
ParserData.MlyValue.VOID,p1,p2))
fun MUL (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 21,(
ParserData.MlyValue.VOID,p1,p2))
fun DIV (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 22,(
ParserData.MlyValue.VOID,p1,p2))
fun MINUS (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 23,(
ParserData.MlyValue.VOID,p1,p2))
fun PRIME (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 24,(
ParserData.MlyValue.VOID,p1,p2))
fun COLON (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 25,(
ParserData.MlyValue.VOID,p1,p2))
fun CONS (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 26,(
ParserData.MlyValue.VOID,p1,p2))
fun APPEND (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 27,(
ParserData.MlyValue.VOID,p1,p2))
fun RAISE (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 28,(
ParserData.MlyValue.VOID,p1,p2))
fun EXCEPTION (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 29,(
ParserData.MlyValue.VOID,p1,p2))
fun INT (i,p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 30,(
ParserData.MlyValue.INT i,p1,p2))
fun ID (i,p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 31,(
ParserData.MlyValue.ID i,p1,p2))
fun EOF (p1,p2) =3D Token.TOKEN (ParserData.LrTable.T 32,(
ParserData.MlyValue.VOID,p1,p2))
end
end
functor MLLexFun( structure Tokens : ML_TOKENS ) : LEXER =3D
struct
structure UserDeclarations =3D
struct
(* File: ML.lex
Modified 1993-05-24
*)
structure Tokens =3D Tokens
type pos =3D int
type svalue =3D Tokens.svalue
type ('a,'b) token =3D ('a,'b) Tokens.token
type lexresult =3D (svalue,pos) token
val line =3D ref 1
exception ml_lex_gen;
val error =3D fn X =3D> (
Lib.output( !Lib.std_err,X^"\n");
Lib.flush_out( !Lib.std_err );
raise ml_lex_gen)
val eof =3D fn () =3D> Tokens.EOF(!line,!line)
end (* end of user routines *)
exception LexError (* raised if illegal leaf action tried *)
structure Internal =3D
struct
datatype yyfinstate =3D N of int
type statedata =3D {fin : yyfinstate list, trans: string}
(* transition & final state table *)
val tab =3D let
val s =3D [=20
(0,=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\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\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,=20
"\003\003\003\003\003\003\003\003\003\025\027\003\003\003\003\003\
\\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\
\\025\003\003\003\003\003\003\024\023\022\021\020\019\017\003\016\
\\014\014\014\014\014\014\014\014\014\014\012\011\010\008\003\005\
\\007\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\003\003\003\003\003\
\\003\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\003\004\003\003\003\
\\003"
),
(5,=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\006\000\000\000\000\000\000\000\000\
\\006\006\006\006\006\006\006\006\006\006\000\000\000\000\000\000\
\\000\006\006\006\006\006\006\006\006\006\006\006\006\006\006\006\
\\006\006\006\006\006\006\006\006\006\006\006\000\000\000\000\006\
\\000\006\006\006\006\006\006\006\006\006\006\006\006\006\006\006\
\\006\006\006\006\006\006\006\006\006\006\006\000\000\000\000\000\
\\000"
),
(8,=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\
\\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"
),
(12,=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\
\\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\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\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,=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\
\\015\015\015\015\015\015\015\015\015\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"
),
(17,=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\
\\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\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\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,=20
"\000\000\000\000\000\000\000\000\000\026\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\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\\000\000\000\000\000\000\000\000\000\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 =3D x=20
val s =3D map f (rev (tl (rev s)))=20
exception LexHackingError=20
fun look ((j,x)::r, i) =3D if i =3D j then x else look(r, i)=20
| look ([], i) =3D raise LexHackingError
fun g {fin=3Dx, trans=3Di} =3D {fin=3Dx, trans=3Dlook(s,i)}=20
in Vector.fromList(map g=20
[{fin =3D [], trans =3D 0},
{fin =3D [], trans =3D 1},
{fin =3D [], trans =3D 1},
{fin =3D [(N 49)], trans =3D 0},
{fin =3D [(N 10),(N 49)], trans =3D 0},
{fin =3D [(N 47),(N 49)], trans =3D 5},
{fin =3D [(N 47)], trans =3D 5},
{fin =3D [(N 37),(N 49)], trans =3D 0},
{fin =3D [(N 22),(N 49)], trans =3D 8},
{fin =3D [(N 13)], trans =3D 0},
{fin =3D [(N 24),(N 49)], trans =3D 0},
{fin =3D [(N 20),(N 49)], trans =3D 0},
{fin =3D [(N 39),(N 49)], trans =3D 12},
{fin =3D [(N 35)], trans =3D 0},
{fin =3D [(N 44),(N 49)], trans =3D 14},
{fin =3D [(N 44)], trans =3D 14},
{fin =3D [(N 30),(N 49)], trans =3D 0},
{fin =3D [(N 28),(N 49)], trans =3D 17},
{fin =3D [(N 16)], trans =3D 0},
{fin =3D [(N 18),(N 49)], trans =3D 0},
{fin =3D [(N 26),(N 49)], trans =3D 0},
{fin =3D [(N 32),(N 49)], trans =3D 0},
{fin =3D [(N 8),(N 49)], trans =3D 0},
{fin =3D [(N 6),(N 49)], trans =3D 0},
{fin =3D [(N 41),(N 49)], trans =3D 0},
{fin =3D [(N 4),(N 49)], trans =3D 25},
{fin =3D [(N 4)], trans =3D 25},
{fin =3D [(N 1)], trans =3D 0}])
end
structure StartStates =3D
struct
datatype yystartstate =3D STARTSTATE of int
(* start state definitions *)
val INITIAL =3D STARTSTATE 1;
end
type result =3D UserDeclarations.lexresult
exception LexerError (* raised if illegal leaf action tried *)
end
fun makeLexer yyinput =3D
let val yygone0=3D1
val yyb =3D ref "\n" (* buffer *)
val yybl =3D ref 1 (*buffer length *)
val yybufpos =3D ref 1 (* location of next character to use *)
val yygone =3D ref yygone0 (* position in file of beginning of buffer =
*)
val yydone =3D ref false (* eof found yet? *)
val yybegin =3D ref 1 (*Current 'start state' for lexer *)
val YYBEGIN =3D fn (Internal.StartStates.STARTSTATE x) =3D>
yybegin :=3D x
fun lex () : Internal.result =3D
let fun continue() =3D lex() in
let fun scan (s,AcceptingLeaves : Internal.yyfinstate list list,l,i0) =
=3D
let fun action (i,nil) =3D raise LexError
| action (i,nil::l) =3D action (i-1,l)
| action (i,(node::acts)::l) =3D
case node of
Internal.N yyk =3D>=20
(let val yytext =3D substring(!yyb,i0,i-i0)
val yypos =3D i0+ !yygone
open UserDeclarations Internal.StartStates
in (yybufpos :=3D i; case yyk of=20
(* Application actions *)
1 =3D> (Lib.inc line; lex())
| 10 =3D> (Tokens.VBAR(!line,!line))
| 13 =3D> (Tokens.ARROW(!line,!line))
| 16 =3D> (Tokens.THIN_ARROW(!line,!line))
| 18 =3D> (Tokens.COMMA(!line,!line))
| 20 =3D> (Tokens.SEMICOLON(!line,!line))
| 22 =3D> (Tokens.EQ(!line,!line))
| 24 =3D> (Tokens.LESS'(!line,!line))
| 26 =3D> (Tokens.PLUS(!line,!line))
| 28 =3D> (Tokens.MINUS(!line,!line))
| 30 =3D> (Tokens.DIV(!line,!line))
| 32 =3D> (Tokens.MUL(!line,!line))
| 35 =3D> (Tokens.CONS(!line,!line))
| 37 =3D> (Tokens.APPEND(!line,!line))
| 39 =3D> (Tokens.COLON(!line,!line))
| 4 =3D> (lex())
| 41 =3D> (Tokens.PRIME(!line,!line))
| 44 =3D> ( Tokens.INT( valOf(Int.fromString yytext), !line, !line ) )
| 47 =3D> (
if yytext=3D"fun" then Tokens.FUN(!line,!line)
else if yytext=3D"val" then Tokens.VAL(!line,!line)
else if yytext=3D"datatype" then Tokens.DATATYPE(!line,!line)
else if yytext=3D"type" then Tokens.TYPE(!line,!line)
else if yytext=3D"let" then Tokens.LET(!line,!line)
else if yytext=3D"in" then Tokens.IN(!line,!line)
else if yytext=3D"end" then Tokens.END(!line,!line)
else if yytext=3D"case" then Tokens.CASE(!line,!line)
else if yytext=3D"of" then Tokens.OF(!line,!line)
else if yytext=3D"as" then Tokens.AS(!line,!line)
else if yytext=3D"and" then Tokens.AND(!line,!line)
else if yytext=3D"raise" then Tokens.RAISE(!line,!line)
else if yytext=3D"exception" then Tokens.EXCEPTION(!line,!line)
else Tokens.ID(yytext,!line,!line)
)
| 49 =3D> (error("ML.lex: Bad character "^yytext))
| 6 =3D> (Tokens.LPAR(!line,!line))
| 8 =3D> (Tokens.RPAR(!line,!line))
| _ =3D> raise Internal.LexerError
) end )
val {fin,trans} =3D Vector.sub(Internal.tab, s)
val NewAcceptingLeaves =3D fin::AcceptingLeaves
in if l =3D !yybl then
if trans =3D #trans(Vector.sub(Internal.tab,0))
then action(l,NewAcceptingLeaves
) else let val newchars=3D if !yydone then "" else yyinput 1024
in if (size newchars)=3D0
then (yydone :=3D true;
if (l=3Di0) then UserDeclarations.eof ()
else action(l,NewAcceptingLeaves))
else (if i0=3Dl then yyb :=3D newchars
else yyb :=3D substring(!yyb,i0,l-i0)^newchars;
yygone :=3D !yygone+i0;
yybl :=3D size (!yyb);
scan (s,AcceptingLeaves,l-i0,0))
end
else let val NewChar =3D Char.ord(String.sub(!yyb,l))
val NewState =3D if NewChar<128 then =
Char.ord(String.sub(trans,NewChar)) else =
Char.ord(String.sub(trans,128))
in if NewState=3D0 then action(l,NewAcceptingLeaves)
else scan(NewState,NewAcceptingLeaves,l+1,i0)
end
end
(*
val start=3D if substring(!yyb,!yybufpos-1,1)=3D"\n"
then !yybegin+1 else !yybegin
*)
in scan(!yybegin (* start *),nil,!yybufpos,!yybufpos)
end
end
in lex
end
end
(*
require "basis.__string";
require "basis.__int";
require "basis.__bool";
require "pp.sml";
require "base-sig.sml";
require "parser2.sml";
require "join.sml";
require "ML-grm-sig.sml";
require "ML-grm.sml";
require "ML-lex.sml";
require "lib.sml";
require "ast.sml";
*)
(* File: parse.sml=20
Created 1993-05-24.
Modified 1996-06-04.
Renamed from io.sml to parse.sml 1999-12-09 when structure Print was=20
removed from this file and reimplemented in print.sml
*)
structure MLLrVals : ML_LRVALS =3D
MLLrValsFun(structure Token =3D LrParser.Token );
structure MLLex : LEXER =3D
MLLexFun(structure Tokens =3D MLLrVals.Tokens );
structure MLParser : PARSER =3D
Join(structure ParserData =3D MLLrVals.ParserData
structure Lex =3D MLLex
structure LrParser =3D LrParser);
signature PARSE =3D
sig
val parse_declarations : string -> Ast.parse_result list
val parse_dec : string -> Ast.dec=20
val parse_decs : string -> Ast.dec list
val parse_type_dec : string -> Ast.type_dec=20
val parse_datatype_dec : string -> Ast.datatype_dec=20
val parse_datatype_decs : string -> Ast.datatype_dec list
val parse_exp : string -> Ast.exp
val parse_ty_exp : string -> Ast.ty_exp
end
structure Parse : PARSE =3D
struct
open Lib
fun string_reader S =3D
let val next =3D ref S in
fn _ =3D> !next before next :=3D ""
end
fun parse_declarations (S:string) : Ast.parse_result list =3D=20
let fun print_error( Msg, Line1,Line2) =3D (
output( !std_err,
"Syntax error at line " ^ Int.toString(Line1) ^
": " ^ Msg ^ "\n");
flush_out( !std_err ) )
in
case
MLParser.parse(
0,
MLParser.makeLexer (string_reader S),
print_error,
()
)
of (X,Y) =3D>X=20
end
fun parse_decs S =3D
case parse_declarations S of Ast.parsed_fun( Ds ) :: nil =3D> Ds
fun parse_dec S =3D case parse_decs S of D::nil =3D> D
fun parse_type_dec S =3D
case parse_declarations S of Ast.parsed_type TD :: nil =3D> TD
fun parse_datatype_decs S =3D
case parse_declarations S of=20
Ast.parsed_datatype( DDs ) :: nil =3D> DDs
fun parse_datatype_dec S =3D
case parse_datatype_decs S of DD::nil =3D> DD
fun parse_exp S =3D
case parse_dec("fun f(X) =3D " ^ S) of {exp,...} =3D> exp
fun parse_ty_exp S =3D
case parse_declarations( "type t =3D " ^ S ) of
(Ast.parsed_type { ty_exp, ty_pars=3Dnil, ... }) :: nil =3D> ty_exp
end (* Parse *)
structure Predefined =3D
struct
val S =3D Parse.parse_ty_exp "int * int -> bool"=20
end (* structure Predefined *)
------_=_NextPart_000_01BF4636.F6376BCE
Content-Type: TEXT/PLAIN;
name="log"
Content-Transfer-Encoding: quoted-printable
Content-Disposition: attachment;
filename="log"
Content-Description: Compilation log file
Content-ID: <Pine.SOL.4.10.9912141349031.24367@muppet1.cs.chalmers.se>
------_=_NextPart_000_01BF4636.F6376BCE--